{-# LANGUAGE GADTs           #-}
{-# LANGUAGE OverloadedLists #-}

{-| This module exports the `tomlToDhall` function for translating a
    TOML syntax tree from @tomland@ to a Dhall syntax tree. For now,
    this package does not have type inference so a Dhall type is needed.

    For converting source code into a Dhall syntax tree see the @dhall@
    package, and for converting the TOML syntax tree to source code see
    the @tomland@ package.

    This module also exports `tomlToDhallMain` which implements the
    @toml-to-dhall@ command which converts TOML source directly into
    Dhall source.

    In theory all TOML objects should be converted but there are some known
    failure cases:
    * Arrays of arrays of objects - not supported by @tomland@
    * Arrays of heterogeneous primitive types - not supported by @tomland@
        * Arrays of objects of different types are allowed (note that this
            requires conversion to a Dhall union)

    TOML bools translate to Dhall @Bool@s:

> $ cat schema.dhall
> { b : Bool }
> $ toml-to-dhall schema.dhall <<< 'b = true'
> { b = True }

    TOML numbers translate to Dhall numbers:

> $ cat schema.dhall
> { n : Natural, d : Double }
> $ toml-to-dhall schema.dhall << EOF
> n = 1
> d = 3.14
> EOF
> { d = 3.14, n = 1}

    TOML text translates to Dhall @Text@:

> $ cat schema.dhall
> { t : Text }
> $ toml-to-dhall schema.dhall << EOF
> t = "Hello!"
> EOF
> { t = "Hello!" }

    TOML arrays and table arrays translate to Dhall @List@:

> $ cat schema.dhall
> { nums : List Natural, tables : List { a : Natural, b : Text } }
> $ toml-to-dhall schema.dhall << EOF
> nums = [1, 2, 3]
>
> [[tables]]
> a = 1
> b = "Hello,"
> [[tables]]
> a = 2
> b = " World!"
> EOF
> { nums = [ 1, 2, 3 ]
> , tables = [ { a = 1, b = "Hello," }, { a = 2, b = " World!" } ]
> }

    Note, [lists of lists of objects](https://github.com/kowainik/tomland/issues/373)
    and [heterogeneous lists](https://github.com/kowainik/tomland/issues/373) are not
    supported by @tomland@ so a paraser error will be returned:

> $ cat schema.dhall
> { list : List (<a : Natural | b : Bool>) }
> $ toml-to-dhall schema.dhall << EOF
> list = [1, true]
> EOF
> toml-to-dhall: invalid TOML:
> 1:12:
>   |
> 1 | list = [1, true]
>   |            ^
> unexpected 't'
> expecting ',', ']', or integer

    Because of this, unions have limited use in lists, but can be used fully
    in tables:

> $ cat schema.dhall
> { list : List (<a : Natural | b : Bool>), item : <a : Natural | b : Bool> }
> $ toml-to-dhall schema.dhall << EOF
> list = [1, 2]
> item = true
> EOF
> { item = < a : Natural | b : Bool >.b True
> , list = [ < a : Natural | b : Bool >.a 1, < a : Natural | b : Bool >.a 2 ]
> }

    TOML tables translate to Dhall records:

> $ cat schema.dhall
> { num : Natural, table : { num1 : Natural, table1 : { num2 : Natural } } }
> $ toml-to-dhall schema.dhall << EOF
> num = 0
>
> [table]
> num1 = 1
>
> [table.table1]
> num2 = 2
> EOF
> { num = 0, table = { num1 = 1, table1.num2 = 2 } }

-}
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)

    -- TODO: allow different types of matching (ex. first, strict, none)
    -- currently we just pick the first enum that matches
    (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))

-- TODO: keep track of the path for more helpful error messages
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"

    -- TODO: allow different types of matching (ex. first, strict, none)
    -- currently we just pick the first enum that matches
    (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


-- | An intermediate object created from a 'TOML' before an 'Expr'.
--   It does two things, firstly joining the tomlPairs, tomlTables,
--   and tomlTableArrays parts of the TOML. Second, it turns the dense
--   paths (ex. a.b.c = 1) into sparse paths (ex. a = { b = { c = 1 }}).
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)
    -- this shouldn't happen because tomland has already verified correctness
    -- of the toml object
    Object
_ <> Object
_ = Object
Invalid

-- | Creates an arbitrarily nested object
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