toml-parser 1.3.1.3 → 1.3.2.0
raw patch · 12 files changed
+414/−177 lines, 12 files
Files
- ChangeLog.md +5/−0
- README.lhs +7/−17
- README.md +7/−17
- src/Toml/FromValue/Generic.hs +73/−13
- src/Toml/FromValue/Matcher.hs +33/−15
- src/Toml/Generic.hs +83/−0
- src/Toml/Semantics.hs +83/−105
- src/Toml/ToValue/Generic.hs +45/−8
- test/DecodeSpec.hs +8/−0
- test/DerivingViaSpec.hs +65/−0
- test/HieDemoSpec.hs +1/−1
- toml-parser.cabal +4/−1
ChangeLog.md view
@@ -1,5 +1,10 @@ # 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
README.lhs view
@@ -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
README.md view
@@ -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
src/Toml/FromValue/Generic.hs view
@@ -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 #-}
src/Toml/FromValue/Matcher.hs view
@@ -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,9 +46,33 @@ -- 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. -- -- @since 1.3.0.0@@ -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 --
+ src/Toml/Generic.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}+{-|+Module : Toml.Generic+Description : Integration with DerivingVia extension+Copyright : (c) Eric Mertens, 2024+License : ISC+Maintainer : emertens@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 #-}
src/Toml/Semantics.hs view
@@ -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 : emertens@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,77 +98,62 @@ 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.-constructInlineTable :: [(Key, Value)] -> M Table-constructInlineTable kvs = framesToTable <$> foldM (uncurry . addEntry) Map.empty kvs+ FrameTable _ t -> framesToValue t+ FrameArray (t :| ts) -> Array (rev (map framesToValue (t : ts)))+ FrameValue v -> v where- -- turns x.y.z = v into a nested table of one leaf value- singleCase = foldr (\k v -> FrameTable Open (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 (FrameValue val) subkey))-- -- there's already a table at this parent key, attempt to extend it- f (Just (FrameTable _ subtab)) | Just subkey' <- NonEmpty.nonEmpty subkey =- Just . FrameTable Open <$> addEntry subtab subkey' val+ rev = foldl (flip (:)) [] -- GHC fails to inline reverse - -- attempted to overwrite an existing assignment, abort- f _ = invalidKey key AlreadyAssigned+-- | 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+addSection kind (k :| []) kvs =+ alterFrame k \case+ -- defining a new table+ Nothing ->+ case kind of+ TableKind -> FrameTable Closed <$> go mempty+ ArrayTableKind -> FrameArray . (:| []) <$> go mempty - -- 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+ -- 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 - -- 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+ -- 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 - 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+ -- 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 -- within the @[table]@ section in which they were introduced.@@ -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 :| []) val =+ alterFrame key \case+ Nothing -> 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 :| 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 <$> constructInlineTable 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)
src/Toml/ToValue/Generic.hs view
@@ -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 #-}
test/DecodeSpec.hs view
@@ -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 : emertens@gmail.com++-} module DecodeSpec (spec) where import Data.Maybe (fromMaybe)
+ test/DerivingViaSpec.hs view
@@ -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 : emertens@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"]
test/HieDemoSpec.hs view
@@ -202,7 +202,7 @@ [Else (pure Nothing)] instance FromValue NoneConfig where- fromValue = parseTableFromValue genericParseTable+ fromValue = parseTableFromValue (pure NoneConfig) spec :: Spec spec =
toml-parser.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: toml-parser-version: 1.3.1.3+version: 1.3.2.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with@@ -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: