{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Text.Toml.Types
( Table
, emptyTable
, VTArray
, VArray
, Node (..)
, Explicitness (..)
, isExplicit
, insert
, throwParser
, Toml
, TomlM
, Parser
) where
import Control.Applicative (Alternative)
import Control.DeepSeq (NFData)
import Control.Monad (MonadPlus, join, when)
import Control.Monad.State (State)
import Control.Monad.State.Class (MonadState, get, modify)
import Control.Monad.Trans (lift)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
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
import Data.Void (Void)
import GHC.Generics (Generic)
import Text.Megaparsec hiding (State)
type Parser m a = (MonadState (Set [Text]) m) => ParsecT Void Text m a
type TomlM m = (MonadState (S.Set [Text]) m)
type Toml = State (S.Set [Text])
type Table = HashMap Text Node
emptyTable :: Table
emptyTable = M.empty
type VTArray = Vector Table
type VArray = Vector Node
data Node = VTable Table
| VTArray VTArray
| VString Text
| VInteger Int64
| VFloat Double
| VBoolean Bool
| VDatetime UTCTime
| VArray VArray
deriving (Eq, Show, Generic)
instance NFData Node where
data Explicitness = Explicit | Implicit
deriving (Eq, Show)
isExplicit :: Explicitness -> Bool
isExplicit Explicit = True
isExplicit Implicit = False
throwParser :: (MonadPlus m, Alternative m, Ord e, MonadParsec e s m) => String -> m a
throwParser x = fancyFailure $ S.fromList [ErrorFail x]
insert :: (TomlM m) => Explicitness -> ([Text], Node) -> Table -> Parser m Table
insert _ ([], _) _ = throwParser "FATAL: Cannot call 'insert' without a name."
insert ex ([name], node) ttbl =
case M.lookup name ttbl of
Nothing -> do when (isExplicit ex) $ updateExStateOrError [name] node
return $ M.insert name node ttbl
Just (VTable t) -> case node of
(VTable nt) -> case merge t nt of
Left ds -> nameInsertError ds name
Right r -> do when (isExplicit ex) $
updateExStateOrError [name] node
return $ M.insert name (VTable r) ttbl
_ -> commonInsertError node [name]
Just (VTArray a) -> case node of
(VTArray na) -> return $ M.insert name (VTArray $ a V.++ na) ttbl
_ -> commonInsertError node [name]
Just _ -> commonInsertError node [name]
insert ex (fullName@(name:ns), node) ttbl =
case M.lookup name ttbl of
Nothing -> do
r <- insert Implicit (ns, node) emptyTable
when (isExplicit ex) $ updateExStateOrError fullName node
return $ M.insert name (VTable r) ttbl
Just (VTable t) -> do
r <- insert Implicit (ns, node) t
when (isExplicit ex) $ updateExStateOrError fullName node
return $ M.insert name (VTable r) ttbl
Just (VTArray a) ->
if V.null a
then throwParser "FATAL: Call to 'insert' found impossibly empty VArray."
else do r <- insert Implicit (ns, node) (V.last a)
return $ M.insert name (VTArray $ V.init a `V.snoc` r) ttbl
Just _ -> commonInsertError node fullName
merge :: Table -> Table -> Either [Text] Table
merge existing new = case M.keys existing `intersect` M.keys new of
[] -> Right $ M.union existing new
ds -> Left ds
updateExStateOrError :: (TomlM m) => [Text] -> Node -> Parser m ()
updateExStateOrError name node@(VTable _) = do
explicitlyDefinedNames <- lift get
let ns = explicitlyDefinedNames
when (S.member name ns) $ tableClashError name
updateExState name node
updateExStateOrError _ _ = return ()
updateExState :: (TomlM m) => [Text] -> Node -> Parser m ()
updateExState name (VTable _) = lift $ modify (S.insert name)
updateExState _ _ = return ()
nameInsertError :: (TomlM m) => [Text] -> Text -> Parser m a
nameInsertError ns name = throwParser . T.unpack $ T.concat
[ "Cannot redefine key(s) (", T.intercalate ", " ns
, "), from table named '", name, "'." ]
tableClashError :: (TomlM m) => [Text] -> Parser m a
tableClashError name = throwParser . T.unpack $ T.concat
[ "Cannot redefine table named: '", T.intercalate "." name, "'." ]
commonInsertError :: (TomlM m) => Node -> [Text] -> Parser m a
commonInsertError what name = throwParser . join $
[ "Cannot insert ", w, " as '", n, "' since key already exists." ]
where
n = T.unpack $ T.intercalate "." name
w = case what of (VTable _) -> "tables"
_ -> "array of tables"