Store CallStack information in Errors directly.

Adds a `makeError` constructor that provides a HasCallStack
constraint. One should generally use this instead of the Error
constructor.

src/Assigning/Assignment.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, ImplicitParams #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 -- | Assignment of AST onto some other structure (typically terms).
 --
@@ -83,7 +83,6 @@ module Assigning.Assignment
 , putLocals
 -- Results
 , Error(..)
-, errorCallStack
 , nodeError
 , firstSet
 -- Running
@@ -225,7 +224,7 @@ manyThrough step stop = go
 
 
 nodeError :: HasCallStack => [Either String grammar] -> Node grammar -> Error (Either String grammar)
-nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol))
+nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol)) ?callStack
 
 
 firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
@@ -279,15 +278,15 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
                   Many rule -> fix (\ recur state -> (go rule state >>= \ (a, state') -> first (a:) <$> if state == state' then pure ([], state') else recur state') `catchError` const (pure ([], state))) state >>= uncurry yield
                   Alt (a:as) -> sconcat (flip yield state <$> a:|as)
                   Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield
-                  Fail s -> throwError ((makeError node) { errorActual = Just (Left s) })
+                  Fail s -> throwError ((makeError' node) { errorActual = Just (Left s) })
                   Choose _ (Just atEnd) _ | Nothing <- node -> go atEnd state >>= uncurry yield
-                  _ -> Left (makeError node)
+                  _ -> Left (makeError' node)
 
                 state@State{..} = case (runTracing t, initialState) of
                   (Choose table _ _, State { stateNodes = Term (In node _) : _ }) | symbolType (nodeSymbol node) /= Regular, symbols@(_:_) <- Table.tableAddresses table, all ((== Regular) . symbolType) symbols -> skipTokens initialState
                   _ -> initialState
                 expectedSymbols = firstSet (t `Then` return)
-                makeError = withStateCallStack (tracingCallSite t) state $ maybe (Error (Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
+                makeError' = withStateCallStack (tracingCallSite t) state $ maybe (makeError (Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
 
 requireExhaustive :: Symbol grammar => Maybe (String, SrcLoc) -> (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar)
 requireExhaustive callSite (a, state) = let state' = skipTokens state in case stateNodes state' of

src/Assigning/Assignment/Deterministic.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FunctionalDependencies, ImplicitParams #-}
 -- | Deterministic assignment, à la _Deterministic, Error-Correcting Combinator Parsers_, S. Doaitse Swierstra & Luc Duponcheel: http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.80.9967&rep=rep1&type=pdf
 module Assigning.Assignment.Deterministic
 ( Assigning(..)
@@ -60,13 +60,13 @@ choose :: (Enum symbol, HasCallStack)
 choose nullable firstSet table src state follow = case stateInput state of
   []  -> case nullable of
     Nullable f -> Right (state, f state)
-    _          -> Left (withFrozenCallStack (Error (stateSpan state) (Right . toEnum <$> IntSet.toList firstSet) Nothing))
+    _          -> Left (withFrozenCallStack (Error (stateSpan state) (Right . toEnum <$> IntSet.toList firstSet) Nothing ?callStack))
   s:_ -> case fromEnum (astSymbol s) `IntMap.lookup` table of
     Just k -> k src state follow
     _      -> notFound (astSymbol s) state follow
   where notFound s state follow = case nullable of
           Nullable f | any (fromEnum s `IntSet.member`) follow -> Right (state, f state)
-          _                                                    -> Left (withFrozenCallStack (Error (stateSpan state) (Right . toEnum <$> IntSet.toList firstSet) (Just (Right s))))
+          _                                                    -> Left (withFrozenCallStack (Error (stateSpan state) (Right . toEnum <$> IntSet.toList firstSet) (Just (Right s)) ?callStack))
 
 instance (Enum symbol, Ord symbol) => Applicative (Assignment symbol) where
   pure a = Assignment (pure a) lowerBound []
@@ -99,15 +99,15 @@ instance (Enum symbol, Ord symbol) => Alternative (Assignment symbol) where
 instance (Enum symbol, Ord symbol, Show symbol) => Assigning symbol (Assignment symbol) where
   leafNode s = Assignment NotNullable (IntSet.singleton (fromEnum s))
     [ (s, \ src state _ -> case stateInput state of
-      []  -> Left (withFrozenCallStack (Error (stateSpan state) [Right s] Nothing))
+      []  -> Left (withFrozenCallStack (Error (stateSpan state) [Right s] Nothing ?callStack))
       s:_ -> case decodeUtf8' (sourceBytes (Source.slice (astRange s) src)) of
-        Left err   -> Left (withFrozenCallStack (Error (astSpan s) [Left "valid utf-8"] (Just (Left (show err)))))
+        Left err   -> Left (withFrozenCallStack (Error (astSpan s) [Left "valid utf-8"] (Just (Left (show err))) ?callStack))
         Right text -> Right (advanceState state, text))
     ]
 
   branchNode s a = Assignment NotNullable (IntSet.singleton (fromEnum s))
     [ (s, \ src state _ -> case stateInput state of
-      []  -> Left (withFrozenCallStack (Error (stateSpan state) [Right s] Nothing))
+      []  -> Left (withFrozenCallStack (Error (stateSpan state) [Right s] Nothing ?callStack))
       s:_ -> first (const (advanceState state)) <$> runAssignment a src state { stateInput = astChildren s })
     ]
 
@@ -132,7 +132,7 @@ runAssignment (Assignment nullable firstSet table) src input
     Left err -> Left err
     Right (state', a') -> case stateInput state' of
       []   -> Right (state', a')
-      s':_ -> Left (withFrozenCallStack (Error (stateSpan state') [] (Just (Right (astSymbol s')))))
+      s':_ -> Left (withFrozenCallStack (Error (stateSpan state') [] (Just (Right (astSymbol s'))) ?callStack))
 
 
 data Nullable symbol a

src/Data/Error.hs

@@ -11,19 +11,25 @@ import Data.Source
 import Data.Span
 import System.Console.ANSI
 
-data Error grammar = HasCallStack => Error { errorSpan :: Span, errorExpected :: [grammar], errorActual :: Maybe grammar }
-  deriving (Typeable)
+data Error grammar = Error
+  { errorSpan :: Span
+  , errorExpected :: [grammar]
+  , errorActual :: Maybe grammar
+  , errorCallStack :: CallStack
+  } deriving (Typeable)
+
+-- | This instance does not take into account the call stack.
+instance Eq grammar => Eq (Error grammar) where
+  (Error s e a _) == (Error s' e' a' _) = all id [s == s', e == e', a == a']
 
-deriving instance Eq grammar => Eq (Error grammar)
 deriving instance Foldable Error
 deriving instance Functor Error
 deriving instance Show grammar => Show (Error grammar)
 deriving instance Traversable Error
 instance Exception (Error String)
 
-errorCallStack :: Error grammar -> CallStack
-errorCallStack Error{} = callStack
-
+makeError :: HasCallStack => Span -> [grammar] -> Maybe grammar -> Error grammar
+makeError s e a = Error s e a ?callStack
 
 withCallStack :: CallStack -> (HasCallStack => a) -> a
 withCallStack cs action = let ?callStack = cs in action

src/Data/Syntax.hs

@@ -220,8 +220,8 @@ instance Message String where
 errorSyntax :: Error.Error String -> [a] -> Error a
 errorSyntax Error.Error{..} = Error (ErrorStack $ errorSite <$> getCallStack callStack) errorExpected errorActual
 
-unError :: Span -> Error a -> Error.Error String
-unError span Error{..} = Error.withCallStack (freezeCallStack (fromCallSiteList $ unErrorSite <$> unErrorStack errorCallStack)) (Error.Error span errorExpected errorActual)
+unError :: HasCallStack => Span -> Error a -> Error.Error String
+unError span Error{..} = Error.withCallStack (freezeCallStack (fromCallSiteList $ unErrorSite <$> unErrorStack errorCallStack)) (Error.makeError span errorExpected errorActual)
 
 data ErrorSite = ErrorSite { errorMessage :: String, errorLocation :: SrcLoc }
   deriving (Eq, Show, Generic, Named, Message)