dhall-json: implement --type mode for encoding type as json

dhall-json/dhall-to-json/Main.hs

@@ -8,7 +8,7 @@ import Control.Applicative (optional, (<|>))
 import Control.Exception   (SomeException)
 import Data.Aeson          (Value)
 import Data.Version        (showVersion)
-import Dhall.JSON          (Conversion, SpecialDoubleMode (..))
+import Dhall.JSON          (Conversion, SpecialDoubleMode (..), EncodeTarget)
 import Options.Applicative (Parser, ParserInfo)
 
 import qualified Control.Exception
@@ -31,6 +31,7 @@ data Options
         , pretty                    :: Bool
         , omission                  :: Value -> Value
         , conversion                :: Conversion
+        , encodeTarget              :: EncodeTarget
         , approximateSpecialDoubles :: Bool
         , file                      :: Maybe FilePath
         , output                    :: Maybe FilePath
@@ -44,6 +45,7 @@ parseOptions =
         <*> parsePretty
         <*> Dhall.JSON.parsePreservationAndOmission
         <*> Dhall.JSON.parseConversion
+        <*> Dhall.JSON.parseEncodeTarget
         <*> parseApproximateSpecialDoubles
         <*> optional parseFile
         <*> optional parseOutput
@@ -150,7 +152,7 @@ main = do
                     Nothing   -> Text.IO.getContents
                     Just path -> Text.IO.readFile path
 
-                json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode file text)
+                json <- omission <$> explaining (Dhall.JSON.codeToValue conversion specialDoubleMode encodeTarget file text)
 
                 let write =
                         case output of

dhall-json/src/Dhall/JSON.hs

@@ -201,6 +201,8 @@ module Dhall.JSON (
     , omitNull
     , omitEmpty
     , parsePreservationAndOmission
+    , EncodeTarget(..)
+    , parseEncodeTarget
     , Conversion(..)
     , defaultConversion
     , convertToHomogeneousMaps
@@ -592,6 +594,32 @@ dhallToJSON e0 = loop (Core.alphaNormalize (Core.normalize e0))
                     outer _ = Left (Unsupported e)
 
                 outer value
+
+        -- Schemas
+        Core.Bool -> return (Aeson.String "Bool")
+        Core.Natural -> return (Aeson.String "Natural")
+        Core.Bytes -> return (Aeson.String "Bytes")
+        Core.Integer -> return (Aeson.String "Integer")
+        Core.Double -> return (Aeson.String "Double")
+        Core.Text -> return (Aeson.String "Text")
+        Core.Date -> return (Aeson.String "Date")
+        Core.Time -> return (Aeson.String "Time")
+        Core.TimeZone -> return (Aeson.String "TimeZone")
+        Core.App Core.List t -> do
+            t' <- loop t
+            return $ Aeson.Object [("type", Aeson.String "List"), ("element", t')]
+        Core.App Core.Optional t -> do
+            t' <- loop t
+            return $ Aeson.Object [("type", Aeson.String "Optional"), ("element", t')]
+        Core.Record a -> do
+            a' <- traverse (loop . Core.recordFieldValue) a
+            return $ Aeson.Object [("type", Aeson.String "Record"), ("fields", Aeson.toJSON (Dhall.Map.toMap a')) ]
+        Core.Union a -> do
+            let go Nothing = return $ Aeson.Object []
+                go (Just t) = loop t
+            a' <- traverse go a
+            return $ Aeson.Object [("type", Aeson.String "Union"), ("choices", Aeson.toJSON (Dhall.Map.toMap a')) ]
+
         _ -> Left (Unsupported e)
 
 getContents :: Expr s Void -> Maybe (Text, Maybe (Expr s Void))
@@ -692,6 +720,22 @@ parseNullPreservation =
 parsePreservationAndOmission :: Parser (Value -> Value)
 parsePreservationAndOmission = parseOmission <|> parseNullPreservation
 
+
+{-| Specify whether to encode data or type as JSON (default data) -}
+data EncodeTarget
+    = EncodeData
+    | EncodeType
+
+parseEncodeTarget :: Parser EncodeTarget
+parseEncodeTarget =
+        Options.Applicative.flag'
+            EncodeType
+            (   Options.Applicative.long "type"
+            <>  Options.Applicative.help "Encode the type of the input expression instead of the value"
+            )
+    <|> pure EncodeData
+
+
 {-| Specify whether or not to convert association lists of type
     @List { mapKey: Text, mapValue : v }@ to records
 -}
@@ -1198,24 +1242,26 @@ handleSpecialDoubles specialDoubleMode =
 codeToValue
   :: Conversion
   -> SpecialDoubleMode
+  -> EncodeTarget
   -> Maybe FilePath  -- ^ The source file path. If no path is given, imports
                      -- are resolved relative to the current directory.
   -> Text  -- ^ Input text.
   -> IO Value
-codeToValue conversion specialDoubleMode mFilePath code = do
-  fmap snd (codeToHeaderAndValue conversion specialDoubleMode mFilePath code)
+codeToValue conversion specialDoubleMode encodeTarget mFilePath code = do
+  fmap snd (codeToHeaderAndValue conversion specialDoubleMode encodeTarget mFilePath code)
 
 {-| This is like `codeToValue`, except also returning a `Header` that is a
     valid YAML comment derived from the original Dhall code's `Header`
 -}
 codeToHeaderAndValue
   :: Conversion
   -> SpecialDoubleMode
+  -> EncodeTarget
   -> Maybe FilePath  -- ^ The source file path. If no path is given, imports
                      -- are resolved relative to the current directory.
   -> Text  -- ^ Input text.
   -> IO (Header, Value)
-codeToHeaderAndValue conversion specialDoubleMode mFilePath code = do
+codeToHeaderAndValue conversion specialDoubleMode encodeTarget mFilePath code = do
     (Header header, parsedExpression) <- Core.throws (Dhall.Parser.exprAndHeaderFromText (fromMaybe "(input)" mFilePath) code)
 
     let adapt line =
@@ -1231,10 +1277,15 @@ codeToHeaderAndValue conversion specialDoubleMode mFilePath code = do
 
     resolvedExpression <- Dhall.Import.loadRelativeTo rootDirectory UseSemanticCache parsedExpression
 
-    _ <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
+    t <- Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
+
+    let resolvedExpression' =
+            case encodeTarget of
+                EncodeData -> resolvedExpression
+                EncodeType -> t
 
     let convertedExpression =
-            convertToHomogeneousMaps conversion resolvedExpression
+            convertToHomogeneousMaps conversion resolvedExpression'
 
     specialDoubleExpression <- Core.throws (handleSpecialDoubles specialDoubleMode convertedExpression)
 

dhall-json/src/Dhall/JSON/Yaml.hs

@@ -90,7 +90,7 @@ dhallToYaml Options{..} mFilePath code = do
 
   let adapt (header, value) = (header, omission value)
 
-  (Header comment, json) <- adapt <$> explaining (Dhall.JSON.codeToHeaderAndValue conversion UseYAMLEncoding mFilePath code)
+  (Header comment, json) <- adapt <$> explaining (Dhall.JSON.codeToHeaderAndValue conversion UseYAMLEncoding Dhall.JSON.EncodeData mFilePath code)
 
   let suffix
         | preserveHeader = Data.Text.Encoding.encodeUtf8 comment

dhall-json/tasty/Main.hs

@@ -34,6 +34,7 @@ testTree =
         , testDhallToJSON "./tasty/data/emptyObjectStrongType"
         , testDhallToJSON "./tasty/data/toArbitraryJSON_12_0_0"
         , testDhallToJSON "./tasty/data/toArbitraryJSON_13_0_0"
+        , testDhallToJSON "./tasty/data/types"
         , testJSONToDhall "./tasty/data/emptyAlternative"
         , testJSONToDhall "./tasty/data/emptyObject"
         , testJSONToDhall "./tasty/data/emptyList"

dhall-json/tasty/data/types.dhall

@@ -0,0 +1,7 @@
+{
+    field: Text,
+    nested: { nested_field: Natural },
+    list: List Bool,
+    optional: Optional Text,
+    union: < A: Natural | B: Text | C >
+}

dhall-json/tasty/data/types.json

@@ -0,0 +1,28 @@
+{
+  "fields": {
+    "field": "Text",
+    "list": {
+      "element": "Bool",
+      "type": "List"
+    },
+    "nested": {
+      "fields": {
+        "nested_field": "Natural"
+      },
+      "type": "Record"
+    },
+    "optional": {
+      "element": "Text",
+      "type": "Optional"
+    },
+    "union": {
+      "choices": {
+        "A": "Natural",
+        "B": "Text",
+        "C": {}
+      },
+      "type": "Union"
+    }
+  },
+  "type": "Record"
+}

dhall-yaml/src/Dhall/Yaml.hs

@@ -12,7 +12,7 @@ module Dhall.Yaml
 import Data.ByteString      (ByteString)
 import Data.ByteString.Lazy (toStrict)
 import Data.Text            (Text)
-import Dhall.JSON           (SpecialDoubleMode (..), codeToHeaderAndValue)
+import Dhall.JSON           (SpecialDoubleMode (..), codeToHeaderAndValue, EncodeTarget(EncodeData))
 import Dhall.JSON.Yaml      (Options (..))
 import Dhall.Parser         (Header (..))
 
@@ -44,7 +44,7 @@ dhallToYaml Options{..} mFilePath code = do
 
   let adapt (header, value) = (header, omission value)
 
-  (Header comment, json) <- adapt <$> explaining (codeToHeaderAndValue conversion UseYAMLEncoding mFilePath code)
+  (Header comment, json) <- adapt <$> explaining (codeToHeaderAndValue conversion UseYAMLEncoding EncodeData mFilePath code)
 
   let suffix
           | preserveHeader = Data.Text.Encoding.encodeUtf8 comment