diff --git a/Changelog.org b/Changelog.org new file mode 100644 --- /dev/null +++ b/Changelog.org @@ -0,0 +1,8 @@ +* 0.1.1.0 +- Add tests +- Mark ~FromToml Value String~ as overlapping - now it can be derived for newtypes +- Rename old ~pTable~ into ~pTableL~, introduce ~pTable~ with produces value without location +- Rework ~FromToml b (L a)~ to delegate work to ~FromToml b a~ +* 0.1.0.0 +Initial release + diff --git a/Readme.org b/Readme.org new file mode 100644 --- /dev/null +++ b/Readme.org @@ -0,0 +1,6 @@ +#+STARTUP: content + +Parser combinators for directly parsing TOML values produced by +`toml-reader`. Parsers track where values originate in the source +document and intelligently combine errors between alternative parsing +branches to report only the most relevant error to the user. diff --git a/src/TOML/Parse.hs b/src/TOML/Parse.hs --- a/src/TOML/Parse.hs +++ b/src/TOML/Parse.hs @@ -36,6 +36,7 @@ , Index(..) , (.!=) , pTable + , pTableL , pKey , pKeyMaybe , pStr @@ -339,15 +340,15 @@ class FromToml a b where fromToml :: L a -> Parser b -instance FromToml a (L a) where +instance FromToml b a => FromToml b (L a) where {-# INLINE fromToml #-} - fromToml = pure + fromToml b@(L env _) = L env <$> fromToml b instance FromToml a a where {-# INLINE fromToml #-} fromToml = pure . extract -instance FromToml Value String where +instance {-# OVERLAPPING #-} FromToml Value String where {-# INLINE fromToml #-} fromToml = fmap T.unpack . pStr @@ -368,7 +369,7 @@ fromToml = pDouble instance (Ord k, FromToml Text k, FromToml Value v) => FromToml Value (Map k v) where - fromToml = pTable >=> fromToml + fromToml = pTableL >=> fromToml instance (Ord k, FromToml Text k, FromToml Value v) => FromToml Table (Map k v) where fromToml (L env y) = do @@ -406,14 +407,14 @@ instance Index (L Value) where {-# INLINE (.:) #-} {-# INLINE (.:?) #-} - (.:) x key = pTable x >>= pKey key >>= fromToml - (.:?) x key = pTable x >>= traverse fromToml . liftMaybe . pKeyMaybe key + (.:) x key = pTableL x >>= pKey key >>= fromToml + (.:?) x key = pTableL x >>= traverse fromToml . liftMaybe . pKeyMaybe key instance a ~ L Value => Index (Parser a) where {-# INLINE (.:) #-} {-# INLINE (.:?) #-} - (.:) x key = x >>= pTable >>= pKey key >>= fromToml - (.:?) x key = x >>= pTable >>= traverse fromToml . liftMaybe . pKeyMaybe key + (.:) x key = x >>= pTableL >>= pKey key >>= fromToml + (.:?) x key = x >>= pTableL >>= traverse fromToml . liftMaybe . pKeyMaybe key -- | Assign default value to a parser that produces 'Maybe'. Typically used together with '.:?': -- @@ -422,8 +423,11 @@ (.!=) :: Functor m => m (Maybe a) -> a -> m a (.!=) action def = fromMaybe def <$> action -pTable :: TomlParse m => L Value -> m (L Table) -pTable = \case +pTable :: TomlParse m => L Value -> m Table +pTable = fmap extract . pTableL + +pTableL :: TomlParse m => L Value -> m (L Table) +pTableL = \case L env (Table x) -> pure $ L env x other@(L _ other') -> throwParseError other $ UnexpectedType TTable other' diff --git a/test/TomlReaderTests.hs b/test/TomlReaderTests.hs new file mode 100644 --- /dev/null +++ b/test/TomlReaderTests.hs @@ -0,0 +1,148 @@ +---------------------------------------------------------------------------- +-- | +-- Module : TomlReaderTests +-- Copyright : (c) Sergey Vinokurov 2022 +-- License : Apache-2.0 (see LICENSE) +-- Maintainer : serg.foo@gmail.com +---------------------------------------------------------------------------- + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module TomlReaderTests (main) where + +import Control.Arrow (left) +import Data.Text (Text) +import Options.Applicative as Opts +import Prettyprinter +import Prettyprinter.Combinators +import Prettyprinter.Generics +import System.Exit +import System.IO + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options qualified as Tasty +import Test.Tasty.Runners qualified as Tasty + +import TOML as Toml +import TOML.Parse as Toml + +data Config = Config + { cfgTastyOpts :: !Tasty.OptionSet + } + +optsParser :: Opts.Parser Tasty.OptionSet -> Opts.Parser Config +optsParser tastyParser = do + cfgTastyOpts <- tastyParser + pure Config{..} + +progInfo :: Opts.Parser Tasty.OptionSet -> Opts.ParserInfo Config +progInfo tastyParser = info + (helper <*> optsParser tastyParser) + (fullDesc <> header "My new shiny test suite!") + +main :: IO () +main = do + Tasty.installSignalHandlers + + let allTests = tests + ingredients = defaultIngredients + tastyParser = snd $ Tasty.suiteOptionParser ingredients allTests + + Config{cfgTastyOpts} <- + customExecParser (prefs (showHelpOnEmpty <> noBacktrack <> multiSuffix "*")) (progInfo tastyParser) + + case Tasty.tryIngredients ingredients cfgTastyOpts allTests of + Nothing -> do + hPutStrLn stderr + "No ingredients agreed to run. Something is wrong either with your ingredient set or the options." + exitFailure + Just act -> do + ok <- act + if ok then exitSuccess else exitFailure + +data Sample1 = Sample1 + { _sample1Bar :: String + , _sample1Frob :: [Int] + } deriving (Eq, Show) + +instance FromToml Toml.Value Sample1 where + fromToml x = do + (foo :: L Table) <- x .: "foo" + Sample1 <$> foo .: "bar" <*> foo .: "frob" + +data Sample2 = Sample2 + { _sample2Bar :: String + , _sample2Frob :: [Int] + } deriving (Eq, Show) + +instance FromToml Toml.Value Sample2 where + fromToml x = do + foo <- x .: "foo" >>= pTableL + Sample2 <$> foo .: "bar" <*> foo .: "frob" + +newtype SpecialString = SpecialString { unSpecialString :: String } + deriving (Eq, Show, FromToml Value) + +data Sample3 = Sample3 + { _sample3Bar :: SpecialString + , _sample3Frob :: [Int] + } deriving (Eq, Show) + +instance FromToml Toml.Value Sample3 where + fromToml x = do + (foo :: L Table) <- x .: "foo" + Sample3 <$> foo .: "bar" <*> foo .: "frob" + +sample :: Text +sample = + "\ + \[foo]\n\ + \bar = \"quux\"\n\ + \frob = [1, 2]\n\ + \" + +deriving instance Generic Value +deriving instance Generic ContextItem +deriving instance Generic DecodeError +deriving instance Generic NormalizeError +deriving instance Generic TOMLError + +instance Pretty Value where + pretty = ppToml + +instance Pretty ContextItem where + pretty = ppGeneric + +instance Pretty DecodeError where + pretty = ppGeneric + +instance Pretty NormalizeError where + pretty = ppGeneric + +instance Pretty TOMLError where + pretty = ppGeneric + +tests :: TestTree +tests = testGroup "Tests" + [ testCase "Test 1" $ + (left renderString (left pretty (Toml.decode sample) >>= (\x -> Toml.runParser (x :: Value) Toml.fromToml))) @?= + Right (Sample1 "quux" [1, 2]) + , testCase "Test 2" $ + (left renderString (left pretty (Toml.decode sample) >>= (\x -> Toml.runParser (x :: Value) Toml.fromToml))) @?= + Right (Sample2 "quux" [1, 2]) + , testCase "Test 3" $ + (left renderString (left pretty (Toml.decode sample) >>= (\x -> Toml.runParser (x :: Value) Toml.fromToml))) @?= + Right (Sample3 (SpecialString "quux") [1, 2]) + ] diff --git a/toml-reader-parse.cabal b/toml-reader-parse.cabal --- a/toml-reader-parse.cabal +++ b/toml-reader-parse.cabal @@ -3,7 +3,7 @@ name: toml-reader-parse version: - 0.1.0.0 + 0.1.1.0 synopsis: Alternative parser for TOML values produced by the toml-reader package. @@ -27,6 +27,10 @@ build-type: Simple +extra-source-files: + Readme.org + Changelog.org + homepage: https://github.com/sergv/toml-reader-parse source-repository head type: git @@ -75,3 +79,26 @@ , text , time , vector + +test-suite toml-reader-tests + import: ghc-options + type: + exitcode-stdio-1.0 + main-is: + test/TomlReaderTests.hs + hs-source-dirs: + . + test + build-depends: + , base + , optparse-applicative + , prettyprinter + , prettyprinter-combinators + , tasty + , tasty-hunit + , text + , toml-reader + , toml-reader-parse + ghc-options: + -rtsopts + -main-is TomlReaderTests