Remove unnecessary implicit params

src/Assigning/Assignment.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, ImplicitParams #-}
+{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 -- | Assignment of AST onto some other structure (typically terms).
 --
@@ -107,6 +107,7 @@ import Data.Span
 import Data.Term
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8')
+import GHC.Exts (fromList)
 import Text.Parser.Combinators as Parsers hiding (choice)
 import TreeSitter.Language
 
@@ -223,8 +224,8 @@ manyThrough step stop = go
   where go = (,) [] <$> stop <|> first . (:) <$> step <*> go
 
 
-nodeError :: HasCallStack => [Either String grammar] -> Node grammar -> Error (Either String grammar)
-nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol)) ?callStack
+nodeError :: CallStack -> [Either String grammar] -> Node grammar -> Error (Either String grammar)
+nodeError cs expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol)) cs
 
 
 firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
@@ -286,15 +287,18 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
                   (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 (makeError (Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
+                assignmentStack = maybe emptyCallStack (fromList . pure) (tracingCallSite t)
+                makeError' = maybe
+                             (Error (Span statePos statePos) (fmap Right expectedSymbols) Nothing assignmentStack)
+                             (nodeError assignmentStack (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
-  [] -> Right (a, state')
-  Term (In node _) : _ -> Left (withStateCallStack callSite state (nodeError [] node))
-
-withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a
-withStateCallStack callSite state = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state))))
+requireExhaustive callSite (a, state) =
+  let state' = skipTokens state
+      stack = fromCallSiteList (maybe id (:) callSite (stateCallSites state))
+  in case stateNodes state' of
+    [] -> Right (a, state')
+    Term (In node _) : _ -> Left (nodeError stack [] node)
 
 skipTokens :: Symbol grammar => State ast grammar -> State ast grammar
 skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation) (stateNodes state) }

src/Assigning/Assignment/Deterministic.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FunctionalDependencies, ImplicitParams #-}
+{-# LANGUAGE FunctionalDependencies #-}
 -- | 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 ?callStack))
+    _          -> Left (makeError (stateSpan state) (Right . toEnum <$> IntSet.toList firstSet) Nothing)
   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)) ?callStack))
+          _                                                    -> Left (makeError (stateSpan state) (Right . toEnum <$> IntSet.toList firstSet) (Just (Right s)))
 
 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 ?callStack))
+      []  -> Left (makeError (stateSpan state) [Right s] Nothing)
       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))) ?callStack))
+        Left err   -> Left (makeError (astSpan s) [Left "valid utf-8"] (Just (Left (show err))))
         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 ?callStack))
+      []  -> Left (makeError (stateSpan state) [Right s] Nothing)
       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'))) ?callStack))
+      s':_ -> Left (makeError (stateSpan state') [] (Just (Right (astSymbol s'))))
 
 
 data Nullable symbol a

src/Data/Error.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, ImplicitParams, RankNTypes, StandaloneDeriving #-}
+{-# LANGUAGE GADTs, ImplicitParams, RankNTypes #-}
 module Data.Error
   ( Error (..)
   , formatError
@@ -37,7 +37,7 @@ instance Eq grammar => Eq (Error grammar) where
 instance Exception (Error String)
 
 makeError :: HasCallStack => Span -> [grammar] -> Maybe grammar -> Error grammar
-makeError s e a = Error s e a ?callStack
+makeError s e a = withFrozenCallStack (Error s e a ?callStack)
 
 withCallStack :: CallStack -> (HasCallStack => a) -> a
 withCallStack cs action = let ?callStack = cs in action