diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -import Prelude hiding (readFile) +import Prelude hiding (readFile) import Criterion.Main -import Data.Text.IO (readFile) +import Data.Text.IO (readFile) import Text.Toml +import Text.Toml.Types () +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe Left{} = Nothing +eitherToMaybe (Right x) = Just x main :: IO () main = do diff --git a/htoml-megaparsec.cabal b/htoml-megaparsec.cabal --- a/htoml-megaparsec.cabal +++ b/htoml-megaparsec.cabal @@ -1,5 +1,5 @@ name: htoml-megaparsec -version: 1.0.0.4 +version: 1.0.1.0 synopsis: Parser for TOML files description: TOML is an obvious and minimal format for config files. This package provides a TOML parser @@ -35,7 +35,7 @@ , Text.Toml.Types hs-source-dirs: src default-language: Haskell2010 - build-depends: base >= 4.3 && < 5 + build-depends: base >= 4.8 && < 5 , containers >= 0.5 , megaparsec >= 6.0.0 , unordered-containers >= 0.2 @@ -44,6 +44,7 @@ , text >= 1.0 && < 2 , mtl >= 2.2 , composition-prelude >= 0.1.1.0 + , deepseq , time -any , old-locale -any if impl(ghc >= 8.0) @@ -55,6 +56,7 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N main-is: Test.hs other-modules: BurntSushi + , JSON , Text.Toml.Parser.Spec type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -66,8 +68,7 @@ , aeson , text , time - -- from here non-lib deps - , htoml + , htoml-megaparsec , bytestring , file-embed , tasty @@ -89,5 +90,5 @@ , text , time -- from here non-lib deps - , htoml + , htoml-megaparsec , criterion diff --git a/src/Text/Toml.hs b/src/Text/Toml.hs --- a/src/Text/Toml.hs +++ b/src/Text/Toml.hs @@ -6,7 +6,6 @@ import Text.Megaparsec import Text.Toml.Parser - -- | Parse a 'Text' that results in 'Either' a 'String' -- containing the error message, or an internal representation -- of the document as a 'Table'. diff --git a/src/Text/Toml/Parser.hs b/src/Text/Toml/Parser.hs --- a/src/Text/Toml/Parser.hs +++ b/src/Text/Toml/Parser.hs @@ -57,9 +57,9 @@ -- | Parses a table of key-value pairs. table :: (TomlM m) => Parser m Table table = do - pairs <- try (many (assignment <* skipBlanks)) <|> (try skipBlanks >> return []) + pairs <- (many (assignment <* skipBlanks) <|> (skipBlanks >> return [])) case maybeDupe (map fst pairs) of - Just k -> fail $ "Cannot redefine key " ++ (unpack k) + Just k -> fail $ "Cannot redefine key " ++ unpack k Nothing -> return $ M.fromList pairs -- | Parses an inline table of key-value pairs. @@ -150,8 +150,8 @@ boolean :: (TomlM m) => Parser m Node -boolean = VBoolean <$> ( (try . string $ "true") *> return True <|> - (try . string $ "false") *> return False ) +boolean = VBoolean <$> ( (string $ "true") *> return True <|> + (string $ "false") *> return False ) anyStr :: (TomlM m) => Parser m Node @@ -164,7 +164,7 @@ basicStr :: (TomlM m) => Parser m Text basicStr = between dQuote dQuote (fmap pack $ many strChar) where - strChar = try escSeq <|> try (satisfy (\c -> c /= '"' && c /= '\\')) + strChar = escSeq <|> noneOf ("\"\\" :: String) --satisfy (\c -> c /= '"' && c /= '\\')) dQuote = char '\"' @@ -211,12 +211,12 @@ -- | Attoparsec 'double' parses scientific "e" notation; reimplement according to Toml spec. float :: (TomlM m) => Parser m Node float = VFloat <$> do - n <- intStr <* lookAhead (satisfy (\c -> c == '.' || c == 'e' || c == 'E')) - d <- (satisfy (== '.') *> uintStr) <|> return "0" - e <- (satisfy (\c -> c == 'e' || c == 'E') *> intStr) <|> return "0" + 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 = try (string "-") <|> (try (char '+') >> return "") <|> return "" + sign = string "-" <|> (char '+' >> return "") <|> return "" uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar) intStr = do s <- T.unpack <$> sign u <- uintStr @@ -246,16 +246,16 @@ escSeq :: (TomlM m) => Parser m Char escSeq = char '\\' *> escSeqChar where - escSeqChar = try (char '"') *> return '"' - <|> try (char '\\') *> return '\\' - <|> try (char '/') *> return '/' - <|> try (char 'b') *> return '\b' - <|> try (char 't') *> return '\t' - <|> try (char 'n') *> return '\n' - <|> try (char 'f') *> return '\f' - <|> try (char 'r') *> return '\r' - <|> try (char 'u') *> unicodeHex 4 - <|> try (char 'U') *> unicodeHex 8 + escSeqChar = (char '"') *> return '"' + <|> (char '\\') *> return '\\' + <|> (char '/') *> return '/' + <|> (char 'b') *> return '\b' + <|> (char 't') *> return '\t' + <|> (char 'n') *> return '\n' + <|> (char 'f') *> return '\f' + <|> (char 'r') *> return '\r' + <|> (char 'u') *> unicodeHex 4 + <|> (char 'U') *> unicodeHex 8 "escape character" @@ -272,19 +272,21 @@ -- | Parser for signs (a plus or a minus). signed :: (Num a, TomlM m) => Parser m a -> Parser m a -signed p = try (negate <$> (char '-' *> p)) - <|> try (char '+' *> p) - <|> try p +signed p = (negate <$> (char '-' *> p)) + <|> (char '+' *> p) + <|> p -- | Parses the (rest of the) line including an EOF, whitespace and comments. skipBlanks :: (TomlM m) => Parser m () skipBlanks = skipMany blank where - blank = try ((some $ satisfy isSpc) >> return ()) <|> try comment <|> try (void eol) - comment = char '#' >> (many $ satisfy (/= '\n')) >> return () + blank = try ((some $ satisfy isSpc) >> return ()) <|> comment <|> (void eol) + comment = char '#' >> (many $ (noneOf ("\n" :: String))) >> return () -- | Results in 'True' for whitespace chars, tab or space, according to spec. isSpc :: Char -> Bool -isSpc c = c == ' ' || c == '\t' +isSpc ' ' = True +isSpc '\t' = True +isSpc _ = False diff --git a/src/Text/Toml/Types.hs b/src/Text/Toml/Types.hs --- a/src/Text/Toml/Types.hs +++ b/src/Text/Toml/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -13,19 +14,17 @@ , Explicitness (..) , isExplicit , insert - , ToJSON (..) - , ToBsJSON (..) , 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.Aeson.Types hiding (Parser) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.Int (Int64) @@ -39,6 +38,7 @@ 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 @@ -69,7 +69,7 @@ | VBoolean !Bool | VDatetime !UTCTime | VArray !VArray - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) -- | To mark whether or not a 'Table' has been explicitly defined. -- See: https://github.com/toml-lang/toml/issues/376 @@ -174,65 +174,3 @@ n = T.unpack $ T.intercalate "." name w = case what of (VTable _) -> "tables" _ -> "array of tables" - - --- * Regular ToJSON instances - --- | 'ToJSON' instances for the 'Node' type that produce Aeson (JSON) --- in line with the TOML specification. -instance ToJSON Node where - toJSON (VTable v) = toJSON v - toJSON (VTArray v) = toJSON v - toJSON (VString v) = toJSON v - toJSON (VInteger v) = toJSON v - toJSON (VFloat v) = toJSON v - toJSON (VBoolean v) = toJSON v - toJSON (VDatetime v) = toJSON v - toJSON (VArray v) = toJSON v - - - --- * Special BurntSushi ToJSON type class and instances - --- | Type class for conversion to BurntSushi-style JSON. --- --- BurntSushi has made a language agnostic test suite available that --- this library uses. This test suit expects that values are encoded --- as JSON objects with a 'type' and a 'value' member. -class ToBsJSON a where - toBsJSON :: a -> Value - --- | Provide a 'toBsJSON' instance to the 'VTArray'. -instance (ToBsJSON a) => ToBsJSON (Vector a) where - toBsJSON = Array . V.map toBsJSON - {-# INLINE toBsJSON #-} - --- | Provide a 'toBsJSON' instance to the 'NTable'. -instance (ToBsJSON v) => ToBsJSON (M.HashMap Text v) where - toBsJSON = Object . M.map toBsJSON - {-# INLINE toBsJSON #-} - --- | 'ToBsJSON' instances for the 'TValue' type that produce Aeson (JSON) --- in line with BurntSushi's language agnostic TOML test suite. --- --- As seen in this function, BurntSushi's JSON encoding explicitly --- specifies the types of the values. -instance ToBsJSON Node where - toBsJSON (VTable v) = toBsJSON v - toBsJSON (VTArray v) = toBsJSON v - toBsJSON (VString v) = object [ "type" .= toJSON ("string" :: String) - , "value" .= toJSON v ] - toBsJSON (VInteger v) = object [ "type" .= toJSON ("integer" :: String) - , "value" .= toJSON (show v) ] - toBsJSON (VFloat v) = object [ "type" .= toJSON ("float" :: String) - , "value" .= toJSON (show v) ] - toBsJSON (VBoolean v) = object [ "type" .= toJSON ("bool" :: String) - , "value" .= toJSON (if v then "true" else "false" :: String) ] - toBsJSON (VDatetime v) = object [ "type" .= toJSON ("datetime" :: String) - , "value" .= toJSON (let s = show v - z = take (length s - 4) s ++ "Z" - d = take (length z - 10) z - t = drop (length z - 9) z - in d ++ "T" ++ t) ] - toBsJSON (VArray v) = object [ "type" .= toJSON ("array" :: String) - , "value" .= toBsJSON v ] diff --git a/test/BurntSushi.hs b/test/BurntSushi.hs --- a/test/BurntSushi.hs +++ b/test/BurntSushi.hs @@ -3,6 +3,7 @@ module BurntSushi (tests) where +import JSON import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit @@ -58,5 +59,5 @@ Right jsonCorrect -> assertEqual "" jsonCorrect (toBsJSON tomlTry) assertParseFailure f tomlBS = case parseTomlDoc "test" (decodeUtf8 tomlBS) of - Left _ -> return () + Left _ -> return () Right _ -> assertFailure $ "Parser accepted invalid TOML file: " ++ f diff --git a/test/JSON.hs b/test/JSON.hs new file mode 100644 --- /dev/null +++ b/test/JSON.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module JSON where + +import Data.Aeson.Types +import qualified Data.HashMap.Strict as M +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Text.Toml.Types + +-- * Regular ToJSON instances + +-- | 'ToJSON' instances for the 'Node' type that produce Aeson (JSON) +-- in line with the TOML specification. +instance ToJSON Node where + toJSON (VTable v) = toJSON v + toJSON (VTArray v) = toJSON v + toJSON (VString v) = toJSON v + toJSON (VInteger v) = toJSON v + toJSON (VFloat v) = toJSON v + toJSON (VBoolean v) = toJSON v + toJSON (VDatetime v) = toJSON v + toJSON (VArray v) = toJSON v + +-- * Special BurntSushi ToJSON type class and instances + +-- | Type class for conversion to BurntSushi-style JSON. +-- +-- BurntSushi has made a language agnostic test suite available that +-- this library uses. This test suite expects that values are encoded +-- as JSON objects with a 'type' and a 'value' member. +class ToBsJSON a where + toBsJSON :: a -> Value + +-- | Provide a 'toBsJSON' instance to the 'VTArray'. +instance (ToBsJSON a) => ToBsJSON (Vector a) where + toBsJSON = Array . V.map toBsJSON + {-# INLINE toBsJSON #-} + +-- | Provide a 'toBsJSON' instance to the 'NTable'. +instance (ToBsJSON v) => ToBsJSON (M.HashMap Text v) where + toBsJSON = Object . M.map toBsJSON + {-# INLINE toBsJSON #-} + +-- | 'ToBsJSON' instances for the 'TValue' type that produce Aeson (JSON) +-- in line with BurntSushi's language agnostic TOML test suite. +-- +-- As seen in this function, BurntSushi's JSON encoding explicitly +-- specifies the types of the values. +instance ToBsJSON Node where + toBsJSON (VTable v) = toBsJSON v + toBsJSON (VTArray v) = toBsJSON v + toBsJSON (VString v) = object [ "type" .= toJSON ("string" :: String) + , "value" .= toJSON v ] + toBsJSON (VInteger v) = object [ "type" .= toJSON ("integer" :: String) + , "value" .= toJSON (show v) ] + toBsJSON (VFloat v) = object [ "type" .= toJSON ("float" :: String) + , "value" .= toJSON (show v) ] + toBsJSON (VBoolean v) = object [ "type" .= toJSON ("bool" :: String) + , "value" .= toJSON (if v then "true" else "false" :: String) ] + toBsJSON (VDatetime v) = object [ "type" .= toJSON ("datetime" :: String) + , "value" .= toJSON (let s = show v + z = take (length s - 4) s ++ "Z" + d = take (length z - 10) z + t = drop (length z - 9) z + in d ++ "T" ++ t) ] + toBsJSON (VArray v) = object [ "type" .= toJSON ("array" :: String) + , "value" .= toBsJSON v ]