Add call stacks to Syntax.Error.

src/Data/Syntax.hs

@@ -5,9 +5,11 @@ import Algorithm
 import Control.Monad.Error.Class hiding (Error)
 import Data.Align.Generic
 import Data.ByteString (ByteString)
+import qualified Data.Error as Error
 import Data.Functor.Classes.Eq.Generic
 import Data.Functor.Classes.Show.Generic
 import Data.Record
+import Data.Span
 import qualified Data.Syntax.Assignment as Assignment
 import Data.Union
 import GHC.Generics
@@ -23,7 +25,7 @@ emptyTerm :: (HasCallStack, Empty :< fs) => Assignment.Assignment ast grammar (T
 emptyTerm = makeTerm <$> Assignment.location <*> pure Empty
 
 handleError :: (HasCallStack, Error :< fs, Show grammar) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
-handleError = flip catchError (\ Assignment.Error{..} -> makeTerm <$> Assignment.location <*> pure (Error (either id show <$> errorExpected) (either id show <$> errorActual) []) <* Assignment.source)
+handleError = flip catchError (\ Error.Error{..} -> makeTerm <$> Assignment.location <*> pure (Error (getCallStack callStack) (either id show <$> errorExpected) (either id show <$> errorActual) []) <* Assignment.source)
 
 
 -- Undifferentiated
@@ -68,8 +70,11 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
 
 
 -- | Syntax representing a parsing or assignment error.
-data Error a = Error { errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
+data Error a = Error { errorCallStack :: [([Char], SrcLoc)], errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Show, Traversable)
 
 instance Eq1 Error where liftEq = genericLiftEq
 instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
+
+unError :: HasCallStack => Span -> Error a -> Error.Error String
+unError span Error{..} = Error.withCallStack (fromCallSiteList errorCallStack) (Error.Error span errorExpected errorActual)

src/Renderer/TOC.hs

@@ -26,7 +26,7 @@ import Data.Align (crosswalk)
 import Data.Bifunctor (bimap, first)
 import Data.Blob
 import Data.ByteString.Lazy (toStrict)
-import Data.Error as Error (Error(..), formatError)
+import Data.Error as Error (formatError)
 import Data.Foldable (fold, foldl', toList)
 import Data.Functor.Both hiding (fst, snd)
 import qualified Data.Functor.Both as Both
@@ -125,7 +125,7 @@ declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syn
 declarationAlgebra blob@Blob{..} (a :< r)
   | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier))
   | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier))
-  | Just (Syntax.Error errorExpected errorActual _) <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Error.Error (sourceSpan a) errorExpected errorActual))) blobLanguage
+  | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage
   | otherwise = Nothing
   where getSource = toText . flip Source.slice blobSource . byteRange
 
@@ -135,7 +135,7 @@ markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fiel
                      -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
 markupSectionAlgebra blob@Blob{..} (a :< r)
   | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level
-  | Just (Syntax.Error errorExpected errorActual _) <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Error.Error (sourceSpan a) errorExpected errorActual))) blobLanguage
+  | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage
   | otherwise = Nothing
   where getSource = firstLine . toText . flip Source.slice blobSource . byteRange
         firstLine = T.takeWhile (/= '\n')

src/Semantic/Task.hs

@@ -52,6 +52,7 @@ import Diff
 import Info
 import qualified Files
 import GHC.Conc (atomically)
+import GHC.Stack
 import Language
 import Language.Markdown
 import Parser
@@ -199,9 +200,9 @@ runParser Options{..} blob@Blob{..} = go
             case res of
               Left err -> writeLog Error "failed parsing" blobFields >> pure (Left err)
               Right ast -> logTiming "assign" $ case Assignment.assignBy by blobSource assignment ast of
-                Left err -> do
+                Left err@Error.Error{..} -> do
                   writeLog Error (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) blobFields
-                  pure $ Right (Syntax.makeTerm (totalRange blobSource :. totalSpan blobSource :. Nil) (Syntax.Error (Error.errorExpected err) (Error.errorActual err) []))
+                  pure $ Right (Syntax.makeTerm (totalRange blobSource :. totalSpan blobSource :. Nil) (Syntax.Error (getCallStack (Error.errorCallStack err)) errorExpected errorActual []))
                 Right term -> do
                   for_ (errors term) $ \ err ->
                     writeLog Warning (Error.formatError optionsPrintSource optionsEnableColour blob err) blobFields
@@ -212,7 +213,7 @@ runParser Options{..} blob@Blob{..} = go
         blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ]
         errors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
         errors = cata $ \ (a :< syntax) -> case syntax of
-          _ | Just (Syntax.Error expected actual _) <- prj syntax -> [Error.Error (sourceSpan a) expected actual]
+          _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err]
           _ -> fold syntax
         logTiming :: String -> Task a -> Task a
         logTiming msg = time msg blobFields