{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
module Dhall.TomlToDhall
( tomlToDhall
, tomlToDhallMain
, CompileError
) where
import Control.Exception (Exception, throwIO)
import Data.Either (rights)
import Data.Foldable (foldl', toList)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Text (Text)
import Data.Void (Void)
import Dhall.Core (DhallDouble (..), Expr)
import Dhall.Parser (Src)
import Dhall.Toml.Utils (fileToDhall)
import Toml.Parser (TomlParseError)
import Toml.Type.AnyValue (AnyValue (AnyValue))
import Toml.Type.Key (Key (Key), Piece (Piece))
import Toml.Type.PrefixTree (PrefixTree)
import Toml.Type.TOML (TOML)
import Toml.Type.Value (Value)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Sequence as Seq
import qualified Data.Text
import qualified Data.Text.IO as Text.IO
import qualified Dhall.Core as Core
import qualified Dhall.Map as Map
import qualified System.Environment
import qualified Toml.Parser
import qualified Toml.Type.AnyValue as Toml.AnyValue
import qualified Toml.Type.PrefixTree as Toml.PrefixTree
import qualified Toml.Type.TOML as Toml.TOML
import qualified Toml.Type.Value as Value
data CompileError
= Unimplemented String
| Incompatible (Expr Src Void) Object
| InvalidToml TomlParseError
| InternalError String
| MissingKey String
instance Show CompileError where
show :: CompileError -> String
show (Unimplemented String
s) = String
"unimplemented: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
show (Incompatible Expr Src Void
e Object
toml) = String
"incompatible: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Expr Src Void -> String
forall a. Show a => a -> String
show Expr Src Void
e) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Object -> String
forall a. Show a => a -> String
show Object
toml)
show (InvalidToml TomlParseError
e) = String
"invalid TOML:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TomlParseError -> Text
Toml.Parser.unTomlParseError TomlParseError
e)
show (InternalError String
e) = String
"internal error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
e
show (MissingKey String
e) = String
"missing key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
e
instance Exception CompileError
tomlToDhall :: Expr Src Void -> TOML -> Either CompileError (Expr Src Void)
tomlToDhall :: Expr Src Void -> TOML -> Either CompileError (Expr Src Void)
tomlToDhall Expr Src Void
schema TOML
toml = Expr Src Void -> Object -> Either CompileError (Expr Src Void)
toDhall (Expr Src Void -> Expr Src Void
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr Src Void
schema) (TOML -> Object
tomlToObject TOML
toml)
tomlValueToDhall :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
tomlValueToDhall :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
tomlValueToDhall Expr Src Void
exprType Value t
v = case (Expr Src Void
exprType, Value t
v) of
(Expr Src Void
Core.Bool , Value.Bool Bool
a ) -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Bool -> Expr Src Void
forall s a. Bool -> Expr s a
Core.BoolLit Bool
a
(Expr Src Void
Core.Natural , Value.Integer Integer
a) -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Natural -> Expr Src Void
forall s a. Natural -> Expr s a
Core.NaturalLit (Natural -> Expr Src Void) -> Natural -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
a
(Expr Src Void
Core.Double , Value.Double Double
a ) -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ DhallDouble -> Expr Src Void
forall s a. DhallDouble -> Expr s a
Core.DoubleLit (DhallDouble -> Expr Src Void) -> DhallDouble -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Double -> DhallDouble
DhallDouble Double
a
(Expr Src Void
Core.Text , Value.Text Text
a ) -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Chunks Src Void -> Expr Src Void
forall s a. Chunks s a -> Expr s a
Core.TextLit (Chunks Src Void -> Expr Src Void)
-> Chunks Src Void -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ [(Text, Expr Src Void)] -> Text -> Chunks Src Void
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
a
(Expr Src Void
_ , Value.Zoned ZonedTime
_ ) -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
Unimplemented String
"toml time values"
(Expr Src Void
_ , Value.Local LocalTime
_ ) -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
Unimplemented String
"toml time values"
(Expr Src Void
_ , Value.Day Day
_ ) -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
Unimplemented String
"toml time values"
(t :: Expr Src Void
t@(Core.App Expr Src Void
Core.List Expr Src Void
_) , Value.Array [] ) -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Maybe (Expr Src Void) -> Seq (Expr Src Void) -> Expr Src Void
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit (Expr Src Void -> Maybe (Expr Src Void)
forall a. a -> Maybe a
Just Expr Src Void
t) []
(Core.App Expr Src Void
Core.Optional Expr Src Void
t , Value t
a ) -> do
Expr Src Void
o <- Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
tomlValueToDhall Expr Src Void
t Value t
a
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a
Core.Some Expr Src Void
o
(Core.App Expr Src Void
Core.List Expr Src Void
t , Value.Array [Value t1]
a ) -> do
[Expr Src Void]
l <- (Value t1 -> Either CompileError (Expr Src Void))
-> [Value t1] -> Either CompileError [Expr Src Void]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Expr Src Void -> Value t1 -> Either CompileError (Expr Src Void)
forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
tomlValueToDhall Expr Src Void
t) [Value t1]
a
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Maybe (Expr Src Void) -> Seq (Expr Src Void) -> Expr Src Void
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit Maybe (Expr Src Void)
forall a. Maybe a
Nothing ([Expr Src Void] -> Seq (Expr Src Void)
forall a. [a] -> Seq a
Seq.fromList [Expr Src Void]
l)
(Core.Union Map Text (Maybe (Expr Src Void))
m , Value t
_) -> let
f :: Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void)
f Text
key Maybe (Expr Src Void)
maybeType = case Maybe (Expr Src Void)
maybeType of
Just Expr Src Void
ty -> do
Expr Src Void
expr <- Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
tomlValueToDhall Expr Src Void
ty Value t
v
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
Core.App (Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr Src Void
exprType (FieldSelection Src -> Expr Src Void)
-> FieldSelection Src -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
key) Expr Src Void
expr
Maybe (Expr Src Void)
Nothing -> case Value t
v of
Value.Text Text
a | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key ->
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr Src Void
exprType (Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
a)
Value t
_ -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
exprType (AnyValue -> Object
Prim (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
v))
in case [Either CompileError (Expr Src Void)] -> [Expr Src Void]
forall a b. [Either a b] -> [b]
rights (Map Text (Either CompileError (Expr Src Void))
-> [Either CompileError (Expr Src Void)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void))
-> Map Text (Maybe (Expr Src Void))
-> Map Text (Either CompileError (Expr Src Void))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void)
f Map Text (Maybe (Expr Src Void))
m)) of
[] -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
exprType (AnyValue -> Object
Prim (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
v))
Expr Src Void
x:[Expr Src Void]
_ -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void
x
(Expr Src Void, Value t)
_ -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
exprType (AnyValue -> Object
Prim (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
v))
toDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void)
toDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void)
toDhall Expr Src Void
exprType Object
value = case (Expr Src Void
exprType, Object
value) of
(Expr Src Void
_, Object
Invalid) -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
InternalError String
"invalid object"
(Core.Union Map Text (Maybe (Expr Src Void))
m , Object
_) -> let
f :: Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void)
f Text
key Maybe (Expr Src Void)
maybeType = case Maybe (Expr Src Void)
maybeType of
Just Expr Src Void
ty -> do
Expr Src Void
expr <- Expr Src Void -> Object -> Either CompileError (Expr Src Void)
toDhall Expr Src Void
ty Object
value
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
Core.App (Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr Src Void
exprType (FieldSelection Src -> Expr Src Void)
-> FieldSelection Src -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
key) Expr Src Void
expr
Maybe (Expr Src Void)
Nothing -> case Object
value of
Prim (AnyValue (Value.Text Text
a)) | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key ->
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr Src Void
exprType (Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
a)
Object
_ -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
exprType Object
value
in case [Either CompileError (Expr Src Void)] -> [Expr Src Void]
forall a b. [Either a b] -> [b]
rights (Map Text (Either CompileError (Expr Src Void))
-> [Either CompileError (Expr Src Void)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void))
-> Map Text (Maybe (Expr Src Void))
-> Map Text (Either CompileError (Expr Src Void))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void)
f Map Text (Maybe (Expr Src Void))
m)) of
[] -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
exprType Object
value
Expr Src Void
x:[Expr Src Void]
_ -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void
x
(Core.App Expr Src Void
Core.List Expr Src Void
t, Array []) -> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Maybe (Expr Src Void) -> Seq (Expr Src Void) -> Expr Src Void
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit (Expr Src Void -> Maybe (Expr Src Void)
forall a. a -> Maybe a
Just Expr Src Void
t) []
(Core.App Expr Src Void
Core.List Expr Src Void
t, Array [Object]
a) -> do
[Expr Src Void]
l <- (Object -> Either CompileError (Expr Src Void))
-> [Object] -> Either CompileError [Expr Src Void]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Expr Src Void -> Object -> Either CompileError (Expr Src Void)
toDhall Expr Src Void
t) [Object]
a
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Maybe (Expr Src Void) -> Seq (Expr Src Void) -> Expr Src Void
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit Maybe (Expr Src Void)
forall a. Maybe a
Nothing ([Expr Src Void] -> Seq (Expr Src Void)
forall a. [a] -> Seq a
Seq.fromList [Expr Src Void]
l)
(Core.Record Map Text (RecordField Src Void)
r, Table HashMap Piece Object
t) -> let
f :: Text -> (Expr Src Void) -> Either CompileError (Expr Src Void)
f :: Text -> Expr Src Void -> Either CompileError (Expr Src Void)
f Text
k Expr Src Void
ty | Just Object
val <- Piece -> HashMap Piece Object -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (Text -> Piece
Piece Text
k) HashMap Piece Object
t = Expr Src Void -> Object -> Either CompileError (Expr Src Void)
toDhall Expr Src Void
ty Object
val
| Core.App Expr Src Void
Core.Optional Expr Src Void
ty' <- Expr Src Void
ty = Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ (Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
Core.App Expr Src Void
forall s a. Expr s a
Core.None Expr Src Void
ty')
| Core.App Expr Src Void
Core.List Expr Src Void
_ <- Expr Src Void
ty = Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Maybe (Expr Src Void) -> Seq (Expr Src Void) -> Expr Src Void
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit (Expr Src Void -> Maybe (Expr Src Void)
forall a. a -> Maybe a
Just Expr Src Void
ty) []
| Bool
otherwise = CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
MissingKey (String -> CompileError) -> String -> CompileError
forall a b. (a -> b) -> a -> b
$ Text -> String
Data.Text.unpack Text
k
in do
Map Text (Expr Src Void)
values <- (Text -> Expr Src Void -> Either CompileError (Expr Src Void))
-> Map Text (Expr Src Void)
-> Either CompileError (Map Text (Expr Src Void))
forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
(k -> a -> f b) -> Map k a -> f (Map k b)
Map.traverseWithKey Text -> Expr Src Void -> Either CompileError (Expr Src Void)
f (RecordField Src Void -> Expr Src Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField Src Void -> Expr Src Void)
-> Map Text (RecordField Src Void) -> Map Text (Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField Src Void)
r)
Expr Src Void -> Either CompileError (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Either CompileError (Expr Src Void))
-> Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit (Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Expr Src Void -> RecordField Src Void)
-> Map Text (Expr Src Void) -> Map Text (RecordField Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (Expr Src Void)
values)
(Expr Src Void
_, Prim (AnyValue Value t
v)) -> Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
tomlValueToDhall Expr Src Void
exprType Value t
v
(Expr Src Void
ty, Object
obj) -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (CompileError -> Either CompileError (Expr Src Void))
-> CompileError -> Either CompileError (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
ty Object
obj
data Object
= Prim Toml.AnyValue.AnyValue
| Array [Object]
| Table (HashMap.HashMap Piece Object)
| Invalid
deriving (Int -> Object -> ShowS
[Object] -> ShowS
Object -> String
(Int -> Object -> ShowS)
-> (Object -> String) -> ([Object] -> ShowS) -> Show Object
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Object] -> ShowS
$cshowList :: [Object] -> ShowS
show :: Object -> String
$cshow :: Object -> String
showsPrec :: Int -> Object -> ShowS
$cshowsPrec :: Int -> Object -> ShowS
Show)
instance Semigroup Object where
(Table HashMap Piece Object
ls) <> :: Object -> Object -> Object
<> (Table HashMap Piece Object
rs) = HashMap Piece Object -> Object
Table (HashMap Piece Object
ls HashMap Piece Object
-> HashMap Piece Object -> HashMap Piece Object
forall a. Semigroup a => a -> a -> a
<> HashMap Piece Object
rs)
Object
_ <> Object
_ = Object
Invalid
sparseObject :: Key -> Object -> Object
sparseObject :: Key -> Object -> Object
sparseObject (Key (Piece
piece :| [])) Object
value = HashMap Piece Object -> Object
Table (HashMap Piece Object -> Object) -> HashMap Piece Object -> Object
forall a b. (a -> b) -> a -> b
$ Piece -> Object -> HashMap Piece Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Piece
piece Object
value
sparseObject (Key (Piece
piece :| Piece
rest:[Piece]
rest')) Object
value
= HashMap Piece Object -> Object
Table (HashMap Piece Object -> Object) -> HashMap Piece Object -> Object
forall a b. (a -> b) -> a -> b
$ Piece -> Object -> HashMap Piece Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Piece
piece (Key -> Object -> Object
sparseObject (NonEmpty Piece -> Key
Key (NonEmpty Piece -> Key) -> NonEmpty Piece -> Key
forall a b. (a -> b) -> a -> b
$ Piece
rest Piece -> [Piece] -> NonEmpty Piece
forall a. a -> [a] -> NonEmpty a
:| [Piece]
rest') Object
value)
pairsToObject :: HashMap.HashMap Key Toml.AnyValue.AnyValue -> Object
pairsToObject :: HashMap Key AnyValue -> Object
pairsToObject HashMap Key AnyValue
pairs
= (Object -> Object -> Object)
-> Object -> HashMap Key Object -> Object
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
(<>) (HashMap Piece Object -> Object
Table HashMap Piece Object
forall k v. HashMap k v
HashMap.empty)
(HashMap Key Object -> Object) -> HashMap Key Object -> Object
forall a b. (a -> b) -> a -> b
$ (Key -> Object -> Object)
-> HashMap Key Object -> HashMap Key Object
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.mapWithKey Key -> Object -> Object
sparseObject
(HashMap Key Object -> HashMap Key Object)
-> HashMap Key Object -> HashMap Key Object
forall a b. (a -> b) -> a -> b
$ (AnyValue -> Object) -> HashMap Key AnyValue -> HashMap Key Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnyValue -> Object
Prim HashMap Key AnyValue
pairs
tablesToObject :: Toml.PrefixTree.PrefixMap TOML -> Object
tablesToObject :: PrefixMap TOML -> Object
tablesToObject PrefixMap TOML
tables
= (Object -> Object -> Object) -> Object -> [Object] -> Object
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
(<>) (HashMap Piece Object -> Object
Table HashMap Piece Object
forall k v. HashMap k v
HashMap.empty)
([Object] -> Object) -> [Object] -> Object
forall a b. (a -> b) -> a -> b
$ (PrefixTree TOML -> Object) -> [PrefixTree TOML] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map PrefixTree TOML -> Object
prefixTreeToObject
([PrefixTree TOML] -> [Object]) -> [PrefixTree TOML] -> [Object]
forall a b. (a -> b) -> a -> b
$ PrefixMap TOML -> [PrefixTree TOML]
forall k v. HashMap k v -> [v]
HashMap.elems PrefixMap TOML
tables
prefixTreeToObject :: PrefixTree TOML -> Object
prefixTreeToObject :: PrefixTree TOML -> Object
prefixTreeToObject (Toml.PrefixTree.Leaf Key
key TOML
toml)
= Key -> Object -> Object
sparseObject Key
key (TOML -> Object
tomlToObject TOML
toml)
prefixTreeToObject (Toml.PrefixTree.Branch Key
prefix Maybe TOML
_ PrefixMap TOML
toml)
= Key -> Object -> Object
sparseObject Key
prefix (PrefixMap TOML -> Object
tablesToObject PrefixMap TOML
toml)
tableArraysToObject :: HashMap.HashMap Key (NonEmpty TOML) -> Object
tableArraysToObject :: HashMap Key (NonEmpty TOML) -> Object
tableArraysToObject HashMap Key (NonEmpty TOML)
arrays
= (Object -> Object -> Object)
-> Object -> HashMap Key Object -> Object
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
(<>) (HashMap Piece Object -> Object
Table HashMap Piece Object
forall k v. HashMap k v
HashMap.empty)
(HashMap Key Object -> Object) -> HashMap Key Object -> Object
forall a b. (a -> b) -> a -> b
$ (Key -> Object -> Object)
-> HashMap Key Object -> HashMap Key Object
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.mapWithKey Key -> Object -> Object
sparseObject
(HashMap Key Object -> HashMap Key Object)
-> HashMap Key Object -> HashMap Key Object
forall a b. (a -> b) -> a -> b
$ (NonEmpty TOML -> Object)
-> HashMap Key (NonEmpty TOML) -> HashMap Key Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Object] -> Object
Array ([Object] -> Object)
-> (NonEmpty TOML -> [Object]) -> NonEmpty TOML -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TOML -> Object) -> [TOML] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TOML -> Object
tomlToObject ([TOML] -> [Object])
-> (NonEmpty TOML -> [TOML]) -> NonEmpty TOML -> [Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TOML -> [TOML]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) HashMap Key (NonEmpty TOML)
arrays
tomlToObject :: TOML -> Object
tomlToObject :: TOML -> Object
tomlToObject TOML
toml = Object
pairs Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
tables Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
tableArrays
where
pairs :: Object
pairs = HashMap Key AnyValue -> Object
pairsToObject (HashMap Key AnyValue -> Object) -> HashMap Key AnyValue -> Object
forall a b. (a -> b) -> a -> b
$ TOML -> HashMap Key AnyValue
Toml.TOML.tomlPairs TOML
toml
tables :: Object
tables = PrefixMap TOML -> Object
tablesToObject (PrefixMap TOML -> Object) -> PrefixMap TOML -> Object
forall a b. (a -> b) -> a -> b
$ TOML -> PrefixMap TOML
Toml.TOML.tomlTables TOML
toml
tableArrays :: Object
tableArrays = HashMap Key (NonEmpty TOML) -> Object
tableArraysToObject (HashMap Key (NonEmpty TOML) -> Object)
-> HashMap Key (NonEmpty TOML) -> Object
forall a b. (a -> b) -> a -> b
$ TOML -> HashMap Key (NonEmpty TOML)
Toml.TOML.tomlTableArrays TOML
toml
tomlToDhallMain :: IO ()
tomlToDhallMain :: IO ()
tomlToDhallMain = do
Text
text <- IO Text
Text.IO.getContents
TOML
toml <- case Text -> Either TomlParseError TOML
Toml.Parser.parse Text
text of
Left TomlParseError
tomlErr -> CompileError -> IO TOML
forall e a. Exception e => e -> IO a
throwIO (TomlParseError -> CompileError
InvalidToml TomlParseError
tomlErr)
Right TOML
toml -> TOML -> IO TOML
forall (m :: * -> *) a. Monad m => a -> m a
return TOML
toml
[String]
args <- IO [String]
System.Environment.getArgs
String
schemaFile <- case [String]
args of
[] -> String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"schema not provided"
String
schemaFile:[] -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
schemaFile
[String]
_ -> String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"too many agrgs"
Expr Src Void
schema <- String -> IO (Expr Src Void)
fileToDhall String
schemaFile
Expr Src Void
dhall <- case Expr Src Void -> TOML -> Either CompileError (Expr Src Void)
tomlToDhall Expr Src Void
schema TOML
toml of
Left CompileError
err -> CompileError -> IO (Expr Src Void)
forall e a. Exception e => e -> IO a
throwIO CompileError
err
Right Expr Src Void
dhall -> Expr Src Void -> IO (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
dhall
Text -> IO ()
Text.IO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Expr Src Void -> Text
forall a. Pretty a => a -> Text
Core.pretty Expr Src Void
dhall