htoml-megaparsec 2.1.0.2 → 2.1.0.3
raw patch · 3 files changed
+54/−52 lines, 3 filesdep +semigroupsdep ~megaparsecPVP ok
version bump matches the API change (PVP)
Dependencies added: semigroups
Dependency ranges changed: megaparsec
API changes (from Hackage documentation)
Files
- htoml-megaparsec.cabal +8/−4
- internal/Text/Toml/Parser.hs +18/−18
- internal/Text/Toml/Types.hs +28/−30
htoml-megaparsec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: htoml-megaparsec-version: 2.1.0.2+version: 2.1.0.3 license: BSD3 license-file: LICENSE copyright: (c) 2013-2016 Cies Breijs, 2017-2018 Vanessa McHale@@ -44,7 +44,7 @@ text >=1.0 && <2, mtl >=2.2, composition-prelude >=0.1.1.0- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates @@ -69,11 +69,15 @@ mtl >=2.2, deepseq -any, time >=1.5.0- ++ if !impl(ghc >=8.0)+ build-depends:+ semigroups -any+ if !impl(ghc >=7.10) build-depends: void -any- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates
internal/Text/Toml/Parser.hs view
@@ -11,7 +11,7 @@ import Control.Monad import Control.Monad.State (evalState) import Data.Functor-import qualified Data.HashMap.Lazy as M+import qualified Data.HashMap.Lazy as HM import qualified Data.Set as S import Data.Text (Text, pack, unpack) import qualified Data.Text as T@@ -44,10 +44,10 @@ -- | Parses a table of key-value pairs. table :: (TomlM m) => Parser m Table table = do- pairs <- many (assignment <* skipBlanks) <|> (skipBlanks >> pure [])+ pairs <- many (assignment <* skipBlanks) <|> (skipBlanks Data.Functor.$> []) case maybeDupe (map fst pairs) of Just k -> throwParser $ "Cannot redefine key '" ++ unpack k ++ "'"- Nothing -> return $ M.fromList pairs+ Nothing -> pure $ HM.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 $ M.fromList pairs+ Nothing -> pure $ Right $ VTable $ HM.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- return $ case eitherHdr of Left ns -> (ns, VTable tbl )- Right ns -> (ns, VTArray $ V.singleton tbl)+ pure $ 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- return (k, v)+ pure (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 -> return $ VDatetime t+ case mt of Just t -> pure $ 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]+ d <- (char '.' *> uintStr) <|> pure "0"+ e <- (oneOf ("eE" :: String) *> intStr) <|> pure "0"+ pure . read . join $ [n, ".", d, "e", e] where- sign = (T.singleton <$> char '-') <|> (char '+' >> return "") <|> return ""+ sign = (T.singleton <$> char '-') <|> (char '+' Data.Functor.$> "") <|> pure "" uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar) intStr = do s <- T.unpack <$> sign u <- uintStr- return . join $ s : [u]+ pure . 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- return $ if v <= maxChar then toEnum v else '�'+ pure $ if v <= maxChar then toEnum v else '�' where -- isHex x = or . sequence [isDigit, isAsciiUpper, isAsciiLower] maxChar = fromEnum (maxBound :: Char)
internal/Text/Toml/Types.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -26,13 +26,11 @@ 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 qualified Data.HashMap.Lazy as HM import Data.Int (Int64) import Data.List (intersect)-import Data.Set (Set)+import Data.Semigroup 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 ()@@ -42,18 +40,18 @@ import GHC.Generics (Generic) import Text.Megaparsec hiding (State) -type Parser m a = (MonadState (Set [Text]) m) => ParsecT Void Text m a+type Parser m a = (MonadState (S.Set [T.Text]) m) => ParsecT Void T.Text m a -type TomlM m = (MonadState (S.Set [Text]) m)+type TomlM m = (MonadState (S.Set [T.Text]) m) -type Toml = State (S.Set [Text])+type Toml = State (S.Set [T.Text]) -- | The TOML 'Table' is a mapping ('HashMap') of 'Text' keys to 'Node' values.-type Table = HashMap Text Node+type Table = HM.HashMap T.Text Node -- | Contruct an empty 'Table'. emptyTable :: Table-emptyTable = M.empty+emptyTable = HM.empty -- | An array of 'Table's, implemented using a 'Vector'. type VTArray = Vector Table@@ -64,7 +62,7 @@ -- | A 'Node' may contain any type of value that may be put in a 'VArray'. data Node = VTable Table | VTArray VTArray- | VString Text+ | VString T.Text | VInteger Int64 | VFloat Double | VBoolean Bool@@ -87,40 +85,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 -> ([Text], Node) -> Table -> Parser m Table+insert :: (TomlM m) => Explicitness -> ([T.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+ case HM.lookup name ttbl of Nothing -> do when (isExplicit ex) $ updateExStateOrError [name] node- return $ M.insert name node ttbl+ pure $ HM.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+ pure $ HM.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+ (VTArray na) -> pure $ HM.insert name (VTArray $ a <> 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+ case HM.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+ pure $ HM.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+ pure $ HM.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+ pure $ HM.insert name (VTArray $ V.init a `V.snoc` r) ttbl Just _ -> commonInsertError node fullName @@ -128,9 +126,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 [Text] Table-merge existing new = case M.keys existing `intersect` M.keys new of- [] -> Right $ M.union existing new+merge :: Table -> Table -> Either [T.Text] Table+merge existing new = case HM.keys existing `intersect` HM.keys new of+ [] -> Right $ HM.union existing new ds -> Left ds -- TOML tables maybe redefined when first definition was implicit.@@ -139,36 +137,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) => [Text] -> Node -> Parser m ()+updateExStateOrError :: (TomlM m) => [T.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 ()+updateExStateOrError _ _ = pure () -- | Like 'updateExStateOrError' but does not raise errors. Only use this when sure -- that redefinitions cannot occur.-updateExState :: (TomlM m) => [Text] -> Node -> Parser m ()+updateExState :: (TomlM m) => [T.Text] -> Node -> Parser m () updateExState name (VTable _) = lift $ modify (S.insert name)-updateExState _ _ = return ()+updateExState _ _ = pure () -- * Parse errors resulting from invalid TOML -- | Key(s) redefintion error.-nameInsertError :: (TomlM m) => [Text] -> Text -> Parser m a+nameInsertError :: (TomlM m) => [T.Text] -> T.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 :: (TomlM m) => [T.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 :: (TomlM m) => Node -> [T.Text] -> Parser m a commonInsertError what name = throwParser . join $ [ "Cannot insert ", w, " as '", n, "' since key already exists." ] where