Add pair2/pair3 and auto

src/Dhall/Config.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module Dhall.Config
     ( -- *
@@ -8,9 +9,13 @@ module Dhall.Config
     , integer
     , double
     , text
-    , vectorOf
+    , vector
+    , pair2
+    , pair3
+    , Interpret(..)
     ) where
 
+import Control.Applicative (empty)
 import Control.Exception (Exception)
 import Data.Text.Lazy (Text)
 import Data.Vector (Vector)
@@ -18,6 +23,7 @@ import Dhall.Core (Expr(..), X)
 import Numeric.Natural (Natural)
 
 import qualified Control.Exception
+import qualified Data.Map
 import qualified Dhall.Core
 import qualified Dhall.Import
 import qualified Dhall.Parser
@@ -43,38 +49,106 @@ input (Type {..}) t = do
 natural :: Type Natural
 natural = Type {..}
   where
-    extract (NaturalLit n) = Just n
-    extract  _             = Nothing
+    extract (NaturalLit n) = pure n
+    extract  _             = empty
 
     expected = Natural
 
 integer :: Type Integer
 integer = Type {..}
   where
-    extract (IntegerLit n) = Just n
-    extract  _             = Nothing
+    extract (IntegerLit n) = pure n
+    extract  _             = empty
 
     expected = Integer
 
 double :: Type Double
 double = Type {..}
   where
-    extract (DoubleLit n) = Just n
-    extract  _            = Nothing
+    extract (DoubleLit n) = pure n
+    extract  _            = empty
 
     expected = Double
 
 text :: Type Text
 text = Type {..}
   where
-    extract (TextLit t) = Just t
-    extract  _          = Nothing
+    extract (TextLit t) = pure t
+    extract  _          = empty
 
     expected = Text
 
-vectorOf :: Type a -> Type (Vector a)
-vectorOf (Type extractIn expectedIn) = Type extractOut expectedOut
+vector :: Type a -> Type (Vector a)
+vector (Type extractIn expectedIn) = Type extractOut expectedOut
   where
     extractOut (ListLit _ es) = traverse extractIn es
 
     expectedOut = List expectedIn
+
+pair2 :: Type a -> Type b -> Type (a, b)
+pair2
+    (Type extractA expectedA)
+    (Type extractB expectedB) = Type {..}
+  where
+    extract (RecordLit m) = do
+        eA <- Data.Map.lookup "_1" m
+        vA <- extractA eA
+        eB <- Data.Map.lookup "_2" m
+        vB <- extractB eB
+        return (vA, vB)
+    extract  _            = empty
+
+    expected = Record (Data.Map.fromList kts)
+      where
+        kts =
+            [ ("_1", expectedA)
+            , ("_2", expectedB)
+            ]
+
+pair3 :: Type a -> Type b -> Type c -> Type (a, b, c)
+pair3
+    (Type extractA expectedA)
+    (Type extractB expectedB)
+    (Type extractC expectedC) = Type {..}
+  where
+    extract (RecordLit m) = do
+        eA <- Data.Map.lookup "_1" m
+        vA <- extractA eA
+        eB <- Data.Map.lookup "_2" m
+        vB <- extractB eB
+        eC <- Data.Map.lookup "_3" m
+        vC <- extractC eC
+        return (vA, vB, vC)
+    extract  _            = empty
+
+    expected = Record (Data.Map.fromList kts)
+      where
+        kts =
+            [ ("_1", expectedA)
+            , ("_2", expectedB)
+            , ("_3", expectedC)
+            ]
+
+class Interpret a where
+    auto :: Type a
+
+instance Interpret Natural where
+    auto = natural
+
+instance Interpret Integer where
+    auto = integer
+
+instance Interpret Double where
+    auto = double
+
+instance Interpret Text where
+    auto = text
+
+instance Interpret a => Interpret (Vector a) where
+    auto = vector auto
+
+instance (Interpret a, Interpret b) => Interpret (a, b) where
+    auto = pair2 auto auto
+
+instance (Interpret a, Interpret b, Interpret c) => Interpret (a, b, c) where
+    auto = pair3 auto auto auto