jsonToDhall.hs

#!/usr/bin/env stack
-- stack --resolver nightly-2018-11-30 script
{-# LANGUAGE OverloadedStrings #-}

import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Dhall
import Dhall.Core
import Dhall.Parser (Src)
import Dhall.TypeCheck (X)
import System.Environment (getArgs)
import Control.Exception (Exception, throwIO)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.ByteString.Lazy.Char8 as Char8
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
import qualified Dhall.Map as Map
import qualified Data.HashMap.Strict as HashMap
import Data.List ((\\))
import Control.Monad
import Data.Scientific (floatingOrInteger, isInteger)

import Debug.Trace

data ConvertError
  = Unsupported (Expr Src X)
                Value
  | MissingKey Text
               (Expr Src X)
               Object
  | UnhandledKeys [Text]
                  (Expr Src X)
                  Object
  | BadValue (Expr Src X)
             Value

errorMessage prefix typeAnn value = prefix <> "\n\
                                    \\n\
                                    \Type: " <> dhallType <> "\n\
                                    \\n\
                                    \Value: " <> json <> "\n\n"
    where json = Char8.unpack (encodePretty value)
          dhallType = Text.unpack (pretty typeAnn)

instance Show ConvertError where
  show (Unsupported typeAnn value) = errorMessage "Unsupported conversion" typeAnn value
  show (MissingKey key typeAnn value) = errorMessage ("Missing key " <> show key <> " in json value") typeAnn value
  show (UnhandledKeys keys typeAnn value) = error ("Found unexpected keys in the json value: " <> show keys) typeAnn value
  show (BadValue typeAnn value) = error "Not valid value for the given type" typeAnn value

instance Exception ConvertError

main = do
  [typeArg] <- getArgs
  typeAnn <- inputExpr (Text.pack typeArg)
  input <- Char8.getContents
  value <- case eitherDecode input of
    Left err -> throwIO (userError err)
    Right v -> return v

  case doit typeAnn value of
    Left err -> throwIO err
    Right expr -> Text.putStr (pretty expr)


doit :: Expr Src X -> Value -> Either ConvertError (Expr Src X)
doit typeAnn input = loop typeAnn input

loop :: Expr Src X -> Value -> Either ConvertError (Expr Src X)
loop t (Object o) | Just t' <- getKeyValueType t = do
  if HashMap.null o
    then return (ListLit (Just t) Seq.empty)
    else do o' <- traverse (loop t') $ o
            let records = map (\(k, v) -> RecordLit (Map.fromList [("mapKey", TextLit (Chunks [] k)), ("mapValue", v)])) . HashMap.toList $ o'
            return (ListLit Nothing (Seq.fromList records))
loop (App List t) (Array a) = do
  a' <- traverse (loop t) . toList $ a
  let annotation = if null a' then Just t else Nothing
  return (ListLit annotation (Seq.fromList a'))
loop (Record r) (Object o) = do
  r' <- Map.traverseWithKey (\k t -> case HashMap.lookup k o of
                                Just value -> loop t value
                                Nothing -> case t of
                                  App Optional t' -> return (App None t')
                                  _ -> Left (MissingKey k t o)
                            ) r
  let extraKeys = HashMap.keys o \\ Map.keys r
  when (not (null extraKeys))
    (Left (UnhandledKeys extraKeys (Record r) o))
  return (RecordLit r')
loop Integer (Number n) = case floatingOrInteger n of
  Right i -> return (IntegerLit i)
  Left _ -> Left (BadValue Integer (Number n))
loop Natural (Number n) | isInteger n && n >= 0 = return (NaturalLit (truncate n)) -- XXX badvalue here? XXX better natural convertion?
loop Text (String t) = return (TextLit (Chunks [] t))
loop (App Optional typeAnn) value = Some <$> loop typeAnn value
loop typeAnn value = Left (Unsupported typeAnn value)

getKeyValueType (App List (Record r)) | length (Map.toList r) == 2 && Map.lookup "mapKey" r == Just Text = Map.lookup "mapValue" r
getKeyValueType _ = Nothing