Provide mapOf and listOf

glguy · Feb 21, 2024 · 9b026e5 · 9b026e5
1 parent cc57969
commit 9b026e5
Show file tree

Hide file tree

Showing 10 changed files with 57 additions and 51 deletions.
diff --git 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
@@ -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,21 +59,43 @@ 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
     fromValue :: Value' l -> Matcher l a
 
     -- | 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 =