{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Text.Toml.Types
  ( Table
  , emptyTable
  , VTArray
  , VArray
  , Node (..)
  , Explicitness (..)
  , isExplicit
  , insert
  , ToJSON (..)
  , ToBsJSON (..)
  ) where

import           Control.Monad       (when)
import           Text.Parsec
import           Data.Aeson.Types
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap   as KM
#endif
import           Data.Int            (Int64)
import           Data.List           (intersect)
import           Data.Set (Set)
import qualified Data.Set            as S
import           Data.Text           (Text)
import qualified Data.Text           as T
import           Data.Time.Clock     (UTCTime)
import           Data.Time.Format    ()
import           Data.Vector         (Vector)
import qualified Data.Vector         as V


-- | The TOML 'Table' is a mapping ('HashMap') of 'Text' keys to 'Node' values.
type Table = HashMap Text Node

-- | Contruct an empty 'Table'.
emptyTable :: Table
emptyTable :: Table
emptyTable = Table
forall k v. HashMap k v
M.empty

-- | An array of 'Table's, implemented using a 'Vector'.
type VTArray = Vector Table

-- | A \"value\" array that may contain zero or more 'Node's, implemented using a 'Vector'.
type VArray = Vector Node

-- | A 'Node' may contain any type of value that may be put in a 'VArray'.
data Node = VTable    !Table
          | VTArray   !VTArray
          | VString   !Text
          | VInteger  !Int64
          | VFloat    !Double
          | VBoolean  !Bool
          | VDatetime !UTCTime
          | VArray    !VArray
  deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
/= :: Node -> Node -> Bool
Eq, Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show)

-- | To mark whether or not a 'Table' has been explicitly defined.
-- See: https://github.com/toml-lang/toml/issues/376
data Explicitness = Explicit | Implicit
  deriving (Explicitness -> Explicitness -> Bool
(Explicitness -> Explicitness -> Bool)
-> (Explicitness -> Explicitness -> Bool) -> Eq Explicitness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Explicitness -> Explicitness -> Bool
== :: Explicitness -> Explicitness -> Bool
$c/= :: Explicitness -> Explicitness -> Bool
/= :: Explicitness -> Explicitness -> Bool
Eq, Int -> Explicitness -> ShowS
[Explicitness] -> ShowS
Explicitness -> String
(Int -> Explicitness -> ShowS)
-> (Explicitness -> String)
-> ([Explicitness] -> ShowS)
-> Show Explicitness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Explicitness -> ShowS
showsPrec :: Int -> Explicitness -> ShowS
$cshow :: Explicitness -> String
show :: Explicitness -> String
$cshowList :: [Explicitness] -> ShowS
showList :: [Explicitness] -> ShowS
Show)

-- | Convenience function to get a boolean value.
isExplicit :: Explicitness -> Bool
isExplicit :: Explicitness -> Bool
isExplicit Explicitness
Explicit = Bool
True
isExplicit Explicitness
Implicit = Bool
False


-- | Inserts a table, 'Table', with the namespaced name, '[Text]', (which
-- may be part of a table array) into a 'Table'.
-- It may result in an error in the 'ParsecT' monad for redefinitions.
insert :: Explicitness -> ([Text], Node) -> Table -> Parsec Text (Set [Text]) Table
insert :: Explicitness
-> ([Text], Node) -> Table -> Parsec Text (Set [Text]) Table
insert Explicitness
_ ([], Node
_) Table
_ = String -> Parsec Text (Set [Text]) Table
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail String
"FATAL: Cannot call 'insert' without a name."
insert Explicitness
ex ([Text
name], Node
node) Table
ttbl =
    -- In case 'name' is final (a top-level name)
    case Text -> Table -> Maybe Node
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
name Table
ttbl of
      Maybe Node
Nothing -> do Bool
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) (ParsecT Text (Set [Text]) Identity ()
 -> ParsecT Text (Set [Text]) Identity ())
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExState [Text
name] Node
node
                    Table -> Parsec Text (Set [Text]) Table
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parsec Text (Set [Text]) Table)
-> Table -> Parsec Text (Set [Text]) Table
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name Node
node Table
ttbl
      Just (VTable Table
t) -> case Node
node of
          (VTable Table
nt) -> case Table -> Table -> Either [Text] Table
merge Table
t Table
nt of
                  Left [Text]
ds -> [Text] -> Text -> Parsec Text (Set [Text]) Table
forall a. [Text] -> Text -> Parsec Text (Set [Text]) a
nameInsertError [Text]
ds Text
name
                  Right Table
r -> do Bool
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) (ParsecT Text (Set [Text]) Identity ()
 -> ParsecT Text (Set [Text]) Identity ())
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall a b. (a -> b) -> a -> b
$
                                  [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExStateOrError [Text
name] Node
node
                                Table -> Parsec Text (Set [Text]) Table
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parsec Text (Set [Text]) Table)
-> Table -> Parsec Text (Set [Text]) Table
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (Table -> Node
VTable Table
r) Table
ttbl
          Node
_ -> Node -> [Text] -> Parsec Text (Set [Text]) Table
forall a. Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError Node
node [Text
name]
      Just (VTArray VTArray
a) -> case Node
node of
          (VTArray VTArray
na) -> Table -> Parsec Text (Set [Text]) Table
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parsec Text (Set [Text]) Table)
-> Table -> Parsec Text (Set [Text]) Table
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (VTArray -> Node
VTArray (VTArray -> Node) -> VTArray -> Node
forall a b. (a -> b) -> a -> b
$ VTArray
a VTArray -> VTArray -> VTArray
forall a. Vector a -> Vector a -> Vector a
V.++ VTArray
na) Table
ttbl
          Node
_ -> Node -> [Text] -> Parsec Text (Set [Text]) Table
forall a. Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError Node
node [Text
name]
      Just Node
_ -> Node -> [Text] -> Parsec Text (Set [Text]) Table
forall a. Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError Node
node [Text
name]
insert Explicitness
ex (fullName :: [Text]
fullName@(Text
name:[Text]
ns), Node
node) Table
ttbl =
    -- In case 'name' is not final (not a top-level name)
    case Text -> Table -> Maybe Node
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
name Table
ttbl of
      Maybe Node
Nothing -> do
          Table
r <- Explicitness
-> ([Text], Node) -> Table -> Parsec Text (Set [Text]) Table
insert Explicitness
Implicit ([Text]
ns, Node
node) Table
emptyTable
          Bool
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) (ParsecT Text (Set [Text]) Identity ()
 -> ParsecT Text (Set [Text]) Identity ())
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExState [Text]
fullName Node
node
          Table -> Parsec Text (Set [Text]) Table
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parsec Text (Set [Text]) Table)
-> Table -> Parsec Text (Set [Text]) Table
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (Table -> Node
VTable Table
r) Table
ttbl
      Just (VTable Table
t) -> do
          Table
r <- Explicitness
-> ([Text], Node) -> Table -> Parsec Text (Set [Text]) Table
insert Explicitness
Implicit ([Text]
ns, Node
node) Table
t
          Bool
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) (ParsecT Text (Set [Text]) Identity ()
 -> ParsecT Text (Set [Text]) Identity ())
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExStateOrError [Text]
fullName Node
node
          Table -> Parsec Text (Set [Text]) Table
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parsec Text (Set [Text]) Table)
-> Table -> Parsec Text (Set [Text]) Table
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (Table -> Node
VTable Table
r) Table
ttbl
      Just (VTArray VTArray
a) ->
          if VTArray -> Bool
forall a. Vector a -> Bool
V.null VTArray
a
          then String -> Parsec Text (Set [Text]) Table
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail String
"FATAL: Call to 'insert' found impossibly empty VArray."
          else do Table
r <- Explicitness
-> ([Text], Node) -> Table -> Parsec Text (Set [Text]) Table
insert Explicitness
Implicit ([Text]
ns, Node
node) (VTArray -> Table
forall a. Vector a -> a
V.last VTArray
a)
                  Table -> Parsec Text (Set [Text]) Table
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parsec Text (Set [Text]) Table)
-> Table -> Parsec Text (Set [Text]) Table
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (VTArray -> Node
VTArray (VTArray -> Node) -> VTArray -> Node
forall a b. (a -> b) -> a -> b
$ (VTArray -> VTArray
forall a. Vector a -> Vector a
V.init VTArray
a) VTArray -> Table -> VTArray
forall a. Vector a -> a -> Vector a
`V.snoc` Table
r) Table
ttbl
      Just Node
_ -> Node -> [Text] -> Parsec Text (Set [Text]) Table
forall a. Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError Node
node [Text]
fullName


-- | Merge two tables, resulting in an error when overlapping keys are
-- found ('Left' will contain those keys).  When no overlapping keys are
-- found the result will contain the union of both tables in a 'Right'.
merge :: Table -> Table -> Either [Text] Table
merge :: Table -> Table -> Either [Text] Table
merge Table
existing Table
new = case Table -> [Text]
forall k v. HashMap k v -> [k]
M.keys Table
existing [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` Table -> [Text]
forall k v. HashMap k v -> [k]
M.keys Table
new of
                       [] -> Table -> Either [Text] Table
forall a b. b -> Either a b
Right (Table -> Either [Text] Table) -> Table -> Either [Text] Table
forall a b. (a -> b) -> a -> b
$ Table -> Table -> Table
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union Table
existing Table
new
                       [Text]
ds -> [Text] -> Either [Text] Table
forall a b. a -> Either a b
Left  ([Text] -> Either [Text] Table) -> [Text] -> Either [Text] Table
forall a b. (a -> b) -> a -> b
$ [Text]
ds

-- TOML tables maybe redefined when first definition was implicit.
-- For instance a top-level table `a` can implicitly defined by defining a non top-level
-- table `b` under it (namely with `[a.b]`). Once the table `a` is subsequently defined
-- explicitly (namely with `[a]`), it is then not possible to (re-)define it again.
-- A parser state of all explicitly defined tables is maintained, which allows
-- raising errors for illegal redefinitions of such.
updateExStateOrError :: [Text] -> Node -> Parsec Text (Set [Text]) ()
updateExStateOrError :: [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExStateOrError [Text]
name node :: Node
node@(VTable Table
_) = do
    Set [Text]
explicitlyDefinedNames <- ParsecT Text (Set [Text]) Identity (Set [Text])
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
    Bool
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Set [Text] -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member [Text]
name Set [Text]
explicitlyDefinedNames) (ParsecT Text (Set [Text]) Identity ()
 -> ParsecT Text (Set [Text]) Identity ())
-> ParsecT Text (Set [Text]) Identity ()
-> ParsecT Text (Set [Text]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> ParsecT Text (Set [Text]) Identity ()
forall a. [Text] -> Parsec Text (Set [Text]) a
tableClashError [Text]
name
    [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExState [Text]
name Node
node
updateExStateOrError [Text]
_ Node
_ = () -> ParsecT Text (Set [Text]) Identity ()
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Like 'updateExStateOrError' but does not raise errors. Only use this when sure
-- that redefinitions cannot occur.
updateExState :: [Text] -> Node -> Parsec Text (S.Set [Text]) ()
updateExState :: [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExState [Text]
name (VTable Table
_) = (Set [Text] -> Set [Text]) -> ParsecT Text (Set [Text]) Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((Set [Text] -> Set [Text])
 -> ParsecT Text (Set [Text]) Identity ())
-> (Set [Text] -> Set [Text])
-> ParsecT Text (Set [Text]) Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Set [Text] -> Set [Text]
forall a. Ord a => a -> Set a -> Set a
S.insert [Text]
name
updateExState [Text]
_ Node
_ = () -> ParsecT Text (Set [Text]) Identity ()
forall a. a -> ParsecT Text (Set [Text]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- * Parse errors resulting from invalid TOML

-- | Key(s) redefintion error.
nameInsertError :: [Text] -> Text -> Parsec Text (Set [Text]) a
nameInsertError :: forall a. [Text] -> Text -> Parsec Text (Set [Text]) a
nameInsertError [Text]
ns Text
name = String -> ParsecT Text (Set [Text]) Identity a
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail (String -> ParsecT Text (Set [Text]) Identity a)
-> (Text -> String) -> Text -> ParsecT Text (Set [Text]) Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> ParsecT Text (Set [Text]) Identity a)
-> Text -> ParsecT Text (Set [Text]) Identity a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
    [ Text
"Cannot redefine key(s) (", Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ns
    , Text
"), from table named '", Text
name, Text
"'." ]

-- | Table redefinition error.
tableClashError :: [Text] -> Parsec Text (Set [Text]) a
tableClashError :: forall a. [Text] -> Parsec Text (Set [Text]) a
tableClashError [Text]
name = String -> ParsecT Text (Set [Text]) Identity a
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail (String -> ParsecT Text (Set [Text]) Identity a)
-> (Text -> String) -> Text -> ParsecT Text (Set [Text]) Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> ParsecT Text (Set [Text]) Identity a)
-> Text -> ParsecT Text (Set [Text]) Identity a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
    [ Text
"Cannot redefine table named: '", Text -> [Text] -> Text
T.intercalate Text
"." [Text]
name, Text
"'." ]

-- | Common redefinition error.
commonInsertError :: Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError :: forall a. Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError Node
what [Text]
name = String -> ParsecT Text (Set [Text]) Identity a
forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail (String -> ParsecT Text (Set [Text]) Identity a)
-> ([String] -> String)
-> [String]
-> ParsecT Text (Set [Text]) Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> ParsecT Text (Set [Text]) Identity a)
-> [String] -> ParsecT Text (Set [Text]) Identity a
forall a b. (a -> b) -> a -> b
$
    [ String
"Cannot insert ", String
w, String
" as '", String
n, String
"' since key already exists." ]
  where
    n :: String
n = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." [Text]
name
    w :: String
w = case Node
what of (VTable Table
_) -> String
"tables"
                     Node
_          -> String
"array of tables"


-- * Regular ToJSON instances

-- | 'ToJSON' instances for the 'Node' type that produce Aeson (JSON)
-- in line with the TOML specification.
instance ToJSON Node where
  toJSON :: Node -> Value
toJSON (VTable Table
v)    = Table -> Value
forall a. ToJSON a => a -> Value
toJSON Table
v
  toJSON (VTArray VTArray
v)   = VTArray -> Value
forall a. ToJSON a => a -> Value
toJSON VTArray
v
  toJSON (VString Text
v)   = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
v
  toJSON (VInteger Int64
v)  = Int64 -> Value
forall a. ToJSON a => a -> Value
toJSON Int64
v
  toJSON (VFloat Double
v)    = Double -> Value
forall a. ToJSON a => a -> Value
toJSON Double
v
  toJSON (VBoolean Bool
v)  = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
v
  toJSON (VDatetime UTCTime
v) = UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
v
  toJSON (VArray VArray
v)    = VArray -> Value
forall a. ToJSON a => a -> Value
toJSON VArray
v



-- * Special BurntSushi ToJSON type class and instances

-- | Type class for conversion to BurntSushi-style JSON.
--
-- BurntSushi has made a language agnostic test suite available that
-- this library uses. This test suit expects that values are encoded
-- as JSON objects with a 'type' and a 'value' member.
class ToBsJSON a where
  toBsJSON :: a -> Value

-- | Provide a 'toBsJSON' instance to the 'VTArray'.
instance (ToBsJSON a) => ToBsJSON (Vector a) where
  toBsJSON :: Vector a -> Value
toBsJSON = Array -> Value
Array (Array -> Value) -> (Vector a -> Array) -> Vector a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Vector a -> Array
forall a b. (a -> b) -> Vector a -> Vector b
V.map a -> Value
forall a. ToBsJSON a => a -> Value
toBsJSON
  {-# INLINE toBsJSON #-}

-- | Provide a 'toBsJSON' instance to the 'NTable'.
instance (ToBsJSON v) => ToBsJSON (M.HashMap Text v) where
#if MIN_VERSION_aeson(2,0,0)
  toBsJSON :: HashMap Text v -> Value
toBsJSON = Object -> Value
Object (Object -> Value)
-> (HashMap Text v -> Object) -> HashMap Text v -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Value -> Object
forall v. HashMap Text v -> KeyMap v
KM.fromHashMapText (HashMap Text Value -> Object)
-> (HashMap Text v -> HashMap Text Value)
-> HashMap Text v
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Value) -> HashMap Text v -> HashMap Text Value
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map v -> Value
forall a. ToBsJSON a => a -> Value
toBsJSON
#else
  toBsJSON = Object . M.map toBsJSON
#endif
  {-# INLINE toBsJSON #-}

-- | 'ToBsJSON' instance for 'KeyMap'.
#if MIN_VERSION_aeson(2,0,0)
instance (ToBsJSON v) => ToBsJSON (KM.KeyMap v) where
  toBsJSON :: KeyMap v -> Value
toBsJSON = Object -> Value
Object (Object -> Value) -> (KeyMap v -> Object) -> KeyMap v -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Value) -> KeyMap v -> Object
forall a b. (a -> b) -> KeyMap a -> KeyMap b
KM.map v -> Value
forall a. ToBsJSON a => a -> Value
toBsJSON
  {-# INLINE toBsJSON #-}
#endif

-- | 'ToBsJSON' instances for the 'TValue' type that produce Aeson (JSON)
-- in line with BurntSushi's language agnostic TOML test suite.
--
-- As seen in this function, BurntSushi's JSON encoding explicitly
-- specifies the types of the values.
instance ToBsJSON Node where
  toBsJSON :: Node -> Value
toBsJSON (VTable Table
v)    = Table -> Value
forall a. ToBsJSON a => a -> Value
toBsJSON Table
v
  toBsJSON (VTArray VTArray
v)   = VTArray -> Value
forall a. ToBsJSON a => a -> Value
toBsJSON VTArray
v
  toBsJSON (VString Text
v)   = [Pair] -> Value
object [ Key
"type"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"string" :: String)
                                  , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
v ]
  toBsJSON (VInteger Int64
v)  = [Pair] -> Value
object [ Key
"type"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"integer" :: String)
                                  , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (Int64 -> String
forall a. Show a => a -> String
show Int64
v) ]
  toBsJSON (VFloat Double
v)    = [Pair] -> Value
object [ Key
"type"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"float" :: String)
                                  , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (Double -> String
forall a. Show a => a -> String
show Double
v) ]
  toBsJSON (VBoolean Bool
v)  = [Pair] -> Value
object [ Key
"type"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"bool" :: String)
                                  , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (if Bool
v then String
"true" else String
"false" :: String) ]
  toBsJSON (VDatetime UTCTime
v) = [Pair] -> Value
object [ Key
"type"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"datetime" :: String)
                                  , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (let s :: String
s = UTCTime -> String
forall a. Show a => a -> String
show UTCTime
v
                                                           z :: String
z = Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)  String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Z"
                                                           d :: String
d = Int -> ShowS
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
z Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10) String
z
                                                           t :: String
t = Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
z Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
9)  String
z
                                                       in  String
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"T" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t) ]
  toBsJSON (VArray VArray
v)    = [Pair] -> Value
object [ Key
"type"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"array" :: String)
                                  , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= VArray -> Value
forall a. ToBsJSON a => a -> Value
toBsJSON VArray
v ]