diff --git a/src/Toml/Schema.hs b/src/Toml/Schema.hs index af7247f..5610282 100644 --- a/src/Toml/Schema.hs +++ b/src/Toml/Schema.hs @@ -9,6 +9,8 @@ Maintainer : emertens@gmail.com module Toml.Schema ( -- * FromValue FromValue(..), + mapOf, + listOf, -- ** Matcher Matcher, @@ -64,5 +66,7 @@ module Toml.Schema ( import Toml.Schema.FromValue import Toml.Schema.Generic +import Toml.Schema.ParseTable +import Toml.Schema.Matcher import Toml.Schema.ToValue import Toml.Semantics diff --git a/src/Toml/Schema/FromValue.hs b/src/Toml/Schema/FromValue.hs index 323dd59..5550b1a 100644 --- a/src/Toml/Schema/FromValue.hs +++ b/src/Toml/Schema/FromValue.hs @@ -27,37 +27,17 @@ module Toml.Schema.FromValue ( FromValue(..), FromKey(..), - -- * Matcher - runMatcher, - runMatcherFatalWarn, - runMatcherIgnoreWarn, - Matcher, - MatchMessage(..), - Result(..), - warn, - warnAt, - failAt, - - -- * Table matching - ParseTable, - parseTable, + -- * Containers + mapOf, + listOf, + + -- * Tables parseTableFromValue, reqKey, - optKey, reqKeyOf, + optKey, optKeyOf, - warnTable, - warnTableAt, - failTableAt, - KeyAlt(..), - pickKey, - getScope, - Scope(..), - - -- * Table matching primitives - getTable, - setTable, - liftMatcher, + ) where import Control.Monad (zipWithM) @@ -79,6 +59,32 @@ import Toml.Schema.Matcher import Toml.Schema.ParseTable import Toml.Semantics +-- | Table matching function used to help implement 'fromValue' for tables. +-- Key matching function is given the annotation of the key for error reporting. +-- Value matching function is given the key in case values can depend on their keys. +mapOf :: + Ord k => + (l -> Text -> Matcher l k) {- ^ key matcher -} -> + (Text -> Value' l -> Matcher l v) {- ^ value matcher -} -> + Value' l -> Matcher l (Map k v) +mapOf matchKey matchVal = + \case + Table' _ (MkTable t) -> Map.fromList <$> sequence kvs + where + kvs = [liftA2 (,) (matchKey l k) (inKey k (matchVal k v)) | (k, (l, v)) <- Map.assocs t] + v -> typeError "table" v + +-- | List matching function used to help implemented 'fromValue' for arrays. +-- The element matching function is given the list index in case values can +-- depend on their index. +listOf :: + (Int -> Value' l -> Matcher l a) -> + Value' l -> Matcher l [a] +listOf matchElt = + \case + List' _ xs -> zipWithM (\i -> inIndex i . matchElt i) [0..] xs + v -> typeError "array" v + -- | Class for types that can be decoded from a TOML value. class FromValue a where -- | Convert a 'Value' or report an error message @@ -86,14 +92,10 @@ class FromValue a where -- | Used to implement instance for @[]@. Most implementations rely on the default implementation. listFromValue :: Value' l -> Matcher l [a] - listFromValue (List' _ xs) = zipWithM (\i v -> inIndex i (fromValue v)) [0..] xs - listFromValue v = typeError "array" v + listFromValue = listOf (const fromValue) instance (Ord k, FromKey k, FromValue v) => FromValue (Map k v) where - fromValue (Table' _ (MkTable t)) = Map.fromList <$> traverse f (Map.assocs t) - where - f (k,(_, v)) = (,) <$> fromKey k <*> inKey k (fromValue v) - fromValue v = typeError "table" v + fromValue = mapOf fromKey (const fromValue) instance FromValue Table where fromValue (Table' _ t) = pure (forgetTableAnns t) @@ -103,25 +105,25 @@ instance FromValue Table where -- -- @since 1.3.0.0 class FromKey a where - fromKey :: Text -> Matcher l a + fromKey :: l -> Text -> Matcher l a -- | Matches all strings -- -- @since 1.3.0.0 instance a ~ Char => FromKey [a] where - fromKey = pure . Text.unpack + fromKey _ = pure . Text.unpack -- | Matches all strings -- -- @since 1.3.0.0 instance FromKey Text where - fromKey = pure + fromKey _ = pure -- | Matches all strings -- -- @since 1.3.0.0 instance FromKey Data.Text.Lazy.Text where - fromKey = pure . Data.Text.Lazy.fromStrict + fromKey _ = pure . Data.Text.Lazy.fromStrict -- | Report a type error typeError :: String {- ^ expected type -} -> Value' l {- ^ actual value -} -> Matcher l a diff --git a/src/Toml/Schema/Generic.hs b/src/Toml/Schema/Generic.hs index 3c3a5d6..eff1e7a 100644 --- a/src/Toml/Schema/Generic.hs +++ b/src/Toml/Schema/Generic.hs @@ -41,7 +41,7 @@ module Toml.Schema.Generic ( genericFromArray, genericFromTable, GFromArray, - GToArray, + GParseTable, -- * ToValue genericToArray, @@ -53,6 +53,7 @@ module Toml.Schema.Generic ( import Data.Coerce (coerce) import GHC.Generics (Generic(Rep)) import Toml.Schema.FromValue +import Toml.Schema.Matcher import Toml.Schema.Generic.FromValue import Toml.Schema.Generic.ToValue (GToTable, GToArray, genericToTable, genericToArray) import Toml.Schema.ToValue (ToTable(toTable), ToValue(toValue), defaultTableToValue) diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs index 84541ff..3fa42d7 100644 --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -13,7 +13,7 @@ import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (it, shouldBe, Spec) -import Toml +import Toml (decode, encode) import Toml.Schema newtype Fruits = Fruits { fruits :: [Fruit] } diff --git a/test/DerivingViaSpec.hs b/test/DerivingViaSpec.hs index 8f91f37..82b9f7e 100644 --- a/test/DerivingViaSpec.hs +++ b/test/DerivingViaSpec.hs @@ -17,7 +17,6 @@ module DerivingViaSpec (spec) where import GHC.Generics (Generic) import Test.Hspec (it, shouldBe, Spec) -import Toml import Toml.Schema data Physical = Physical { diff --git a/test/HieDemoSpec.hs b/test/HieDemoSpec.hs index d35a327..5ecc8dc 100644 --- a/test/HieDemoSpec.hs +++ b/test/HieDemoSpec.hs @@ -19,8 +19,8 @@ import Data.Text (Text) import GHC.Generics ( Generic ) import QuoteStr (quoteStr) import Test.Hspec (Spec, it, shouldBe) -import Toml (decode, Value'(..), Table') -import Toml.Schema +import Toml (decode) +import Toml.Schema as Toml ----------------------------------------------------------------------- -- THIS CODE DERIVED FROM CODE UNDER THE FOLLOWING LICENSE diff --git a/test/LexerSpec.hs b/test/LexerSpec.hs index e534933..1064634 100644 --- a/test/LexerSpec.hs +++ b/test/LexerSpec.hs @@ -2,8 +2,8 @@ module LexerSpec (spec) where import Test.Hspec (it, shouldBe, Spec) -import Toml -import Toml.Schema +import Toml (Value'(Integer), parse) +import Toml.Schema (table, (.=)) spec :: Spec spec = diff --git a/test/PrettySpec.hs b/test/PrettySpec.hs index ae964ee..c49c82c 100644 --- a/test/PrettySpec.hs +++ b/test/PrettySpec.hs @@ -1,11 +1,11 @@ {-# Language OverloadedStrings #-} module PrettySpec (spec) where -import Test.Hspec (it, shouldBe, Spec) -import QuoteStr (quoteStr) -import Toml (encode, parse, prettyToml, Table) import Data.Map qualified as Map import Data.Text (Text) +import QuoteStr (quoteStr) +import Test.Hspec (it, shouldBe, Spec) +import Toml (encode, parse, prettyToml, Table) tomlString :: Table -> String tomlString = show . prettyToml diff --git a/test/ToValueSpec.hs b/test/ToValueSpec.hs index e5f9558..18cb9cc 100644 --- a/test/ToValueSpec.hs +++ b/test/ToValueSpec.hs @@ -2,8 +2,8 @@ module ToValueSpec where import Test.Hspec (it, shouldBe, Spec) -import Toml -import Toml.Schema +import Toml (Value'(Integer, Text, List)) +import Toml.Schema (ToValue(toValue)) spec :: Spec spec = diff --git a/test/TomlSpec.hs b/test/TomlSpec.hs index 56d4209..564feb0 100644 --- a/test/TomlSpec.hs +++ b/test/TomlSpec.hs @@ -17,8 +17,8 @@ import Data.Text (Text) import Data.Time (Day) import QuoteStr (quoteStr) import Test.Hspec (describe, it, shouldBe, shouldSatisfy, Spec) -import Toml -import Toml.Schema +import Toml (Result(..), Table'(..), Value'(..), parse, decode) +import Toml.Schema (table, (.=)) spec :: Spec spec =