Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-toml-parser for openSUSE:Factory checked in at 2024-01-23 22:55:44 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-toml-parser (Old) and /work/SRC/openSUSE:Factory/.ghc-toml-parser.new.16006 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-toml-parser" Tue Jan 23 22:55:44 2024 rev:5 rq:1140741 version:1.3.2.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-toml-parser/ghc-toml-parser.changes 2024-01-10 21:51:40.082814974 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-toml-parser.new.16006/ghc-toml-parser.changes 2024-01-23 22:56:02.192178887 +0100 @@ -1,0 +2,17 @@ +Mon Jan 15 18:58:05 UTC 2024 - Peter Simons <psim...@suse.com> + +- Update toml-parser to version 1.3.2.0. + ## 1.3.2.0 + + * Added `Toml.Generic` to make instances easily derivable via DerivingVia. + * Added GHC.Generics support for switching between product types and TOML arrays. + +------------------------------------------------------------------- +Wed Jan 10 05:21:23 UTC 2024 - Peter Simons <psim...@suse.com> + +- Update toml-parser to version 1.3.1.3. + ## 1.3.1.3 + + * Bugfix: Previous fix admitted some invalid inline tables - these are now rejected + +------------------------------------------------------------------- Old: ---- toml-parser-1.3.1.2.tar.gz New: ---- toml-parser-1.3.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-toml-parser.spec ++++++ --- /var/tmp/diff_new_pack.BI51ld/_old 2024-01-23 22:56:02.972207407 +0100 +++ /var/tmp/diff_new_pack.BI51ld/_new 2024-01-23 22:56:02.976207553 +0100 @@ -20,7 +20,7 @@ %global pkgver %{pkg_name}-%{version} %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.3.1.2 +Version: 1.3.2.0 Release: 0 Summary: TOML 1.0.0 parser License: ISC ++++++ toml-parser-1.3.1.2.tar.gz -> toml-parser-1.3.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/ChangeLog.md new/toml-parser-1.3.2.0/ChangeLog.md --- old/toml-parser-1.3.1.2/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,14 @@ # Revision history for toml-parser +## 1.3.2.0 + +* Added `Toml.Generic` to make instances easily derivable via DerivingVia. +* Added GHC.Generics support for switching between product types and TOML arrays. + +## 1.3.1.3 + +* Bugfix: Previous fix admitted some invalid inline tables - these are now rejected + ## 1.3.1.2 * Bugfix: In some cases overlapping keys in inline tables could throw an exception diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/README.lhs new/toml-parser-1.3.2.0/README.lhs --- old/toml-parser-1.3.1.2/README.lhs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/README.lhs 2001-09-09 03:46:40.000000000 +0200 @@ -46,9 +46,8 @@ import Test.Hspec (Spec, hspec, it, shouldBe) import Toml (parse, decode, encode, Value(..)) import Toml.FromValue (Result(Success), FromValue(fromValue), parseTableFromValue, reqKey) -import Toml.FromValue.Generic (genericParseTable) +import Toml.Generic (GenericTomlTable(..)) import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue, table, (.=)) -import Toml.ToValue.Generic (genericToTable) main :: IO () main = hspec (parses >> decodes >> encodes) @@ -122,21 +121,17 @@ ```haskell newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) + deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruits data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] } deriving (Eq, Show, Generic) + deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit data Physical = Physical { color :: String, shape :: String } - deriving (Eq, Show, Generic) + deriving (Eq, Show) newtype Variety = Variety String - deriving (Eq, Show, Generic) - -instance FromValue Fruits where - fromValue = parseTableFromValue genericParseTable - -instance FromValue Fruit where - fromValue = parseTableFromValue genericParseTable + deriving (Eq, Show) instance FromValue Physical where fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape") @@ -164,21 +159,16 @@ The `ToValue` class is for all datatypes that can be encoded into TOML. The more specialized `ToTable` class is for datatypes that encode into -tables and are thus elligible to be top-level types (all TOML documents +tables and are thus eligible to be top-level types (all TOML documents are tables at the top-level). Generics can be used to derive `ToTable` for simple record types. Manually defined instances are available for the more complex cases. ```haskell -instance ToValue Fruits where toValue = defaultTableToValue -instance ToValue Fruit where toValue = defaultTableToValue instance ToValue Physical where toValue = defaultTableToValue -instance ToValue Variety where toValue = defaultTableToValue - -instance ToTable Fruits where toTable = genericToTable -instance ToTable Fruit where toTable = genericToTable instance ToTable Physical where toTable x = table ["color" .= color x, "shape" .= shape x] +instance ToValue Variety where toValue = defaultTableToValue instance ToTable Variety where toTable (Variety x) = table ["name" .= x] encodes :: Spec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/README.md new/toml-parser-1.3.2.0/README.md --- old/toml-parser-1.3.1.2/README.md 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/README.md 2001-09-09 03:46:40.000000000 +0200 @@ -46,9 +46,8 @@ import Test.Hspec (Spec, hspec, it, shouldBe) import Toml (parse, decode, encode, Value(..)) import Toml.FromValue (Result(Success), FromValue(fromValue), parseTableFromValue, reqKey) -import Toml.FromValue.Generic (genericParseTable) +import Toml.Generic (GenericTomlTable(..)) import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue, table, (.=)) -import Toml.ToValue.Generic (genericToTable) main :: IO () main = hspec (parses >> decodes >> encodes) @@ -122,21 +121,17 @@ ```haskell newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) + deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruits data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] } deriving (Eq, Show, Generic) + deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit data Physical = Physical { color :: String, shape :: String } - deriving (Eq, Show, Generic) + deriving (Eq, Show) newtype Variety = Variety String - deriving (Eq, Show, Generic) - -instance FromValue Fruits where - fromValue = parseTableFromValue genericParseTable - -instance FromValue Fruit where - fromValue = parseTableFromValue genericParseTable + deriving (Eq, Show) instance FromValue Physical where fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape") @@ -164,21 +159,16 @@ The `ToValue` class is for all datatypes that can be encoded into TOML. The more specialized `ToTable` class is for datatypes that encode into -tables and are thus elligible to be top-level types (all TOML documents +tables and are thus eligible to be top-level types (all TOML documents are tables at the top-level). Generics can be used to derive `ToTable` for simple record types. Manually defined instances are available for the more complex cases. ```haskell -instance ToValue Fruits where toValue = defaultTableToValue -instance ToValue Fruit where toValue = defaultTableToValue instance ToValue Physical where toValue = defaultTableToValue -instance ToValue Variety where toValue = defaultTableToValue - -instance ToTable Fruits where toTable = genericToTable -instance ToTable Fruit where toTable = genericToTable instance ToTable Physical where toTable x = table ["color" .= color x, "shape" .= shape x] +instance ToValue Variety where toValue = defaultTableToValue instance ToTable Variety where toTable (Variety x) = table ["name" .= x] encodes :: Spec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/src/Toml/FromValue/Generic.hs new/toml-parser-1.3.2.0/src/Toml/FromValue/Generic.hs --- old/toml-parser-1.3.1.2/src/Toml/FromValue/Generic.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/src/Toml/FromValue/Generic.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,4 @@ +{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-} {-| Module : Toml.FromValue.Generic Description : GHC.Generics derived table parsing @@ -11,60 +12,119 @@ -} module Toml.FromValue.Generic ( + -- * Record from table GParseTable(..), genericParseTable, + + -- * Product type from array + GFromArray(..), + genericFromArray, ) where +import Control.Monad.Trans.State (StateT(..)) +import Data.Coerce (coerce) import GHC.Generics +import Toml.FromValue (FromValue, fromValue, optKey, reqKey) +import Toml.FromValue.Matcher (Matcher) import Toml.FromValue.ParseTable (ParseTable) -import Toml.FromValue (FromValue, optKey, reqKey) +import Toml.Value (Value) -- | Match a 'Table' using the field names in a record. -- -- @since 1.2.0.0 genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable a -genericParseTable = gParseTable (pure . to) +genericParseTable = to <$> gParseTable {-# INLINE genericParseTable #-} +-- | Match a 'Value' as an array positionally matching field fields +-- of a constructor to the elements of the array. +-- +-- @since 1.3.2.0 +genericFromArray :: (Generic a, GFromArray (Rep a)) => Value -> Matcher a +genericFromArray v = + do xs <- fromValue v + (gen, xs') <- runStateT gFromArray xs + if null xs' then + pure (to gen) + else + fail ("array " ++ show (length xs') ++ " elements too long") +{-# INLINE genericFromArray #-} + -- gParseTable is written in continuation passing style because -- it allows all the GHC.Generics constructors to inline into -- a single location which allows the optimizer to optimize them -- complete away. --- | Supports conversion of product types with field selector names to --- TOML values. +-- | Supports conversion of TOML tables into record values using +-- field selector names as TOML keys. -- -- @since 1.0.2.0 class GParseTable f where -- | Convert a value and apply the continuation to the result. - gParseTable :: (f a -> ParseTable b) -> ParseTable b + gParseTable :: ParseTable (f a) -- | Ignores type constructor name instance GParseTable f => GParseTable (D1 c f) where - gParseTable f = gParseTable (f . M1) + gParseTable = M1 <$> gParseTable {-# INLINE gParseTable #-} --- | Ignores value constructor name -instance GParseTable f => GParseTable (C1 c f) where - gParseTable f = gParseTable (f . M1) +-- | Ignores value constructor name - only supports record constructors +instance GParseTable f => GParseTable (C1 ('MetaCons sym fix 'True) f) where + gParseTable = M1 <$> gParseTable {-# INLINE gParseTable #-} -- | Matches left then right component instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where - gParseTable f = gParseTable \x -> gParseTable \y -> f (x :*: y) + gParseTable = + do x <- gParseTable + y <- gParseTable + pure (x :*: y) {-# INLINE gParseTable #-} -- | Omits the key from the table on nothing, includes it on just instance {-# OVERLAPS #-} (Selector s, FromValue a) => GParseTable (S1 s (K1 i (Maybe a))) where - gParseTable f = f . M1 . K1 =<< optKey (selName (M1 [] :: S1 s [] ())) + gParseTable = + do x <- optKey (selName (M1 [] :: S1 s [] ())) + pure (M1 (K1 x)) {-# INLINE gParseTable #-} -- | Uses record selector name as table key instance (Selector s, FromValue a) => GParseTable (S1 s (K1 i a)) where - gParseTable f = f . M1 . K1 =<< reqKey (selName (M1 [] :: S1 s [] ())) + gParseTable = + do x <- reqKey (selName (M1 [] :: S1 s [] ())) + pure (M1 (K1 x)) {-# INLINE gParseTable #-} -- | Emits empty table instance GParseTable U1 where - gParseTable f = f U1 + gParseTable = pure U1 {-# INLINE gParseTable #-} + +-- | Supports conversion of TOML arrays into product-type values. +-- +-- @since 1.3.2.0 +class GFromArray f where + gFromArray :: StateT [Value] Matcher (f a) + +instance GFromArray f => GFromArray (M1 i c f) where + gFromArray :: forall a. StateT [Value] Matcher (M1 i c f a) + gFromArray = coerce (gFromArray :: StateT [Value] Matcher (f a)) + {-# INLINE gFromArray #-} + +instance (GFromArray f, GFromArray g) => GFromArray (f :*: g) where + gFromArray = + do x <- gFromArray + y <- gFromArray + pure (x :*: y) + {-# INLINE gFromArray #-} + +instance FromValue a => GFromArray (K1 i a) where + gFromArray = StateT \case + [] -> fail "array too short" + x:xs -> (\v -> (K1 v, xs)) <$> fromValue x + {-# INLINE gFromArray #-} + +-- | Uses no array elements +instance GFromArray U1 where + gFromArray = pure U1 + {-# INLINE gFromArray #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/src/Toml/FromValue/Matcher.hs new/toml-parser-1.3.2.0/src/Toml/FromValue/Matcher.hs --- old/toml-parser-1.3.1.2/src/Toml/FromValue/Matcher.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/src/Toml/FromValue/Matcher.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {-| Module : Toml.FromValue.Matcher Description : A type for building results while tracking scopes @@ -37,11 +38,7 @@ ) where import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (Except, runExcept, throwE) -import Control.Monad.Trans.Reader (asks, local, ReaderT(..)) -import Control.Monad.Trans.Writer.CPS (runWriterT, tell, WriterT) +import Control.Monad (MonadPlus, ap, liftM) import Data.Monoid (Endo(..)) -- | Computations that result in a 'Result' and which track a list @@ -49,8 +46,32 @@ -- messages. -- -- Use 'withScope' to run a 'Matcher' in a new, nested scope. -newtype Matcher a = Matcher (ReaderT [Scope] (WriterT (DList MatchMessage) (Except (DList MatchMessage))) a) - deriving (Functor, Applicative, Monad, Alternative, MonadPlus) +newtype Matcher a = Matcher { + unMatcher :: + forall r. + [Scope] -> + DList MatchMessage -> + (DList MatchMessage -> r) -> + (DList MatchMessage -> a -> r) -> + r + } + +instance Functor Matcher where + fmap = liftM + +instance Applicative Matcher where + pure x = Matcher (\_env warn _err ok -> ok warn x) + (<*>) = ap + +instance Monad Matcher where + m >>= f = Matcher (\env warn err ok -> unMatcher m env warn err (\warn' x -> unMatcher (f x) env warn' err ok)) + {-# INLINE (>>=) #-} + +instance Alternative Matcher where + empty = Matcher (\_env _warn err _ok -> err mempty) + Matcher x <|> Matcher y = Matcher (\env warn err ok -> x env warn (\errs1 -> y env warn (\errs2 -> err (errs1 <> errs2)) ok) ok) + +instance MonadPlus Matcher -- | Scopes for TOML message. -- @@ -108,34 +129,31 @@ -- -- @since 1.3.0.0 runMatcher :: Matcher a -> Result MatchMessage a -runMatcher (Matcher m) = - case runExcept (runWriterT (runReaderT m [])) of - Left e -> Failure (runDList e) - Right (x,w) -> Success (runDList w) x +runMatcher (Matcher m) = m [] mempty (Failure . runDList) (Success . runDList) -- | Run a 'Matcher' with a locally extended scope. -- -- @since 1.3.0.0 withScope :: Scope -> Matcher a -> Matcher a -withScope ctx (Matcher m) = Matcher (local (ctx :) m) +withScope ctx (Matcher m) = Matcher (\env -> m (ctx : env)) -- | Get the current list of scopes. -- -- @since 1.3.0.0 getScope :: Matcher [Scope] -getScope = Matcher (asks reverse) +getScope = Matcher (\env warn _err ok -> ok warn (reverse env)) -- | Emit a warning mentioning the current scope. warning :: String -> Matcher () warning w = do loc <- getScope - Matcher (lift (tell (one (MatchMessage loc w)))) + Matcher (\_env warn _err ok -> ok (warn <> one (MatchMessage loc w)) ()) -- | Fail with an error message annotated to the current location. instance MonadFail Matcher where fail e = do loc <- getScope - Matcher (lift (lift (throwE (one (MatchMessage loc e))))) + Matcher (\_env _warn err _ok -> err (one (MatchMessage loc e))) -- | Update the scope with the message corresponding to a table key -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/src/Toml/Generic.hs new/toml-parser-1.3.2.0/src/Toml/Generic.hs --- old/toml-parser-1.3.1.2/src/Toml/Generic.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/toml-parser-1.3.2.0/src/Toml/Generic.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-} +{-| +Module : Toml.Generic +Description : Integration with DerivingVia extension +Copyright : (c) Eric Mertens, 2024 +License : ISC +Maintainer : emert...@gmail.com + +This module makes it possible to easily derive the TOML classes +using the @DerivingVia@ extension. + +For example: + +@ +data Physical = Physical { + color :: String, + shape :: String + } + deriving (Eq, Show, Generic) + deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical +@ + +These derived instances would allow you to match TOML @{color="red", shape="round"}@ to value @Coord 1 2@. + +@ +data Coord = Coord Int Int + deriving (Eq, Show, Generic) + deriving (ToValue, FromValue) via GenericTomlArray Physical +@ + +These derived instances would allow you to match TOML @[1,2]@ to value @Coord 1 2@. + +-} +module Toml.Generic ( + GenericTomlTable(GenericTomlTable), + GenericTomlArray(GenericTomlArray), + ) where + +import Data.Coerce (coerce) +import GHC.Generics (Generic(Rep)) +import Toml.FromValue (FromValue(fromValue), parseTableFromValue) +import Toml.FromValue.Generic (GParseTable, GFromArray, genericParseTable, genericFromArray) +import Toml.FromValue.Matcher (Matcher) +import Toml.ToValue (ToTable(toTable), ToValue(toValue), defaultTableToValue) +import Toml.ToValue.Generic (GToTable, GToArray, genericToTable, genericToArray) +import Toml.Value (Value, Table) + +-- | Helper type to use GHC's DerivingVia extension to derive +-- 'ToValue', 'ToTable', 'FromValue' for records. +-- +-- @since 1.3.2.0 +newtype GenericTomlTable a = GenericTomlTable a + +-- | Instance derived from 'ToTable' instance using 'defaultTableToValue' +instance (Generic a, GToTable (Rep a)) => ToValue (GenericTomlTable a) where + toValue = defaultTableToValue + {-# INLINE toValue #-} + +-- | Instance derived using 'genericToTable' +instance (Generic a, GToTable (Rep a)) => ToTable (GenericTomlTable a) where + toTable = coerce (genericToTable :: a -> Table) + {-# INLINE toTable #-} + +-- | Instance derived using 'genericParseTable' +instance (Generic a, GParseTable (Rep a)) => FromValue (GenericTomlTable a) where + fromValue = coerce (parseTableFromValue genericParseTable :: Value -> Matcher a) + {-# INLINE fromValue #-} + +-- | Helper type to use GHC's DerivingVia extension to derive +-- 'ToValue', 'ToTable', 'FromValue' for any product type. +-- +-- @since 1.3.2.0 +newtype GenericTomlArray a = GenericTomlArray a + +-- | Instance derived using 'genericToArray' +instance (Generic a, GToArray (Rep a)) => ToValue (GenericTomlArray a) where + toValue = coerce (genericToArray :: a -> Value) + {-# INLINE toValue #-} + +-- | Instance derived using 'genericFromArray' +instance (Generic a, GFromArray (Rep a)) => FromValue (GenericTomlArray a) where + fromValue = coerce (genericFromArray :: Value -> Matcher a) + {-# INLINE fromValue #-} \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/src/Toml/Semantics.hs new/toml-parser-1.3.2.0/src/Toml/Semantics.hs --- old/toml-parser-1.3.1.2/src/Toml/Semantics.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/src/Toml/Semantics.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use list literal" #-} +{-# HLINT ignore "Use section" #-} {-| Module : Toml.Semantics Description : Semantic interpretation of raw TOML expressions @@ -7,7 +7,7 @@ License : ISC Maintainer : emert...@gmail.com -This module extracts the nested Map representation of a TOML +This module extracts a nested Map representation of a TOML file. It detects invalid key assignments and resolves dotted key assignments. @@ -16,16 +16,14 @@ import Control.Monad (foldM) import Data.List.NonEmpty (NonEmpty((:|))) -import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Toml.Located (locThing, Located) import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..)) import Toml.Value (Table, Value(..)) --- | The type of errors that can be generated when resolving all the keys --- used in a TOML document. These errors always pertain to some key that --- caused one of three conflicts. +-- | This type represents errors generated when resolving keys in a TOML +-- document. -- -- @since 1.3.0.0 data SemanticError = SemanticError { @@ -50,35 +48,21 @@ Eq {- ^ Default instance -}, Ord {- ^ Default instance -}) --- | Extract semantic value from sequence of raw TOML expressions --- or report a semantic error. +-- | Extracts a semantic value from a sequence of raw TOML expressions, +-- or reports a semantic error if one occurs. -- -- @since 1.3.0.0 -semantics :: [Expr] -> M Table +semantics :: [Expr] -> Either (Located SemanticError) Table semantics exprs = - do let (topKVs, tables) = gather exprs - m1 <- assignKeyVals topKVs Map.empty - m2 <- foldM (\m (kind, key, kvs) -> - addSection kind kvs key m) m1 tables - pure (framesToTable m2) - --- | Line number, key, value -type KeyVals = [(Key, Val)] - --- | Arrange the expressions in a TOML file into the top-level key-value pairs --- and then all the key-value pairs for each subtable. -gather :: [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)]) -gather = goTop [] + do f <- foldM processExpr (flip assignKeyVals Map.empty) exprs + framesToTable <$> f [] where - goTop acc [] = (reverse acc, []) - goTop acc (ArrayTableExpr key : exprs) = (reverse acc, goTable ArrayTableKind key [] exprs) - goTop acc (TableExpr key : exprs) = (reverse acc, goTable TableKind key [] exprs) - goTop acc (KeyValExpr k v : exprs) = goTop ((k,v):acc) exprs - - goTable kind key acc [] = (kind, key, reverse acc) : [] - goTable kind key acc (TableExpr k : exprs) = (kind, key, reverse acc) : goTable TableKind k [] exprs - goTable kind key acc (ArrayTableExpr k : exprs) = (kind, key, reverse acc) : goTable ArrayTableKind k [] exprs - goTable kind key acc (KeyValExpr k v : exprs) = goTable kind key ((k,v):acc) exprs + processExpr f = \case + KeyValExpr k v -> Right (f . ((k,v):)) + TableExpr k -> processSection TableKind k + ArrayTableExpr k -> processSection ArrayTableKind k + where + processSection kind k = flip (addSection kind k) <$> f [] -- | A top-level table used to distinguish top-level defined arrays -- and tables from inline values. @@ -93,7 +77,8 @@ -- TOML syntax makes a distinction between tables and arrays that are -- defined at the top-level and those defined with inline syntax. This -- separate type keeps these syntactic differences separate while table --- and array resolution is still happening. +-- and array resolution is still happening. Frames can keep track of which +-- tables finished and which are eligible for extension. data Frame = FrameTable FrameKind FrameTable | FrameArray (NonEmpty FrameTable) -- stored in reverse order for easy "append" @@ -113,76 +98,61 @@ framesToTable :: FrameTable -> Table framesToTable = fmap \case - FrameTable _ t -> Table (framesToTable t) - FrameArray a -> Array (toArray a) - FrameValue v -> v - where - -- reverses the list while converting the frames to tables - toArray = foldl (\acc frame -> Table (framesToTable frame) : acc) [] - --- | Build a 'Table' value out of a list of key-value pairs. These keys are --- checked to not overlap. In the case of overlap a 'SemanticError' is returned. -constructTable :: [(Key, Value)] -> M Table -constructTable = foldM (uncurry . addEntry) Map.empty - where - -- turns x.y.z = v into a nested table of one leaf value - singleCase = foldr (\k v -> Table (Map.singleton (locThing k) v)) - - addEntry tab (key :| subkey) val = Map.alterF f (locThing key) tab - where - -- no existing assignment at this parent key - no more validation needed - f Nothing = pure (Just (singleCase val subkey)) - - -- there's already a table at this parent key, attempt to extend it - f (Just (Table subtab)) | Just subkey' <- NonEmpty.nonEmpty subkey = - Just . Table <$> addEntry subtab subkey' val - - -- attempted to overwrite an existing assignment, abort - f _ = invalidKey key AlreadyAssigned + FrameTable _ t -> framesToValue t + FrameArray (t :| ts) -> Array (rev (map framesToValue (t : ts))) + FrameValue v -> v + where + rev = foldl (flip (:)) [] -- GHC fails to inline reverse + +-- | Convert 'FrameTable' to a 'Value' forgetting all of the +-- frame distinctions. +framesToValue :: FrameTable -> Value +framesToValue = Table . framesToTable -- | Attempts to insert the key-value pairs given into a new section -- located at the given key-path in a frame map. addSection :: SectionKind {- ^ section kind -} -> - KeyVals {- ^ values to install -} -> Key {- ^ section key -} -> + [(Key, Val)] {- ^ values to install -} -> FrameTable {- ^ local frame map -} -> M FrameTable {- ^ error message or updated local frame table -} -addSection kind kvs = walk - where - walk (k1 :| []) = flip Map.alterF (locThing k1) \case - -- defining a new table - Nothing -> - case kind of - TableKind -> go (FrameTable Closed) Map.empty - ArrayTableKind -> go (FrameArray . pure) Map.empty - - -- defining a super table of a previously defined subtable - Just (FrameTable Open t) -> - case kind of - TableKind -> go (FrameTable Closed) t - ArrayTableKind -> invalidKey k1 ImplicitlyTable - - -- Add a new array element to an existing table array - Just (FrameArray a) -> - case kind of - ArrayTableKind -> go (FrameArray . (`NonEmpty.cons` a)) Map.empty - TableKind -> invalidKey k1 ClosedTable - - -- failure cases - Just (FrameTable Closed _) -> invalidKey k1 ClosedTable - Just (FrameTable Dotted _) -> error "addSection: dotted table left unclosed" - Just (FrameValue {}) -> invalidKey k1 AlreadyAssigned - where - go g t = Just . g . closeDots <$> assignKeyVals kvs t - walk (k1 :| k2 : ks) = flip Map.alterF (locThing k1) \case - Nothing -> go (FrameTable Open ) Map.empty - Just (FrameTable tk t) -> go (FrameTable tk ) t - Just (FrameArray (t :| ts)) -> go (FrameArray . (:| ts)) t - Just (FrameValue _) -> invalidKey k1 AlreadyAssigned - where - go g t = Just . g <$> walk (k2 :| ks) t +addSection kind (k :| []) kvs = + alterFrame k \case + -- defining a new table + Nothing -> + case kind of + TableKind -> FrameTable Closed <$> go mempty + ArrayTableKind -> FrameArray . (:| []) <$> go mempty + + -- defining a super table of a previously defined subtable + Just (FrameTable Open t) -> + case kind of + TableKind -> FrameTable Closed <$> go t + ArrayTableKind -> invalidKey k ImplicitlyTable + + -- Add a new array element to an existing table array + Just (FrameArray (t :| ts)) -> + case kind of + TableKind -> invalidKey k ClosedTable + ArrayTableKind -> FrameArray . (:| t : ts) <$> go mempty + + -- failure cases + Just (FrameTable Closed _) -> invalidKey k ClosedTable + Just (FrameTable Dotted _) -> error "addSection: dotted table left unclosed" + Just (FrameValue {}) -> invalidKey k AlreadyAssigned + where + go = assignKeyVals kvs + +addSection kind (k1 :| k2 : ks) kvs = + alterFrame k1 \case + Nothing -> FrameTable Open <$> go mempty + Just (FrameTable tk t) -> FrameTable tk <$> go t + Just (FrameArray (t :| ts)) -> FrameArray . (:| ts) <$> go t + Just (FrameValue _) -> invalidKey k1 AlreadyAssigned + where + go = addSection kind (k2 :| ks) kvs -- | Close all of the tables that were implicitly defined with -- dotted prefixes. These tables are only eligible for extension @@ -194,31 +164,36 @@ frame -> frame -- | Extend the given frame table with a list of key-value pairs. --- Either the updated frame table will be returned -assignKeyVals :: KeyVals -> FrameTable -> M FrameTable +-- Any tables created through dotted keys will be closed after +-- all of the key-value pairs are processed. +assignKeyVals :: [(Key, Val)] -> FrameTable -> M FrameTable assignKeyVals kvs t = closeDots <$> foldM f t kvs where f m (k,v) = assign k v m --- | Assign a single dotted key in a frame. +-- | Assign a single dotted key in a frame. Any open table traversed +-- by a dotted key will be marked as dotted so that it will become +-- closed at the end of the current call to 'assignKeyVals'. assign :: Key -> Val -> FrameTable -> M FrameTable -assign (key :| []) val = flip Map.alterF (locThing key) \case - Nothing -> Just . FrameValue <$> valToValue val - Just{} -> invalidKey key AlreadyAssigned - -assign (key :| k1 : keys) val = flip Map.alterF (locThing key) \case - Nothing -> go Map.empty - Just (FrameTable Open t) -> go t - Just (FrameTable Dotted t) -> go t - Just (FrameTable Closed _) -> invalidKey key ClosedTable - Just (FrameArray _) -> invalidKey key ClosedTable - Just (FrameValue _) -> invalidKey key AlreadyAssigned +assign (key :| []) val = + alterFrame key \case + Nothing -> FrameValue <$> valToValue val + Just{} -> invalidKey key AlreadyAssigned + +assign (key :| k1 : keys) val = + alterFrame key \case + Nothing -> go mempty + Just (FrameTable Open t) -> go t + Just (FrameTable Dotted t) -> go t + Just (FrameTable Closed _) -> invalidKey key ClosedTable + Just (FrameArray _) -> invalidKey key ClosedTable + Just (FrameValue _) -> invalidKey key AlreadyAssigned where - go t = Just . FrameTable Dotted <$> assign (k1 :| keys) val t + go t = FrameTable Dotted <$> assign (k1 :| keys) val t -- | Convert 'Val' to 'Value' potentially raising an error if --- it has inline tables with key-conflicts. +-- it contains inline tables with key-conflicts. valToValue :: Val -> M Value valToValue = \case ValInteger x -> Right (Integer x) @@ -230,8 +205,7 @@ ValLocalTime x -> Right (LocalTime x) ValDay x -> Right (Day x) ValArray xs -> Array <$> traverse valToValue xs - ValTable kvs -> do entries <- (traverse . traverse) valToValue kvs - Table <$> constructTable entries + ValTable kvs -> framesToValue <$> assignKeyVals kvs mempty -- | Abort validation by reporting an error about the given key. invalidKey :: @@ -239,3 +213,7 @@ SemanticErrorKind {- ^ error kind -} -> M a invalidKey key kind = Left ((`SemanticError` kind) <$> key) + +-- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable' +alterFrame :: Located String -> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable +alterFrame k f = Map.alterF (fmap Just . f) (locThing k) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/src/Toml/ToValue/Generic.hs new/toml-parser-1.3.2.0/src/Toml/ToValue/Generic.hs --- old/toml-parser-1.3.1.2/src/Toml/ToValue/Generic.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/src/Toml/ToValue/Generic.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,5 @@ {-| -Module : Toml.ToValue.Matcher +Module : Toml.ToValue.Generic Description : GHC.Generics derived table generation Copyright : (c) Eric Mertens, 2023 License : ISC @@ -8,30 +8,46 @@ Use 'genericToTable' to derive an instance of 'Toml.ToValue.ToTable' using the field names of a record. +Use 'genericToArray' to derive an instance of 'Toml.ToValue.ToValue' +using the positions of data in a constructor. + -} module Toml.ToValue.Generic ( + + -- * Records to Tables GToTable(..), genericToTable, + + -- * Product types to Arrays + GToArray(..), + genericToArray, ) where import Data.Map qualified as Map import GHC.Generics -import Toml.Value (Table) +import Toml.Value (Table, Value(Array)) import Toml.ToValue (ToValue(..)) -- | Use a record's field names to generate a 'Table' -- -- @since 1.0.2.0 genericToTable :: (Generic a, GToTable (Rep a)) => a -> Table -genericToTable = gToTable . from +genericToTable x = Map.fromList (gToTable (from x) []) {-# INLINE genericToTable #-} +-- | Use a record's field names to generate a 'Table' +-- +-- @since 1.3.2.0 +genericToArray :: (Generic a, GToArray (Rep a)) => a -> Value +genericToArray a = Array (gToArray (from a) []) +{-# INLINE genericToArray #-} + -- | Supports conversion of product types with field selector names -- to TOML values. -- -- @since 1.0.2.0 class GToTable f where - gToTable :: f a -> Table + gToTable :: f a -> [(String, Value)] -> [(String, Value)] -- | Ignores type constructor names instance GToTable f => GToTable (D1 c f) where @@ -49,20 +65,41 @@ -- | Omits the key from the table on nothing, includes it on just instance {-# OVERLAPS #-} (Selector s, ToValue a) => GToTable (S1 s (K1 i (Maybe a))) where - gToTable (M1 (K1 Nothing)) = Map.empty - gToTable s@(M1 (K1 (Just x))) = Map.singleton (selName s) (toValue x) + gToTable (M1 (K1 Nothing)) = id + gToTable s@(M1 (K1 (Just x))) = ((selName s, toValue x):) {-# INLINE gToTable #-} -- | Uses record selector name as table key instance (Selector s, ToValue a) => GToTable (S1 s (K1 i a)) where - gToTable s@(M1 (K1 x)) = Map.singleton (selName s) (toValue x) + gToTable s@(M1 (K1 x)) = ((selName s, toValue x):) {-# INLINE gToTable #-} -- | Emits empty table instance GToTable U1 where - gToTable _ = Map.empty + gToTable _ = id {-# INLINE gToTable #-} instance GToTable V1 where gToTable v = case v of {} {-# INLINE gToTable #-} + +-- | Convert product types to arrays positionally. +-- +-- @since 1.3.2.0 +class GToArray f where + gToArray :: f a -> [Value] -> [Value] + +-- | Ignore metadata +instance GToArray f => GToArray (M1 i c f) where + gToArray (M1 x) = gToArray x + {-# INLINE gToArray #-} + +-- | Convert left and then right +instance (GToArray f, GToArray g) => GToArray (f :*: g) where + gToArray (x :*: y) = gToArray x . gToArray y + {-# INLINE gToArray #-} + +-- | Convert fields using 'ToValue' instances +instance ToValue a => GToArray (K1 i a) where + gToArray (K1 x) = (toValue x :) + {-# INLINE gToArray #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/src/Toml/ToValue.hs new/toml-parser-1.3.2.0/src/Toml/ToValue.hs --- old/toml-parser-1.3.1.2/src/Toml/ToValue.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/src/Toml/ToValue.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -- needed for type equality on old GHC {-| Module : Toml.ToValue Description : Automation for converting application values to TOML. @@ -11,7 +11,7 @@ Because the top-level TOML document is always a table, the 'ToTable' class is for types that specifically support -conversion from a 'Table'. +conversion to a 'Table'. "Toml.ToValue.Generic" can be used to derive instances of 'ToTable' automatically for record types. @@ -73,8 +73,21 @@ -- | Class for things that can be embedded into a TOML table. -- --- Implement this for things that embed into a 'Table' and then +-- Implement this for things that always embed into a 'Table' and then -- the 'ToValue' instance can be derived with 'defaultTableToValue'. +-- +-- @ +-- instance ToValue Example where +-- toValue = defaultTableToValue +-- +-- -- Option 1: Manual instance +-- instance ToTable Example where +-- toTable x = 'table' ["field1" '.=' field1 x, "field2" '.=' field2 x] +-- +-- -- Option 2: GHC.Generics derived instance using Toml.ToValue.Generic +-- instance ToTable Example where +-- toTable = genericToTable +-- @ class ToValue a => ToTable a where -- | Convert a single value into a table @@ -88,7 +101,8 @@ instance (ToKey k, ToValue v) => ToValue (Map k v) where toValue = defaultTableToValue --- | Convert to a table key +-- | Convert to a table key. This class enables various string types to be +-- used as the keys of a 'Map' when converting into TOML tables. -- -- @since 1.3.0.0 class ToKey a where @@ -104,7 +118,7 @@ -- -- @since 1.3.0.0 instance ToKey Data.Text.Text where - toKey =Data.Text.unpack + toKey = Data.Text.unpack -- | toKey = unpack -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/test/DecodeSpec.hs new/toml-parser-1.3.2.0/test/DecodeSpec.hs --- old/toml-parser-1.3.1.2/test/DecodeSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/test/DecodeSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,12 @@ {-# Language DuplicateRecordFields #-} +{-| +Module : DecodeSpec +Description : Show that decoding TOML works using the various provided classes +Copyright : (c) Eric Mertens, 2023 +License : ISC +Maintainer : emert...@gmail.com + +-} module DecodeSpec (spec) where import Data.Maybe (fromMaybe) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/test/DerivingViaSpec.hs new/toml-parser-1.3.2.0/test/DerivingViaSpec.hs --- old/toml-parser-1.3.1.2/test/DerivingViaSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/toml-parser-1.3.2.0/test/DerivingViaSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,65 @@ +{-# LANGUAGE DerivingVia, DeriveGeneric #-} +{-| +Module : DerivingViaSpec +Description : Show that TOML classes can be derived with DerivingVia +Copyright : (c) Eric Mertens, 2024 +License : ISC +Maintainer : emert...@gmail.com + +This module ensures that the classes are actually derivable with +generalized newtype deriving. In particular 'fromValue' uses the +'Matcher' type and that type can't use monad transformers without +preventing this from working. The test ensures we don't have a +regression later. + +-} +module DerivingViaSpec (spec) where + +import GHC.Generics (Generic) +import Test.Hspec (it, shouldBe, Spec) +import Toml (Value(..)) +import Toml.FromValue ( FromValue(fromValue) ) +import Toml.FromValue.Matcher (runMatcher, Result(Success)) +import Toml.Generic (GenericTomlTable(..), GenericTomlArray(..)) +import Toml.ToValue (ToTable(toTable), (.=), table, ToValue(toValue)) + +data Physical = Physical { + color :: String, + shape :: String + } + deriving (Eq, Show, Generic) + deriving (ToTable, FromValue, ToValue) via GenericTomlTable Physical + +data TwoThings = TwoThings Int String + deriving (Eq, Show, Generic) + deriving (FromValue, ToValue) via GenericTomlArray TwoThings + +spec :: Spec +spec = + do let sem = Physical "red" "round" + tab = table ["color" .= "red", "shape" .= "round"] + + it "supports toValue" $ + toValue sem + `shouldBe` + Table tab + + it "supports toTable" $ + toTable sem + `shouldBe` + tab + + it "supports fromValue" $ + runMatcher (fromValue (Table tab)) + `shouldBe` + Success [] sem + + it "converts from arrays positionally" $ + runMatcher (fromValue (Array [Integer 42, String "forty-two"])) + `shouldBe` + Success [] (TwoThings 42 "forty-two") + + it "converts to arrays positionally" $ + toValue (TwoThings 42 "forty-two") + `shouldBe` + Array [Integer 42, String "forty-two"] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/test/HieDemoSpec.hs new/toml-parser-1.3.2.0/test/HieDemoSpec.hs --- old/toml-parser-1.3.1.2/test/HieDemoSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/test/HieDemoSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -202,7 +202,7 @@ [Else (pure Nothing)] instance FromValue NoneConfig where - fromValue = parseTableFromValue genericParseTable + fromValue = parseTableFromValue (pure NoneConfig) spec :: Spec spec = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/test/TomlSpec.hs new/toml-parser-1.3.2.0/test/TomlSpec.hs --- old/toml-parser-1.3.1.2/test/TomlSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/test/TomlSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -566,6 +566,16 @@ parse [quoteStr| x = {a.b = 1, a = 2}|] `shouldBe` Left "1:15: key error: a is already assigned" + + it "checks for overwrites from other inline tables" $ + parse [quoteStr| + tab = { inner = { dog = "best" }, inner.cat = "worst" }|] + `shouldBe` Left "1:35: key error: inner is already assigned" + + it "checks for overlaps of other inline tables" $ + parse [quoteStr| + tbl = { fruit = { apple.color = "red" }, fruit.apple.texture = { smooth = true } }|] + `shouldBe` Left "1:42: key error: fruit is already assigned" describe "array of tables" do it "supports array of tables syntax" $ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/toml-parser-1.3.1.2/toml-parser.cabal new/toml-parser-1.3.2.0/toml-parser.cabal --- old/toml-parser-1.3.1.2/toml-parser.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/toml-parser-1.3.2.0/toml-parser.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,6 @@ cabal-version: 3.0 name: toml-parser -version: 1.3.1.2 +version: 1.3.2.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with @@ -13,7 +13,7 @@ copyright: 2023 Eric Mertens category: Text build-type: Simple -tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.3, 9.8.1} +tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.4, 9.8.1} extra-doc-files: ChangeLog.md @@ -52,6 +52,7 @@ Toml.FromValue.Generic Toml.FromValue.Matcher Toml.FromValue.ParseTable + Toml.Generic Toml.Lexer Toml.Lexer.Token Toml.Located @@ -97,6 +98,7 @@ toml-parser, other-modules: DecodeSpec + DerivingViaSpec FromValueSpec HieDemoSpec LexerSpec @@ -112,6 +114,7 @@ ghc-options: -pgmL markdown-unlit -optL "haskell toml" default-extensions: QuasiQuotes + DerivingVia other-modules: QuoteStr hs-source-dirs: