Merge branch 'master' into print-source

src/Data/Syntax/Assignment.hs

@@ -75,6 +75,7 @@ module Data.Syntax.Assignment
 , while
 -- Results
 , Error(..)
+, errorCallStack
 , formatErrorWithOptions
 -- Running
 , assignBy
@@ -174,7 +175,10 @@ data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected
 deriving instance Eq grammar => Eq (Error grammar)
 deriving instance Show grammar => Show (Error grammar)
 
-nodeError :: [grammar] -> Node grammar -> Error grammar
+errorCallStack :: Error grammar -> CallStack
+errorCallStack Error{} = callStack
+
+nodeError :: HasCallStack => [grammar] -> Node grammar -> Error grammar
 nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart expected (Just actual)
 
 
@@ -221,7 +225,7 @@ showPos :: Maybe FilePath -> Info.Pos -> ShowS
 showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . shows posLine . showChar ':' . shows posColumn
 
 -- | Run an assignment over an AST exhaustively.
-assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
+assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast))
          => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast.
          -> Source.Source                          -- ^ The source for the parse tree.
          -> Assignment ast grammar a               -- ^ The 'Assignment to run.
@@ -230,7 +234,7 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (
 assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure
 
 -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively.
-runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
+runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast))
               => (forall x. Base ast x -> Node grammar)        -- ^ A function to project a 'Node' from the ast.
               -> Source.Source                                 -- ^ The source for the parse tree.
               -> Assignment ast grammar a                      -- ^ The 'Assignment' to run.
@@ -264,12 +268,17 @@ runAssignment toNode source = (\ assignment state -> go assignment state >>= req
                   Alt a b -> yield a state `catchError` (\ err -> yield b state { stateError = Just err })
                   Throw e -> Left e
                   Catch during handler -> (go during state `catchError` (flip go state . handler)) >>= uncurry yield
-                  _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node)
+                  Choose{} -> Left (makeError node)
+                  Project{} -> Left (makeError node)
+                  Children{} -> Left (makeError node)
+                  Source -> Left (makeError node)
 
                 state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState
                       | otherwise = initialState
                 expectedSymbols | Choose choices _ <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices
                                 | otherwise = []
+                makeError :: HasCallStack => Maybe (Base ast ast) -> Error grammar
+                makeError node = maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node
 
         runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar)
         runMany rule = loop

test/Data/Syntax/Assignment/Spec.hs

@@ -270,6 +270,11 @@ spec = do
       `shouldBe`
         Right (Out "magenta", Out "red")
 
+    it "produces errors with callstacks pointing at the failing assignment" $
+      first (fmap fst . getCallStack . errorCallStack) (runAssignment headF "blue" red (makeState [node Blue 0 4 []]))
+      `shouldBe`
+      Left [ "symbol", "red" ]
+
 node :: symbol -> Int -> Int -> [AST symbol] -> AST symbol
 node symbol start end children = cofree $ Node symbol (Range start end) (Info.Span (Info.Pos 1 (succ start)) (Info.Pos 1 (succ end))) :< children
 
@@ -283,14 +288,14 @@ instance Symbol Grammar where
 data Out = Out ByteString | OutError ByteString
   deriving (Eq, Show)
 
-red :: Assignment (AST Grammar) Grammar Out
+red :: HasCallStack => Assignment (AST Grammar) Grammar Out
 red = Out <$ symbol Red <*> source
 
-green :: Assignment (AST Grammar) Grammar Out
+green :: HasCallStack => Assignment (AST Grammar) Grammar Out
 green = Out <$ symbol Green <*> source
 
-blue :: Assignment (AST Grammar) Grammar Out
+blue :: HasCallStack => Assignment (AST Grammar) Grammar Out
 blue = Out <$ symbol Blue <*> source
 
-magenta :: Assignment (AST Grammar) Grammar Out
+magenta :: HasCallStack => Assignment (AST Grammar) Grammar Out
 magenta = Out <$ symbol Magenta <*> source