From f0cb1a4715d9f0178424b37b2ee336e9acb022cd Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 00:05:57 -0400
Subject: [PATCH 1/8] :fire: the HasCallStack constraint in TypeScript
 assignment.

---
 src/Language/TypeScript/Assignment.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs
index 8b157585c..b8182090b 100644
--- a/src/Language/TypeScript/Assignment.hs
+++ b/src/Language/TypeScript/Assignment.hs
@@ -168,7 +168,7 @@ type Syntax = '[
   ]
 
 type Term = Term.Term (Data.Union.Union Syntax) (Record Location)
-type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
+type Assignment = Assignment.Assignment [] Grammar Term
 
 -- | Assignment from AST in Ruby’s grammar onto a program in TypeScript’s syntax.
 assignment :: Assignment

From 1f959572434f4a8af136e146b4494d34a077e62d Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 09:57:15 -0400
Subject: [PATCH 2/8] =?UTF-8?q?Don=E2=80=99t=20build=20call=20stacks.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Data/Syntax.hs                    | 22 +++++++++++-----------
 src/Language/JSON/Assignment.hs       |  3 +--
 src/Language/Markdown/Assignment.hs   |  3 +--
 src/Language/Python/Assignment.hs     |  6 ++----
 src/Language/Ruby/Assignment.hs       |  6 ++----
 src/Language/TypeScript/Assignment.hs | 14 ++++++--------
 6 files changed, 23 insertions(+), 31 deletions(-)

diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs
index 325736b6d..f243053cd 100644
--- a/src/Data/Syntax.hs
+++ b/src/Data/Syntax.hs
@@ -28,39 +28,39 @@ import GHC.Stack
 -- Combinators
 
 -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
-makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm :: (f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
 makeTerm a = makeTerm' a . inj
 
 -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
-makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
+makeTerm' :: (Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
 makeTerm' a f = termIn (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f
 
 -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
-makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm1 :: (f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
 makeTerm1 = makeTerm1' . inj
 
 -- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
-makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
+makeTerm1' :: (Semigroup a, Foldable f) => f (Term f a) -> Term f a
 makeTerm1' f = case toList f of
   a : _ -> makeTerm' (termAnnotation (unTerm a)) f
   _ -> error "makeTerm1': empty structure"
 
 -- | Construct an empty term at the current position.
-emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
+emptyTerm :: (Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
 emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
   where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil
 
 -- | Catch assignment errors into an error term.
-handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
+handleError :: (Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
 handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
 
 -- | Catch parse errors into an error term.
-parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
+parseError :: (Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
 parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack (getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
 
 
 -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
-contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
+contextualize :: (Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
               => m (Term (Union fs) a)
               -> m (Term (Union fs) a)
               -> m (Term (Union fs) a)
@@ -70,7 +70,7 @@ contextualize context rule = make <$> Assignment.manyThrough context rule
           _ -> node
 
 -- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
-postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
+postContextualizeThrough :: (Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
                          => m (Term (Union fs) a)
                          -> m (Term (Union fs) a)
                          -> m b
@@ -81,7 +81,7 @@ postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThr
           _ -> (node, end)
 
 -- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
-postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
+postContextualize :: (Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
                   => m (Term (Union fs) a)
                   -> m (Term (Union fs) a)
                   -> m (Term (Union fs) a)
@@ -91,7 +91,7 @@ postContextualize context rule = make <$> rule <*> many context
           _ -> node
 
 -- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
-infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs)
+infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, Apply Foldable fs)
              => m (Term (Union fs) a)
              -> m (Term (Union fs) a)
              -> m (Term (Union fs) a)
diff --git a/src/Language/JSON/Assignment.hs b/src/Language/JSON/Assignment.hs
index 2ab025fa7..d10ad35db 100644
--- a/src/Language/JSON/Assignment.hs
+++ b/src/Language/JSON/Assignment.hs
@@ -14,7 +14,6 @@ import qualified Data.Syntax.Assignment as Assignment
 import qualified Data.Syntax.Literal as Literal
 import qualified Data.Term as Term
 import Data.Union
-import GHC.Stack
 import Language.JSON.Grammar as Grammar
 
 type Syntax =
@@ -31,7 +30,7 @@ type Syntax =
   ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
+type Assignment = Assignment.Assignment [] Grammar Term
 
 
 assignment :: Assignment
diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs
index 49038f408..6a724d3e7 100644
--- a/src/Language/Markdown/Assignment.hs
+++ b/src/Language/Markdown/Assignment.hs
@@ -18,7 +18,6 @@ import Data.Term as Term (Term(..), TermF(..), termIn, unwrap)
 import qualified Data.Text as Text
 import Data.Text.Encoding (encodeUtf8)
 import Data.Union
-import GHC.Stack
 import Language.Markdown as Grammar (Grammar(..))
 import qualified Language.Markdown.Syntax as Markup
 
@@ -51,7 +50,7 @@ type Syntax =
    ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Language.Markdown.Assignment.Term
+type Assignment = Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Language.Markdown.Assignment.Term
 
 
 assignment :: Assignment
diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs
index d9211284a..0bcdca569 100644
--- a/src/Language/Python/Assignment.hs
+++ b/src/Language/Python/Assignment.hs
@@ -22,7 +22,6 @@ import qualified Data.Syntax.Statement as Statement
 import qualified Data.Syntax.Type as Type
 import qualified Data.Term as Term
 import Data.Union
-import GHC.Stack
 import Language.Python.Syntax as Python.Syntax
 import Language.Python.Grammar as Grammar
 
@@ -81,7 +80,7 @@ type Syntax =
    ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
+type Assignment = Assignment.Assignment [] Grammar Term
 
 -- | Assignment from AST in Python's grammar onto a program in Python's syntax.
 assignment :: Assignment
@@ -473,8 +472,7 @@ manyTermsTill :: Show b => Assignment.Assignment [] Grammar Term -> Assignment.A
 manyTermsTill step end = manyTill (step <|> comment) end
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.
-infixTerm :: HasCallStack
-          => Assignment
+infixTerm :: Assignment
           -> Assignment
           -> [Assignment.Assignment [] Grammar (Term -> Term -> Union Syntax Term)]
           -> Assignment.Assignment [] Grammar (Union Syntax Term)
diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs
index 6da9ab629..7efb02b4d 100644
--- a/src/Language/Ruby/Assignment.hs
+++ b/src/Language/Ruby/Assignment.hs
@@ -21,7 +21,6 @@ import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
 import qualified Data.Term as Term
 import Data.Union
-import GHC.Stack
 import Language.Ruby.Grammar as Grammar
 
 -- | The type of Ruby syntax.
@@ -79,7 +78,7 @@ type Syntax = '[
   ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
+type Assignment = Assignment.Assignment [] Grammar Term
 
 -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax.
 assignment :: Assignment
@@ -407,8 +406,7 @@ manyTermsTill :: Show b => Assignment.Assignment [] Grammar Term -> Assignment.A
 manyTermsTill step end = manyTill (step <|> comment) end
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.
-infixTerm :: HasCallStack
-          => Assignment
+infixTerm :: Assignment
           -> Assignment
           -> [Assignment.Assignment [] Grammar (Term -> Term -> Union Syntax Term)]
           -> Assignment.Assignment [] Grammar (Union Syntax Term)
diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs
index b8182090b..39a194e99 100644
--- a/src/Language/TypeScript/Assignment.hs
+++ b/src/Language/TypeScript/Assignment.hs
@@ -20,7 +20,6 @@ import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
 import qualified Data.Syntax.Type as Type
 import Data.Union
-import GHC.Stack
 import Language.TypeScript.Grammar as Grammar
 import qualified Language.TypeScript.Syntax as TypeScript.Syntax
 import qualified Data.Term as Term
@@ -282,7 +281,7 @@ anonymousClass = makeTerm <$> symbol Grammar.AnonymousClass <*> children (Declar
 abstractClass :: Assignment
 abstractClass = makeTerm <$> symbol Grammar.AbstractClass <*> (TypeScript.Syntax.AbstractClass <$> identifier <*> (typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements)
 
-classHeritage' :: HasCallStack => Assignment.Assignment [] Grammar [Term]
+classHeritage' :: Assignment.Assignment [] Grammar [Term]
 classHeritage' = symbol Grammar.ClassHeritage *> children (((++) `on` toList) <$> optional extendsClause' <*> optional implementsClause')
 
 extendsClause' :: Assignment
@@ -389,7 +388,7 @@ methodDefinition = makeMethod <$>
   where
     makeMethod loc (modifier, readonly, receiver, propertyName', (typeParameters', params, ty'), statements) = makeTerm loc (Declaration.Method [modifier, readonly, typeParameters', ty'] receiver propertyName' params statements)
 
-callSignatureParts :: HasCallStack => Assignment.Assignment [] Grammar (Term, [Term], Term)
+callSignatureParts :: Assignment.Assignment [] Grammar (Term, [Term], Term)
 callSignatureParts =  symbol Grammar.CallSignature *> children ((,,) <$> (fromMaybe <$> emptyTerm <*> optional typeParameters) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional typeAnnotation'))
 
 callSignature :: Assignment
@@ -405,7 +404,7 @@ methodSignature :: Assignment
 methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> children ((,,,) <$> (accessibilityModifier' <|> emptyTerm) <*> (readonly' <|> emptyTerm) <*> propertyName <*> callSignatureParts)
   where makeMethodSignature loc (modifier, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.MethodSignature [modifier, readonly, typeParams, annotation] propertyName params)
 
-formalParameters :: HasCallStack => Assignment.Assignment [] Grammar [Term]
+formalParameters :: Assignment.Assignment [] Grammar [Term]
 formalParameters = symbol FormalParameters *> children (concat <$> many ((\as b -> as ++ [b]) <$> many (term decorator) <*> term parameter))
 
 decorator :: Assignment
@@ -503,7 +502,7 @@ constructorTy = makeTerm <$> symbol ConstructorType <*> children (TypeScript.Syn
 statementBlock :: Assignment
 statementBlock = makeTerm <$> symbol StatementBlock <*> children (many statement)
 
-classBodyStatements :: HasCallStack => Assignment.Assignment [] Grammar [Term]
+classBodyStatements :: Assignment.Assignment [] Grammar [Term]
 classBodyStatements = symbol ClassBody *> children (concat <$> many ((\as b -> as ++ [b]) <$> many (term decorator) <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature)))
 
 publicFieldDefinition :: Assignment
@@ -671,7 +670,7 @@ module' :: Assignment
 module' = makeTerm <$> symbol Module <*> children (Declaration.Module <$> (string <|> identifier <|> nestedIdentifier) <*> ((symbol StatementBlock *> children (many statement)) <|> pure []))
 
 
-statements :: HasCallStack => Assignment.Assignment [] Grammar [Term]
+statements :: Assignment.Assignment [] Grammar [Term]
 statements = symbol StatementBlock *> children (many statement)
 
 arrowFunction :: Assignment
@@ -754,8 +753,7 @@ emptyStatement :: Assignment
 emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ source <|> pure Syntax.Empty)
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.
-infixTerm :: HasCallStack
-          => Assignment
+infixTerm :: Assignment
           -> Assignment
           -> [Assignment.Assignment [] Grammar (Term -> Term -> Data.Union.Union Syntax Term)]
           -> Assignment.Assignment [] Grammar (Data.Union.Union Syntax Term)

From 8b702e27c7b14b8d9d289fd2809135b7d7921eb4 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 09:57:30 -0400
Subject: [PATCH 3/8] =?UTF-8?q?Don=E2=80=99t=20propagate=20call=20stacks.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Data/Syntax/Assignment.hs | 142 ++++++++++++++--------------------
 1 file changed, 56 insertions(+), 86 deletions(-)

diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs
index 38d6bf205..00d739cef 100644
--- a/src/Data/Syntax/Assignment.hs
+++ b/src/Data/Syntax/Assignment.hs
@@ -114,7 +114,6 @@ import Data.Semigroup
 import qualified Data.Source as Source (Source, slice, sourceBytes)
 import qualified Data.Syntax.Assignment.Table as Table
 import Data.Term
-import GHC.Stack
 import qualified Info
 import Prelude hiding (fail, until)
 import Text.Parser.Combinators as Parsers hiding (choice)
@@ -123,7 +122,7 @@ import TreeSitter.Language
 -- | Assignment from an AST with some set of 'symbol's onto some other value.
 --
 --   This is essentially a parser.
-type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar))
+type Assignment ast grammar = Freer (AssignmentF ast grammar)
 
 data AssignmentF ast grammar a where
   End :: AssignmentF ast grammar ()
@@ -137,80 +136,68 @@ data AssignmentF ast grammar a where
   Label :: Assignment ast grammar a -> String -> AssignmentF ast grammar a
   Fail :: String -> AssignmentF ast grammar a
 
-data Tracing f a where
-  Tracing :: { tracingCallSite :: Maybe (String, SrcLoc), runTracing :: f a } -> Tracing f a
-
-assignmentCallSite :: Assignment ast grammar a -> Maybe (String, SrcLoc)
-assignmentCallSite (Tracing site _ `Then` _) = site
-assignmentCallSite _ = Nothing
-
-tracing :: HasCallStack => f a -> Tracing f a
-tracing f = case getCallStack callStack of
-  (_ : site : _) -> Tracing (Just site) f
-  _ -> Tracing Nothing f
-
 -- | Zero-width production of the current location.
 --
 --   If assigning at the end of input or at the end of a list of children, the loccation will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node.
-location :: HasCallStack => Assignment ast grammar (Record Location)
-location = tracing Location `Then` return
+location :: Assignment ast grammar (Record Location)
+location = Location `Then` return
 
 -- | Zero-width production of the current node.
-currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ())
-currentNode = tracing CurrentNode `Then` return
+currentNode :: Assignment ast grammar (TermF ast (Node grammar) ())
+currentNode = CurrentNode `Then` return
 
 -- | Zero-width match of a node with the given symbol, producing the current node’s location.
-symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
-symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` return
+symbol :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar (Record Location)
+symbol s = Choose (Table.singleton s location) Nothing Nothing `Then` return
 
 -- | A rule to produce a node’s source as a ByteString.
-source :: HasCallStack => Assignment ast grammar ByteString
-source = tracing Source `Then` return
+source :: Assignment ast grammar ByteString
+source = Source `Then` return
 
 -- | Match a node by applying an assignment to its children.
-children :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a
-children child = tracing (Children child) `Then` return
+children :: Assignment ast grammar a -> Assignment ast grammar a
+children child = Children child `Then` return
 
 -- | Advance past the current node.
-advance :: HasCallStack => Assignment ast grammar ()
+advance :: Assignment ast grammar ()
 advance = () <$ source
 
 -- | Construct a committed choice table from a list of alternatives. Use this to efficiently select between long lists of rules.
-choice :: (Enum grammar, Eq1 ast, Ix grammar, HasCallStack) => [Assignment ast grammar a] -> Assignment ast grammar a
+choice :: (Enum grammar, Eq1 ast, Ix grammar) => [Assignment ast grammar a] -> Assignment ast grammar a
 choice [] = empty
 choice alternatives
   | null choices = asum alternatives
-  | otherwise    = tracing (Choose (Table.fromListWith (<|>) choices) (wrap . tracing . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers)) `Then` return
+  | otherwise    = Choose (Table.fromListWith (<|>) choices) (wrap . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers) `Then` return
   where (choices, atEnd, handlers) = foldMap toChoices alternatives
         toChoices :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> ([(grammar, Assignment ast grammar a)], [Assignment ast grammar a], [Error (Either String grammar) -> Assignment ast grammar a])
         toChoices rule = case rule of
-          Tracing _ (Choose t a h) `Then` continue -> (Table.toList (fmap (>>= continue) t), toList ((>>= continue) <$> a), toList ((continue <=<) <$> h))
-          Tracing _ (Many  child)   `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
-          Tracing _ (Label child _) `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
-          Tracing _ (Alt as) `Then` continue -> foldMap (toChoices . continue) as
+          Choose t a h `Then` continue -> (Table.toList (fmap (>>= continue) t), toList ((>>= continue) <$> a), toList ((continue <=<) <$> h))
+          Many  child   `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
+          Label child _ `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
+          Alt as `Then` continue -> foldMap (toChoices . continue) as
           _ -> ([], [rule], [])
 
         mergeHandlers [] = Nothing
         mergeHandlers hs = Just (\ err -> asum (hs <*> [err]))
 
 -- | Match and advance past a node with the given symbol.
-token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
+token :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar (Record Location)
 token s = symbol s <* advance
 
 
 -- | Collect a list of values passing a predicate.
-while :: (Alternative m, Monad m, HasCallStack) => (a -> Bool) -> m a -> m [a]
+while :: (Alternative m, Monad m) => (a -> Bool) -> m a -> m [a]
 while predicate step = many $ do
   result <- step
   guard (predicate result)
   pure result
 
 -- | Collect a list of values failing a predicate.
-until :: (Alternative m, Monad m, HasCallStack) => (a -> Bool) -> m a -> m [a]
+until :: (Alternative m, Monad m) => (a -> Bool) -> m a -> m [a]
 until = while . (not .)
 
 -- | Match the first operand until the second operand matches, returning both results. Like 'manyTill', but returning the terminal value.
-manyThrough :: (Alternative m, HasCallStack) => m a -> m b -> m ([a], b)
+manyThrough :: Alternative m => m a -> m b -> m ([a], b)
 manyThrough step stop = go
   where go = (,) [] <$> stop <|> first . (:) <$> step <*> go
 
@@ -231,12 +218,12 @@ data Node grammar = Node
 nodeLocation :: Node grammar -> Record Location
 nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil
 
-nodeError :: HasCallStack => [Either String grammar] -> Node grammar -> Error (Either String grammar)
+nodeError :: [Either String grammar] -> Node grammar -> Error (Either String grammar)
 nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol))
 
 
 firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
-firstSet = iterFreer (\ (Tracing _ assignment) _ -> case assignment of
+firstSet = iterFreer (\ assignment _ -> case assignment of
   Choose table _ _ -> Table.tableAddresses table
   Label child _ -> firstSet child
   _ -> []) . ([] <$)
@@ -257,29 +244,29 @@ runAssignment :: forall grammar a ast. (Enum grammar, Ix grammar, Symbol grammar
               -> Assignment ast grammar a                                      -- ^ The 'Assignment' to run.
               -> State ast grammar                                             -- ^ The current state.
               -> Either (Error (Either String grammar)) (a, State ast grammar) -- ^ 'Either' an 'Error' or an assigned value & updated state.
-runAssignment source = \ assignment state -> go assignment state >>= requireExhaustive (assignmentCallSite assignment)
+runAssignment source = \ assignment state -> go assignment state >>= requireExhaustive
   -- Note: We explicitly bind source above in order to ensure that the where clause can close over them; they don’t change through the course of the run, so holding one reference is sufficient. On the other hand, we don’t want to accidentally capture the assignment and state in the where clause, since they change at every step—and capturing when you meant to shadow is an easy mistake to make, & results in hard-to-debug errors. Binding them in a lambda avoids that problem while also being easier to follow than a pointfree definition.
   where go :: Assignment ast grammar result -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar)
         go assignment = iterFreer run ((pure .) . (,) <$> assignment)
         {-# INLINE go #-}
 
-        run :: Tracing (AssignmentF ast grammar) x
+        run :: AssignmentF ast grammar x
             -> (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar))
             -> State ast grammar
             -> Either (Error (Either String grammar)) (result, State ast grammar)
         run t yield initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
-          where atNode (Term (In node f)) = case runTracing t of
+          where atNode (Term (In node f)) = case t of
                   Location -> yield (nodeLocation node) state
                   CurrentNode -> yield (In node (() <$ f)) state
                   Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
                   Children child -> do
-                    (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t)
-                    yield a (advanceState state' { stateNodes = stateNodes, stateCallSites = stateCallSites })
+                    (a, state') <- go child state { stateNodes = toList f } >>= requireExhaustive
+                    yield a (advanceState state' { stateNodes = stateNodes })
                   Choose choices _ handler | Just choice <- Table.lookup (nodeSymbol node) choices -> (go choice state `catchError` (maybe throwError (flip go state .) handler)) >>= uncurry yield
                   _ -> anywhere (Just node)
 
-                anywhere node = case runTracing t of
-                  End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield
+                anywhere node = case t of
+                  End -> requireExhaustive ((), state) >>= uncurry yield
                   Location -> yield (Info.Range stateOffset stateOffset :. Info.Span statePos statePos :. Nil) state
                   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)
@@ -288,19 +275,16 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
                   Choose _ (Just atEnd) _ | Nothing <- node -> go atEnd state >>= uncurry yield
                   _ -> Left (makeError node)
 
-                state@State{..} = case (runTracing t, initialState) of
+                state@State{..} = case (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 (Info.Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
+                makeError = maybe (Error (Info.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
+requireExhaustive :: Symbol grammar => (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar)
+requireExhaustive (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 action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action
+  Term (In node _) : _ -> Left (nodeError [] node)
 
 skipTokens :: Symbol grammar => State ast grammar -> State ast grammar
 skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation . unTerm) (stateNodes state) }
@@ -308,22 +292,21 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
 -- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
 advanceState :: State ast grammar -> State ast grammar
 advanceState state@State{..}
-  | Term (In Node{..} _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest
+  | Term (In Node{..} _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) rest
   | otherwise = state
 
 -- | State kept while running 'Assignment's.
 data State ast grammar = State
-  { stateOffset :: {-# UNPACK #-} !Int    -- ^ The offset into the Source thus far reached, measured in bytes.
-  , statePos :: {-# UNPACK #-} !Info.Pos  -- ^ The (1-indexed) line/column position in the Source thus far reached.
-  , stateCallSites :: ![(String, SrcLoc)] -- ^ The symbols & source locations of the calls thus far.
-  , stateNodes :: ![AST ast grammar]      -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
+  { stateOffset :: {-# UNPACK #-} !Int   -- ^ The offset into the Source thus far reached, measured in bytes.
+  , statePos :: {-# UNPACK #-} !Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached.
+  , stateNodes :: ![AST ast grammar]     -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
   }
 
 deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar)
 deriving instance (Show grammar, Show1 ast) => Show (State ast grammar)
 
 makeState :: [AST ast grammar] -> State ast grammar
-makeState = State 0 (Info.Pos 1 1) []
+makeState = State 0 (Info.Pos 1 1)
 
 
 -- Instances
@@ -336,15 +319,14 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Monoid (Assignment ast grammar a
   mappend = (<|>)
 
 instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
-  empty :: HasCallStack => Assignment ast grammar a
-  empty = tracing (Alt []) `Then` return
+  empty = Alt [] `Then` return
 
-  (<|>) :: forall a. HasCallStack => Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a
+  (<|>) :: forall a. Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a
   Return a <|> _ = Return a
-  l@(Tracing cs _ `Then` _) <|> r@Return{} = Tracing cs (Alt [l, r]) `Then` id
-  l@(Tracing callSiteL la `Then` continueL) <|> r@(Tracing callSiteR ra `Then` continueR) = go callSiteL la continueL callSiteR ra continueR
-    where go :: forall l r . Maybe (String, SrcLoc) -> AssignmentF ast grammar l -> (l -> Assignment ast grammar a) -> Maybe (String, SrcLoc) -> AssignmentF ast grammar r -> (r -> Assignment ast grammar a) -> Assignment ast grammar a
-          go callSiteL la continueL callSiteR ra continueR = case (la, ra) of
+  l <|> r@Return{} = Alt [l, r] `Then` id
+  l@(la `Then` continueL) <|> r@(ra `Then` continueR) = go la continueL ra continueR
+    where go :: forall l r . AssignmentF ast grammar l -> (l -> Assignment ast grammar a) -> AssignmentF ast grammar r -> (r -> Assignment ast grammar a) -> Assignment ast grammar a
+          go la continueL ra continueR = case (la, ra) of
             (Fail _, _) -> r
             (Alt [], _) -> r
             (_, Alt []) -> l
@@ -355,43 +337,31 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast gram
             where alternate :: AssignmentF ast grammar (Either l r) -> Assignment ast grammar a
                   alternate a = rebuild a (either continueL continueR)
                   rebuild :: AssignmentF ast grammar x -> (x -> Assignment ast grammar a) -> Assignment ast grammar a
-                  rebuild a c = Tracing (callSiteL <|> callSiteR) a `Then` c
+                  rebuild a c = a `Then` c
 
-  many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a]
-  many a = tracing (Many a) `Then` return
+  many a = Many a `Then` return
 
 instance MonadFail (Assignment ast grammar) where
-  fail :: HasCallStack => String -> Assignment ast grammar a
-  fail s = tracing (Fail s) `Then` return
+  fail s = Fail s `Then` return
 
 instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar, Show1 ast) => Parsing (Assignment ast grammar) where
-  try :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a
   try = id
 
-  (<?>) :: HasCallStack => Assignment ast grammar a -> String -> Assignment ast grammar a
-  a <?> s = tracing (Label a s) `Then` return
+  a <?> s = Label a s `Then` return
 
-  unexpected :: HasCallStack => String -> Assignment ast grammar a
   unexpected = fail
 
-  eof :: HasCallStack => Assignment ast grammar ()
-  eof = tracing End `Then` return
+  eof = End `Then` return
 
-  notFollowedBy :: (HasCallStack, Show a) => Assignment ast grammar a -> Assignment ast grammar ()
   notFollowedBy a = a *> unexpected (show a) <|> pure ()
 
 instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error (Either String grammar)) (Assignment ast grammar) where
-  throwError :: HasCallStack => Error (Either String grammar) -> Assignment ast grammar a
   throwError err = fail (show err)
 
-  catchError :: HasCallStack => Assignment ast grammar a -> (Error (Either String grammar) -> Assignment ast grammar a) -> Assignment ast grammar a
-  catchError rule handler = iterFreer (\ (Tracing cs assignment) continue -> case assignment of
-    Choose choices atEnd Nothing -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler)) `Then` return
-    Choose choices atEnd (Just onError) -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err))) `Then` return
-    _ -> Tracing cs assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule)
-
-instance Show1 f => Show1 (Tracing f) where
-  liftShowsPrec sp sl d = liftShowsPrec sp sl d . runTracing
+  catchError rule handler = iterFreer (\ assignment continue -> case assignment of
+    Choose choices atEnd Nothing -> Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler) `Then` return
+    Choose choices atEnd (Just onError) -> Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err)) `Then` return
+    _ -> assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule)
 
 instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (AssignmentF ast grammar) where
   liftShowsPrec sp sl d a = case a of

From e95f35e45e9062b0f991f4f2bb2a463013a6c168 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 10:03:42 -0400
Subject: [PATCH 4/8] Fix the :memo: for syntaxParserForLanguage.

---
 src/Parser.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Parser.hs b/src/Parser.hs
index a0ebe2b3f..099163982 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -86,7 +86,7 @@ someParser _ Python     = Just (SomeParser pythonParser)
 someParser _ Ruby       = Just (SomeParser rubyParser)
 someParser _ TypeScript = Just (SomeParser typescriptParser)
 
--- | Return a 'Language'-specific 'Parser', if one exists, falling back to the 'LineByLineParser'.
+-- | Return a 'Language'-specific 'Parser', if one exists.
 syntaxParserForLanguage :: Language -> Maybe (Parser (Term Syntax (Record DefaultFields)))
 syntaxParserForLanguage language = case language of
   Go         -> Just (TreeSitterParser tree_sitter_go)

From ebef3a82a10ad43b1982db3f8810c20f2de34f1b Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 11:30:15 -0400
Subject: [PATCH 5/8] =?UTF-8?q?Revert=20"Don=E2=80=99t=20propagate=20call?=
 =?UTF-8?q?=20stacks."?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This reverts commit 263d5e97ab579c36cfc22d7dae428675c0b1e4b5.
---
 src/Data/Syntax/Assignment.hs | 142 ++++++++++++++++++++--------------
 1 file changed, 86 insertions(+), 56 deletions(-)

diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs
index 00d739cef..38d6bf205 100644
--- a/src/Data/Syntax/Assignment.hs
+++ b/src/Data/Syntax/Assignment.hs
@@ -114,6 +114,7 @@ import Data.Semigroup
 import qualified Data.Source as Source (Source, slice, sourceBytes)
 import qualified Data.Syntax.Assignment.Table as Table
 import Data.Term
+import GHC.Stack
 import qualified Info
 import Prelude hiding (fail, until)
 import Text.Parser.Combinators as Parsers hiding (choice)
@@ -122,7 +123,7 @@ import TreeSitter.Language
 -- | Assignment from an AST with some set of 'symbol's onto some other value.
 --
 --   This is essentially a parser.
-type Assignment ast grammar = Freer (AssignmentF ast grammar)
+type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar))
 
 data AssignmentF ast grammar a where
   End :: AssignmentF ast grammar ()
@@ -136,68 +137,80 @@ data AssignmentF ast grammar a where
   Label :: Assignment ast grammar a -> String -> AssignmentF ast grammar a
   Fail :: String -> AssignmentF ast grammar a
 
+data Tracing f a where
+  Tracing :: { tracingCallSite :: Maybe (String, SrcLoc), runTracing :: f a } -> Tracing f a
+
+assignmentCallSite :: Assignment ast grammar a -> Maybe (String, SrcLoc)
+assignmentCallSite (Tracing site _ `Then` _) = site
+assignmentCallSite _ = Nothing
+
+tracing :: HasCallStack => f a -> Tracing f a
+tracing f = case getCallStack callStack of
+  (_ : site : _) -> Tracing (Just site) f
+  _ -> Tracing Nothing f
+
 -- | Zero-width production of the current location.
 --
 --   If assigning at the end of input or at the end of a list of children, the loccation will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node.
-location :: Assignment ast grammar (Record Location)
-location = Location `Then` return
+location :: HasCallStack => Assignment ast grammar (Record Location)
+location = tracing Location `Then` return
 
 -- | Zero-width production of the current node.
-currentNode :: Assignment ast grammar (TermF ast (Node grammar) ())
-currentNode = CurrentNode `Then` return
+currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ())
+currentNode = tracing CurrentNode `Then` return
 
 -- | Zero-width match of a node with the given symbol, producing the current node’s location.
-symbol :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar (Record Location)
-symbol s = Choose (Table.singleton s location) Nothing Nothing `Then` return
+symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
+symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` return
 
 -- | A rule to produce a node’s source as a ByteString.
-source :: Assignment ast grammar ByteString
-source = Source `Then` return
+source :: HasCallStack => Assignment ast grammar ByteString
+source = tracing Source `Then` return
 
 -- | Match a node by applying an assignment to its children.
-children :: Assignment ast grammar a -> Assignment ast grammar a
-children child = Children child `Then` return
+children :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a
+children child = tracing (Children child) `Then` return
 
 -- | Advance past the current node.
-advance :: Assignment ast grammar ()
+advance :: HasCallStack => Assignment ast grammar ()
 advance = () <$ source
 
 -- | Construct a committed choice table from a list of alternatives. Use this to efficiently select between long lists of rules.
-choice :: (Enum grammar, Eq1 ast, Ix grammar) => [Assignment ast grammar a] -> Assignment ast grammar a
+choice :: (Enum grammar, Eq1 ast, Ix grammar, HasCallStack) => [Assignment ast grammar a] -> Assignment ast grammar a
 choice [] = empty
 choice alternatives
   | null choices = asum alternatives
-  | otherwise    = Choose (Table.fromListWith (<|>) choices) (wrap . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers) `Then` return
+  | otherwise    = tracing (Choose (Table.fromListWith (<|>) choices) (wrap . tracing . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers)) `Then` return
   where (choices, atEnd, handlers) = foldMap toChoices alternatives
         toChoices :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> ([(grammar, Assignment ast grammar a)], [Assignment ast grammar a], [Error (Either String grammar) -> Assignment ast grammar a])
         toChoices rule = case rule of
-          Choose t a h `Then` continue -> (Table.toList (fmap (>>= continue) t), toList ((>>= continue) <$> a), toList ((continue <=<) <$> h))
-          Many  child   `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
-          Label child _ `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
-          Alt as `Then` continue -> foldMap (toChoices . continue) as
+          Tracing _ (Choose t a h) `Then` continue -> (Table.toList (fmap (>>= continue) t), toList ((>>= continue) <$> a), toList ((continue <=<) <$> h))
+          Tracing _ (Many  child)   `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
+          Tracing _ (Label child _) `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], [])
+          Tracing _ (Alt as) `Then` continue -> foldMap (toChoices . continue) as
           _ -> ([], [rule], [])
 
         mergeHandlers [] = Nothing
         mergeHandlers hs = Just (\ err -> asum (hs <*> [err]))
 
 -- | Match and advance past a node with the given symbol.
-token :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar (Record Location)
+token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
 token s = symbol s <* advance
 
 
 -- | Collect a list of values passing a predicate.
-while :: (Alternative m, Monad m) => (a -> Bool) -> m a -> m [a]
+while :: (Alternative m, Monad m, HasCallStack) => (a -> Bool) -> m a -> m [a]
 while predicate step = many $ do
   result <- step
   guard (predicate result)
   pure result
 
 -- | Collect a list of values failing a predicate.
-until :: (Alternative m, Monad m) => (a -> Bool) -> m a -> m [a]
+until :: (Alternative m, Monad m, HasCallStack) => (a -> Bool) -> m a -> m [a]
 until = while . (not .)
 
 -- | Match the first operand until the second operand matches, returning both results. Like 'manyTill', but returning the terminal value.
-manyThrough :: Alternative m => m a -> m b -> m ([a], b)
+manyThrough :: (Alternative m, HasCallStack) => m a -> m b -> m ([a], b)
 manyThrough step stop = go
   where go = (,) [] <$> stop <|> first . (:) <$> step <*> go
 
@@ -218,12 +231,12 @@ data Node grammar = Node
 nodeLocation :: Node grammar -> Record Location
 nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil
 
-nodeError :: [Either String grammar] -> Node grammar -> Error (Either String grammar)
+nodeError :: HasCallStack => [Either String grammar] -> Node grammar -> Error (Either String grammar)
 nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol))
 
 
 firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
-firstSet = iterFreer (\ assignment _ -> case assignment of
+firstSet = iterFreer (\ (Tracing _ assignment) _ -> case assignment of
   Choose table _ _ -> Table.tableAddresses table
   Label child _ -> firstSet child
   _ -> []) . ([] <$)
@@ -244,29 +257,29 @@ runAssignment :: forall grammar a ast. (Enum grammar, Ix grammar, Symbol grammar
               -> Assignment ast grammar a                                      -- ^ The 'Assignment' to run.
               -> State ast grammar                                             -- ^ The current state.
               -> Either (Error (Either String grammar)) (a, State ast grammar) -- ^ 'Either' an 'Error' or an assigned value & updated state.
-runAssignment source = \ assignment state -> go assignment state >>= requireExhaustive
+runAssignment source = \ assignment state -> go assignment state >>= requireExhaustive (assignmentCallSite assignment)
   -- Note: We explicitly bind source above in order to ensure that the where clause can close over them; they don’t change through the course of the run, so holding one reference is sufficient. On the other hand, we don’t want to accidentally capture the assignment and state in the where clause, since they change at every step—and capturing when you meant to shadow is an easy mistake to make, & results in hard-to-debug errors. Binding them in a lambda avoids that problem while also being easier to follow than a pointfree definition.
   where go :: Assignment ast grammar result -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar)
         go assignment = iterFreer run ((pure .) . (,) <$> assignment)
         {-# INLINE go #-}
 
-        run :: AssignmentF ast grammar x
+        run :: Tracing (AssignmentF ast grammar) x
             -> (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar))
             -> State ast grammar
             -> Either (Error (Either String grammar)) (result, State ast grammar)
         run t yield initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
-          where atNode (Term (In node f)) = case t of
+          where atNode (Term (In node f)) = case runTracing t of
                   Location -> yield (nodeLocation node) state
                   CurrentNode -> yield (In node (() <$ f)) state
                   Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
                   Children child -> do
-                    (a, state') <- go child state { stateNodes = toList f } >>= requireExhaustive
-                    yield a (advanceState state' { stateNodes = stateNodes })
+                    (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t)
+                    yield a (advanceState state' { stateNodes = stateNodes, stateCallSites = stateCallSites })
                   Choose choices _ handler | Just choice <- Table.lookup (nodeSymbol node) choices -> (go choice state `catchError` (maybe throwError (flip go state .) handler)) >>= uncurry yield
                   _ -> anywhere (Just node)
 
-                anywhere node = case t of
-                  End -> requireExhaustive ((), state) >>= uncurry yield
+                anywhere node = case runTracing t of
+                  End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield
                   Location -> yield (Info.Range stateOffset stateOffset :. Info.Span statePos statePos :. Nil) state
                   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)
@@ -275,16 +288,19 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
                   Choose _ (Just atEnd) _ | Nothing <- node -> go atEnd state >>= uncurry yield
                   _ -> Left (makeError node)
 
-                state@State{..} = case (t, initialState) of
+                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 = maybe (Error (Info.Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
+                makeError = withStateCallStack (tracingCallSite t) state $ maybe (Error (Info.Span statePos statePos) (fmap Right expectedSymbols) Nothing) (nodeError (fmap Right expectedSymbols))
 
-requireExhaustive :: Symbol grammar => (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar)
-requireExhaustive (a, state) = let state' = skipTokens state in case stateNodes state' of
+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 (nodeError [] node)
+  Term (In node _) : _ -> Left (withStateCallStack callSite state (nodeError [] node))
+
+withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a
+withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action
 
 skipTokens :: Symbol grammar => State ast grammar -> State ast grammar
 skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation . unTerm) (stateNodes state) }
@@ -292,21 +308,22 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
 -- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
 advanceState :: State ast grammar -> State ast grammar
 advanceState state@State{..}
-  | Term (In Node{..} _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) rest
+  | Term (In Node{..} _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest
   | otherwise = state
 
 -- | State kept while running 'Assignment's.
 data State ast grammar = State
-  { stateOffset :: {-# UNPACK #-} !Int   -- ^ The offset into the Source thus far reached, measured in bytes.
-  , statePos :: {-# UNPACK #-} !Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached.
-  , stateNodes :: ![AST ast grammar]     -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
+  { stateOffset :: {-# UNPACK #-} !Int    -- ^ The offset into the Source thus far reached, measured in bytes.
+  , statePos :: {-# UNPACK #-} !Info.Pos  -- ^ The (1-indexed) line/column position in the Source thus far reached.
+  , stateCallSites :: ![(String, SrcLoc)] -- ^ The symbols & source locations of the calls thus far.
+  , stateNodes :: ![AST ast grammar]      -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
   }
 
 deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar)
 deriving instance (Show grammar, Show1 ast) => Show (State ast grammar)
 
 makeState :: [AST ast grammar] -> State ast grammar
-makeState = State 0 (Info.Pos 1 1)
+makeState = State 0 (Info.Pos 1 1) []
 
 
 -- Instances
@@ -319,14 +336,15 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Monoid (Assignment ast grammar a
   mappend = (<|>)
 
 instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
-  empty = Alt [] `Then` return
+  empty :: HasCallStack => Assignment ast grammar a
+  empty = tracing (Alt []) `Then` return
 
-  (<|>) :: forall a. Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a
+  (<|>) :: forall a. HasCallStack => Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a
   Return a <|> _ = Return a
-  l <|> r@Return{} = Alt [l, r] `Then` id
-  l@(la `Then` continueL) <|> r@(ra `Then` continueR) = go la continueL ra continueR
-    where go :: forall l r . AssignmentF ast grammar l -> (l -> Assignment ast grammar a) -> AssignmentF ast grammar r -> (r -> Assignment ast grammar a) -> Assignment ast grammar a
-          go la continueL ra continueR = case (la, ra) of
+  l@(Tracing cs _ `Then` _) <|> r@Return{} = Tracing cs (Alt [l, r]) `Then` id
+  l@(Tracing callSiteL la `Then` continueL) <|> r@(Tracing callSiteR ra `Then` continueR) = go callSiteL la continueL callSiteR ra continueR
+    where go :: forall l r . Maybe (String, SrcLoc) -> AssignmentF ast grammar l -> (l -> Assignment ast grammar a) -> Maybe (String, SrcLoc) -> AssignmentF ast grammar r -> (r -> Assignment ast grammar a) -> Assignment ast grammar a
+          go callSiteL la continueL callSiteR ra continueR = case (la, ra) of
             (Fail _, _) -> r
             (Alt [], _) -> r
             (_, Alt []) -> l
@@ -337,31 +355,43 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast gram
             where alternate :: AssignmentF ast grammar (Either l r) -> Assignment ast grammar a
                   alternate a = rebuild a (either continueL continueR)
                   rebuild :: AssignmentF ast grammar x -> (x -> Assignment ast grammar a) -> Assignment ast grammar a
-                  rebuild a c = a `Then` c
+                  rebuild a c = Tracing (callSiteL <|> callSiteR) a `Then` c
 
-  many a = Many a `Then` return
+  many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a]
+  many a = tracing (Many a) `Then` return
 
 instance MonadFail (Assignment ast grammar) where
-  fail s = Fail s `Then` return
+  fail :: HasCallStack => String -> Assignment ast grammar a
+  fail s = tracing (Fail s) `Then` return
 
 instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar, Show1 ast) => Parsing (Assignment ast grammar) where
+  try :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a
   try = id
 
-  a <?> s = Label a s `Then` return
+  (<?>) :: HasCallStack => Assignment ast grammar a -> String -> Assignment ast grammar a
+  a <?> s = tracing (Label a s) `Then` return
 
+  unexpected :: HasCallStack => String -> Assignment ast grammar a
   unexpected = fail
 
-  eof = End `Then` return
+  eof :: HasCallStack => Assignment ast grammar ()
+  eof = tracing End `Then` return
 
+  notFollowedBy :: (HasCallStack, Show a) => Assignment ast grammar a -> Assignment ast grammar ()
   notFollowedBy a = a *> unexpected (show a) <|> pure ()
 
 instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error (Either String grammar)) (Assignment ast grammar) where
+  throwError :: HasCallStack => Error (Either String grammar) -> Assignment ast grammar a
   throwError err = fail (show err)
 
-  catchError rule handler = iterFreer (\ assignment continue -> case assignment of
-    Choose choices atEnd Nothing -> Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler) `Then` return
-    Choose choices atEnd (Just onError) -> Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err)) `Then` return
-    _ -> assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule)
+  catchError :: HasCallStack => Assignment ast grammar a -> (Error (Either String grammar) -> Assignment ast grammar a) -> Assignment ast grammar a
+  catchError rule handler = iterFreer (\ (Tracing cs assignment) continue -> case assignment of
+    Choose choices atEnd Nothing -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler)) `Then` return
+    Choose choices atEnd (Just onError) -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err))) `Then` return
+    _ -> Tracing cs assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule)
+
+instance Show1 f => Show1 (Tracing f) where
+  liftShowsPrec sp sl d = liftShowsPrec sp sl d . runTracing
 
 instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (AssignmentF ast grammar) where
   liftShowsPrec sp sl d a = case a of

From 0f75f7d817a3e2ec036fcd0b76fe829351d336a0 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 11:30:19 -0400
Subject: [PATCH 6/8] =?UTF-8?q?Revert=20"Don=E2=80=99t=20build=20call=20st?=
 =?UTF-8?q?acks."?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This reverts commit cba54ef4b0915297a7e8805801ea17136e3f8bbe.
---
 src/Data/Syntax.hs                    | 22 +++++++++++-----------
 src/Language/JSON/Assignment.hs       |  3 ++-
 src/Language/Markdown/Assignment.hs   |  3 ++-
 src/Language/Python/Assignment.hs     |  6 ++++--
 src/Language/Ruby/Assignment.hs       |  6 ++++--
 src/Language/TypeScript/Assignment.hs | 14 ++++++++------
 6 files changed, 31 insertions(+), 23 deletions(-)

diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs
index f243053cd..325736b6d 100644
--- a/src/Data/Syntax.hs
+++ b/src/Data/Syntax.hs
@@ -28,39 +28,39 @@ import GHC.Stack
 -- Combinators
 
 -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
-makeTerm :: (f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
 makeTerm a = makeTerm' a . inj
 
 -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
-makeTerm' :: (Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
+makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
 makeTerm' a f = termIn (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f
 
 -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
-makeTerm1 :: (f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
 makeTerm1 = makeTerm1' . inj
 
 -- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
-makeTerm1' :: (Semigroup a, Foldable f) => f (Term f a) -> Term f a
+makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
 makeTerm1' f = case toList f of
   a : _ -> makeTerm' (termAnnotation (unTerm a)) f
   _ -> error "makeTerm1': empty structure"
 
 -- | Construct an empty term at the current position.
-emptyTerm :: (Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
+emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
 emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
   where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil
 
 -- | Catch assignment errors into an error term.
-handleError :: (Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
+handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
 handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
 
 -- | Catch parse errors into an error term.
-parseError :: (Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
+parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
 parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack (getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
 
 
 -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
-contextualize :: (Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
+contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
               => m (Term (Union fs) a)
               -> m (Term (Union fs) a)
               -> m (Term (Union fs) a)
@@ -70,7 +70,7 @@ contextualize context rule = make <$> Assignment.manyThrough context rule
           _ -> node
 
 -- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
-postContextualizeThrough :: (Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
+postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
                          => m (Term (Union fs) a)
                          -> m (Term (Union fs) a)
                          -> m b
@@ -81,7 +81,7 @@ postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThr
           _ -> (node, end)
 
 -- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
-postContextualize :: (Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
+postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
                   => m (Term (Union fs) a)
                   -> m (Term (Union fs) a)
                   -> m (Term (Union fs) a)
@@ -91,7 +91,7 @@ postContextualize context rule = make <$> rule <*> many context
           _ -> node
 
 -- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
-infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, Apply Foldable fs)
+infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs)
              => m (Term (Union fs) a)
              -> m (Term (Union fs) a)
              -> m (Term (Union fs) a)
diff --git a/src/Language/JSON/Assignment.hs b/src/Language/JSON/Assignment.hs
index d10ad35db..2ab025fa7 100644
--- a/src/Language/JSON/Assignment.hs
+++ b/src/Language/JSON/Assignment.hs
@@ -14,6 +14,7 @@ import qualified Data.Syntax.Assignment as Assignment
 import qualified Data.Syntax.Literal as Literal
 import qualified Data.Term as Term
 import Data.Union
+import GHC.Stack
 import Language.JSON.Grammar as Grammar
 
 type Syntax =
@@ -30,7 +31,7 @@ type Syntax =
   ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = Assignment.Assignment [] Grammar Term
+type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
 
 
 assignment :: Assignment
diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs
index 6a724d3e7..49038f408 100644
--- a/src/Language/Markdown/Assignment.hs
+++ b/src/Language/Markdown/Assignment.hs
@@ -18,6 +18,7 @@ import Data.Term as Term (Term(..), TermF(..), termIn, unwrap)
 import qualified Data.Text as Text
 import Data.Text.Encoding (encodeUtf8)
 import Data.Union
+import GHC.Stack
 import Language.Markdown as Grammar (Grammar(..))
 import qualified Language.Markdown.Syntax as Markup
 
@@ -50,7 +51,7 @@ type Syntax =
    ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Language.Markdown.Assignment.Term
+type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Language.Markdown.Assignment.Term
 
 
 assignment :: Assignment
diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs
index 0bcdca569..d9211284a 100644
--- a/src/Language/Python/Assignment.hs
+++ b/src/Language/Python/Assignment.hs
@@ -22,6 +22,7 @@ import qualified Data.Syntax.Statement as Statement
 import qualified Data.Syntax.Type as Type
 import qualified Data.Term as Term
 import Data.Union
+import GHC.Stack
 import Language.Python.Syntax as Python.Syntax
 import Language.Python.Grammar as Grammar
 
@@ -80,7 +81,7 @@ type Syntax =
    ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = Assignment.Assignment [] Grammar Term
+type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
 
 -- | Assignment from AST in Python's grammar onto a program in Python's syntax.
 assignment :: Assignment
@@ -472,7 +473,8 @@ manyTermsTill :: Show b => Assignment.Assignment [] Grammar Term -> Assignment.A
 manyTermsTill step end = manyTill (step <|> comment) end
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.
-infixTerm :: Assignment
+infixTerm :: HasCallStack
+          => Assignment
           -> Assignment
           -> [Assignment.Assignment [] Grammar (Term -> Term -> Union Syntax Term)]
           -> Assignment.Assignment [] Grammar (Union Syntax Term)
diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs
index 7efb02b4d..6da9ab629 100644
--- a/src/Language/Ruby/Assignment.hs
+++ b/src/Language/Ruby/Assignment.hs
@@ -21,6 +21,7 @@ import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
 import qualified Data.Term as Term
 import Data.Union
+import GHC.Stack
 import Language.Ruby.Grammar as Grammar
 
 -- | The type of Ruby syntax.
@@ -78,7 +79,7 @@ type Syntax = '[
   ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = Assignment.Assignment [] Grammar Term
+type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
 
 -- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax.
 assignment :: Assignment
@@ -406,7 +407,8 @@ manyTermsTill :: Show b => Assignment.Assignment [] Grammar Term -> Assignment.A
 manyTermsTill step end = manyTill (step <|> comment) end
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.
-infixTerm :: Assignment
+infixTerm :: HasCallStack
+          => Assignment
           -> Assignment
           -> [Assignment.Assignment [] Grammar (Term -> Term -> Union Syntax Term)]
           -> Assignment.Assignment [] Grammar (Union Syntax Term)
diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs
index 39a194e99..b8182090b 100644
--- a/src/Language/TypeScript/Assignment.hs
+++ b/src/Language/TypeScript/Assignment.hs
@@ -20,6 +20,7 @@ import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
 import qualified Data.Syntax.Type as Type
 import Data.Union
+import GHC.Stack
 import Language.TypeScript.Grammar as Grammar
 import qualified Language.TypeScript.Syntax as TypeScript.Syntax
 import qualified Data.Term as Term
@@ -281,7 +282,7 @@ anonymousClass = makeTerm <$> symbol Grammar.AnonymousClass <*> children (Declar
 abstractClass :: Assignment
 abstractClass = makeTerm <$> symbol Grammar.AbstractClass <*> (TypeScript.Syntax.AbstractClass <$> identifier <*> (typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements)
 
-classHeritage' :: Assignment.Assignment [] Grammar [Term]
+classHeritage' :: HasCallStack => Assignment.Assignment [] Grammar [Term]
 classHeritage' = symbol Grammar.ClassHeritage *> children (((++) `on` toList) <$> optional extendsClause' <*> optional implementsClause')
 
 extendsClause' :: Assignment
@@ -388,7 +389,7 @@ methodDefinition = makeMethod <$>
   where
     makeMethod loc (modifier, readonly, receiver, propertyName', (typeParameters', params, ty'), statements) = makeTerm loc (Declaration.Method [modifier, readonly, typeParameters', ty'] receiver propertyName' params statements)
 
-callSignatureParts :: Assignment.Assignment [] Grammar (Term, [Term], Term)
+callSignatureParts :: HasCallStack => Assignment.Assignment [] Grammar (Term, [Term], Term)
 callSignatureParts =  symbol Grammar.CallSignature *> children ((,,) <$> (fromMaybe <$> emptyTerm <*> optional typeParameters) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional typeAnnotation'))
 
 callSignature :: Assignment
@@ -404,7 +405,7 @@ methodSignature :: Assignment
 methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> children ((,,,) <$> (accessibilityModifier' <|> emptyTerm) <*> (readonly' <|> emptyTerm) <*> propertyName <*> callSignatureParts)
   where makeMethodSignature loc (modifier, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.MethodSignature [modifier, readonly, typeParams, annotation] propertyName params)
 
-formalParameters :: Assignment.Assignment [] Grammar [Term]
+formalParameters :: HasCallStack => Assignment.Assignment [] Grammar [Term]
 formalParameters = symbol FormalParameters *> children (concat <$> many ((\as b -> as ++ [b]) <$> many (term decorator) <*> term parameter))
 
 decorator :: Assignment
@@ -502,7 +503,7 @@ constructorTy = makeTerm <$> symbol ConstructorType <*> children (TypeScript.Syn
 statementBlock :: Assignment
 statementBlock = makeTerm <$> symbol StatementBlock <*> children (many statement)
 
-classBodyStatements :: Assignment.Assignment [] Grammar [Term]
+classBodyStatements :: HasCallStack => Assignment.Assignment [] Grammar [Term]
 classBodyStatements = symbol ClassBody *> children (concat <$> many ((\as b -> as ++ [b]) <$> many (term decorator) <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature)))
 
 publicFieldDefinition :: Assignment
@@ -670,7 +671,7 @@ module' :: Assignment
 module' = makeTerm <$> symbol Module <*> children (Declaration.Module <$> (string <|> identifier <|> nestedIdentifier) <*> ((symbol StatementBlock *> children (many statement)) <|> pure []))
 
 
-statements :: Assignment.Assignment [] Grammar [Term]
+statements :: HasCallStack => Assignment.Assignment [] Grammar [Term]
 statements = symbol StatementBlock *> children (many statement)
 
 arrowFunction :: Assignment
@@ -753,7 +754,8 @@ emptyStatement :: Assignment
 emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ source <|> pure Syntax.Empty)
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.
-infixTerm :: Assignment
+infixTerm :: HasCallStack
+          => Assignment
           -> Assignment
           -> [Assignment.Assignment [] Grammar (Term -> Term -> Data.Union.Union Syntax Term)]
           -> Assignment.Assignment [] Grammar (Data.Union.Union Syntax Term)

From ca7471039235708d4b0cdaa9c3fd0a2a44098fb7 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 11:30:27 -0400
Subject: [PATCH 7/8] Revert ":fire: the HasCallStack constraint in TypeScript
 assignment."

This reverts commit 886d14b1b83e9fea8655ffcce762ce594262a100.
---
 src/Language/TypeScript/Assignment.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs
index b8182090b..8b157585c 100644
--- a/src/Language/TypeScript/Assignment.hs
+++ b/src/Language/TypeScript/Assignment.hs
@@ -168,7 +168,7 @@ type Syntax = '[
   ]
 
 type Term = Term.Term (Data.Union.Union Syntax) (Record Location)
-type Assignment = Assignment.Assignment [] Grammar Term
+type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
 
 -- | Assignment from AST in Ruby’s grammar onto a program in TypeScript’s syntax.
 assignment :: Assignment

From b800d8c4779a1c0db252ff0f64dbcdc5dd4820fc Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Thu, 26 Oct 2017 11:33:42 -0400
Subject: [PATCH 8/8] Bump effects for faster-compiling membership constraints.

---
 vendor/effects | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vendor/effects b/vendor/effects
index a1351b26a..82de1945a 160000
--- a/vendor/effects
+++ b/vendor/effects
@@ -1 +1 @@
-Subproject commit a1351b26a557cec1f7a87d5f6563189329f4f450
+Subproject commit 82de1945a13e7c9b14c6eae00425869e6ba1efd2