htoml-megaparsec 1.2.0.2 → 2.0.0.0
raw patch · 8 files changed
+528/−497 lines, 8 filesdep ~megaparsecPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: megaparsec
API changes (from Hackage documentation)
- Text.Toml: parseErrorPretty :: (Ord t, ShowToken t, ShowErrorComponent e) => ParseError t e -> String
- Text.Toml: parseTomlDoc :: FilePath -> Text -> Either TomlError Table
Files
- htoml-megaparsec.cabal +32/−3
- internal/Text/Megaparsec/CharRW.hs +31/−0
- internal/Text/Toml/Parser.hs +284/−0
- internal/Text/Toml/Types.hs +179/−0
- src/Text/Megaparsec/CharRW.hs +0/−31
- src/Text/Toml.hs +2/−0
- src/Text/Toml/Parser.hs +0/−284
- src/Text/Toml/Types.hs +0/−179
htoml-megaparsec.cabal view
@@ -1,6 +1,6 @@-cabal-version: 1.18+cabal-version: 2.0 name: htoml-megaparsec-version: 1.2.0.2+version: 2.0.0.0 license: BSD3 license-file: LICENSE copyright: (c) 2013-2016 Cies Breijs, 2017-2018 Vanessa McHale@@ -32,9 +32,36 @@ library exposed-modules: Text.Toml+ hs-source-dirs: src+ default-language: Haskell2010+ other-extensions: ConstraintKinds DeriveGeneric FlexibleContexts+ OverloadedStrings RankNTypes GADTs MonoLocalBinds+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5,+ containers >=0.5,+ megaparsec >=6.0.0,+ htoml-internal -any,+ unordered-containers >=0.2,+ vector >=0.10,+ text >=1.0 && <2,+ mtl >=2.2,+ composition-prelude >=0.1.1.0,+ deepseq -any,+ time >=1.5.0+ + if !impl(ghc >=7.10)+ build-depends:+ void -any+ + if impl(ghc >=8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates++library htoml-internal+ exposed-modules: Text.Toml.Parser Text.Toml.Types- hs-source-dirs: src+ hs-source-dirs: internal other-modules: Text.Megaparsec.CharRW default-language: Haskell2010@@ -82,6 +109,7 @@ text -any, time -any, htoml-megaparsec -any,+ htoml-internal -any, bytestring -any, file-embed -any, tasty -any,@@ -97,5 +125,6 @@ build-depends: base -any, htoml-megaparsec -any,+ htoml-internal -any, criterion -any, text -any
+ internal/Text/Megaparsec/CharRW.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GADTs #-}++module Text.Megaparsec.CharRW ( module X+ , oneOf+ , noneOf+ ) where++import Data.Foldable (Foldable)+import Text.Megaparsec+import Text.Megaparsec.Char as X hiding (noneOf, oneOf)+import qualified Text.Megaparsec.Char as Megaparsec++{-# RULES+"noneOf/char" forall c. noneOf [c] = char 'c'+"noneOf/satsify" forall c c'. noneOf [c, c'] = satisfy (\x -> x /= c && x /= c')+"oneOf/notChar" forall c. oneOf [c] = notChar 'c'+"oneOf/satisfy" forall c c'. oneOf [c, c'] = satisfy (\x -> x == c || x == c')+ #-}++{-# RULES+"noneOf/satsify" forall c c' c''. noneOf [c, c', c''] = satisfy (\x -> x /= c && x /= c' && x /= c'')+"oneOf/satsify" forall c c' c''. oneOf [c, c', c''] = satisfy (\x -> x == c || x == c' || x == c'')+ #-}++{-# INLINE [1] noneOf #-}+noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char+noneOf = Megaparsec.noneOf++{-# INLINE [1] oneOf #-}+oneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char+oneOf = Megaparsec.oneOf
+ internal/Text/Toml/Parser.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Text.Toml.Parser+ ( module Text.Toml.Parser+ , module Text.Toml.Types+ ) where++import Control.Applicative hiding (many, optional, some, (<|>))+import Control.Monad+import Control.Monad.State (evalState)+import Data.Functor+import qualified Data.HashMap.Lazy as M+import Data.Monoid+import qualified Data.Set as S+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Void+import Text.Megaparsec.CharRW++import Data.Time.Format (defaultTimeLocale, iso8601DateFormat,+ parseTimeM)++import Numeric (readHex)+import Text.Megaparsec++import Text.Toml.Types++import Prelude+++type TomlError = ParseError (Token Text) Void++-- | Convenience function for the test suite and GHCI.+parseOnly :: Parser Toml a -> Text -> Either TomlError a+parseOnly parser = flip evalState mempty . runParserT parser "noneSrc"++-- | Parses a complete document formatted according to the TOML spec.+tomlDoc :: (TomlM m) => Parser m Table+tomlDoc = do+ skipBlanks+ topTable <- table+ namedSections <- many namedSection+ -- Ensure the input is completely consumed+ eof+ -- Load each named section into the top table+ foldM (flip (insert Explicit)) topTable namedSections++-- | Parses a table of key-value pairs.+table :: (TomlM m) => Parser m Table+table = do+ pairs <- many (assignment <* skipBlanks) <|> (skipBlanks >> pure [])+ case maybeDupe (map fst pairs) of+ Just k -> throwParser $ "Cannot redefine key '" ++ unpack k ++ "'"+ Nothing -> return $ M.fromList pairs++-- | Parses an inline table of key-value pairs.+inlineTable :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node)+inlineTable = do+ pairs <- between (char '{') (char '}') (skipSpaces *> separatedValues <* skipSpaces)+ case maybeDupe (map fst pairs) of+ Just k ->+ pure $ Left (S.fromList [ErrorFail $ "Cannot redefine key " ++ unpack k ])+ Nothing -> pure $ Right $ VTable $ M.fromList pairs+ where+ skipSpaces = many (satisfy isSpc)+ separatedValues = sepBy (skipSpaces *> assignment <* skipSpaces) comma+ comma = skipSpaces >> char ',' >> skipSpaces++-- | Find dupes, if any.+maybeDupe :: Ord a => [a] -> Maybe a+maybeDupe xx = dup xx S.empty+ where+ dup [] _ = Nothing+ dup (x:xs) s = if S.member x s then Just x else dup xs (S.insert x s)+++-- | Parses a 'Table' or 'TableArray' with its header.+-- The resulting tuple has the header's value in the first position, and the+-- 'NTable' or 'NTArray' in the second.+namedSection :: (TomlM m) => Parser m ([Text], Node)+namedSection = do+ eitherHdr <- try (Left <$> tableHeader) <|> (Right <$> tableArrayHeader)+ skipBlanks+ tbl <- table+ skipBlanks+ return $ case eitherHdr of Left ns -> (ns, VTable tbl )+ Right ns -> (ns, VTArray $ V.singleton tbl)+++-- | Parses a table header.+tableHeader :: (TomlM m) => Parser m [Text]+tableHeader = between (char '[') (char ']') headerValue+++-- | Parses a table array header.+tableArrayHeader :: (TomlM m) => Parser m [Text]+tableArrayHeader = between (string "[[") (string "]]") headerValue+++-- | Parses the value of any header (names separated by dots), into a list of 'Text'.+headerValue :: (TomlM m) => Parser m [Text]+headerValue = ((pack <$> some keyChar) <|> anyStr') `sepBy1` char '.'+ where+ keyChar = alphaNumChar <|> oneOf ("-_" :: String)++-- | Parses a key-value assignment.+assignment :: (TomlM m) => Parser m (Text, Node)+assignment = do+ k <- (pack <$> some keyChar) <|> anyStr'+ many (satisfy isSpc) >> char '=' >> skipBlanks+ v' <- value+ v <- case v' of+ Right x -> pure x+ Left y -> fancyFailure y+ return (k, v)+ where+ -- TODO: Follow the spec, e.g.: only first char cannot be '['.+ keyChar = alphaNumChar <|> oneOf ("-_" :: String)+++-- | Parses a value.+value :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node)+value = (pure <$> try array <?> "array")+ <|> (pure <$> try boolean <?> "boolean")+ <|> (pure <$> try anyStr <?> "string")+ <|> (pure <$> try datetime <?> "datetime")+ <|> (pure <$> try float <?> "float")+ <|> (pure <$> try integer <?> "integer")+ <|> (inlineTable <?> "inline table")+++--+-- | * Toml value parsers+--++array :: (TomlM m) => Parser m Node+array = (try (arrayOf array) <?> "array of arrays")+ <|> (try (arrayOf boolean) <?> "array of booleans")+ <|> (try (arrayOf anyStr) <?> "array of strings")+ <|> (try (arrayOf datetime) <?> "array of datetimes")+ <|> (try (arrayOf float) <?> "array of floats")+ <|> (arrayOf integer <?> "array of integers")+++boolean :: (TomlM m) => Parser m Node+boolean = VBoolean <$> ( string "true" $> True <|>+ string "false" $> False )+++anyStr :: (TomlM m) => Parser m Node+anyStr = VString <$> anyStr'++anyStr' :: (TomlM m) => Parser m Text+anyStr' = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> literalStr+++basicStr :: (TomlM m) => Parser m Text+basicStr = between dQuote dQuote (pack <$> many strChar)+ where+ strChar = escSeq <|> noneOf ("\"\\" :: String)+ dQuote = char '\"'++multiBasicStr :: (TomlM m) => Parser m Text+multiBasicStr = openDQuote3 *> escWhiteSpc *> (pack <$> manyTill strChar (try dQuote3))+ where+ -- | Parse the a tripple-double quote, with possibly a newline attached+ openDQuote3 = try (dQuote3 <* char '\n') <|> dQuote3+ -- | Parse tripple-double quotes+ dQuote3 = count 3 $ char '"'+ -- | Parse a string char, accepting escaped codes, ignoring escaped white space+ strChar = escSeq <|> noneOf ("\\" :: String) <* escWhiteSpc+ -- | Parse escaped white space, if any+ escWhiteSpc = many $ char '\\' >> char '\n' >> many (oneOf ("\n\t " :: String))+++literalStr :: (TomlM m) => Parser m Text+literalStr = between sQuote sQuote (pack <$> many (noneOf ("'" :: String)))+ where+ sQuote = char '\''+++multiLiteralStr :: (TomlM m) => Parser m Text+multiLiteralStr = openSQuote3 *> (pack <$> manyTill anyChar sQuote3)+ where+ -- | Parse the a tripple-single quote, with possibly a newline attached+ openSQuote3 = try (sQuote3 <* char '\n') <|> sQuote3+ -- | Parse tripple-single quotes+ sQuote3 = try . count 3 . char $ '\''+++datetime :: (TomlM m) => Parser m Node+datetime = do+ d <- manyTill anyChar (char 'Z')+ let mt = parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%X") d+ case mt of Just t -> return $ VDatetime t+ Nothing -> throwParser "parsing datetime failed"+++-- | Attoparsec 'double' parses scientific "e" notation; reimplement according to Toml spec.+float :: (TomlM m) => Parser m Node+float = VFloat <$> do+ n <- intStr <* lookAhead (oneOf (".eE" :: String))+ d <- (char '.' *> uintStr) <|> return "0"+ e <- (oneOf ("eE" :: String) *> intStr) <|> return "0"+ return . read . join $ [n, ".", d, "e", e]+ where+ sign = (T.singleton <$> char '-') <|> (char '+' >> return "") <|> return ""+ uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar)+ intStr = do s <- T.unpack <$> sign+ u <- uintStr+ return . join $ s : [u]+++integer :: (TomlM m) => Parser m Node+integer = VInteger <$> signed (read <$> uintStr)+ where+ uintStr :: (TomlM m) => Parser m String+ uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar)++--+-- * Utility functions+--++-- | Parses the elements of an array, while restricting them to a certain type.+arrayOf :: (TomlM m) => Parser m Node -> Parser m Node+arrayOf p = VArray . V.fromList <$>+ between (char '[') (char ']') (skipBlanks *> separatedValues)+ where+ separatedValues = sepEndBy (skipBlanks *> try p <* skipBlanks) comma <* skipBlanks+ comma = skipBlanks >> char ',' >> skipBlanks+++-- | Parser for escape sequences.+escSeq :: (TomlM m) => Parser m Char+escSeq = char '\\' *> escSeqChar+ where+ escSeqChar = char '"'+ <|> char '\\'+ <|> char '/'+ <|> char 'n' $> '\n'+ <|> char 't' $> '\t'+ <|> char 'r' $> '\r'+ <|> char 'b' $> '\b'+ <|> char 'f' $> '\f'+ <|> char 'u' *> unicodeHex 4+ <|> char 'U' *> unicodeHex 8+ <?> "escaped character"+++-- | Parser for unicode hexadecimal values of representation length 'n'.+unicodeHex :: (TomlM m) => Int -> Parser m Char+unicodeHex n = do+ h <- count n hexDigitChar -- (satisfy isHex)+ let v = fst . head . readHex $ h+ return $ if v <= maxChar then toEnum v else '�'+ where+ -- isHex x = or . sequence [isDigit, isAsciiUpper, isAsciiLower]+ maxChar = fromEnum (maxBound :: Char)+++-- | Parser for signs (a plus or a minus).+signed :: (Num a, TomlM m) => Parser m a -> Parser m a+signed p = p+ <|> (negate <$> (char '-' *> p))+ <|> (char '+' *> p)+++-- | Parses the (rest of the) line including an EOF, whitespace and comments.+skipBlanks :: (TomlM m) => Parser m ()+skipBlanks = skipMany blank+ where+ blank = void (some (satisfy isSpc)) <|> comment <|> void eol+ comment = char '#' >> void (many $ noneOf ("\n" :: String))+++-- | Results in 'True' for whitespace chars, tab or space, according to spec.+isSpc :: Char -> Bool+isSpc ' ' = True+isSpc '\t' = True+isSpc _ = False
+ internal/Text/Toml/Types.hs view
@@ -0,0 +1,179 @@+{-# 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"
− src/Text/Megaparsec/CharRW.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE GADTs #-}--module Text.Megaparsec.CharRW ( module X- , oneOf- , noneOf- ) where--import Data.Foldable (Foldable)-import Text.Megaparsec-import Text.Megaparsec.Char as X hiding (noneOf, oneOf)-import qualified Text.Megaparsec.Char as Megaparsec--{-# RULES-"noneOf/char" forall c. noneOf [c] = char 'c'-"noneOf/satsify" forall c c'. noneOf [c, c'] = satisfy (\x -> x /= c && x /= c')-"oneOf/notChar" forall c. oneOf [c] = notChar 'c'-"oneOf/satisfy" forall c c'. oneOf [c, c'] = satisfy (\x -> x == c || x == c')- #-}--{-# RULES-"noneOf/satsify" forall c c' c''. noneOf [c, c', c''] = satisfy (\x -> x /= c && x /= c' && x /= c'')-"oneOf/satsify" forall c c' c''. oneOf [c, c', c''] = satisfy (\x -> x == c || x == c' || x == c'')- #-}--{-# INLINE [1] noneOf #-}-noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-noneOf = Megaparsec.noneOf--{-# INLINE [1] oneOf #-}-oneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char-oneOf = Megaparsec.oneOf
src/Text/Toml.hs view
@@ -1,5 +1,7 @@ module Text.Toml ( parseTomlDoc , parseErrorPretty+ , Table+ , Node (..) ) where import Control.Composition
− src/Text/Toml/Parser.hs
@@ -1,284 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Text.Toml.Parser- ( module Text.Toml.Parser- , module Text.Toml.Types- ) where--import Control.Applicative hiding (many, optional, some, (<|>))-import Control.Monad-import Control.Monad.State (evalState)-import Data.Functor-import qualified Data.HashMap.Lazy as M-import Data.Monoid-import qualified Data.Set as S-import Data.Text (Text, pack, unpack)-import qualified Data.Text as T-import qualified Data.Vector as V-import Data.Void-import Text.Megaparsec.CharRW--import Data.Time.Format (defaultTimeLocale, iso8601DateFormat,- parseTimeM)--import Numeric (readHex)-import Text.Megaparsec--import Text.Toml.Types--import Prelude---type TomlError = ParseError (Token Text) Void---- | Convenience function for the test suite and GHCI.-parseOnly :: Parser Toml a -> Text -> Either TomlError a-parseOnly parser = flip evalState mempty . runParserT parser "noneSrc"---- | Parses a complete document formatted according to the TOML spec.-tomlDoc :: (TomlM m) => Parser m Table-tomlDoc = do- skipBlanks- topTable <- table- namedSections <- many namedSection- -- Ensure the input is completely consumed- eof- -- Load each named section into the top table- foldM (flip (insert Explicit)) topTable namedSections---- | Parses a table of key-value pairs.-table :: (TomlM m) => Parser m Table-table = do- pairs <- many (assignment <* skipBlanks) <|> (skipBlanks >> pure [])- case maybeDupe (map fst pairs) of- Just k -> throwParser $ "Cannot redefine key '" ++ unpack k ++ "'"- Nothing -> return $ M.fromList pairs---- | Parses an inline table of key-value pairs.-inlineTable :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node)-inlineTable = do- pairs <- between (char '{') (char '}') (skipSpaces *> separatedValues <* skipSpaces)- case maybeDupe (map fst pairs) of- Just k ->- pure $ Left (S.fromList [ErrorFail $ "Cannot redefine key " ++ unpack k ])- Nothing -> pure $ Right $ VTable $ M.fromList pairs- where- skipSpaces = many (satisfy isSpc)- separatedValues = sepBy (skipSpaces *> assignment <* skipSpaces) comma- comma = skipSpaces >> char ',' >> skipSpaces---- | Find dupes, if any.-maybeDupe :: Ord a => [a] -> Maybe a-maybeDupe xx = dup xx S.empty- where- dup [] _ = Nothing- dup (x:xs) s = if S.member x s then Just x else dup xs (S.insert x s)----- | Parses a 'Table' or 'TableArray' with its header.--- The resulting tuple has the header's value in the first position, and the--- 'NTable' or 'NTArray' in the second.-namedSection :: (TomlM m) => Parser m ([Text], Node)-namedSection = do- eitherHdr <- try (Left <$> tableHeader) <|> (Right <$> tableArrayHeader)- skipBlanks- tbl <- table- skipBlanks- return $ case eitherHdr of Left ns -> (ns, VTable tbl )- Right ns -> (ns, VTArray $ V.singleton tbl)----- | Parses a table header.-tableHeader :: (TomlM m) => Parser m [Text]-tableHeader = between (char '[') (char ']') headerValue----- | Parses a table array header.-tableArrayHeader :: (TomlM m) => Parser m [Text]-tableArrayHeader = between (string "[[") (string "]]") headerValue----- | Parses the value of any header (names separated by dots), into a list of 'Text'.-headerValue :: (TomlM m) => Parser m [Text]-headerValue = ((pack <$> some keyChar) <|> anyStr') `sepBy1` char '.'- where- keyChar = alphaNumChar <|> oneOf ("-_" :: String)---- | Parses a key-value assignment.-assignment :: (TomlM m) => Parser m (Text, Node)-assignment = do- k <- (pack <$> some keyChar) <|> anyStr'- many (satisfy isSpc) >> char '=' >> skipBlanks- v' <- value- v <- case v' of- Right x -> pure x- Left y -> fancyFailure y- return (k, v)- where- -- TODO: Follow the spec, e.g.: only first char cannot be '['.- keyChar = alphaNumChar <|> oneOf ("-_" :: String)----- | Parses a value.-value :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node)-value = (pure <$> try array <?> "array")- <|> (pure <$> try boolean <?> "boolean")- <|> (pure <$> try anyStr <?> "string")- <|> (pure <$> try datetime <?> "datetime")- <|> (pure <$> try float <?> "float")- <|> (pure <$> try integer <?> "integer")- <|> (inlineTable <?> "inline table")-------- | * Toml value parsers-----array :: (TomlM m) => Parser m Node-array = (try (arrayOf array) <?> "array of arrays")- <|> (try (arrayOf boolean) <?> "array of booleans")- <|> (try (arrayOf anyStr) <?> "array of strings")- <|> (try (arrayOf datetime) <?> "array of datetimes")- <|> (try (arrayOf float) <?> "array of floats")- <|> (arrayOf integer <?> "array of integers")---boolean :: (TomlM m) => Parser m Node-boolean = VBoolean <$> ( string "true" $> True <|>- string "false" $> False )---anyStr :: (TomlM m) => Parser m Node-anyStr = VString <$> anyStr'--anyStr' :: (TomlM m) => Parser m Text-anyStr' = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> literalStr---basicStr :: (TomlM m) => Parser m Text-basicStr = between dQuote dQuote (pack <$> many strChar)- where- strChar = escSeq <|> noneOf ("\"\\" :: String)- dQuote = char '\"'--multiBasicStr :: (TomlM m) => Parser m Text-multiBasicStr = openDQuote3 *> escWhiteSpc *> (pack <$> manyTill strChar (try dQuote3))- where- -- | Parse the a tripple-double quote, with possibly a newline attached- openDQuote3 = try (dQuote3 <* char '\n') <|> dQuote3- -- | Parse tripple-double quotes- dQuote3 = count 3 $ char '"'- -- | Parse a string char, accepting escaped codes, ignoring escaped white space- strChar = escSeq <|> noneOf ("\\" :: String) <* escWhiteSpc- -- | Parse escaped white space, if any- escWhiteSpc = many $ char '\\' >> char '\n' >> many (oneOf ("\n\t " :: String))---literalStr :: (TomlM m) => Parser m Text-literalStr = between sQuote sQuote (pack <$> many (noneOf ("'" :: String)))- where- sQuote = char '\''---multiLiteralStr :: (TomlM m) => Parser m Text-multiLiteralStr = openSQuote3 *> (pack <$> manyTill anyChar sQuote3)- where- -- | Parse the a tripple-single quote, with possibly a newline attached- openSQuote3 = try (sQuote3 <* char '\n') <|> sQuote3- -- | Parse tripple-single quotes- sQuote3 = try . count 3 . char $ '\''---datetime :: (TomlM m) => Parser m Node-datetime = do- d <- manyTill anyChar (char 'Z')- let mt = parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%X") d- case mt of Just t -> return $ VDatetime t- Nothing -> throwParser "parsing datetime failed"----- | Attoparsec 'double' parses scientific "e" notation; reimplement according to Toml spec.-float :: (TomlM m) => Parser m Node-float = VFloat <$> do- n <- intStr <* lookAhead (oneOf (".eE" :: String))- d <- (char '.' *> uintStr) <|> return "0"- e <- (oneOf ("eE" :: String) *> intStr) <|> return "0"- return . read . join $ [n, ".", d, "e", e]- where- sign = (T.singleton <$> char '-') <|> (char '+' >> return "") <|> return ""- uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar)- intStr = do s <- T.unpack <$> sign- u <- uintStr- return . join $ s : [u]---integer :: (TomlM m) => Parser m Node-integer = VInteger <$> signed (read <$> uintStr)- where- uintStr :: (TomlM m) => Parser m String- uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar)------- * Utility functions------- | Parses the elements of an array, while restricting them to a certain type.-arrayOf :: (TomlM m) => Parser m Node -> Parser m Node-arrayOf p = VArray . V.fromList <$>- between (char '[') (char ']') (skipBlanks *> separatedValues)- where- separatedValues = sepEndBy (skipBlanks *> try p <* skipBlanks) comma <* skipBlanks- comma = skipBlanks >> char ',' >> skipBlanks----- | Parser for escape sequences.-escSeq :: (TomlM m) => Parser m Char-escSeq = char '\\' *> escSeqChar- where- escSeqChar = char '"'- <|> char '\\'- <|> char '/'- <|> char 'n' $> '\n'- <|> char 't' $> '\t'- <|> char 'r' $> '\r'- <|> char 'b' $> '\b'- <|> char 'f' $> '\f'- <|> char 'u' *> unicodeHex 4- <|> char 'U' *> unicodeHex 8- <?> "escaped character"----- | Parser for unicode hexadecimal values of representation length 'n'.-unicodeHex :: (TomlM m) => Int -> Parser m Char-unicodeHex n = do- h <- count n hexDigitChar -- (satisfy isHex)- let v = fst . head . readHex $ h- return $ if v <= maxChar then toEnum v else '�'- where- -- isHex x = or . sequence [isDigit, isAsciiUpper, isAsciiLower]- maxChar = fromEnum (maxBound :: Char)----- | Parser for signs (a plus or a minus).-signed :: (Num a, TomlM m) => Parser m a -> Parser m a-signed p = p- <|> (negate <$> (char '-' *> p))- <|> (char '+' *> p)----- | Parses the (rest of the) line including an EOF, whitespace and comments.-skipBlanks :: (TomlM m) => Parser m ()-skipBlanks = skipMany blank- where- blank = void (some (satisfy isSpc)) <|> comment <|> void eol- comment = char '#' >> void (many $ noneOf ("\n" :: String))----- | Results in 'True' for whitespace chars, tab or space, according to spec.-isSpc :: Char -> Bool-isSpc ' ' = True-isSpc '\t' = True-isSpc _ = False
− src/Text/Toml/Types.hs
@@ -1,179 +0,0 @@-{-# 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"