diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,25 @@ # Revision history for toml-parser +## 1.2.0.0 -- + +* Remove `FromTable` class. This class existed for things that could be + matched specifically from tables, which is what the top-level values + always are. However `FromValue` already handles this, and both classes + can fail, so having the extra level of checking doesn't avoid failure. + It does, however, create a lot of noise generating instances. Note that + `ToTable` continues to exist because `toTable` isn't allowed to fail, + and when serializing to TOML syntax you can only serialize top-level + tables. +* Extracted `Toml.FromValue.Matcher` and `Toml.FromValue.ParseTable` into + their own modules. +* Add `pickKey`, `liftMatcher`, `inKey`, `inIndex`, `parseTableFromValue` to `Toml.FromValue` +* Replace `genericFromTable` with `genericParseTable`. The intended way to + derive a `FromValue` instance is now to write: + + ```haskell + instance FromValue T where fromValue = parseTableFromValue genericParseTable + ``` + ## 1.1.1.0 -- 2023-07-03 * Add support for GHC 8.10.7 and 9.0.2 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -21,13 +21,13 @@ TOML --> [Token]: Toml.Lexer [Token] --> [Expr]: Toml.Parser [Expr] --> Table : Toml.Semantics - Table --> ApplicationTypes : Toml.FromTable - ApplicationTypes --> Table : Toml.ToTable + Table --> ApplicationTypes : Toml.FromValue + ApplicationTypes --> Table : Toml.ToValue Table --> TOML : Toml.Pretty ``` -The highest-level interface to this package is to define `FromTable` and `ToTable` +The highest-level interface to this package is to define `FromValue` and `ToTable` instances for your application-specific datatypes. These can be used with `encode` and `decode` to convert to and from TOML. @@ -101,22 +101,17 @@ newtype Variety = Variety String deriving (Eq, Show) -instance FromTable Fruits where - fromTable = runParseTable (Fruits <$> reqKey "fruits") - -instance FromTable Fruit where - fromTable = runParseTable (Fruit <$> reqKey "name" <*> optKey "physical" <*> reqKey "varieties") +instance FromValue Fruits where + fromValue = parseTableFromValue (Fruits <$> reqKey "fruits") -instance FromTable Physical where - fromTable = runParseTable (Physical <$> reqKey "color" <*> reqKey "shape") +instance FroValue Fruit where + fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> reqKey "varieties") -instance FromTable Variety where - fromTable = runParseTable (Variety <$> reqKey "name") +instance FromValue Physical where + fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape") -instance FromValue Fruits where fromValue = defaultTableFromValue -instance FromValue Fruit where fromValue = defaultTableFromValue -instance FromValue Physical where fromValue = defaultTableFromValue -instance FromValue Variety where fromValue = defaultTableFromValue +instance FromValue Variety where + fromValue = parseTableFromValue (Variety <$> reqKey "name") ``` We can run this example on the original value to deserialize it into domain-specific datatypes. @@ -141,8 +136,12 @@ exOpt :: Maybe Bool} deriving (Show, Generic, Eq) -instance FromTable ExampleRecord where fromTable = genericFromTable -instance FromValue ExampleRecord where fromValue = defaultTableFromValue +instance FromValue ExampleRecord where fromValue = parseTableFromValue genericParseTable instance ToTable ExampleRecord where toTable = genericToTable instance ToValue ExampleRecord where toValue = defaultTableToValue ``` + +## Larger Example + +A demonstration of using this package at a more realistic scale +can be found in [HieDemoSpec](test/HieDemoSpec.hs). diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -33,7 +33,8 @@ ) where import Text.Printf (printf) -import Toml.FromValue (FromTable (fromTable), runMatcher, Result(..)) +import Toml.FromValue (FromValue (fromValue), Result(..)) +import Toml.FromValue.Matcher (runMatcher) import Toml.Lexer (scanTokens, Token(TokError)) import Toml.Located (Located(Located)) import Toml.Parser (parseRawToml) @@ -53,9 +54,9 @@ Left (printf "%d:%d: parse error: unexpected %s" (posLine p) (posColumn p) (prettyToken t)) Right exprs -> semantics exprs --- | Use the 'FromTable' instance to decode a value from a TOML string. -decode :: FromTable a => String -> Result a -decode = either (Failure . pure) (runMatcher . fromTable) . parse +-- | Use the 'FromValue' instance to decode a value from a TOML string. +decode :: FromValue a => String -> Result a +decode = either (Failure . pure) (runMatcher . fromValue . Table) . parse -- | Use the 'ToTable' instance to encode a value to a TOML string. encode :: ToTable a => a -> TomlDoc diff --git a/src/Toml/FromValue.hs b/src/Toml/FromValue.hs --- a/src/Toml/FromValue.hs +++ b/src/Toml/FromValue.hs @@ -8,48 +8,45 @@ Use 'FromValue' to define a transformation from some 'Value' to an application domain type. -Use 'FromTable' to define transformations specifically from 'Table'. These -instances are interesting because all top-level TOML values are tables, -so these are the types that work for top-level deserialization. - -Use 'ParseTable' to help build 'FromTable' instances. It will make it easy to -track which table keys have been used and which are left over. +Use 'ParseTable' to help build 'FromValue' instances that match tables. It +will make it easy to track which table keys have been used and which are left +over. Warnings can be emitted using 'warning' and 'warnTable' (depending on what) context you're in. These warnings can provide useful feedback about problematic decodings or keys that might be unused now but were perhaps meaningful in an old version of a configuration file. -"Toml.FromValue.Generic" can be used to derive instances of 'FromTable' +"Toml.FromValue.Generic" can be used to derive instances of 'FromValue' automatically for record types. -} module Toml.FromValue ( -- * Deserialization classes FromValue(..), - FromTable(..), - defaultTableFromValue, -- * Matcher Matcher, Result(..), - runMatcher, - withScope, warning, -- * Table matching ParseTable, runParseTable, + parseTableFromValue, optKey, reqKey, warnTable, + KeyAlt(..), + pickKey, -- * Table matching primitives getTable, setTable, + liftMatcher, ) where -import Control.Applicative (Alternative) +import Control.Applicative (Alternative, optional) import Control.Monad (MonadPlus, zipWithM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict (StateT(..), put, get) @@ -61,9 +58,10 @@ import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) -import Toml.FromValue.Matcher (Matcher, Result(..), runMatcher, withScope, warning) +import Toml.FromValue.Matcher (Matcher, Result(..), runMatcher, withScope, warning, inIndex, inKey) import Toml.Pretty (prettySimpleKey, prettyValue) import Toml.Value (Value(..), Table) +import Toml.FromValue.ParseTable -- | Class for types that can be decoded from a TOML value. class FromValue a where @@ -72,31 +70,37 @@ -- | Used to implement instance for '[]'. Most implementations rely on the default implementation. listFromValue :: Value -> Matcher [a] - listFromValue (Array xs) = zipWithM (\i v -> withScope ("[" ++ show i ++ "]") (fromValue v)) [0::Int ..] xs + listFromValue (Array xs) = zipWithM (\i v -> inIndex i (fromValue v)) [0..] xs listFromValue v = typeError "array" v --- | Class for types that can be decoded from a TOML table. -class FromValue a => FromTable a where - -- | Convert a 'Table' or report an error message - fromTable :: Table -> Matcher a - -instance (Ord k, IsString k, FromValue v) => FromTable (Map k v) where - fromTable t = Map.fromList <$> traverse f (Map.assocs t) - where - f (k,v) = (,) (fromString k) <$> withScope ('.':show (prettySimpleKey k)) (fromValue v) - instance (Ord k, IsString k, FromValue v) => FromValue (Map k v) where - fromValue = defaultTableFromValue - --- | Derive 'fromValue' implementation from 'fromTable' -defaultTableFromValue :: FromTable a => Value -> Matcher a -defaultTableFromValue (Table t) = fromTable t -defaultTableFromValue v = typeError "table" v + fromValue (Table t) = Map.fromList <$> traverse f (Map.assocs t) + where + f (k,v) = (,) (fromString k) <$> inKey k (fromValue v) + fromValue v = typeError "table" v -- | Report a type error typeError :: String {- ^ expected type -} -> Value {- ^ actual value -} -> Matcher a -typeError wanted got = fail ("Type error. wanted: " ++ wanted ++ " got: " ++ show (prettyValue got)) +typeError wanted got = fail ("type error. wanted: " ++ wanted ++ " got: " ++ valueType got) +-- | Used to derive a 'fromValue' implementation from a 'ParseTable' matcher. +parseTableFromValue :: ParseTable a -> Value -> Matcher a +parseTableFromValue p (Table t) = runParseTable p t +parseTableFromValue _ v = typeError "table" v + +valueType :: Value -> String +valueType = \case + Integer {} -> "integer" + Float {} -> "float" + Array {} -> "array" + Table {} -> "table" + Bool {} -> "boolean" + String {} -> "string" + TimeOfDay {} -> "local time" + LocalTime {} -> "local date-time" + Day {} -> "locate date" + ZonedTime {} -> "offset date-time" + -- | Matches integer values instance FromValue Integer where fromValue (Integer x) = pure x @@ -184,56 +188,10 @@ instance FromValue Value where fromValue = pure --- | A 'Matcher' that tracks a current set of unmatched key-value --- pairs from a table. --- --- Use 'optKey' and 'reqKey' to extract keys. --- --- Use 'getTable' and 'setTable' to override the table and implement --- other primitives. -newtype ParseTable a = ParseTable (StateT Table Matcher a) - deriving (Functor, Applicative, Monad, Alternative, MonadPlus) - -instance MonadFail ParseTable where - fail = ParseTable . fail - --- | Run a 'ParseTable' computation with a given starting 'Table'. --- Unused tables will generate a warning. To change this behavior --- 'getTable' and 'setTable' can be used to discard or generate --- error messages. -runParseTable :: ParseTable a -> Table -> Matcher a -runParseTable (ParseTable p) t = - do (x, t') <- runStateT p t - case Map.keys t' of - [] -> pure x - [k] -> x <$ warning ("Unexpected key: " ++ show (prettySimpleKey k)) - ks -> x <$ warning ("Unexpected keys: " ++ intercalate ", " (map (show . prettySimpleKey) ks)) - --- | Return the remaining portion of the table being matched. -getTable :: ParseTable Table -getTable = ParseTable get - --- | Replace the remaining portion of the table being matched. -setTable :: Table -> ParseTable () -setTable = ParseTable . put - --- | Emit a warning at the current location. -warnTable :: String -> ParseTable () -warnTable = ParseTable . lift . warning - -- | Match a table entry by key if it exists or return 'Nothing' if not. optKey :: FromValue a => String -> ParseTable (Maybe a) -optKey key = ParseTable $ StateT \t -> - case Map.lookup key t of - Nothing -> pure (Nothing, t) - Just v -> - do r <- withScope ('.' : show (prettySimpleKey key)) (fromValue v) - pure (Just r, Map.delete key t) +optKey = optional . reqKey -- | Match a table entry by key or report an error if missing. reqKey :: FromValue a => String -> ParseTable a -reqKey key = - do mb <- optKey key - case mb of - Nothing -> fail ("Missing key: " ++ show (prettySimpleKey key)) - Just v -> pure v +reqKey key = pickKey [Key key fromValue] diff --git a/src/Toml/FromValue/Generic.hs b/src/Toml/FromValue/Generic.hs --- a/src/Toml/FromValue/Generic.hs +++ b/src/Toml/FromValue/Generic.hs @@ -5,26 +5,28 @@ License : ISC Maintainer : emertens@gmail.com -Use 'genericFromTable' to derive an instance of 'Toml.FromValue.FromTable' -using the field names of a record. +Use 'genericParseTable' to derive a 'ParseTable' using the field names +of a record. This can be combined with 'Toml.FromValue.parseTableFromValue' +to derive a 'Toml.FromValue.FromValue' instance. -} module Toml.FromValue.Generic ( GParseTable(..), - genericFromTable, + genericParseTable, ) where import GHC.Generics -import Toml.FromValue (FromValue(..), ParseTable, optKey, reqKey, runParseTable) +import Toml.FromValue.ParseTable (ParseTable, runParseTable) import Toml.FromValue.Matcher (Matcher) -import Toml.Value (Table) +import Toml.FromValue (FromValue, fromValue, optKey, reqKey) +import Toml.Value (Table, Value(Table)) -- | Match a 'Table' using the field names in a record. -- --- @since 1.0.2.0 -genericFromTable :: (Generic a, GParseTable (Rep a)) => Table -> Matcher a -genericFromTable = runParseTable (gParseTable (pure . to)) -{-# INLINE genericFromTable #-} +-- @since 1.2.0.0 +genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable a +genericParseTable = gParseTable (pure . to) +{-# INLINE genericParseTable #-} -- gParseTable is written in continuation passing style because -- it allows all the GHC.Generics constructors to inline into @@ -49,6 +51,7 @@ gParseTable f = gParseTable (f . M1) {-# 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) {-# INLINE gParseTable #-} diff --git a/src/Toml/FromValue/Matcher.hs b/src/Toml/FromValue/Matcher.hs --- a/src/Toml/FromValue/Matcher.hs +++ b/src/Toml/FromValue/Matcher.hs @@ -22,6 +22,10 @@ withScope, getScope, warning, + + -- * Scope helpers + inKey, + inIndex, ) where import Control.Monad.Trans.Class (lift) @@ -31,6 +35,7 @@ import Data.Monoid (Endo(..)) import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus) +import Toml.Pretty (prettySimpleKey) -- | Computations that result in a 'Result' and which track a list -- of nested contexts to assist in generating warnings and error @@ -86,3 +91,15 @@ fail e = do loc <- getScope Matcher (lift (lift (throwE (string (e ++ " in top" ++ concat loc))))) + +-- | Update the scope with the message corresponding to a table key +-- +-- @since 1.2.0.0 +inKey :: String -> Matcher a -> Matcher a +inKey key = withScope ('.' : show (prettySimpleKey key)) + +-- | Update the scope with the message corresponding to an array index +-- +-- @since 1.2.0.0 +inIndex :: Int -> Matcher a -> Matcher a +inIndex i = withScope ("[" ++ show i ++ "]") diff --git a/src/Toml/FromValue/ParseTable.hs b/src/Toml/FromValue/ParseTable.hs new file mode 100644 --- /dev/null +++ b/src/Toml/FromValue/ParseTable.hs @@ -0,0 +1,125 @@ +{-| +Module : Toml.FromValue.ParseTable +Description : A type for matching keys out of a table +Copyright : (c) Eric Mertens, 2023 +License : ISC +Maintainer : emertens@gmail.com + +This module provides utilities for matching key-value pairs +out of tables while building up application-specific values. + +It will help generate warnings for unused keys, help select +between multiple possible keys, and emit location-specific +error messages when keys are unavailable. + +This module provides the 'ParseTable' implementation, but +most of the basic functionality is exported directly from +"Toml.FromValue". + +-} +module Toml.FromValue.ParseTable ( + -- * Base interface + ParseTable, + KeyAlt(..), + pickKey, + runParseTable, + + -- * Primitives + liftMatcher, + warnTable, + setTable, + getTable, + ) where + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (StateT(..), get, put) +import Data.List (intercalate) +import Data.Map qualified as Map +import Toml.FromValue.Matcher (warning, Matcher, inKey) +import Toml.Pretty (prettySimpleKey) +import Toml.Value (Table, Value) + +-- | A 'Matcher' that tracks a current set of unmatched key-value +-- pairs from a table. +-- +-- Use 'optKey' and 'reqKey' to extract keys. +-- +-- Use 'getTable' and 'setTable' to override the table and implement +-- other primitives. +newtype ParseTable a = ParseTable (StateT Table Matcher a) + deriving (Functor, Applicative, Monad, Alternative, MonadPlus) + +-- | Implemented in terms of 'fail' on 'Matcher' +instance MonadFail ParseTable where + fail = ParseTable . fail + +-- | Lift a matcher into the current table parsing context. +liftMatcher :: Matcher a -> ParseTable a +liftMatcher = ParseTable . lift + +-- | Run a 'ParseTable' computation with a given starting 'Table'. +-- Unused tables will generate a warning. To change this behavior +-- 'getTable' and 'setTable' can be used to discard or generate +-- error messages. +runParseTable :: ParseTable a -> Table -> Matcher a +runParseTable (ParseTable p) t = + do (x, t') <- runStateT p t + case Map.keys t' of + [] -> pure x + [k] -> x <$ warning ("unexpected key: " ++ show (prettySimpleKey k)) + ks -> x <$ warning ("unexpected keys: " ++ intercalate ", " (map (show . prettySimpleKey) ks)) + +-- | Return the remaining portion of the table being matched. +getTable :: ParseTable Table +getTable = ParseTable get + +-- | Replace the remaining portion of the table being matched. +setTable :: Table -> ParseTable () +setTable = ParseTable . put + +-- | Emit a warning at the current location. +warnTable :: String -> ParseTable () +warnTable = ParseTable . lift . warning + + +-- | Key and value matching function +-- +-- @since 1.2.0.0 +data KeyAlt a + = Key String (Value -> Matcher a) -- ^ pick alternative based on key match + | Else (Matcher a) -- ^ default case when no previous cases matched + +-- | Take the first option from a list of table keys and matcher functions. +-- This operation will commit to the first table key that matches. If the +-- associated matcher fails, only that error will be propagated and the +-- other alternatives will not be matched. +-- +-- If no keys match, an error message is generated explaining which keys +-- would have been accepted. +-- +-- This is provided as an alternative to chaining multiple 'reqKey' cases +-- together with @('<|>')@ because that will generate one error message for +-- each unmatched alternative as well as the error associate with the +-- matched alternative. +-- +-- @since 1.2.0.0 +pickKey :: [KeyAlt a] -> ParseTable a +pickKey xs = + do t <- getTable + foldr (f t) (fail errMsg) xs + where + f t (Else m) _ = liftMatcher m + f t (Key k c) continue = + case Map.lookup k t of + Nothing -> continue + Just v -> + do setTable $! Map.delete k t + liftMatcher (inKey k (c v)) + + errMsg = + case xs of + [] -> "no alternatives" + [Key k _] -> "missing key: " ++ show (prettySimpleKey k) + _ -> "possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs] diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -7,11 +7,12 @@ import QuoteStr (quoteStr) import Test.Hspec (it, shouldBe, Spec) import Toml (decode, Result(Success), encode) -import Toml.FromValue (FromTable(..), FromValue(..), defaultTableFromValue, runParseTable, reqKey, optKey) -import Toml.FromValue.Generic (genericFromTable) +import Toml.FromValue (FromValue(..), runParseTable, reqKey, optKey) +import Toml.FromValue.Generic (genericParseTable) import Toml.ToValue (ToTable(..), ToValue(toValue), (.=), defaultTableToValue) import Toml.ToValue.Generic (genericToTable) import Toml (Result(..)) +import Toml.FromValue (parseTableFromValue) newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) @@ -31,14 +32,9 @@ name :: String } deriving (Eq, Show, Generic) -instance FromTable Fruits where fromTable = genericFromTable -instance FromTable Physical where fromTable = genericFromTable -instance FromTable Variety where fromTable = genericFromTable - -instance FromValue Fruits where fromValue = defaultTableFromValue -instance FromValue Fruit where fromValue = defaultTableFromValue -instance FromValue Physical where fromValue = defaultTableFromValue -instance FromValue Variety where fromValue = defaultTableFromValue +instance FromValue Fruits where fromValue = parseTableFromValue genericParseTable +instance FromValue Physical where fromValue = parseTableFromValue genericParseTable +instance FromValue Variety where fromValue = parseTableFromValue genericParseTable instance ToTable Fruits where toTable = genericToTable instance ToTable Physical where toTable = genericToTable @@ -49,8 +45,8 @@ instance ToValue Physical where toValue = defaultTableToValue instance ToValue Variety where toValue = defaultTableToValue -instance FromTable Fruit where - fromTable = runParseTable (Fruit +instance FromValue Fruit where + fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> (fromMaybe [] <$> optKey "varieties")) @@ -124,14 +120,14 @@ color = "yellow"|] `shouldBe` Success [ - "Unexpected keys: count, taste in top.fruits[0]", - "Unexpected key: color in top.fruits[1]"] + "unexpected keys: count, taste in top.fruits[0]", + "unexpected key: color in top.fruits[1]"] (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []]) it "handles missing key errors" $ (decode "[[fruits]]" :: Result Fruits) `shouldBe` - Failure ["Missing key: name in top.fruits[0]"] + Failure ["missing key: name in top.fruits[0]"] it "handles parse errors while decoding" $ (decode "x =" :: Result Fruits) diff --git a/test/HieDemoSpec.hs b/test/HieDemoSpec.hs new file mode 100644 --- /dev/null +++ b/test/HieDemoSpec.hs @@ -0,0 +1,401 @@ +{-| +Module : HieDemoSpec +Description : Exercise various components of FromValue on a life-sized example +Copyright : (c) Eric Mertens, 2023 +License : ISC +Maintainer : emertens@gmail.com + +This module demonstrates how "Toml.FromValue" can handle a real-world +format as used in hie-bios. These types are copied from + +with slight alterations because the Other case is for YAML-specific extensibility. +This approach would work just the same when parameterized in that same way. + +-} +module HieDemoSpec where + +import Control.Applicative (optional) +import GHC.Generics ( Generic ) +import QuoteStr (quoteStr) +import Test.Hspec (Spec, it, shouldBe) +import Toml (Value(Table, Array), Table, Result(..), decode) +import Toml.FromValue +import Toml.FromValue.Generic (genericParseTable) + +----------------------------------------------------------------------- +-- THIS CODE DERIVED FROM CODE UNDER THE FOLLOWING LICENSE +----------------------------------------------------------------------- + +-- Copyright (c) 2009, IIJ Innovation Institute Inc. +-- All rights reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: + +-- * Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- * Neither the name of the copyright holders nor the names of its +-- contributors may be used to endorse or promote products derived +-- from this software without specific prior written permission. + +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. + +data CradleConfig = CradleConfig + { cradle :: CradleComponent + , dependencies :: Maybe [FilePath] + } deriving (Generic, Show, Eq) + +data CradleComponent + = Multi [MultiSubComponent] + | Cabal CabalConfig + | Stack StackConfig + | Direct DirectConfig + | Bios BiosConfig + | None NoneConfig + deriving (Generic, Show, Eq) + +data NoneConfig = NoneConfig + deriving (Generic, Show, Eq) + +data MultiSubComponent = MultiSubComponent + { path :: FilePath + , config :: CradleConfig + } deriving (Generic, Show, Eq) + +data CabalConfig = CabalConfig + { cabalProject :: Maybe FilePath + , cabalComponents :: OneOrManyComponents CabalComponent + } deriving (Show, Eq) + +data CabalComponent = CabalComponent + { cabalPath :: FilePath + , cabalComponent :: String + , cabalComponentProject :: Maybe FilePath + } deriving (Show, Eq) + +data StackConfig = StackConfig + { stackYaml :: Maybe FilePath + , stackComponents :: OneOrManyComponents StackComponent + } deriving (Show, Eq) + +data StackComponent = StackComponent + { stackPath :: FilePath + , stackComponent :: String + , stackComponentYAML :: Maybe FilePath + } deriving (Show, Eq) + +data OneOrManyComponents component + = SingleComponent String + | ManyComponents [component] + | NoComponent + deriving (Show, Eq) + +data DirectConfig = DirectConfig + { arguments :: [String] + } deriving (Generic, Show, Eq) + +data BiosConfig = BiosConfig + { callable :: Callable + , depsCallable :: Maybe Callable + , ghcPath :: Maybe FilePath + } deriving (Show, Eq) + +data Callable + = Program FilePath + | Shell String + deriving (Show, Eq) + +----------------------------------------------------------------------- +-- END OF DERIVED CODE +----------------------------------------------------------------------- + +instance FromValue CradleConfig where + fromValue = parseTableFromValue genericParseTable + +instance FromValue CradleComponent where + fromValue = parseTableFromValue $ + pickKey [ + Key "multi" (fmap Multi . fromValue), + Key "cabal" (fmap Cabal . fromValue), + Key "stack" (fmap Stack . fromValue), + Key "direct" (fmap Direct . fromValue), + Key "bios" (fmap Bios . fromValue), + Key "none" (fmap None . fromValue)] + +instance FromValue MultiSubComponent where + fromValue = parseTableFromValue genericParseTable + +instance FromValue CabalConfig where + fromValue v@Toml.Array{} = CabalConfig Nothing . ManyComponents <$> fromValue v + fromValue (Toml.Table t) = getComponentTable CabalConfig "cabalProject" t + fromValue _ = fail "cabal configuration expects table or array" + +getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> String -> Toml.Table -> Matcher a +getComponentTable con pathKey = runParseTable $ con + <$> optKey pathKey + <*> pickKey [ + Key "component" (fmap SingleComponent . fromValue), + Key "components" (fmap ManyComponents . fromValue), + Else (pure NoComponent)] + +instance FromValue CabalComponent where + fromValue = parseTableFromValue $ CabalComponent + <$> reqKey "path" + <*> reqKey "component" + <*> optKey "cabalProject" + +instance FromValue StackConfig where + fromValue v@Toml.Array{} = StackConfig Nothing . ManyComponents <$> fromValue v + fromValue (Toml.Table t) = getComponentTable StackConfig "stackYaml" t + fromValue _ = fail "stack configuration expects table or array" + +instance FromValue StackComponent where + fromValue = parseTableFromValue $ StackComponent + <$> reqKey "path" + <*> reqKey "component" + <*> optKey "stackYaml" + +instance FromValue DirectConfig where + fromValue = parseTableFromValue genericParseTable + +instance FromValue BiosConfig where + fromValue = parseTableFromValue $ BiosConfig + <$> getCallable + <*> getDepsCallable + <*> optKey "with-ghc" + where + getCallable = + pickKey [ + Key "program" (fmap Program . fromValue), + Key "shell" (fmap Shell . fromValue)] + getDepsCallable = + optional (pickKey [ + Key "dependency-program" (fmap Program . fromValue), + Key "dependency-shell" (fmap Shell . fromValue)]) + +instance FromValue NoneConfig where + fromValue = parseTableFromValue genericParseTable + +spec :: Spec +spec = + do it "parses this project's hie.toml" $ + decode [quoteStr| + dependencies = [ + "src/Toml/Lexer.x", + "src/Toml/Parser.y", + ] + + [[cradle.cabal]] + path = "./src" + component = "toml-parser:lib:toml-parser" + + [[cradle.cabal]] + path = "./test" + component = "toml-parser:test:unittests" + + [[cradle.cabal]] + path = "./test-drivers/encoder" + component = "toml-test-drivers:exe:TomlEncoder" + + [[cradle.cabal]] + path = "./test-drivers/decoder" + component = "toml-test-drivers:exe:TomlDecoder" + + [[cradle.cabal]] + path = "./test-drivers/highlighter" + component = "toml-test-drivers:exe:TomlHighlighter" + |] + `shouldBe` + Success [] CradleConfig + { cradle = + Cabal + CabalConfig + { cabalProject = Nothing + , cabalComponents = + ManyComponents + [ CabalComponent + { cabalPath = "./src" + , cabalComponent = "toml-parser:lib:toml-parser" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test" + , cabalComponent = "toml-parser:test:unittests" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test-drivers/encoder" + , cabalComponent = "toml-test-drivers:exe:TomlEncoder" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test-drivers/decoder" + , cabalComponent = "toml-test-drivers:exe:TomlDecoder" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test-drivers/highlighter" + , cabalComponent = "toml-test-drivers:exe:TomlHighlighter" + , cabalComponentProject = Nothing + } + ] + } + , dependencies = Just ["src/Toml/Lexer.x" , "src/Toml/Parser.y"] + } + + it "has focused error messages" $ + decode [quoteStr| + [cradle.cabal] + path = "./src" + component = 42 + |] + `shouldBe` + (Failure ["type error. wanted: string got: integer in top.cradle.cabal.component"] + :: Result CradleConfig) + + it "detects unusd keys" $ + decode [quoteStr| + [[cradle.multi]] + path = "./src" + [cradle.multi.config.cradle.cabal] + component = "toml-parser:lib:toml-parser" + thing1 = 10 # unused key for test case + + [[cradle.multi]] + path = "./test" + [cradle.multi.config.cradle.stack] + component = "toml-parser:test:unittests" + thing2 = 20 # more unused keys for test case + thing3 = false + |] + `shouldBe` + Success + [ "unexpected key: thing1 in top.cradle.multi[0].config.cradle.cabal" + , "unexpected keys: thing2, thing3 in top.cradle.multi[1].config.cradle.stack" + ] + CradleConfig + { cradle = + Multi + [ MultiSubComponent + { path = "./src" + , config = + CradleConfig + { cradle = + Cabal + CabalConfig + { cabalProject = Nothing + , cabalComponents = SingleComponent "toml-parser:lib:toml-parser" + } + , dependencies = Nothing + } + } + , MultiSubComponent + { path = "./test" + , config = + CradleConfig + { cradle = + Stack + StackConfig + { stackYaml = Nothing + , stackComponents = SingleComponent "toml-parser:test:unittests" + } + , dependencies = Nothing + } + } + ] + , dependencies = Nothing + } + + it "parses things using components" $ + decode [quoteStr| + dependencies = [ + "src/Toml/Lexer.x", + "src/Toml/Parser.y", + ] + + [cradle.cabal] + cabalProject = "cabal.project" + + [[cradle.cabal.components]] + path = "./src" + component = "toml-parser:lib:toml-parser" + + [[cradle.cabal.components]] + path = "./test" + component = "toml-parser:test:unittests" + + [[cradle.cabal.components]] + path = "./test-drivers/encoder" + component = "toml-test-drivers:exe:TomlEncoder" + + [[cradle.cabal.components]] + path = "./test-drivers/decoder" + component = "toml-test-drivers:exe:TomlDecoder" + + [[cradle.cabal.components]] + path = "./test-drivers/highlighter" + component = "toml-test-drivers:exe:TomlHighlighter" + |] + `shouldBe` + Success + [] + CradleConfig + { cradle = + Cabal + CabalConfig + { cabalProject = Just "cabal.project" + , cabalComponents = + ManyComponents + [ CabalComponent + { cabalPath = "./src" + , cabalComponent = "toml-parser:lib:toml-parser" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test" + , cabalComponent = "toml-parser:test:unittests" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test-drivers/encoder" + , cabalComponent = "toml-test-drivers:exe:TomlEncoder" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test-drivers/decoder" + , cabalComponent = "toml-test-drivers:exe:TomlDecoder" + , cabalComponentProject = Nothing + } + , CabalComponent + { cabalPath = "./test-drivers/highlighter" + , cabalComponent = "toml-test-drivers:exe:TomlHighlighter" + , cabalComponentProject = Nothing + } + ] + } + , dependencies = Just [ "src/Toml/Lexer.x" , "src/Toml/Parser.y" ] + } + + it "handles the none case" $ + decode [quoteStr| + [cradle.none]|] + `shouldBe` + Success [] (CradleConfig { + cradle = None NoneConfig, + dependencies = Nothing}) diff --git a/toml-parser.cabal b/toml-parser.cabal --- a/toml-parser.cabal +++ b/toml-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: toml-parser -version: 1.1.1.0 +version: 1.2.0.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with @@ -51,6 +51,7 @@ Toml.FromValue Toml.FromValue.Generic Toml.FromValue.Matcher + Toml.FromValue.ParseTable Toml.Lexer Toml.Lexer.Token Toml.Lexer.Utils @@ -92,6 +93,7 @@ toml-parser, other-modules: DecodeSpec + HieDemoSpec LexerSpec PrettySpec QuoteStr