summaryrefslogtreecommitdiff
path: root/src/Dhall/JSON.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Dhall/JSON.hs')
-rw-r--r--src/Dhall/JSON.hs396
1 files changed, 388 insertions, 8 deletions
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