From fbb217f8e7e399eaa3e327d95249e3745db5eff7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Aug 2017 15:22:25 -0400 Subject: [PATCH] Add call stacks to Syntax.Error. --- src/Data/Syntax.hs | 9 +++++++-- src/Renderer/TOC.hs | 6 +++--- src/Semantic/Task.hs | 7 ++++--- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 60b59bbe6..a0579d492 100644 --- a/src/Data/Syntax.hs +++ b/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) diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index f7c0a1842..55209c9d2 100644 --- a/src/Renderer/TOC.hs +++ b/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') diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 1f90eaa76..153f33104 100644 --- a/src/Semantic/Task.hs +++ b/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