{-# 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 = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq, Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Explicitness -> Explicitness -> Bool
$c/= :: Explicitness -> Explicitness -> Bool
== :: Explicitness -> Explicitness -> Bool
$c== :: Explicitness -> Explicitness -> Bool
Eq, Int -> Explicitness -> ShowS
[Explicitness] -> ShowS
Explicitness -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Explicitness] -> ShowS
$cshowList :: [Explicitness] -> ShowS
show :: Explicitness -> String
$cshow :: Explicitness -> String
showsPrec :: Int -> Explicitness -> ShowS
$cshowsPrec :: Int -> 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
_ = 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 forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
name Table
ttbl of
      Maybe Node
Nothing -> do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) forall a b. (a -> b) -> a -> b
$ [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExState [Text
name] Node
node
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 -> forall a. [Text] -> Text -> Parsec Text (Set [Text]) a
nameInsertError [Text]
ds Text
name
                  Right Table
r -> do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) forall a b. (a -> b) -> a -> b
$
                                  [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExStateOrError [Text
name] Node
node
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
_ -> 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (VTArray -> Node
VTArray forall a b. (a -> b) -> a -> b
$ VTArray
a forall a. Vector a -> Vector a -> Vector a
V.++ VTArray
na) Table
ttbl
          Node
_ -> forall a. Node -> [Text] -> Parsec Text (Set [Text]) a
commonInsertError Node
node [Text
name]
      Just Node
_ -> 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 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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) forall a b. (a -> b) -> a -> b
$ [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExState [Text]
fullName Node
node
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Explicitness -> Bool
isExplicit Explicitness
ex) forall a b. (a -> b) -> a -> b
$ [Text] -> Node -> ParsecT Text (Set [Text]) Identity ()
updateExStateOrError [Text]
fullName Node
node
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. Vector a -> Bool
V.null VTArray
a
          then 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) (forall a. Vector a -> a
V.last VTArray
a)
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
name (VTArray -> Node
VTArray forall a b. (a -> b) -> a -> b
$ (forall a. Vector a -> Vector a
V.init VTArray
a) forall a. Vector a -> a -> Vector a
`V.snoc` Table
r) Table
ttbl
      Just Node
_ -> 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 forall k v. HashMap k v -> [k]
M.keys Table
existing forall a. Eq a => [a] -> [a] -> [a]
`intersect` forall k v. HashMap k v -> [k]
M.keys Table
new of
                       [] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union Table
existing Table
new
                       [Text]
ds -> forall a b. a -> Either a b
Left  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 <- forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.member [Text]
name Set [Text]
explicitlyDefinedNames) forall a b. (a -> b) -> a -> b
$ 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
_ = 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
_) = forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
S.insert [Text]
name
updateExState [Text]
_ Node
_ = 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 = forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack 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 = forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack 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 = forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 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)    = forall a. ToJSON a => a -> Value
toJSON Table
v
  toJSON (VTArray VTArray
v)   = forall a. ToJSON a => a -> Value
toJSON VTArray
v
  toJSON (VString Text
v)   = forall a. ToJSON a => a -> Value
toJSON Text
v
  toJSON (VInteger Int64
v)  = forall a. ToJSON a => a -> Value
toJSON Int64
v
  toJSON (VFloat Double
v)    = forall a. ToJSON a => a -> Value
toJSON Double
v
  toJSON (VBoolean Bool
v)  = forall a. ToJSON a => a -> Value
toJSON Bool
v
  toJSON (VDatetime UTCTime
v) = forall a. ToJSON a => a -> Value
toJSON UTCTime
v
  toJSON (VArray VArray
v)    = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> Vector a -> Vector b
V.map 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. HashMap Text v -> KeyMap v
KM.fromHashMapText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> KeyMap a -> KeyMap b
KM.map 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)    = forall a. ToBsJSON a => a -> Value
toBsJSON Table
v
  toBsJSON (VTArray VTArray
v)   = forall a. ToBsJSON a => a -> Value
toBsJSON VTArray
v
  toBsJSON (VString Text
v)   = [Pair] -> Value
object [ Key
"type"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (String
"string" :: String)
                                  , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Text
v ]
  toBsJSON (VInteger Int64
v)  = [Pair] -> Value
object [ Key
"type"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (String
"integer" :: String)
                                  , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (forall a. Show a => a -> String
show Int64
v) ]
  toBsJSON (VFloat Double
v)    = [Pair] -> Value
object [ Key
"type"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (String
"float" :: String)
                                  , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (forall a. Show a => a -> String
show Double
v) ]
  toBsJSON (VBoolean Bool
v)  = [Pair] -> Value
object [ Key
"type"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (String
"bool" :: String)
                                  , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= 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"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (String
"datetime" :: String)
                                  , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (let s :: String
s = forall a. Show a => a -> String
show UTCTime
v
                                                           z :: String
z = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
4)  String
s forall a. [a] -> [a] -> [a]
++ String
"Z"
                                                           d :: String
d = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
z forall a. Num a => a -> a -> a
- Int
10) String
z
                                                           t :: String
t = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
z forall a. Num a => a -> a -> a
- Int
9)  String
z
                                                       in  String
d forall a. [a] -> [a] -> [a]
++ String
"T" forall a. [a] -> [a] -> [a]
++ String
t) ]
  toBsJSON (VArray VArray
v)    = [Pair] -> Value
object [ Key
"type"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (String
"array" :: String)
                                  , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToBsJSON a => a -> Value
toBsJSON VArray
v ]