{-# 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])
-- | 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 = 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 (Eq, Show, Generic)
instance NFData Node where
-- | 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 (Eq, Show)
-- | Convenience function to get a boolean value.
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]
-- | 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 :: (TomlM m) => Explicitness -> ([Text], Node) -> Table -> Parser m Table
insert _ ([], _) _ = throwParser "FATAL: Cannot call 'insert' without a name."
insert ex ([name], node) ttbl =
-- In case 'name' is final (a top-level name)
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 =
-- In case 'name' is not final (not a top-level name)
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
-- FIXME use a Set here (?)
-- | 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 existing new = case M.keys existing `intersect` M.keys new of
[] -> Right $ M.union existing new
ds -> Left 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 :: (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 ()
-- | Like 'updateExStateOrError' but does not raise errors. Only use this when sure
-- that redefinitions cannot occur.
updateExState :: (TomlM m) => [Text] -> Node -> Parser m ()
updateExState name (VTable _) = lift $ modify (S.insert name)
updateExState _ _ = return ()
-- * Parse errors resulting from invalid TOML
-- | Key(s) redefintion error.
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, "'." ]
-- | Table redefinition error.
tableClashError :: (TomlM m) => [Text] -> Parser m a
tableClashError name = throwParser . T.unpack $ T.concat
[ "Cannot redefine table named: '", T.intercalate "." name, "'." ]
-- | Common redefinition error.
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"