put locations on the tests

src/Toml/FromValue.hs

@@ -119,7 +119,7 @@ typeError wanted got = failAt (valueAnn got) ("type error. wanted: " ++ wanted +
 
 -- | Used to derive a 'fromValue' implementation from a 'ParseTable' matcher.
 parseTableFromValue :: ParseTable l a -> Value' l -> Matcher l a
-parseTableFromValue p (Table' _ t) = runParseTable p t
+parseTableFromValue p (Table' l t) = runParseTable p l t
 parseTableFromValue _ v = typeError "table" v
 
 -- | Matches integer values

src/Toml/FromValue/ParseTable.hs

@@ -27,6 +27,8 @@ module Toml.FromValue.ParseTable (
     -- * Primitives
     liftMatcher,
     warnTable,
+    warnTableAt,
+    failTableAt,
     setTable,
     getTable,
     ) where
@@ -35,9 +37,11 @@ import Control.Applicative (Alternative, empty)
 import Control.Monad (MonadPlus)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State.Strict (StateT(..), get, put)
+import Control.Monad.Trans.Reader
+import Data.Foldable (for_)
 import Data.List (intercalate)
 import Data.Map qualified as Map
-import Toml.FromValue.Matcher (warning, Matcher, inKey)
+import Toml.FromValue.Matcher (warning, Matcher, inKey, failAt, warningAt)
 import Toml.Pretty (prettySimpleKey)
 import Toml.Value (Table'(..), Value')
 
@@ -48,7 +52,7 @@ import Toml.Value (Table'(..), Value')
 --
 -- Use 'getTable' and 'setTable' to override the table and implement
 -- other primitives.
-newtype ParseTable l a = ParseTable (StateT (Table' l) (Matcher l) a)
+newtype ParseTable l a = ParseTable (ReaderT l (StateT (Table' l) (Matcher l)) a)
     deriving (Functor, Applicative, Monad, Alternative, MonadPlus)
 
 -- | Implemented in terms of 'fail' on 'Matcher'
@@ -57,32 +61,37 @@ instance MonadFail (ParseTable l) where
 
 -- | Lift a matcher into the current table parsing context.
 liftMatcher :: Matcher l a -> ParseTable l a
-liftMatcher = ParseTable . lift
+liftMatcher = ParseTable . lift . 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 l a -> Table' l -> Matcher l a
-runParseTable (ParseTable p) t =
- do (x, MkTable 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))
+runParseTable :: ParseTable l a -> l -> Table' l -> Matcher l a
+runParseTable (ParseTable p) l t =
+ do (x, MkTable t') <- runStateT (runReaderT p l) t
+    for_ (Map.assocs t') \(k, (a, _)) ->
+        warningAt a ("unexpected key: " ++ show (prettySimpleKey k))
+    pure x
+
 
 -- | Return the remaining portion of the table being matched.
 getTable :: ParseTable l (Table' l)
-getTable = ParseTable get
+getTable = ParseTable (lift get)
 
 -- | Replace the remaining portion of the table being matched.
 setTable :: Table' l -> ParseTable l ()
-setTable = ParseTable . put
+setTable = ParseTable . lift . put
 
 -- | Emit a warning at the current location.
 warnTable :: String -> ParseTable l ()
-warnTable = ParseTable . lift . warning
+warnTable = liftMatcher . warning
+
+warnTableAt :: l -> String -> ParseTable l ()
+warnTableAt l = liftMatcher . warningAt l
 
+failTableAt :: l -> String -> ParseTable l a
+failTableAt l = liftMatcher . failAt l
 
 -- | Key and value matching function
 --
@@ -119,7 +128,8 @@ pickKey xs =
                     liftMatcher (inKey k (c v))
 
         errCase =
+         do l <- ParseTable ask
             case xs of
                 []        -> empty -- there's nothing a user can do here
-                [Key k _] -> fail ("missing key: " ++ show (prettySimpleKey k))
-                _         -> fail ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs])
+                [Key k _] -> failTableAt l ("missing key: " ++ show (prettySimpleKey k))
+                _         -> failTableAt l ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs])

test/DecodeSpec.hs

@@ -127,14 +127,15 @@ spec =
             color = "yellow"|]
         `shouldBe`
         Success [
-            "unexpected keys: count, taste in top.fruits[0]",
-            "unexpected key: color in top.fruits[1]"]
+            "4:1: unexpected key: count in top.fruits[0]",
+            "3:1: unexpected key: taste in top.fruits[0]",
+            "7:1: unexpected key: color in top.fruits[1]"]
             (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []])
 
     it "handles missing key errors" $
         (decode "[[fruits]]" :: Result String Fruits)
         `shouldBe`
-        Failure ["missing key: name in top.fruits[0]"]
+        Failure ["1:3: missing key: name in top.fruits[0]"]
 
     it "handles parse errors while decoding" $
         (decode "x =" :: Result String Fruits)

test/FromValueSpec.hs

@@ -27,39 +27,40 @@ humanMatcher m =
 spec :: Spec
 spec =
  do it "handles one reqKey" $
-        humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"]))
+        humanMatcher (runParseTable (reqKey "test") () (table ["test" .= "val"]))
         `shouldBe`
         Success [] "val"
 
     it "handles one optKey" $
-        humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"]))
+        humanMatcher (runParseTable (optKey "test") () (table ["test" .= "val"]))
         `shouldBe`
         Success [] (Just "val")
 
     it "handles one missing optKey" $
-        humanMatcher (runParseTable (optKey "test") (table ["nottest" .= "val"]))
+        humanMatcher (runParseTable (optKey "test") () (table ["nottest" .= "val"]))
         `shouldBe`
-        Success ["unexpected key: nottest in top"] (Nothing :: Maybe String)
+        Success ["testcase: unexpected key: nottest in top"] (Nothing :: Maybe String)
 
     it "handles one missing reqKey" $
-        humanMatcher (runParseTable (reqKey "test") (table ["nottest" .= "val"]))
+        humanMatcher (runParseTable (reqKey "test") () (table ["nottest" .= "val"]))
         `shouldBe`
-        (Failure ["missing key: test in top"] :: Result String String)
+        (Failure ["testcase: missing key: test in top"] :: Result String String)
 
     it "handles one mismatched reqKey" $
-        humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"]))
+        humanMatcher (runParseTable (reqKey "test") () (table ["test" .= "val"]))
         `shouldBe`
         (Failure ["testcase: type error. wanted: integer got: string in top.test"] :: Result String Integer)
 
     it "handles one mismatched optKey" $
-        humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"]))
+        humanMatcher (runParseTable (optKey "test") () (table ["test" .= "val"]))
         `shouldBe`
         (Failure ["testcase: type error. wanted: integer got: string in top.test"] :: Result String (Maybe Integer))
 
     it "handles concurrent errors" $
-        humanMatcher (runParseTable (reqKey "a" <|> empty <|> reqKey "b") (table []))
+        humanMatcher (runParseTable (reqKey "a" <|> empty <|> reqKey "b") () (table []))
         `shouldBe`
-        (Failure ["missing key: a in top", "missing key: b in top"] :: Result String Integer)
+        (Failure ["testcase: missing key: a in top",
+                  "testcase: missing key: b in top"] :: Result String Integer)
 
     it "handles concurrent value mismatch" $
         let v = String "" in
@@ -71,7 +72,7 @@ spec =
             :: Result String (Either Bool Int))
 
     it "doesn't emit an error for empty" $
-        humanMatcher (runParseTable empty (table []))
+        humanMatcher (runParseTable empty () (table []))
         `shouldBe`
         (Failure [] :: Result String Integer)
 
@@ -93,20 +94,20 @@ spec =
                 when (odd n) (warnTable "k1 and k2 sum to an odd value")
                 pure n
         in
-        humanMatcher (runParseTable pt (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)]))
+        humanMatcher (runParseTable pt () (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)]))
         `shouldBe`
         Success ["k1 and k2 sum to an odd value in top"] (3 :: Integer)
 
     it "offers helpful messages when no keys match" $
         let pt = pickKey [Key "this" \_ -> pure 'a', Key "." \_ -> pure 'b']
         in
-        humanMatcher (runParseTable pt (MkTable mempty))
+        humanMatcher (runParseTable pt () (MkTable mempty))
         `shouldBe`
-        (Failure ["possible keys: this, \".\" in top"] :: Result String Char)
+        (Failure ["testcase: possible keys: this, \".\" in top"] :: Result String Char)
 
     it "generates an error message on an empty pickKey" $
         let pt = pickKey []
         in
-        humanMatcher (runParseTable pt (MkTable mempty))
+        humanMatcher (runParseTable pt () (MkTable mempty))
         `shouldBe`
         (Failure [] :: Result String Char)

test/HieDemoSpec.hs

@@ -143,10 +143,10 @@ instance FromValue MultiSubComponent where
 
 instance FromValue CabalConfig where
     fromValue v@Toml.Array'{} = CabalConfig Nothing . ManyComponents <$> fromValue v
-    fromValue (Toml.Table' _ t) = getComponentTable CabalConfig "cabalProject" t
+    fromValue (Toml.Table' l t) = getComponentTable CabalConfig "cabalProject" l t
     fromValue _               = fail "cabal configuration expects table or array"
 
-getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> String -> Toml.Table' l -> Matcher l a
+getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> String -> l -> Toml.Table' l -> Matcher l a
 getComponentTable con pathKey = runParseTable $ con
     <$> optKey pathKey
     <*> pickKey [
@@ -162,7 +162,7 @@ instance FromValue CabalComponent where
 
 instance FromValue StackConfig where
     fromValue v@Toml.Array'{} = StackConfig Nothing . ManyComponents <$> fromValue v
-    fromValue (Toml.Table' _ t) = getComponentTable StackConfig "stackYaml" t
+    fromValue (Toml.Table' l t) = getComponentTable StackConfig "stackYaml" l t
     fromValue _ = fail "stack configuration expects table or array"
 
 instance FromValue StackComponent where
@@ -298,8 +298,10 @@ spec =
             |]
         `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"
+            [ "5:1: unexpected key: thing1 in top.cradle.multi[0].config.cradle.cabal"
+            , "11:1: unexpected key: thing2 in top.cradle.multi[1].config.cradle.stack"
+            , "12:1: unexpected key: thing3 in top.cradle.multi[1].config.cradle.stack"
+
             ]
             CradleConfig
                 { cradle =