module Text.Toml.Types where
import Data.Aeson.Types
import qualified Data.HashMap.Strict as M
import Data.Int (Int64)
import Data.List (intersect)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.Format ()
import qualified Data.Vector as V
type Table = M.HashMap Text Node
data Node = NTValue TValue
| NTable Table
| NTArray [Table]
deriving (Eq, Show)
data TValue = VString Text
| VInteger Int64
| VFloat Double
| VBoolean Bool
| VDatetime UTCTime
| VArray [TValue]
deriving (Eq, Show)
emptyTable :: Table
emptyTable = M.empty
emptyNTable :: Node
emptyNTable = NTable M.empty
insert :: ([Text], Node) -> Table -> Either Text Table
insert ([], _) _ = error "FATAL: Cannot call 'insert' without a name."
insert (_ , NTValue _) _ = error "FATAL: Cannot call 'insert' with a TValue."
insert ([name], node) ttbl =
case M.lookup name ttbl of
Nothing -> Right $ M.insert name node ttbl
Just (NTable t) -> case node of
(NTable nt) -> case merge t nt of
Left ds -> Left $ T.concat [ "Cannot redefine key(s) (", (T.intercalate ", " ds)
, "), from table named '", name, "'." ]
Right r -> Right $ M.insert name (NTable r) ttbl
(NTArray _) -> commonInsertError node [name]
Just (NTArray a) -> case node of
(NTable _) -> commonInsertError node [name]
(NTArray na) -> Right $ M.insert name (NTArray $ a ++ na) ttbl
Just _ -> commonInsertError node [name]
insert (fullName@(name:ns), node) ttbl =
case M.lookup name ttbl of
Nothing -> case insert (ns, node) emptyTable of
Left msg -> Left msg
Right r -> Right $ M.insert name (NTable r) ttbl
Just (NTable t) -> case insert (ns, node) t of
Left msg -> Left msg
Right tt -> Right $ M.insert name (NTable tt) ttbl
Just (NTArray []) -> error "FATAL: Call to 'insert' found impossibly empty NTArray."
Just (NTArray a) -> case insert (ns, node) (last a) of
Left msg -> Left msg
Right t -> Right $ M.insert name (NTArray $ (init a) ++ [t]) ttbl
Just _ -> commonInsertError node fullName
merge :: Table -> Table -> Either [Text] Table
merge existing new = case intersect (M.keys existing) (M.keys new) of
[] -> Right $ M.union existing new
ds -> Left $ ds
commonInsertError :: Node -> [Text] -> Either Text Table
commonInsertError what name =
let w = case what of (NTable _) -> "tables"
_ -> "array of tables"
n = T.intercalate "." name
in Left $ T.concat ["Cannot insert ", w, " '", n, "' as key already exists."]
instance ToJSON Node where
toJSON (NTValue v) = toJSON v
toJSON (NTable v) = toJSON v
toJSON (NTArray v) = toJSON v
instance ToJSON TValue where
toJSON (VString v) = toJSON v
toJSON (VInteger v) = toJSON v
toJSON (VFloat v) = toJSON v
toJSON (VBoolean v) = toJSON v
toJSON (VDatetime v) = toJSON v
toJSON (VArray v) = toJSON v
class ToBsJSON a where
toBsJSON :: a -> Value
instance (ToBsJSON a) => ToBsJSON [a] where
toBsJSON = Array . V.fromList . map toBsJSON
instance (ToBsJSON v) => ToBsJSON (M.HashMap Text v) where
toBsJSON = Object . M.map toBsJSON
instance ToBsJSON Node where
toBsJSON (NTValue v) = toBsJSON v
toBsJSON (NTable v) = toBsJSON v
toBsJSON (NTArray v) = toBsJSON v
instance ToBsJSON TValue where
toBsJSON (VString v) = object [ "type" .= toJSON ("string" :: String)
, "value" .= toJSON v ]
toBsJSON (VInteger v) = object [ "type" .= toJSON ("integer" :: String)
, "value" .= toJSON (show v) ]
toBsJSON (VFloat v) = object [ "type" .= toJSON ("float" :: String)
, "value" .= toJSON (show v) ]
toBsJSON (VBoolean v) = object [ "type" .= toJSON ("bool" :: String)
, "value" .= toJSON (if v then "true" else "false" :: String) ]
toBsJSON (VDatetime v) = object [ "type" .= toJSON ("datetime" :: String)
, "value" .= toJSON (let s = show v
z = take (length s 4) s ++ "Z"
d = take (length z 10) z
t = drop (length z 9) z
in d ++ "T" ++ t) ]
toBsJSON (VArray v) = object [ "type" .= toJSON ("array" :: String)
, "value" .= toBsJSON v ]