version 1.2.01.2.0

4 files changed, 510 insertions, 59 deletions

diff --git a/dhall-json.cabal b/dhall-json.cabal
index f23375e..4b9bee1 100644
--- a/dhall-json.cabal
+++ b/dhall-json.cabal
@@ -1,5 +1,5 @@
 Name: dhall-json
-Version: 1.1.0
+Version: 1.2.0
 Cabal-Version: >=1.8.0.2
 Build-Type: Simple
 Tested-With: GHC == 7.10.2, GHC == 8.0.1
@@ -29,11 +29,13 @@ Source-Repository head
 Library
     Hs-Source-Dirs: src
     Build-Depends:
-        base                 >= 4.8.0.0  && < 5   ,
-        aeson                >= 1.0.0.0  && < 1.4 ,
-        dhall                >= 1.11.0   && < 1.14,
-        text                 >= 0.11.1.0 && < 1.3 ,
-        unordered-containers                < 0.3
+        base                      >= 4.8.0.0  && < 5   ,
+        aeson                     >= 1.0.0.0  && < 1.4 ,
+        dhall                     >= 1.14.0   && < 1.15,
+        insert-ordered-containers                < 1.14,
+        optparse-applicative      >= 0.14.0.0 && < 0.15,
+        text                      >= 0.11.1.0 && < 1.3 ,
+        unordered-containers                     < 0.3
     Exposed-Modules: Dhall.JSON
     GHC-Options: -Wall
 
@@ -41,13 +43,13 @@ Executable dhall-to-json
     Hs-Source-Dirs: dhall-to-json
     Main-Is: Main.hs
     Build-Depends:
-        base                                  ,
-        aeson                                 ,
-        aeson-pretty                    < 0.9 ,
-        bytestring                      < 0.11,
-        dhall                                 ,
-        dhall-json                            ,
-        optparse-generic >= 1.1.1    && < 1.4 ,
+        base                       ,
+        aeson                      ,
+        aeson-pretty         < 0.9 ,
+        bytestring           < 0.11,
+        dhall                      ,
+        dhall-json                 ,
+        optparse-applicative       ,
         text
     GHC-Options: -Wall
 
@@ -59,7 +61,7 @@ Executable dhall-to-yaml
         bytestring                      < 0.11,
         dhall                                 ,
         dhall-json                            ,
-        optparse-generic >= 1.1.1    && < 1.4 ,
+        optparse-applicative                  ,
         yaml             >= 0.5.0    && < 0.9 ,
         text
     GHC-Options: -Wall
diff --git a/dhall-to-json/Main.hs b/dhall-to-json/Main.hs
index db0c9a4..e7191ed 100644
--- a/dhall-to-json/Main.hs
+++ b/dhall-to-json/Main.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo     #-}
 {-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
 import Control.Exception (SomeException)
-import Options.Generic (Generic, ParseRecord, type (<?>))
+import Data.Monoid ((<>))
+import Dhall.JSON (Conversion)
+import Options.Applicative (Parser, ParserInfo)
 
 import qualified Control.Exception
 import qualified Data.Aeson
@@ -19,32 +18,72 @@ import qualified Data.Text.IO
 import qualified Dhall
 import qualified Dhall.JSON
 import qualified GHC.IO.Encoding
-import qualified Options.Generic
+import qualified Options.Applicative
 import qualified System.Exit
 import qualified System.IO
 
 data Options = Options
-    { explain  :: Bool <?> "Explain error messages in detail"
-    , pretty   :: Bool <?> "Pretty print generated JSON"
-    , omitNull :: Bool <?> "Omit record fields that are null"
-    } deriving (Generic, ParseRecord)
+    { explain    :: Bool
+    , pretty     :: Bool
+    , omitNull   :: Bool
+    , conversion :: Conversion
+    }
+
+parseOptions :: Parser Options
+parseOptions = Options.Applicative.helper <*> do
+    explain    <- parseExplain
+    pretty     <- parsePretty
+    omitNull   <- parseOmitNull
+    conversion <- Dhall.JSON.parseConversion
+    return (Options {..})
+  where
+    parseExplain =
+        Options.Applicative.switch
+            (   Options.Applicative.long "explain"
+            <>  Options.Applicative.help "Explain error messages in detail"
+            )
+
+    parsePretty =
+        Options.Applicative.switch
+            (   Options.Applicative.long "pretty"
+            <>  Options.Applicative.help "Pretty print generated JSON"
+            )
+
+    parseOmitNull =
+        Options.Applicative.switch
+            (   Options.Applicative.long "omitNull"
+            <>  Options.Applicative.help "Omit record fields that are null"
+            )
+
+parserInfo :: ParserInfo Options
+parserInfo =
+    Options.Applicative.info
+        parseOptions
+        (   Options.Applicative.fullDesc
+        <>  Options.Applicative.progDesc "Compile Dhall to JSON"
+        )
 
 main :: IO ()
-main = handle $ do
+main = do
     GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
-    Options {..} <- Options.Generic.getRecord "Compile Dhall to JSON"
 
-    let encode       = if   Options.Generic.unHelpful pretty
-                       then Data.Aeson.Encode.Pretty.encodePretty
-                       else Data.Aeson.encode
-        explaining   = if Options.Generic.unHelpful explain  then Dhall.detailed      else id
-        omittingNull = if Options.Generic.unHelpful omitNull then Dhall.JSON.omitNull else id
+    Options {..} <- Options.Applicative.execParser parserInfo
+
+    handle $ do
+        let encode =
+                if pretty
+                then Data.Aeson.Encode.Pretty.encodePretty
+                else Data.Aeson.encode
+
+        let explaining = if explain then Dhall.detailed else id
+
+        let omittingNull = if omitNull then Dhall.JSON.omitNull else id
 
-    stdin <- Data.Text.IO.getContents
+        stdin <- Data.Text.IO.getContents
 
-    json  <- omittingNull <$> explaining (Dhall.JSON.codeToValue "(stdin)" stdin)
+        json <- omittingNull <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
 
-    Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json 
+        Data.ByteString.Char8.putStrLn $ Data.ByteString.Lazy.toStrict $ encode json
 
 handle :: IO a -> IO a
 handle = Control.Exception.handle handler
diff --git a/dhall-to-yaml/Main.hs b/dhall-to-yaml/Main.hs
index 15369fb..56b7485 100644
--- a/dhall-to-yaml/Main.hs
+++ b/dhall-to-yaml/Main.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE ApplicativeDo     #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeOperators     #-}
 
 module Main where
 
 import Control.Exception (SomeException)
-import Options.Generic (Generic, ParseRecord, type (<?>))
+import Data.Monoid ((<>))
+import Dhall.JSON (Conversion)
+import Options.Applicative (Parser, ParserInfo)
 
 import qualified Control.Exception
 import qualified Data.ByteString
@@ -17,28 +16,59 @@ import qualified Data.Yaml
 import qualified Dhall
 import qualified Dhall.JSON
 import qualified GHC.IO.Encoding
-import qualified Options.Generic
+import qualified Options.Applicative
 import qualified System.Exit
 import qualified System.IO
 
 data Options = Options
-    { explain  :: Bool <?> "Explain error messages in detail"
-    , omitNull :: Bool <?> "Omit record fields that are null"
-    } deriving (Generic, ParseRecord)
+    { explain    :: Bool
+    , omitNull   :: Bool
+    , conversion :: Conversion
+    }
+
+parseOptions :: Parser Options
+parseOptions = Options.Applicative.helper <*> do
+    explain    <- parseExplain
+    omitNull   <- parseOmitNull
+    conversion <- Dhall.JSON.parseConversion
+    return (Options {..})
+  where
+    parseExplain =
+        Options.Applicative.switch
+            (   Options.Applicative.long "explain"
+            <>  Options.Applicative.help "Explain error messages in detail"
+            )
+
+    parseOmitNull =
+        Options.Applicative.switch
+            (   Options.Applicative.long "omitNull"
+            <>  Options.Applicative.help "Omit record fields that are null"
+            )
+
+parserInfo :: ParserInfo Options
+parserInfo =
+    Options.Applicative.info
+        parseOptions
+        (   Options.Applicative.fullDesc
+        <>  Options.Applicative.progDesc "Compile Dhall to YAML"
+        )
 
 main :: IO ()
-main = handle $ do
+main = do
     GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
-    Options{..} <- Options.Generic.getRecord "Compile Dhall to JSON"
 
-    let explaining   = if Options.Generic.unHelpful explain  then Dhall.detailed      else id
-        omittingNull = if Options.Generic.unHelpful omitNull then Dhall.JSON.omitNull else id
+    Options {..} <- Options.Applicative.execParser parserInfo
+
+    handle $ do
+        let explaining = if explain then Dhall.detailed else id
+
+        let omittingNull = if omitNull then Dhall.JSON.omitNull else id
 
-    stdin <- Data.Text.IO.getContents
+        stdin <- Data.Text.IO.getContents
 
-    json  <- omittingNull <$> explaining (Dhall.JSON.codeToValue "(stdin)" stdin)
+        json <- omittingNull <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
 
-    Data.ByteString.putStr $ Data.Yaml.encode json 
+        Data.ByteString.putStr $ Data.Yaml.encode json 
 
 handle :: IO a -> IO a
 handle = Control.Exception.handle handler
diff --git a/src/Dhall/JSON.hs b/src/Dhall/JSON.hs
index 196dfd7..a66736e 100644
--- a/src/Dhall/JSON.hs
+++ b/src/Dhall/JSON.hs
@@ -1,5 +1,7 @@
+{-# LANGUAGE ApplicativeDo      #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
 
 {-| This library only exports a single `dhallToJSON` function for translating a
     Dhall syntax tree to a JSON syntax tree (i.e. a `Value`) for the @aeson@
@@ -100,21 +102,30 @@ module Dhall.JSON (
     -- * Dhall to JSON
       dhallToJSON
     , omitNull
+    , Conversion(..)
+    , convertToHomogeneousMaps
+    , parseConversion
     , codeToValue
 
     -- * Exceptions
     , CompileError(..)
     ) where
 
+import Control.Applicative (empty, (<|>))
+import Control.Monad (guard)
 import Control.Exception (Exception, throwIO)
 import Data.Aeson (Value(..))
 import Data.Monoid ((<>))
+import Data.Text.Lazy (Text)
 import Data.Typeable (Typeable)
 import Dhall.Core (Expr)
 import Dhall.TypeCheck (X)
+import Options.Applicative (Parser)
 
 import qualified Data.Aeson
+import qualified Data.Foldable
 import qualified Data.HashMap.Strict
+import qualified Data.HashMap.Strict.InsOrd
 import qualified Data.Text
 import qualified Data.Text.Lazy
 import qualified Data.Text.Lazy.Builder
@@ -122,6 +133,7 @@ import qualified Dhall.Core
 import qualified Dhall.Import
 import qualified Dhall.Parser
 import qualified Dhall.TypeCheck
+import qualified Options.Applicative
 
 {-| This is the exception type for errors that might arise when translating
     Dhall to JSON
@@ -197,6 +209,369 @@ omitNull (Bool bool) =
 omitNull Null =
     Null
 
+{-| Specify whether or not to convert association lists of type
+    @List { mapKey: Text, mapValue : v }@ to records
+-}
+data Conversion
+    = NoConversion
+    | Conversion { mapKey :: Text, mapValue :: Text }
+
+{-| Convert association lists to homogeneous maps
+
+    This converts an association list of the form:
+
+    > [ { mapKey = k0, mapValue = v0 }, { mapKey = k1, mapValue = v1 } ]
+
+    ... to a record of the form:
+
+    > { k0 = v0, k1 = v1 }
+-}
+convertToHomogeneousMaps :: Conversion -> Expr s X -> Expr s X
+convertToHomogeneousMaps NoConversion e0 = e0
+convertToHomogeneousMaps (Conversion {..}) e0 = loop (Dhall.Core.normalize e0)
+  where
+    loop e = case e of
+        Dhall.Core.Const a ->
+            Dhall.Core.Const a
+
+        Dhall.Core.Var v ->
+            Dhall.Core.Var v
+
+        Dhall.Core.Lam a b c ->
+            Dhall.Core.Lam a b' c'
+          where
+            b' = loop b
+            c' = loop c
+
+        Dhall.Core.Pi a b c ->
+            Dhall.Core.Pi a b' c'
+          where
+            b' = loop b
+            c' = loop c
+
+        Dhall.Core.App a b ->
+            Dhall.Core.App a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.Let a b c d ->
+            Dhall.Core.Let a b' c' d'
+          where
+            b' = fmap loop b
+            c' =      loop c
+            d' =      loop d
+
+        Dhall.Core.Annot a b ->
+            Dhall.Core.Annot a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.Bool ->
+            Dhall.Core.Bool
+
+        Dhall.Core.BoolLit a ->
+            Dhall.Core.BoolLit a
+
+        Dhall.Core.BoolAnd a b ->
+            Dhall.Core.BoolAnd a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.BoolOr a b ->
+            Dhall.Core.BoolOr a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.BoolEQ a b ->
+            Dhall.Core.BoolEQ a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.BoolNE a b ->
+            Dhall.Core.BoolNE a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.BoolIf a b c ->
+            Dhall.Core.BoolIf a' b' c'
+          where
+            a' = loop a
+            b' = loop b
+            c' = loop c
+
+        Dhall.Core.Natural ->
+            Dhall.Core.Natural
+
+        Dhall.Core.NaturalLit a ->
+            Dhall.Core.NaturalLit a
+
+        Dhall.Core.NaturalFold ->
+            Dhall.Core.NaturalFold
+
+        Dhall.Core.NaturalBuild ->
+            Dhall.Core.NaturalBuild
+
+        Dhall.Core.NaturalIsZero ->
+            Dhall.Core.NaturalIsZero
+
+        Dhall.Core.NaturalEven ->
+            Dhall.Core.NaturalEven
+
+        Dhall.Core.NaturalOdd ->
+            Dhall.Core.NaturalOdd
+
+        Dhall.Core.NaturalToInteger ->
+            Dhall.Core.NaturalToInteger
+
+        Dhall.Core.NaturalShow ->
+            Dhall.Core.NaturalShow
+
+        Dhall.Core.NaturalPlus a b ->
+            Dhall.Core.NaturalPlus a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.NaturalTimes a b ->
+            Dhall.Core.NaturalTimes a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.Integer ->
+            Dhall.Core.Integer
+
+        Dhall.Core.IntegerLit a ->
+            Dhall.Core.IntegerLit a
+
+        Dhall.Core.IntegerShow ->
+            Dhall.Core.IntegerShow
+
+        Dhall.Core.Double ->
+            Dhall.Core.Double
+
+        Dhall.Core.DoubleLit a ->
+            Dhall.Core.DoubleLit a
+
+        Dhall.Core.DoubleShow ->
+            Dhall.Core.DoubleShow
+
+        Dhall.Core.Text ->
+            Dhall.Core.Text
+
+        Dhall.Core.TextLit (Dhall.Core.Chunks a b) ->
+            Dhall.Core.TextLit (Dhall.Core.Chunks a' b)
+          where
+            a' = fmap (fmap loop) a
+
+        Dhall.Core.TextAppend a b ->
+            Dhall.Core.TextAppend a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.List ->
+            Dhall.Core.List
+
+        Dhall.Core.ListLit a b ->
+            case transform of
+                Just c  -> c
+                Nothing -> Dhall.Core.ListLit a' b'
+          where
+            elements = Data.Foldable.toList b
+
+            toKeyValue :: Expr s X -> Maybe (Text, Expr s X)
+            toKeyValue (Dhall.Core.RecordLit m) = do
+                guard (Data.HashMap.Strict.InsOrd.size m == 2)
+
+                key   <- Data.HashMap.Strict.InsOrd.lookup mapKey   m
+                value <- Data.HashMap.Strict.InsOrd.lookup mapValue m
+
+                keyText <- case key of
+                    Dhall.Core.TextLit (Dhall.Core.Chunks [] keyText) ->
+                        return keyText
+
+                    _ ->
+                        empty
+
+                return (Data.Text.Lazy.Builder.toLazyText keyText, value)
+            toKeyValue _ = do
+                empty
+
+            transform =
+                case elements of
+                    [] ->
+                        case a of
+                            Just (Dhall.Core.Record m) -> do
+                                guard (Data.HashMap.Strict.InsOrd.size m == 2)
+                                guard (Data.HashMap.Strict.InsOrd.member mapKey   m)
+                                guard (Data.HashMap.Strict.InsOrd.member mapValue m)
+                                return (Dhall.Core.RecordLit Data.HashMap.Strict.InsOrd.empty)
+                            _ -> do
+                                empty
+
+                    _  -> do
+                        keyValues <- traverse toKeyValue elements
+
+                        let recordLiteral =
+                                Data.HashMap.Strict.InsOrd.fromList keyValues
+
+                        return (Dhall.Core.RecordLit recordLiteral)
+
+            a' = fmap loop a
+            b' = fmap loop b
+
+        Dhall.Core.ListAppend a b ->
+            Dhall.Core.ListAppend a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.ListBuild ->
+            Dhall.Core.ListBuild
+
+        Dhall.Core.ListFold ->
+            Dhall.Core.ListFold
+
+        Dhall.Core.ListLength ->
+            Dhall.Core.ListLength
+
+        Dhall.Core.ListHead ->
+            Dhall.Core.ListHead
+
+        Dhall.Core.ListLast ->
+            Dhall.Core.ListLast
+
+        Dhall.Core.ListIndexed ->
+            Dhall.Core.ListIndexed
+
+        Dhall.Core.ListReverse ->
+            Dhall.Core.ListReverse
+
+        Dhall.Core.Optional ->
+            Dhall.Core.Optional
+
+        Dhall.Core.OptionalLit a b ->
+            Dhall.Core.OptionalLit a' b'
+          where
+            a' =      loop a
+            b' = fmap loop b
+
+        Dhall.Core.OptionalFold ->
+            Dhall.Core.OptionalFold
+
+        Dhall.Core.OptionalBuild ->
+            Dhall.Core.OptionalBuild
+
+        Dhall.Core.Record a ->
+            Dhall.Core.Record a'
+          where
+            a' = fmap loop a
+
+        Dhall.Core.RecordLit a ->
+            Dhall.Core.RecordLit a'
+          where
+            a' = fmap loop a
+
+        Dhall.Core.Union a ->
+            Dhall.Core.Union a'
+          where
+            a' = fmap loop a
+
+        Dhall.Core.UnionLit a b c ->
+            Dhall.Core.UnionLit a b' c'
+          where
+            b' =      loop b
+            c' = fmap loop c
+
+        Dhall.Core.Combine a b ->
+            Dhall.Core.Combine a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.CombineTypes a b ->
+            Dhall.Core.CombineTypes a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.Prefer a b ->
+            Dhall.Core.Prefer a' b'
+          where
+            a' = loop a
+            b' = loop b
+
+        Dhall.Core.Merge a b c ->
+            Dhall.Core.Merge a' b' c'
+          where
+            a' =      loop a
+            b' =      loop b
+            c' = fmap loop c
+
+        Dhall.Core.Constructors a ->
+            Dhall.Core.Constructors a'
+          where
+            a' = loop a
+
+        Dhall.Core.Field a b ->
+            Dhall.Core.Field a' b
+          where
+            a' = loop a
+
+        Dhall.Core.Project a b ->
+            Dhall.Core.Project a' b
+          where
+            a' = loop a
+
+        Dhall.Core.Note a b ->
+            Dhall.Core.Note a b'
+          where
+            b' = loop b
+
+        Dhall.Core.Embed a ->
+            Dhall.Core.Embed a
+
+parseConversion :: Parser Conversion
+parseConversion =
+        conversion
+    <|> noConversion
+  where
+    conversion = do
+        mapKey   <- parseKeyField
+        mapValue <- parseValueField
+        return (Conversion {..})
+      where
+        parseKeyField =
+            Options.Applicative.strOption
+                (   Options.Applicative.long "key"
+                <>  Options.Applicative.help "Reserved key field name for association lists"
+                <>  Options.Applicative.value "mapKey"
+                <>  Options.Applicative.showDefaultWith Data.Text.Lazy.unpack
+                )
+
+        parseValueField =
+            Options.Applicative.strOption
+                (   Options.Applicative.long "value"
+                <>  Options.Applicative.help "Reserved value field name for association lists"
+                <>  Options.Applicative.value "mapValue"
+                <>  Options.Applicative.showDefaultWith Data.Text.Lazy.unpack
+                )
+
+    noConversion =
+        Options.Applicative.flag'
+            NoConversion
+            (   Options.Applicative.long "noMaps"
+            <>  Options.Applicative.help "Disable conversion of association lists to homogeneous maps"
+            )
+
+
 {-| Convert a piece of Text carrying a Dhall inscription to an equivalent JSON Value
 
 >>> :set -XOverloadedStrings
@@ -205,19 +580,24 @@ omitNull Null =
 >>> Object (fromList [("a",Number 1.0)])
 -}
 codeToValue
-  :: Data.Text.Text  -- ^ Describe the input for the sake of error location.
+  :: Conversion
+  -> Data.Text.Text  -- ^ Describe the input for the sake of error location.
   -> Data.Text.Text  -- ^ Input text.
   -> IO Value
-codeToValue name code = do
-    expr <- case Dhall.Parser.exprFromText (Data.Text.unpack name) (Data.Text.Lazy.fromStrict code) of
-      Left  err  -> Control.Exception.throwIO err
-      Right expr -> return expr
+codeToValue conversion name code = do
+    parsedExpression <- case Dhall.Parser.exprFromText (Data.Text.unpack name) (Data.Text.Lazy.fromStrict code) of
+      Left  err              -> Control.Exception.throwIO err
+      Right parsedExpression -> return parsedExpression
+
+    resolvedExpression <- Dhall.Import.load parsedExpression
 
-    expr' <- Dhall.Import.load expr
-    case Dhall.TypeCheck.typeOf expr' of
+    case Dhall.TypeCheck.typeOf resolvedExpression  of
       Left  err -> Control.Exception.throwIO err
       Right _   -> return ()
 
-    case dhallToJSON expr' of
+    let convertedExpression =
+            convertToHomogeneousMaps conversion resolvedExpression
+
+    case dhallToJSON convertedExpression of
       Left  err  -> Control.Exception.throwIO err
       Right json -> return json