{-# LANGUAGE ApplicativeDo     #-}
{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

{-| 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(..))
import Data.Bifunctor       (first)
import Data.Either          (rights)
import Data.Foldable        (fold, toList)
import Data.HashMap.Strict  (HashMap)
import Data.List.NonEmpty   (NonEmpty ((:|)))
import Data.Version         (showVersion)
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(..))
import Toml.Type.Key        (Key(..), Piece(..))
import Toml.Type.PrefixTree (PrefixMap, 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            as Text
import qualified Data.Text.IO         as Text.IO
import qualified Dhall.Core           as Core
import qualified Dhall.Map            as Map
import qualified Options.Applicative  as Options
import qualified Paths_dhall_toml     as Meta
import qualified Toml.Parser
import qualified Toml.Type.TOML       as TOML
import qualified Toml.Type.Value      as Value

data CompileError
    = Unimplemented String
    | Incompatible (Expr Src Void) Object
    | InvalidToml TomlParseError
    | InternalError String
    | MissingKey String
    deriving (Int -> CompileError -> ShowS
[CompileError] -> ShowS
CompileError -> String
(Int -> CompileError -> ShowS)
-> (CompileError -> String)
-> ([CompileError] -> ShowS)
-> Show CompileError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompileError -> ShowS
showsPrec :: Int -> CompileError -> ShowS
$cshow :: CompileError -> String
show :: CompileError -> String
$cshowList :: [CompileError] -> ShowS
showList :: [CompileError] -> ShowS
Show)

instance Exception CompileError where
    displayException :: CompileError -> String
displayException CompileError
exception = case CompileError
exception of
        Unimplemented String
s ->
            String
"unimplemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s
        Incompatible Expr Src Void
e Object
toml ->
            String
"incompatible: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expr Src Void -> String
forall a. Show a => a -> String
show Expr Src Void
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Object -> String
forall a. Show a => a -> String
show Object
toml
        InvalidToml TomlParseError
e ->
            String
"invalid TOML:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TomlParseError -> Text
Toml.Parser.unTomlParseError TomlParseError
e)
        InternalError String
e ->
            String
"internal error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
e
        MissingKey String
e ->
            String
"missing key: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
e

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)
objectToDhall (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)

valueToDhall
    :: Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
valueToDhall :: forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
valueToDhall Expr Src Void
type_ Value t
value = case (Expr Src Void
type_, Value t
value) 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 (Bool -> Expr Src Void
forall s a. Bool -> Expr s a
Core.BoolLit Bool
a)

    (Expr Src Void
Core.Integer, Value.Integer Integer
a) ->
        Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (Integer -> Expr Src Void
forall s a. Integer -> Expr s a
Core.IntegerLit Integer
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 (Natural -> Expr Src Void
forall s a. Natural -> Expr s a
Core.NaturalLit (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 (DhallDouble -> Expr Src Void
forall s a. DhallDouble -> Expr s a
Core.DoubleLit (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 (Chunks Src Void -> Expr Src Void
forall s a. Chunks s a -> Expr s a
Core.TextLit ([(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 (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 (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 (String -> CompileError
Unimplemented String
"toml time values")

    (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 (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
type_) [])

    (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)
valueToDhall Expr Src Void
t Value t
a
        return (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
elementType, Value.Array [Value t1]
elements) -> do
        [Expr Src Void]
expressions <- (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
valueToDhall Expr Src Void
elementType) [Value t1]
elements
        return (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]
expressions))

    -- 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
_) -> do
        let f :: Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void)
f Text
key Maybe (Expr Src Void)
maybeAlternativeType = case Maybe (Expr Src Void)
maybeAlternativeType of
                Just Expr Src Void
alternativeType -> do
                    Expr Src Void
expression <- Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
valueToDhall Expr Src Void
alternativeType Value t
value
                    return (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
type_ (Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
key)) Expr Src Void
expression)
                Maybe (Expr Src Void)
Nothing -> case Value t
value 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 a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr Src Void
type_ (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 (Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
type_ (AnyValue -> Object
Prim (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
value)))

        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 a. Map Text a -> [a]
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 (Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
type_ (AnyValue -> Object
Prim (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
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
x

    (Expr Src Void, Value t)
_ ->
        CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
type_ (AnyValue -> Object
Prim (Value t -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue Value t
value)))

-- TODO: keep track of the path for more helpful error messages
objectToDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void)
objectToDhall :: Expr Src Void -> Object -> Either CompileError (Expr Src Void)
objectToDhall Expr Src Void
type_ Object
object = case (Expr Src Void
type_, Object
object) of
    (Expr Src Void
_, Object
Invalid) -> CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (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
_) -> do
        let f :: Text
-> Maybe (Expr Src Void) -> Either CompileError (Expr Src Void)
f Text
key Maybe (Expr Src Void)
maybeAlternativeType = case Maybe (Expr Src Void)
maybeAlternativeType of
                Just Expr Src Void
alternativeType -> do
                    Expr Src Void
expression <- Expr Src Void -> Object -> Either CompileError (Expr Src Void)
objectToDhall Expr Src Void
alternativeType Object
object
                    return (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
type_ (Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
key)) Expr Src Void
expression)
                Maybe (Expr Src Void)
Nothing -> case Object
object 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 a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field Expr Src Void
type_ (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 (Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
type_ Object
object)

        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 a. Map Text a -> [a]
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 (Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
type_ Object
object)
            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
x

    (Core.Record Map Text (RecordField Src Void)
record, Table HashMap Piece Object
table) -> do
        let process :: Text -> Expr Src Void -> Either CompileError (Expr Src Void)
process Text
key Expr Src Void
fieldType
                | Just Object
nestedObject <- 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
key) HashMap Piece Object
table =
                    Expr Src Void -> Object -> Either CompileError (Expr Src Void)
objectToDhall Expr Src Void
fieldType Object
nestedObject
                | Core.App Expr Src Void
Core.Optional Expr Src Void
innerType <- Expr Src Void
fieldType =
                    Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (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
innerType)
                | Core.App Expr Src Void
Core.List Expr Src Void
_ <- Expr Src Void
fieldType =
                    Expr Src Void -> Either CompileError (Expr Src Void)
forall a b. b -> Either a b
Right (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
fieldType) [])
                | Bool
otherwise =
                    CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (String -> CompileError
MissingKey (Text -> String
Text.unpack Text
key))

        Map Text (Expr Src Void)
expressions <- (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)
process ((RecordField Src Void -> Expr Src Void)
-> Map Text (RecordField Src Void) -> Map Text (Expr Src Void)
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RecordField Src Void -> Expr Src Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue Map Text (RecordField Src Void)
record)

        return (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)
-> Map Text (Expr Src Void) -> Map Text (RecordField Src Void)
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField Map Text (Expr Src Void)
expressions))

    (Core.App Expr Src Void
Core.List (Core.Record [(Text
"mapKey", RecordField Src Void -> Expr Src Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr Src Void
Core.Text), (Text
"mapValue", RecordField Src Void -> Expr Src Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue -> Expr Src Void
valueType)]), Table HashMap Piece Object
table) -> do
        HashMap Piece (Expr Src Void)
hashMap <- (Object -> Either CompileError (Expr Src Void))
-> HashMap Piece Object
-> Either CompileError (HashMap Piece (Expr Src Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HashMap Piece a -> f (HashMap Piece b)
traverse (Expr Src Void -> Object -> Either CompileError (Expr Src Void)
objectToDhall Expr Src Void
valueType) HashMap Piece Object
table

        let expressions :: Seq (Expr Src Void)
expressions = [Expr Src Void] -> Seq (Expr Src Void)
forall a. [a] -> Seq a
Seq.fromList do
                (Piece Text
key, Expr Src Void
value) <- HashMap Piece (Expr Src Void) -> [(Piece, Expr Src Void)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Piece (Expr Src Void)
hashMap

                let newKey :: RecordField Src Void
newKey =
                        Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Chunks Src Void -> Expr Src Void
forall s a. Chunks s a -> Expr s a
Core.TextLit ([(Text, Expr Src Void)] -> Text -> Chunks Src Void
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] Text
key))

                let newValue :: RecordField Src Void
newValue = Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField Expr Src Void
value

                Expr Src Void -> [Expr Src Void]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit [(Text
"mapKey", RecordField Src Void
newKey), (Text
"mapValue", RecordField Src Void
newValue)])

        let listType :: Maybe (Expr Src Void)
listType = if Seq (Expr Src Void) -> Bool
forall a. Seq a -> Bool
Seq.null Seq (Expr Src Void)
expressions then Expr Src Void -> Maybe (Expr Src Void)
forall a. a -> Maybe a
Just Expr Src Void
type_ else Maybe (Expr Src Void)
forall a. Maybe a
Nothing

        Expr Src Void -> Either CompileError (Expr Src Void)
forall a. a -> Either CompileError a
forall (f :: * -> *) a. Applicative f => a -> f a
return (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)
listType Seq (Expr Src Void)
expressions)

    (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 (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]
elements) -> do
        [Expr Src Void]
expressions <- (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Expr Src Void -> Object -> Either CompileError (Expr Src Void)
objectToDhall Expr Src Void
t) [Object]
elements
        return (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]
expressions))

    (Expr Src Void
_, Prim (AnyValue Value t
value)) ->
        Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
forall (t :: TValue).
Expr Src Void -> Value t -> Either CompileError (Expr Src Void)
valueToDhall Expr Src Void
type_ Value t
value

    (Expr Src Void
_, Object
obj) ->
        CompileError -> Either CompileError (Expr Src Void)
forall a b. a -> Either a b
Left (Expr Src Void -> Object -> CompileError
Incompatible Expr Src Void
type_ 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 AnyValue
    | Array [Object]
    | Table (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
$cshowsPrec :: Int -> Object -> ShowS
showsPrec :: Int -> Object -> ShowS
$cshow :: Object -> String
show :: Object -> String
$cshowList :: [Object] -> ShowS
showList :: [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

instance Monoid Object where
    mempty :: Object
mempty = HashMap Piece Object -> Object
Table HashMap Piece Object
forall k v. HashMap k v
HashMap.empty

-- | Creates an arbitrarily nested object
sparseObject :: Key -> Object -> Object
sparseObject :: Key -> Object -> Object
sparseObject (Key (Piece
piece :| [])) Object
value =
    HashMap Piece Object -> Object
Table (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
piece' : [Piece]
pieces)) Object
value =
    HashMap Piece Object -> Object
Table (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 (Piece
piece' Piece -> [Piece] -> NonEmpty Piece
forall a. a -> [a] -> NonEmpty a
:| [Piece]
pieces)) Object
value))

tablesToObject :: PrefixMap TOML -> Object
tablesToObject :: PrefixMap TOML -> Object
tablesToObject = [Object] -> Object
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Object] -> Object)
-> (PrefixMap TOML -> [Object]) -> PrefixMap TOML -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrefixTree TOML -> Object) -> [PrefixTree TOML] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map PrefixTree TOML -> Object
prefixTreeToObject ([PrefixTree TOML] -> [Object])
-> (PrefixMap TOML -> [PrefixTree TOML])
-> PrefixMap TOML
-> [Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrefixMap TOML -> [PrefixTree TOML]
forall k v. HashMap k v -> [v]
HashMap.elems

prefixTreeToObject :: PrefixTree TOML -> Object
prefixTreeToObject :: PrefixTree TOML -> Object
prefixTreeToObject (Leaf Key
key TOML
toml) =
    Key -> Object -> Object
sparseObject Key
key (TOML -> Object
tomlToObject TOML
toml)
prefixTreeToObject (Branch Key
prefix Maybe TOML
_ PrefixMap TOML
toml) =
    Key -> Object -> Object
sparseObject Key
prefix (PrefixMap TOML -> Object
tablesToObject PrefixMap TOML
toml)

tomlToObject :: TOML -> Object
tomlToObject :: TOML -> Object
tomlToObject = TOML -> Object
pairs (TOML -> Object) -> (TOML -> Object) -> TOML -> Object
forall a. Semigroup a => a -> a -> a
<> TOML -> Object
tables (TOML -> Object) -> (TOML -> Object) -> TOML -> Object
forall a. Semigroup a => a -> a -> a
<> TOML -> Object
tableArrays
  where
    pairs :: TOML -> Object
pairs =
          HashMap Key Object -> Object
forall m. Monoid m => HashMap Key m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        (HashMap Key Object -> Object)
-> (TOML -> HashMap Key Object) -> TOML -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
-> (TOML -> HashMap Key Object) -> TOML -> HashMap Key Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnyValue -> Object) -> HashMap Key AnyValue -> HashMap Key Object
forall a b. (a -> b) -> HashMap Key a -> HashMap Key b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnyValue -> Object
Prim
        (HashMap Key AnyValue -> HashMap Key Object)
-> (TOML -> HashMap Key AnyValue) -> TOML -> HashMap Key Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> HashMap Key AnyValue
TOML.tomlPairs

    tables :: TOML -> Object
tables =
          [Object] -> Object
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        ([Object] -> Object) -> (TOML -> [Object]) -> TOML -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrefixTree TOML -> Object) -> [PrefixTree TOML] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map PrefixTree TOML -> Object
prefixTreeToObject
        ([PrefixTree TOML] -> [Object])
-> (TOML -> [PrefixTree TOML]) -> TOML -> [Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrefixMap TOML -> [PrefixTree TOML]
forall k v. HashMap k v -> [v]
HashMap.elems
        (PrefixMap TOML -> [PrefixTree TOML])
-> (TOML -> PrefixMap TOML) -> TOML -> [PrefixTree TOML]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> PrefixMap TOML
TOML.tomlTables

    tableArrays :: TOML -> Object
tableArrays =
          HashMap Key Object -> Object
forall m. Monoid m => HashMap Key m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        (HashMap Key Object -> Object)
-> (TOML -> HashMap Key Object) -> TOML -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
-> (TOML -> HashMap Key Object) -> TOML -> HashMap Key Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty TOML -> Object)
-> HashMap Key (NonEmpty TOML) -> HashMap Key Object
forall a b. (a -> b) -> HashMap Key a -> HashMap Key b
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 a b. (a -> b) -> [a] -> [b]
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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
        (HashMap Key (NonEmpty TOML) -> HashMap Key Object)
-> (TOML -> HashMap Key (NonEmpty TOML))
-> TOML
-> HashMap Key Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> HashMap Key (NonEmpty TOML)
TOML.tomlTableArrays

data Options = Options
    { Options -> Maybe String
input :: Maybe FilePath
    , Options -> Maybe String
output :: Maybe FilePath
    , Options -> String
schemaFile :: FilePath
    }

parserInfo :: Options.ParserInfo Options
parserInfo :: ParserInfo Options
parserInfo = Parser Options -> InfoMod Options -> ParserInfo Options
forall a. Parser a -> InfoMod a -> ParserInfo a
Options.info
    (Parser ((Options -> Options) -> Options -> Options)
forall a. Parser (a -> a)
Options.helper Parser ((Options -> Options) -> Options -> Options)
-> Parser (Options -> Options) -> Parser (Options -> Options)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Options -> Options)
forall a. Parser (a -> a)
versionOption Parser (Options -> Options) -> Parser Options -> Parser Options
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Options
optionsParser)
    (InfoMod Options
forall a. InfoMod a
Options.fullDesc InfoMod Options -> InfoMod Options -> InfoMod Options
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod Options
forall a. String -> InfoMod a
Options.progDesc String
"Convert TOML to Dhall")
  where
    versionOption :: Parser (a -> a)
versionOption =
        String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
Options.infoOption (Version -> String
showVersion Version
Meta.version)
            (String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.long String
"version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
Options.help String
"Display version")

    optionsParser :: Parser Options
optionsParser = do
        Maybe String
input <- (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Options.optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
Options.strOption)
            (  String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.long String
"file"
            Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
Options.help String
"Read TOML from file instead of standard input"
            Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Options.metavar String
"FILE"
            Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasCompleter f => String -> Mod f a
Options.action String
"file"
            )
        Maybe String
output <- (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Options.optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
Options.strOption)
            (  String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
Options.long String
"output"
            Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
Options.help String
"Write Dhall to a file instead of standard output"
            Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Options.metavar String
"FILE"
            Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasCompleter f => String -> Mod f a
Options.action String
"file"
            )
        String
schemaFile <- Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
Options.strArgument
            (  String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
Options.help String
"Path to Dhall schema file"
            Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasCompleter f => String -> Mod f a
Options.action String
"file"
            Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Options.metavar String
"SCHEMA"
            )
        pure Options {String
Maybe String
input :: Maybe String
output :: Maybe String
schemaFile :: String
input :: Maybe String
output :: Maybe String
schemaFile :: String
..}

tomlToDhallMain :: IO ()
tomlToDhallMain :: IO ()
tomlToDhallMain = do
    Options{String
Maybe String
input :: Options -> Maybe String
output :: Options -> Maybe String
schemaFile :: Options -> String
input :: Maybe String
output :: Maybe String
schemaFile :: String
..} <- ParserInfo Options -> IO Options
forall a. ParserInfo a -> IO a
Options.execParser ParserInfo Options
parserInfo

    Text
inputText <- case Maybe String
input of
        Just String
file -> String -> IO Text
Text.IO.readFile String
file
        Maybe String
Nothing   -> IO Text
Text.IO.getContents

    TOML
toml <- Either CompileError TOML -> IO TOML
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws ((TomlParseError -> CompileError)
-> Either TomlParseError TOML -> Either CompileError TOML
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TomlParseError -> CompileError
InvalidToml (Text -> Either TomlParseError TOML
Toml.Parser.parse Text
inputText))

    Expr Src Void
schema <- String -> IO (Expr Src Void)
fileToDhall String
schemaFile

    Expr Src Void
dhall <- Either CompileError (Expr Src Void) -> IO (Expr Src Void)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (Expr Src Void -> TOML -> Either CompileError (Expr Src Void)
tomlToDhall Expr Src Void
schema TOML
toml)

    let outputText :: Text
outputText = Expr Src Void -> Text
forall a. Pretty a => a -> Text
Core.pretty Expr Src Void
dhall

    case Maybe String
output of
        Just String
file -> String -> Text -> IO ()
Text.IO.writeFile String
file Text
outputText
        Maybe String
Nothing   -> Text -> IO ()
Text.IO.putStrLn Text
outputText