diff --git a/htoml-megaparsec.cabal b/htoml-megaparsec.cabal --- a/htoml-megaparsec.cabal +++ b/htoml-megaparsec.cabal @@ -1,20 +1,21 @@ -cabal-version: 2.0 -name: htoml-megaparsec -version: 2.1.0.3 -license: BSD3 -license-file: LICENSE -copyright: (c) 2013-2016 Cies Breijs, 2017-2018 Vanessa McHale -maintainer: Vanessa McHale -author: Cies Breijs, Vanessa McHale -homepage: https://hub.darcs.net/vmchale/htoml-megaparsec -bug-reports: https://hub.darcs.net/vmchale/htoml-megaparsec/issues -synopsis: Parser for TOML files +cabal-version: 2.0 +name: htoml-megaparsec +version: 2.1.0.4 +license: BSD3 +license-file: LICENSE +copyright: (c) 2013-2016 Cies Breijs, 2017-2018 Vanessa McHale +maintainer: Vanessa McHale +author: Cies Breijs, Vanessa McHale +homepage: https://hub.darcs.net/vmchale/htoml-megaparsec +bug-reports: https://hub.darcs.net/vmchale/htoml-megaparsec/issues +synopsis: Parser for TOML files description: TOML is an obvious and minimal format for config files. This package provides a TOML parser built with the Megaparsec. -category: Data, Text, Configuration, Language, TOML -build-type: Simple + +category: Data, Text, Configuration, Language, TOML +build-type: Simple extra-source-files: test/BurntSushi/fetch-toml-tests.sh test/BurntSushi/valid/*.toml @@ -22,25 +23,28 @@ test/BurntSushi/invalid/*.toml benchmarks/example.toml benchmarks/repeated.toml -extra-doc-files: README.md - CHANGES.md +extra-doc-files: + README.md + CHANGES.md + source-repository head - type: darcs + type: darcs location: https://hub.darcs.net/vmchale/htoml-megaparsec library - exposed-modules: - Text.Toml - hs-source-dirs: src + exposed-modules: Text.Toml + hs-source-dirs: src default-language: Haskell2010 - other-extensions: ConstraintKinds DeriveGeneric FlexibleContexts - OverloadedStrings RankNTypes GADTs MonoLocalBinds DeriveAnyClass - ghc-options: -Wall + other-extensions: + ConstraintKinds DeriveGeneric FlexibleContexts OverloadedStrings + RankNTypes GADTs MonoLocalBinds DeriveAnyClass + + ghc-options: -Wall build-depends: base >=4.8 && <5, megaparsec >=6.0.0, - htoml-internal -any, + htoml-internal, text >=1.0 && <2, mtl >=2.2, composition-prelude >=0.1.1.0 @@ -52,71 +56,69 @@ exposed-modules: Text.Toml.Parser Text.Toml.Types - hs-source-dirs: internal - other-modules: - Text.Megaparsec.CharRW + + hs-source-dirs: internal + other-modules: Text.Megaparsec.CharRW default-language: Haskell2010 - other-extensions: ConstraintKinds DeriveGeneric FlexibleContexts - OverloadedStrings RankNTypes GADTs MonoLocalBinds - ghc-options: -Wall + other-extensions: + ConstraintKinds DeriveGeneric FlexibleContexts OverloadedStrings + RankNTypes GADTs MonoLocalBinds + + ghc-options: -Wall build-depends: - base >=4.7 && <5, + base >=4.7 && <5.0, containers >=0.5, - megaparsec >=7.0.0, + megaparsec >=6.0.0, unordered-containers >=0.2, vector >=0.10, text >=1.0 && <2, mtl >=2.2, - deepseq -any, + deepseq, time >=1.5.0 - if !impl(ghc >=8.0) - build-depends: - semigroups -any - if !impl(ghc >=7.10) - build-depends: - void -any + build-depends: void if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates test-suite htoml-test - type: exitcode-stdio-1.0 - main-is: Test.hs - hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test other-modules: BurntSushi JSON Text.Toml.Parser.Spec + default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.9 && <5, - megaparsec -any, - containers -any, - unordered-containers -any, - vector -any, - aeson -any, - text -any, - time -any, - htoml-megaparsec -any, - htoml-internal -any, - bytestring -any, - file-embed -any, - tasty -any, - tasty-hspec -any, - tasty-hunit -any + megaparsec, + containers, + unordered-containers, + vector, + aeson, + text, + time, + htoml-megaparsec, + htoml-internal, + bytestring, + file-embed, + tasty, + tasty-hspec, + tasty-hunit benchmark benchmarks - type: exitcode-stdio-1.0 - main-is: Benchmarks.hs - hs-source-dirs: benchmarks . + type: exitcode-stdio-1.0 + main-is: Benchmarks.hs + hs-source-dirs: benchmarks . default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall build-depends: - base -any, - htoml-megaparsec -any, - htoml-internal -any, - criterion -any, - text -any + base, + htoml-megaparsec, + htoml-internal, + criterion, + text diff --git a/internal/Text/Toml/Parser.hs b/internal/Text/Toml/Parser.hs --- a/internal/Text/Toml/Parser.hs +++ b/internal/Text/Toml/Parser.hs @@ -11,7 +11,7 @@ import Control.Monad import Control.Monad.State (evalState) import Data.Functor -import qualified Data.HashMap.Lazy as HM +import qualified Data.HashMap.Lazy as M import qualified Data.Set as S import Data.Text (Text, pack, unpack) import qualified Data.Text as T @@ -39,15 +39,15 @@ -- Ensure the input is completely consumed eof -- Load each named section into the top table - foldM (flip (insert Explicit)) topTable namedSections + foldM (\x y -> insert Explicit y x) topTable namedSections -- | Parses a table of key-value pairs. table :: (TomlM m) => Parser m Table table = do - pairs <- many (assignment <* skipBlanks) <|> (skipBlanks Data.Functor.$> []) + pairs <- many (assignment <* skipBlanks) <|> (skipBlanks >> pure []) case maybeDupe (map fst pairs) of Just k -> throwParser $ "Cannot redefine key '" ++ unpack k ++ "'" - Nothing -> pure $ HM.fromList pairs + Nothing -> return $ M.fromList pairs -- | Parses an inline table of key-value pairs. inlineTable :: (TomlM m) => Parser m (Either (S.Set (ErrorFancy Void)) Node) @@ -56,11 +56,11 @@ case maybeDupe (map fst pairs) of Just k -> pure $ Left (S.fromList [ErrorFail $ "Cannot redefine key " ++ unpack k ]) - Nothing -> pure $ Right $ VTable $ HM.fromList pairs + Nothing -> pure $ Right $ VTable $ M.fromList pairs where skipSpaces = many (satisfy isSpc) separatedValues = sepBy (skipSpaces *> assignment <* skipSpaces) comma - comma = skipSpaces *> char ',' *> skipSpaces + comma = skipSpaces >> char ',' >> skipSpaces -- | Find dupes, if any. maybeDupe :: Ord a => [a] -> Maybe a @@ -79,8 +79,8 @@ skipBlanks tbl <- table skipBlanks - pure $ case eitherHdr of Left ns -> (ns, VTable tbl) - Right ns -> (ns, VTArray $ V.singleton tbl) + return $ case eitherHdr of Left ns -> (ns, VTable tbl ) + Right ns -> (ns, VTArray $ V.singleton tbl) -- | Parses a table header. @@ -103,12 +103,12 @@ assignment :: (TomlM m) => Parser m (Text, Node) assignment = do k <- (pack <$> some keyChar) <|> anyStr' - many (satisfy isSpc) *> char '=' *> skipBlanks + many (satisfy isSpc) >> char '=' >> skipBlanks v' <- value v <- case v' of Right x -> pure x Left y -> fancyFailure y - pure (k, v) + return (k, v) where -- TODO: Follow the spec, e.g.: only first char cannot be '['. keyChar = alphaNumChar <|> oneOf ("-_" :: String) @@ -164,7 +164,7 @@ -- | 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)) + escWhiteSpc = many $ char '\\' >> char '\n' >> many (oneOf ("\n\t " :: String)) literalStr :: (TomlM m) => Parser m Text @@ -184,22 +184,22 @@ datetime = do d <- manyTill anySingle (char 'Z') let mt = parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%X") d - case mt of Just t -> pure $ VDatetime t + 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) <|> pure "0" - e <- (oneOf ("eE" :: String) *> intStr) <|> pure "0" - pure . read . join $ [n, ".", d, "e", e] + 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 '+' Data.Functor.$> "") <|> pure "" + sign = (T.singleton <$> char '-') <|> (char '+' >> return "") <|> return "" uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar) intStr = do s <- T.unpack <$> sign u <- uintStr - pure . join $ s : [u] + return . join $ s : [u] integer :: (TomlM m) => Parser m Node integer = VInteger <$> signed (read <$> uintStr) @@ -217,7 +217,7 @@ between (char '[') (char ']') (skipBlanks *> separatedValues) where separatedValues = sepEndBy (skipBlanks *> try p <* skipBlanks) comma <* skipBlanks - comma = skipBlanks *> char ',' *> skipBlanks + comma = skipBlanks >> char ',' >> skipBlanks -- | Parser for escape sequences. escSeq :: (TomlM m) => Parser m Char @@ -240,7 +240,7 @@ unicodeHex n = do h <- count n hexDigitChar -- (satisfy isHex) let v = fst . head . readHex $ h - pure $ if v <= maxChar then toEnum v else '�' + return $ if v <= maxChar then toEnum v else '�' where -- isHex x = or . sequence [isDigit, isAsciiUpper, isAsciiLower] maxChar = fromEnum (maxBound :: Char) diff --git a/internal/Text/Toml/Types.hs b/internal/Text/Toml/Types.hs --- a/internal/Text/Toml/Types.hs +++ b/internal/Text/Toml/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -26,11 +26,13 @@ import Control.Monad.State (State) import Control.Monad.State.Class (MonadState, get, modify) import Control.Monad.Trans (lift) -import qualified Data.HashMap.Lazy as HM +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as M import Data.Int (Int64) import Data.List (intersect) -import Data.Semigroup +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 () @@ -40,18 +42,18 @@ import GHC.Generics (Generic) import Text.Megaparsec hiding (State) -type Parser m a = (MonadState (S.Set [T.Text]) m) => ParsecT Void T.Text m a +type Parser m a = (MonadState (Set [Text]) m) => ParsecT Void Text m a -type TomlM m = (MonadState (S.Set [T.Text]) m) +type TomlM m = (MonadState (S.Set [Text]) m) -type Toml = State (S.Set [T.Text]) +type Toml = State (S.Set [Text]) -- | The TOML 'Table' is a mapping ('HashMap') of 'Text' keys to 'Node' values. -type Table = HM.HashMap T.Text Node +type Table = HashMap Text Node -- | Contruct an empty 'Table'. emptyTable :: Table -emptyTable = HM.empty +emptyTable = M.empty -- | An array of 'Table's, implemented using a 'Vector'. type VTArray = Vector Table @@ -62,7 +64,7 @@ -- | A 'Node' may contain any type of value that may be put in a 'VArray'. data Node = VTable Table | VTArray VTArray - | VString T.Text + | VString Text | VInteger Int64 | VFloat Double | VBoolean Bool @@ -85,40 +87,40 @@ -- | 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 -> ([T.Text], Node) -> Table -> Parser m Table +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 HM.lookup name ttbl of + case M.lookup name ttbl of Nothing -> do when (isExplicit ex) $ updateExStateOrError [name] node - pure $ HM.insert name node ttbl + 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 - pure $ HM.insert name (VTable r) ttbl + return $ M.insert name (VTable r) ttbl _ -> commonInsertError node [name] Just (VTArray a) -> case node of - (VTArray na) -> pure $ HM.insert name (VTArray $ a <> na) ttbl + (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 HM.lookup name ttbl of + case M.lookup name ttbl of Nothing -> do r <- insert Implicit (ns, node) emptyTable when (isExplicit ex) $ updateExStateOrError fullName node - pure $ HM.insert name (VTable r) ttbl + return $ M.insert name (VTable r) ttbl Just (VTable t) -> do r <- insert Implicit (ns, node) t when (isExplicit ex) $ updateExStateOrError fullName node - pure $ HM.insert name (VTable r) ttbl + 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) - pure $ HM.insert name (VTArray $ V.init a `V.snoc` r) ttbl + return $ M.insert name (VTArray $ V.init a `V.snoc` r) ttbl Just _ -> commonInsertError node fullName @@ -126,9 +128,9 @@ -- | 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 [T.Text] Table -merge existing new = case HM.keys existing `intersect` HM.keys new of - [] -> Right $ HM.union existing new +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. @@ -137,36 +139,36 @@ -- 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) => [T.Text] -> Node -> Parser m () +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 _ _ = pure () +updateExStateOrError _ _ = return () -- | Like 'updateExStateOrError' but does not raise errors. Only use this when sure -- that redefinitions cannot occur. -updateExState :: (TomlM m) => [T.Text] -> Node -> Parser m () +updateExState :: (TomlM m) => [Text] -> Node -> Parser m () updateExState name (VTable _) = lift $ modify (S.insert name) -updateExState _ _ = pure () +updateExState _ _ = return () -- * Parse errors resulting from invalid TOML -- | Key(s) redefintion error. -nameInsertError :: (TomlM m) => [T.Text] -> T.Text -> Parser m a +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) => [T.Text] -> Parser m a +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 -> [T.Text] -> Parser m a +commonInsertError :: (TomlM m) => Node -> [Text] -> Parser m a commonInsertError what name = throwParser . join $ [ "Cannot insert ", w, " as '", n, "' since key already exists." ] where diff --git a/src/Text/Toml.hs b/src/Text/Toml.hs --- a/src/Text/Toml.hs +++ b/src/Text/Toml.hs @@ -2,12 +2,8 @@ , parseErrorPretty , Table , Node (..) - , TomlError - , VTArray - , VArray ) where -import Control.Composition import Control.Monad.State (evalState) import Data.Text (Text) import Text.Megaparsec @@ -19,4 +15,4 @@ parseTomlDoc :: FilePath -- ^ For error generation -> Text -- ^ TOML source -> Either TomlError Table -parseTomlDoc = flip evalState mempty .* runParserT tomlDoc +parseTomlDoc _ = flip evalState mempty . runParserT tomlDoc "noneSrc"