Merge branch 'simpler-monolithic-syntax' into ghc-8.2.1

2024-12-25 07:55:12 +03:00 · 2017-07-24 11:29:36 -04:00 · 2017-07-24 11:29:36 -04:00 · f364dd4a0b
commit f364dd4a0b
parent 71ce485347 4b06647438
20 changed files with 425 additions and 309 deletions
--- a/semantic-diff.cabal
+++ b/semantic-diff.cabal
@ -110,9 +110,11 @@ library
                     , recursion-schemes
                     , semigroups
                     , split
+                     , stm-chans
                     , template-haskell
                     , text >= 1.2.1.3
                     , these
+                     , time
                     , haskell-tree-sitter
                     , c
                     , go
--- a/src/Data/Syntax/Assignment.hs
+++ b/src/Data/Syntax/Assignment.hs
@ -75,15 +75,18 @@ module Data.Syntax.Assignment
 , while
 -- Results
 , Error(..)
-, ErrorCause(..)
+, Options(..)
+, defaultOptions
+, optionsForHandle
 , printError
+, formatError
+, formatErrorWithOptions
 , withSGRCode
 -- Running
-, assign
 , assignBy
 , runAssignment
 -- Implementation details (for testing)
-, AssignmentState(..)
+, State(..)
 , makeState
 ) where

@ -97,9 +100,10 @@ import Data.Ix (inRange)
 import Data.List.NonEmpty (nonEmpty)
 import Data.Record
 import qualified Data.Source as Source (Source, fromBytes, slice, sourceBytes, sourceLines)
+import Data.String
 import GHC.Stack
 import qualified Info
-import Prologue hiding (Alt, get, hPutStr, Location, Symbol, state)
+import Prologue hiding (Alt, get, hPutStr, Location, State, Symbol, state)
 import System.Console.ANSI
 import Text.Parser.TreeSitter.Language
 import Text.Show hiding (show)
@ -172,50 +176,73 @@ nodeLocation :: Node grammar -> Record Location
 nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil


-data Error grammar where
-  Error
-    :: HasCallStack
-    => { errorPos :: Info.Pos
-       , errorCause :: ErrorCause grammar
-       } -> Error grammar
+data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: Maybe grammar }

 deriving instance Eq grammar => Eq (Error grammar)
 deriving instance Show grammar => Show (Error grammar)

-data ErrorCause grammar
-  = UnexpectedSymbol [grammar] grammar
-  | UnexpectedEndOfInput [grammar]
-  deriving (Eq, Show)
+nodeError :: [grammar] -> Node grammar -> Error grammar
+nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart expected (Just actual)

-- | Pretty-print an Error with reference to the source where it occurred.
+-- | Options for printing errors.
+data Options = Options
+  { optionsColour :: Bool -- ^ Whether to use colour formatting codes suitable for a terminal device.
+  , optionsIncludeSource :: Bool -- ^ Whether to include the source reference.
+  }
+
+defaultOptions :: Options
+defaultOptions = Options
+  { optionsColour = True
+  , optionsIncludeSource = True
+  }
+
+optionsForHandle :: Handle -> IO Options
+optionsForHandle handle = do
+  isTerminal <- hIsTerminalDevice handle
+  pure $ defaultOptions
+    { optionsColour = isTerminal
+    }
+
+-- | Pretty-print an 'Error' to stderr, optionally with reference to the source where it occurred.
 printError :: Show grammar => Blob -> Error grammar -> IO ()
-printError Blob{..} error@Error{..} = do
-  withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": "
-  withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n'
-  putStrErr $ showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ')
-  withSGRCode [SetColor Foreground Vivid Green] . putStrErr $ showChar '^' . showChar '\n'
-  putStrErr $ showString (prettyCallStack callStack) . showChar '\n'
+printError blob error = do
+  options <- optionsForHandle stderr
+  hPutStr stderr $ formatErrorWithOptions options blob error
+
+-- | Format an 'Error', optionally with reference to the source where it occurred.
+--
+-- > formatError = formatErrorWithOptions defaultOptions
+formatError :: Show grammar => Blob -> Error grammar -> String
+formatError = formatErrorWithOptions defaultOptions
+
+-- | Format an 'Error', optionally with reference to the source where it occurred.
+formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> String
+formatErrorWithOptions Options{..} Blob{..} Error{..}
+  = ($ "")
+  $ withSGRCode optionsColour [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ")
+  . withSGRCode optionsColour [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation errorExpected errorActual . showChar '\n')
+  . (if optionsIncludeSource
+    then showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n')
+       . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode optionsColour [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n')
+    else identity)
+  . showString (prettyCallStack callStack) . showChar '\n'
  where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ])
        showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
        lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double)))
-        putStrErr = hPutStr stderr . ($ "")

-withSGRCode :: [SGR] -> IO a -> IO ()
-withSGRCode code action = do
-  isTerm <- hIsTerminalDevice stderr
-  if isTerm then do
-    _ <- hSetSGR stderr code
-    _ <- action
-    hSetSGR stderr []
-  else do
-    _ <- action
-    pure ()
+withSGRCode :: Bool -> [SGR] -> ShowS -> ShowS
+withSGRCode useColour code content =
+  if useColour then
+    showString (setSGRCode code)
+    . content
+    . showString (setSGRCode [])
+  else
+    content

-showExpectation :: Show grammar => Error grammar -> ShowS
-showExpectation Error{..} = case errorCause of
-  UnexpectedEndOfInput [] -> showString "no rule to match at end of input nodes"
-  UnexpectedEndOfInput symbols -> showString "expected " . showSymbols symbols . showString " at end of input nodes"
-  UnexpectedSymbol symbols a -> showString "expected " . showSymbols symbols . showString ", but got " . shows a
+showExpectation :: Show grammar => [grammar] -> Maybe grammar -> ShowS
+showExpectation [] Nothing = showString "no rule to match at end of input nodes"
+showExpectation expected Nothing = showString "expected " . showSymbols expected . showString " at end of input nodes"
+showExpectation expected (Just actual) = showString "expected " . showSymbols expected . showString ", but got " . shows actual

 showSymbols :: Show grammar => [grammar] -> ShowS
 showSymbols [] = showString "end of input nodes"
@ -228,104 +255,90 @@ showPos :: Maybe FilePath -> Info.Pos -> ShowS
 showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . shows posLine . showChar ':' . shows posColumn

 -- | Run an assignment over an AST exhaustively.
-assign :: (HasField fields Info.Range, HasField fields Info.Span, HasField fields grammar, Symbol grammar, Enum grammar, Eq grammar, Traversable f, HasCallStack)
-  => Assignment (Cofree f (Record fields)) grammar a
-  -> Source.Source
-  -> Cofree f (Record fields)
-  -> Either (Error grammar) a
-assign = assignBy (\ (r :< _) -> Node (getField r) (getField r) (getField r))
-
 assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
-  => (forall x. Base ast x -> Node grammar)
-  -> Assignment ast grammar a
-  -> Source.Source
-  -> ast
-  -> Either (Error grammar) a
-assignBy toNode assignment source = fmap fst . assignAllFrom source toNode assignment . makeState . pure
+         => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast.
+         -> Source.Source                          -- ^ The source for the parse tree.
+         -> Assignment ast grammar a               -- ^ The 'Assignment to run.
+         -> ast                                    -- ^ The root of the ast.
+         -> Either (Error grammar) a               -- ^ 'Either' an 'Error' or the assigned value.
+assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure

-assignAllFrom :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
-  => Source.Source
-  -> (forall x. Base ast x -> Node grammar)
-  -> Assignment ast grammar a
-  -> AssignmentState ast grammar
-  -> Either (Error grammar) (a, AssignmentState ast grammar)
-assignAllFrom source toNode assignment state = runAssignment source toNode assignment state >>= go
-  where
-    go (a, state) = case stateNodes (dropAnonymous toNode state) of
-      [] -> Right (a, state)
-      node : _ -> let Node nodeSymbol _ (Info.Span spanStart _) = toNode (F.project node) in
-        Left $ fromMaybe (Error spanStart (UnexpectedSymbol [] nodeSymbol)) (stateError state)
-
-- | Run an assignment of nodes in a grammar onto terms in a syntax.
+-- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively.
 runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
-  => Source.Source
-  -> (forall x. Base ast x -> Node grammar)
-  -> Assignment ast grammar a
-  -> AssignmentState ast grammar
-  -> Either (Error grammar) (a, AssignmentState ast grammar)
-runAssignment source toNode = iterFreer run . fmap ((pure .) . (,))
-  where run :: AssignmentF ast grammar x -> (x -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)) -> AssignmentState ast grammar -> Either (Error grammar) (a, AssignmentState ast grammar)
-        run assignment yield initialState = case (assignment, stateNodes state) of
-          (Location, node : _) -> yield (nodeLocation (toNode (F.project node))) state
-          (Location, []) -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state
-          (Project projection, node : _) -> yield (projection (F.project node)) state
-          (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState toNode state)
-          (Children childAssignment, node : _) -> do
-            (a, state') <- assignAllFrom source toNode childAssignment state { stateNodes = toList (F.project node) }
-            yield a (advanceState toNode state' { stateNodes = stateNodes state })
-          (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state
-          (Many rule, _) -> uncurry yield (runMany rule state)
-          -- Nullability: some rules, e.g. @pure a@ and @many a@, should match at the end of input. Either side of an alternation may be nullable, ergo Alt can match at the end of input.
-          (Alt a b, _) -> case yield a state of
-            Left err -> yield b state { stateError = Just err }
-            r -> r
-          (Throw e, _) -> Left e
-          (Catch during handler, _) -> case yield during state of
-            Left err -> yield (handler err) state
-            Right (a, state') -> Right (a, state')
-          (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols))
-          (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol))
-          where state = case assignment of
-                  Choose choices | all ((== Regular) . symbolType) (choiceSymbols choices) -> dropAnonymous toNode initialState
-                  _ -> initialState
-                expectedSymbols = case assignment of
-                  Choose choices -> choiceSymbols choices
-                  _ -> []
-                choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices
-                runMany :: Assignment ast grammar v -> AssignmentState ast grammar -> ([v], AssignmentState ast grammar)
-                runMany rule state = case runAssignment source toNode rule state of
+              => (forall x. Base ast x -> Node grammar)        -- ^ A function to project a 'Node' from the ast.
+              -> Source.Source                                 -- ^ The source for the parse tree.
+              -> Assignment ast grammar a                      -- ^ The 'Assignment' to run.
+              -> State ast grammar                             -- ^ The current state.
+              -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state.
+runAssignment toNode source = (requireExhaustive <=<) . go
+  where go :: Assignment ast grammar result -> State ast grammar -> Either (Error grammar) (result, State ast grammar)
+        go = iterFreer run . fmap ((pure .) . (,))
+        {-# INLINE go #-}
+
+        run :: AssignmentF ast grammar x
+            -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar))
+            -> State ast grammar
+            -> Either (Error grammar) (result, State ast grammar)
+        run assignment yield initialState = maybe (anywhere Nothing) (atNode . F.project) (listToMaybe (stateNodes state))
+          where atNode node = case assignment of
+                  Location -> yield (nodeLocation (toNode node)) state
+                  Project projection -> yield (projection node) state
+                  Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode node)) source)) (advance state)
+                  Children child -> do
+                    (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive
+                    yield a (advance state' { stateNodes = stateNodes state })
+                  Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state
+                  _ -> anywhere (Just node)
+
+                anywhere node = case assignment of
+                  Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state
+                  Many rule -> uncurry yield (runMany rule state)
+                  Alt a b -> yield a state `catchError` (yield b . setStateError state . Just)
+                  Throw e -> Left e
+                  Catch during handler -> yield during state `catchError` (flip yield state . handler)
+                  _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node)
+
+                state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState
+                      | otherwise = initialState
+                expectedSymbols | Choose choices <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices
+                                | otherwise = []
+
+        runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar)
+        runMany rule = loop
+          where loop state = case go rule state of
                  Left err -> ([], state { stateError = Just err })
-                  Right (a, state') | ((/=) `on` stateCounter) state state' ->
-                                        let (as, state'') = runMany rule state'
-                                        in as `seq` (a : as, state'')
+                  Right (a, state') | ((/=) `on` stateCounter) state state', (as, state'') <- loop state' -> as `seq` (a : as, state'')
                                    | otherwise -> ([a], state')
-        {-# INLINE run #-}
+        {-# INLINE runMany #-}

-dropAnonymous :: (Symbol grammar, Recursive ast) => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar
-dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) }
+        requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar)
+        requireExhaustive (a, state) = case stateNodes (dropAnonymous state) of
+          [] -> Right (a, state)
+          node : _ -> Left (fromMaybe (nodeError [] (toNode (F.project node))) (stateError state))

-- | Advances the state past the current (head) node (if any), dropping it off
-- stateNodes & its corresponding bytes off of source, and updating stateOffset &
-- statePos to its end. Exhausted 'AssignmentState's (those without any
-- remaining nodes) are returned unchanged.
-advanceState :: Recursive ast => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar
-advanceState toNode state@AssignmentState{..}
-  | node : rest <- stateNodes
-  , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest
-  | otherwise = state
+        dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) }
+
+        -- 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.
+        advance state@State{..}
+          | node : rest <- stateNodes
+          , Node{..} <- toNode (F.project node) = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest
+          | otherwise = state

 -- | State kept while running 'Assignment's.
-data AssignmentState ast grammar = AssignmentState
-  { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes.
-  , statePos :: Info.Pos -- ^ The (1-indexed) line/column position in the Source thus far reached.
-  , stateError :: Maybe (Error grammar)
-  , stateCounter :: Int -- ^ Always incrementing counter that tracks how many nodes have been visited.
-  , stateNodes :: [ast] -- ^ 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.”
+data State ast grammar = State
+  { stateOffset :: Int                  -- ^ The offset into the Source thus far reached, measured in bytes.
+  , statePos :: Info.Pos                -- ^ The (1-indexed) line/column position in the Source thus far reached.
+  , stateError :: Maybe (Error grammar) -- ^ The most recently encountered error. Preserved for improved error messages in the presence of backtracking.
+  , stateCounter :: Int                 -- ^ Always incrementing counter that tracks how many nodes have been visited.
+  , stateNodes :: [ast]                 -- ^ 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 (Eq, Show)

-makeState :: [ast] -> AssignmentState ast grammar
-makeState = AssignmentState 0 (Info.Pos 1 1) Nothing 0
+makeState :: [ast] -> State ast grammar
+makeState = State 0 (Info.Pos 1 1) Nothing 0
+
+setStateError :: State ast grammar -> Maybe (Error grammar) -> State ast grammar
+setStateError state error = state { stateError = error }


 -- Instances
@ -356,14 +369,6 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where
    Throw e -> showsUnaryWith showsPrec "Throw" d e
    Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler

-instance Show1 Error where
-  liftShowsPrec sp sl d (Error p c) = showsBinaryWith showsPrec (liftShowsPrec sp sl) "Error" d p c
-
-instance Show1 ErrorCause where
-  liftShowsPrec sp sl d e = case e of
-    UnexpectedSymbol expected actual -> showsBinaryWith (liftShowsPrec sp sl) sp "UnexpectedSymbol" d expected actual
-    UnexpectedEndOfInput expected -> showsUnaryWith (liftShowsPrec sp sl) "UnexpectedEndOfInput" d expected
-
 instance MonadError (Error grammar) (Assignment ast grammar) where
  throwError :: HasCallStack => Error grammar -> Assignment ast grammar a
  throwError error = withFrozenCallStack $ Throw error `Then` return
--- a/src/FDoc/RecursionSchemes.hs
+++ b/src/FDoc/RecursionSchemes.hs
@ -25,7 +25,7 @@ structure.

 The example below adds a new field to the `Record` fields.
 -}
-indexedTermAna :: [Text] -> SyntaxTerm '[NewField, Range, Category]
+indexedTermAna :: [Text] -> Term Syntax (Record '[NewField, Range, Category])
 indexedTermAna childrenLeaves = ana coalgebra (indexedTerm childrenLeaves)
  where
    coalgebra term = (NewField :. (extract term)) :< unwrap term
@ -43,7 +43,7 @@ structure to a new shape.

 The example below adds a new field to the `Record` fields.
 -}
-indexedTermCata :: [Text] -> SyntaxTerm '[NewField, Range, Category]
+indexedTermCata :: [Text] -> Term Syntax (Record '[NewField, Range, Category])
 indexedTermCata childrenLeaves = cata algebra (indexedTerm childrenLeaves)
  where
    algebra :: Functor f => CofreeF f (Record t) (Cofree f (Record (NewField : t))) -> Cofree f (Record (NewField : t))
@ -82,7 +82,7 @@ stringToTermAna "indexed" =>
  the new cofree `Indexed` structure, resulting in a expansion of all possible
  string terms.
 -}
-stringToTermAna :: Text -> SyntaxTerm '[Range, Category]
+stringToTermAna :: Text -> Term Syntax (Record '[Range, Category])
 stringToTermAna = ana coalgebra
  where
    coalgebra representation = case representation of
@ -95,7 +95,7 @@ Catamorphism -- construct a list of Strings from a recursive Term structure.
 The example below shows how to tear down a recursive Term structure into a list
 of String representation.
 -}
-termToStringCata :: SyntaxTerm '[Range, Category] -> [Text]
+termToStringCata :: Term Syntax (Record '[Range, Category]) -> [Text]
 termToStringCata = cata algebra
  where
    algebra term = case term of
@ -177,7 +177,7 @@ Final shape:
 ]

 -}
-termPara :: SyntaxTerm '[Range, Category] -> [(SyntaxTerm '[Range, Category], Text)]
+termPara :: Term Syntax (Record '[Range, Category]) -> [(Term Syntax (Record '[Range, Category]), Text)]
 termPara = para algebra
  where
    algebra term = case term of
--- a/src/FDoc/Term.hs
+++ b/src/FDoc/Term.hs
@ -32,7 +32,7 @@ Example (from GHCi):

 -}

-leafTermF :: Text -> SyntaxTermF '[Range, Category] b
+leafTermF :: Text -> TermF Syntax (Record '[Range, Category]) b
 leafTermF leaf = (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf leaf

 {-
@ -57,11 +57,11 @@ Example (from GHCi):
 > Leaf "example"

 -}
-leafTerm :: Text -> SyntaxTerm '[Range, Category]
+leafTerm :: Text -> Cofree Syntax (Record '[Range, Category])
 leafTerm = cofree . leafTermF

-indexedTermF :: [Text] -> SyntaxTermF '[Range, Category] (SyntaxTerm '[Range, Category])
+indexedTermF :: [Text] -> TermF Syntax (Record '[Range, Category]) (Term Syntax (Record '[Range, Category]))
 indexedTermF leaves = (Range 1 10 :. Category.MethodCall :. Nil) :< Indexed (leafTerm <$> leaves)

-indexedTerm :: [Text] -> SyntaxTerm '[Range, Category]
+indexedTerm :: [Text] -> Term Syntax (Record '[Range, Category])
 indexedTerm leaves = cofree $ indexedTermF leaves
--- a/src/Files.hs
+++ b/src/Files.hs
@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-}
 module Files
 ( readFile
 , readBlobPairsFromHandle
@ -7,6 +7,7 @@ module Files
 ) where

 import Control.Exception (catch, IOException)
+import Control.Monad.IO.Class
 import Data.Aeson
 import Data.These
 import Data.Functor.Both
@ -21,9 +22,9 @@ import Prelude (fail)
 import System.FilePath

 -- | Read a utf8-encoded file to a 'Blob'.
-readFile :: FilePath -> Maybe Language -> IO Blob.Blob
+readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob
 readFile path language = do
-  raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString))
+  raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString))
  pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw)

 -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
@ -31,7 +32,7 @@ languageForFilePath :: FilePath -> Maybe Language
 languageForFilePath = languageForType . toS . takeExtension

 -- | Read JSON encoded blob pairs from a handle.
-readBlobPairsFromHandle :: Handle -> IO [Both Blob.Blob]
+readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob]
 readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
  where
    toBlobPairs BlobDiff{..} = toBlobPair <$> blobs
@ -39,16 +40,16 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
      where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs)))

 -- | Read JSON encoded blobs from a handle.
-readBlobsFromHandle :: Handle -> IO [Blob.Blob]
+readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
 readBlobsFromHandle = fmap toBlobs . readFromHandle
  where toBlobs BlobParse{..} = fmap toBlob blobs

-readFromHandle :: FromJSON a => Handle -> IO a
+readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
 readFromHandle h = do
-  input <- BL.hGetContents h
+  input <- liftIO $ BL.hGetContents h
  case decode input of
    Just d -> pure d
-    Nothing -> die ("invalid input on " <> show h <> ", expecting JSON")
+    Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON")

 toBlob :: Blob -> Blob.Blob
 toBlob Blob{..} = Blob.sourceBlob path language' (fromText content)
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@ -4,12 +4,10 @@ module Interpreter
 , decoratingWith
 , diffTermsWith
 , comparableByConstructor
-, runAlgorithm
-, runAlgorithmSteps
 ) where

 import Algorithm
-import Control.Monad.Free.Freer
+import Control.Monad.Free.Freer hiding (cutoff)
 import Data.Align.Generic
 import Data.Functor.Both
 import Data.Functor.Classes (Eq1)
@ -44,7 +42,7 @@ diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fie
              -> ComparabilityRelation f fields -- ^ A relation on terms used to determine comparability and equality.
              -> Both (Term f (Record fields)) -- ^ A pair of terms.
              -> Diff f (Record fields) -- ^ The resulting diff.
-diffTermsWith refine comparable (Join (a, b)) = runAlgorithm decompose (diff a b)
+diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)
  where decompose :: AlgorithmF (Term f (Record fields)) (Diff f (Record fields)) result -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) result
        decompose step = case step of
          Diff t1 t2 -> refine t1 t2
@ -57,29 +55,11 @@ diffTermsWith refine comparable (Join (a, b)) = runAlgorithm decompose (diff a b
          Replace a b -> pure (replacing a b)

 -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram.
-getLabel :: HasField fields Category => SyntaxTermF fields a -> (Category, Maybe Text)
+getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text)
 getLabel (h :< t) = (Info.category h, case t of
  Leaf s -> Just s
  _ -> Nothing)

-- | Run an Algorithm to completion by repeated application of a stepping operation and return its result.
-runAlgorithm :: forall f result
-             .  (forall x. f x -> Freer f x)
-             -> Freer f result
-             -> result
-runAlgorithm decompose = go
-  where go :: Freer f x -> x
-        go = iterFreer (\ algorithm yield -> yield (go (decompose algorithm)))
-
-- | Run an Algorithm to completion by repeated application of a stepping operation, returning the list of steps taken up to and including the final result.
-runAlgorithmSteps :: (forall x. f x -> Freer f x)
-                  -> Freer f result
-                  -> [Freer f result]
-runAlgorithmSteps decompose = go
-  where go algorithm = case algorithm of
-          Return a -> [Return a]
-          step `Then` yield -> algorithm : go (decompose step >>= yield)
-

 -- | Construct an algorithm to diff a pair of terms.
 algorithmWithTerms :: SyntaxTerm fields
--- a/src/Language.hs
+++ b/src/Language.hs
@ -36,7 +36,7 @@ languageForType mediaType = case mediaType of
    ".py" -> Just Python
    _ -> Nothing

-toVarDeclOrAssignment :: HasField fields Category => SyntaxTerm fields -> SyntaxTerm fields
+toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
 toVarDeclOrAssignment child = case unwrap child of
  S.Indexed [child', assignment] -> cofree $ setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment
  S.Indexed [child'] -> cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child']
@ -44,10 +44,10 @@ toVarDeclOrAssignment child = case unwrap child of
  S.VarAssignment _ _ -> child
  _ -> toVarDecl child

-toVarDecl :: HasField fields Category => SyntaxTerm fields -> SyntaxTerm fields
+toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
 toVarDecl child = cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child]

-toTuple :: SyntaxTerm fields -> [SyntaxTerm fields]
+toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)]
 toTuple child | S.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]
 toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]
 toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)]
--- a/src/Parser.hs
+++ b/src/Parser.hs
@ -1,9 +1,9 @@
 {-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
 module Parser
-( Parser
-, runParser
+( Parser(..)
 -- Syntax parsers
 , parserForLanguage
+, lineByLineParser
 -- À la carte parsers
 , jsonParser
 , markdownParser
@ -12,7 +12,6 @@ module Parser
 ) where

 import qualified CMark
-import Data.Blob
 import Data.Functor.Foldable hiding (fold, Nil)
 import Data.Record
 import Data.Source as Source
@ -37,7 +36,6 @@ import Text.Parser.TreeSitter.Python
 import Text.Parser.TreeSitter.Ruby
 import Text.Parser.TreeSitter.TypeScript
 import Text.Parser.TreeSitter.JSON
-import TreeSitter

 -- | A parser from 'Source' onto some term type.
 data Parser term where
@ -50,7 +48,7 @@ data Parser term where
                   -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's.
                   -> Parser (Term (Union fs) (Record Location))                 -- ^ A parser producing 'Term's.
  -- | A tree-sitter parser.
-  TreeSitterParser :: Language -> Ptr TS.Language -> Parser (SyntaxTerm DefaultFields)
+  TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm DefaultFields)
  -- | A parser for 'Markdown' using cmark.
  MarkdownParser :: Parser (AST CMark.NodeType)
  -- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines.
@ -60,12 +58,12 @@ data Parser term where
 parserForLanguage :: Maybe Language -> Parser (SyntaxTerm DefaultFields)
 parserForLanguage Nothing = LineByLineParser
 parserForLanguage (Just language) = case language of
-  C -> TreeSitterParser C tree_sitter_c
-  Go -> TreeSitterParser Go tree_sitter_go
-  JSON -> TreeSitterParser JSON tree_sitter_json
-  JavaScript -> TreeSitterParser TypeScript tree_sitter_typescript
-  Ruby -> TreeSitterParser Ruby tree_sitter_ruby
-  TypeScript -> TreeSitterParser TypeScript tree_sitter_typescript
+  C -> TreeSitterParser tree_sitter_c
+  Go -> TreeSitterParser tree_sitter_go
+  JSON -> TreeSitterParser tree_sitter_json
+  JavaScript -> TreeSitterParser tree_sitter_typescript
+  Ruby -> TreeSitterParser tree_sitter_ruby
+  TypeScript -> TreeSitterParser tree_sitter_typescript
  _ -> LineByLineParser

 rubyParser :: Parser Ruby.Term
@ -80,22 +78,6 @@ jsonParser = AssignmentParser (ASTParser tree_sitter_json) headF JSON.assignment
 markdownParser :: Parser Markdown.Term
 markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node { nodeSymbol = toGrammar nodeSymbol }) Markdown.assignment

-runParser :: Parser term -> Blob -> IO term
-runParser parser blob@Blob{..} = case parser of
-  ASTParser language -> parseToAST language blobSource
-  AssignmentParser parser by assignment -> do
-    ast <- runParser parser blob
-    case assignBy by assignment blobSource ast of
-      Left err -> do
-        printError blob err
-        pure (errorTerm blobSource)
-      Right term -> pure term
-  TreeSitterParser language tslanguage -> treeSitterParser language tslanguage blobSource
-  MarkdownParser -> pure (cmarkParser blobSource)
-  LineByLineParser -> pure (lineByLineParser blobSource)
-
-errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Location)
-errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error []))

 -- | A fallback parser that treats a file simply as rows of strings.
 lineByLineParser :: Source -> SyntaxTerm DefaultFields
--- a/src/Semantic/Task.hs
+++ b/src/Semantic/Task.hs
@ -1,11 +1,13 @@
 {-# LANGUAGE DataKinds, GADTs, TypeOperators #-}
 module Semantic.Task
 ( Task
+, Level(..)
 , RAlgebra
 , Differ
 , readBlobs
 , readBlobPairs
 , writeToOutput
+, writeLog
 , parse
 , decorate
 , diff
@ -13,10 +15,15 @@ module Semantic.Task
 , distribute
 , distributeFor
 , distributeFoldMap
+, Options(..)
+, defaultOptions
+, configureOptionsForHandle
 , runTask
+, runTaskWithOptions
 ) where

-import qualified Files
+import Control.Concurrent.STM.TMQueue
+import Control.Monad.IO.Class
 import Control.Parallel.Strategies
 import qualified Control.Concurrent.Async as Async
 import Control.Monad.Free.Freer
@ -24,26 +31,63 @@ import Data.Blob
 import qualified Data.ByteString as B
 import Data.Functor.Both as Both
 import Data.Record
+import Data.Source
+import Data.String
+import qualified Data.Syntax as Syntax
 import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra)
+import qualified Data.Syntax.Assignment as Assignment
+import qualified Data.Time.Clock as Time
+import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
+import qualified Data.Time.Format as Time
+import Data.Union
 import Diff
+import qualified Files
 import Language
+import Language.Markdown
 import Parser
-import Prologue hiding (diff)
+import Prologue hiding (diff, hPutStr, Location, show)
+import System.Console.ANSI
+import System.IO (hIsTerminalDevice, hPutStr)
 import Term
+import Text.Show
+import TreeSitter

 data TaskF output where
  ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
  ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
  WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF ()
+  WriteLog :: Level -> String -> TaskF ()
  Parse :: Parser term -> Blob -> TaskF term
  Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
  Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a)
  Render :: Renderer input output -> input -> TaskF output
  Distribute :: Traversable t => t (Task output) -> TaskF (t output)
+  LiftIO :: IO a -> TaskF a

 -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
 type Task = Freer TaskF

+-- | A log message at a specific level.
+data Message = Message Level String Time.UTCTime
+  deriving (Eq, Show)
+
+data Level
+  = Error
+  | Warning
+  | Info
+  | Debug
+  deriving (Eq, Ord, Show)
+
+-- | Format a 'Message', optionally colourized.
+formatMessage :: Bool -> Message -> String
+formatMessage colourize (Message level message time) = showTime time . showChar ' ' . showLevel level . showString ": " . showString message . showChar '\n' $ ""
+  where showLevel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "error")
+        showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString "warning")
+        showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info")
+        showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug")
+        showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%H:%M:%S%Q"))
+
+
 -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
 type Differ f a = Both (Term f a) -> Diff f a

@ -63,6 +107,11 @@ writeToOutput :: Either Handle FilePath -> ByteString -> Task ()
 writeToOutput path contents = WriteToOutput path contents `Then` return


+-- | A 'Task' which logs a message at a specific log level to stderr.
+writeLog :: Level -> String -> Task ()
+writeLog level message = WriteLog level message `Then` return
+
+
 -- | A 'Task' which parses a 'Blob' with the given 'Parser'.
 parse :: Parser term -> Blob -> Task term
 parse parser blob = Parse parser blob `Then` return
@ -97,15 +146,94 @@ distributeFor inputs toTask = distribute (fmap toTask inputs)
 distributeFoldMap :: (Traversable t, Monoid output) => (a -> Task output) -> t a -> Task output
 distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))

+-- | Options controlling 'Task' logging, error handling, &c.
+data Options = Options
+  { optionsColour :: Maybe Bool -- ^ Whether to use colour formatting for errors. 'Nothing' implies automatic selection for the stderr handle, using colour for terminal handles but not for regular files.
+  , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging.
+  , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors.
+  }

-- | Execute a 'Task', yielding its result value in 'IO'.
+defaultOptions :: Options
+defaultOptions = Options
+  { optionsColour = Nothing
+  , optionsLevel = Just Warning
+  , optionsPrintSource = False
+  }
+
+configureOptionsForHandle :: Handle -> Options -> IO Options
+configureOptionsForHandle handle options = do
+  isTerminal <- hIsTerminalDevice handle
+  pure $ options
+    { optionsColour = optionsColour options <|> Just isTerminal
+    }
+
+
+-- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
+--
+-- > runTask = runTaskWithOptions defaultOptions
 runTask :: Task a -> IO a
-runTask = iterFreerA $ \ task yield -> case task of
-  ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield
-  ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield
-  WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
-  Parse parser blob -> runParser parser blob >>= yield
-  Decorate algebra term -> yield (decoratorWithAlgebra algebra term)
-  Diff differ terms -> yield (differ terms)
-  Render renderer input -> yield (renderer input)
-  Distribute tasks -> Async.mapConcurrently runTask tasks >>= yield . withStrategy (parTraversable rseq)
+runTask = runTaskWithOptions defaultOptions
+
+-- | Execute a 'Task' with the passed 'Options', yielding its result value in 'IO'.
+runTaskWithOptions :: Options -> Task a -> IO a
+runTaskWithOptions options task = do
+  options <- configureOptionsForHandle stderr options
+  logQueue <- newTMQueueIO
+  logging <- async (logSink options logQueue)
+
+  result <- runFreerM (\ task -> case task of
+    ReadBlobs source -> pure <$ writeLog Info "ReadBlobs" <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source
+    ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source
+    WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents)
+    WriteLog level message
+      | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (Time.getCurrentTime >>= atomically . writeTMQueue logQueue . Message level message)
+      | otherwise -> pure (pure ())
+    Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob
+    Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term)
+    Diff differ terms -> pure <$ writeLog Info "Diff" <*> pure (differ terms)
+    Render renderer input -> pure <$ writeLog Info "Render" <*> pure (renderer input)
+    Distribute tasks -> pure <$ writeLog Info "Distribute" <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))
+    LiftIO action -> pure action)
+    task
+  atomically (closeTMQueue logQueue)
+  wait logging
+  pure result
+  where logSink options queue = do
+          message <- atomically (readTMQueue queue)
+          case message of
+            Just message -> do
+              hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message)
+              logSink options queue
+            _ -> pure ()
+
+runParser :: Options -> Parser term -> Blob -> Task term
+runParser options parser blob@Blob{..} = case parser of
+  ASTParser language -> liftIO $ parseToAST language blob
+  AssignmentParser parser by assignment -> do
+    ast <- runParser options parser blob
+    case Assignment.assignBy by blobSource assignment ast of
+      Left err -> do
+        let formatOptions = Assignment.defaultOptions
+              { Assignment.optionsColour = fromMaybe True (optionsColour options)
+              , Assignment.optionsIncludeSource = optionsPrintSource options
+              }
+        writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err)
+        pure (errorTerm blobSource)
+      Right term -> do
+        when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors")
+        pure term
+  TreeSitterParser tslanguage -> liftIO $ treeSitterParser tslanguage blob
+  MarkdownParser -> pure (cmarkParser blobSource)
+  LineByLineParser -> pure (lineByLineParser blobSource)
+
+errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location)
+errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error []))
+
+hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool
+hasErrors = cata $ \ (_ :< syntax) -> case syntax of
+  _ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
+  _ -> or syntax
+
+
+instance MonadIO Task where
+  liftIO action = LiftIO action `Then` return
--- a/src/SemanticCmdLine.hs
+++ b/src/SemanticCmdLine.hs
@ -7,13 +7,13 @@ module SemanticCmdLine
 ) where

 import Files (languageForFilePath)
-import Data.Functor.Both
+import Data.Functor.Both hiding (fst, snd)
 import Data.List.Split (splitWhen)
 import Data.Version (showVersion)
 import Development.GitRev
 import Language
 import Options.Applicative hiding (action)
-import Prologue hiding (concurrently, fst, snd, readFile)
+import Prologue hiding (concurrently, option, readFile)
 import Renderer
 import qualified Paths_semantic_diff as Library (version)
 import qualified Semantic.Task as Task
@ -21,7 +21,7 @@ import System.IO (stdin)
 import qualified Semantic (parseBlobs, diffBlobPairs)

 main :: IO ()
-main = customExecParser (prefs showHelpOnEmpty) arguments >>= Task.runTask
+main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions

 runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString
 runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
@ -32,13 +32,19 @@ runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRendere
 -- | A parser for the application's command-line arguments.
 --
 --   Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
-arguments :: ParserInfo (Task.Task ())
-arguments = info (version <*> helper <*> argumentsParser) description
+arguments :: ParserInfo (Task.Options, Task.Task ())
+arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description
  where
    version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")
    versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
    description = fullDesc <> header "semantic -- Parse and diff semantically"

+    optionsParser = Task.Options
+      <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)]
+            (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.")
+      <*> options [("error", Just Task.Error), ("warning", Just Task.Warning), ("info", Just Task.Info), ("debug", Just Task.Debug), ("none", Nothing)]
+            (long "log-level" <> value (Just Task.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
+      <*> switch (long "print-source" <> help "Include source references in logged errors where applicable.")
    argumentsParser = (. Task.writeToOutput) . (>>=)
      <$> hsubparser (diffCommand <> parseCommand)
      <*> (   Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")
@ -46,10 +52,10 @@ arguments = info (version <*> helper <*> argumentsParser) description

    diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
    diffArgumentsParser = runDiff
-      <$> (   flag  (SomeRenderer PatchDiffRenderer) (SomeRenderer PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)")
-          <|> flag' (SomeRenderer JSONDiffRenderer)                                   (long "json" <> help "Output a json diff")
-          <|> flag' (SomeRenderer SExpressionDiffRenderer)                            (long "sexpression" <> help "Output an s-expression diff tree")
-          <|> flag' (SomeRenderer ToCDiffRenderer)                                    (long "toc" <> help "Output a table of contents for a diff") )
+      <$> (   flag  (SomeRenderer PatchDiffRenderer) (SomeRenderer PatchDiffRenderer)       (long "patch" <> help "Output a patch(1)-compatible diff (default)")
+          <|> flag'                                  (SomeRenderer JSONDiffRenderer)        (long "json" <> help "Output a json diff")
+          <|> flag'                                  (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree")
+          <|> flag'                                  (SomeRenderer ToCDiffRenderer)         (long "toc" <> help "Output a table of contents for a diff") )
      <*> (   ((Right . pure) .) . both
          <$> argument filePathReader (metavar "FILE_A")
          <*> argument filePathReader (metavar "FILE_B")
@ -58,8 +64,8 @@ arguments = info (version <*> helper <*> argumentsParser) description
    parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)"))
    parseArgumentsParser = runParse
      <$> (   flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
-          <|> flag' (SomeRenderer JSONTermRenderer)                                               (long "json" <> help "Output JSON parse trees")
-          <|> flag' (SomeRenderer ToCTermRenderer)                                                (long "toc" <> help "Output a table of contents for a file"))
+          <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json" <> help "Output JSON parse trees")
+          <|> flag'                                        (SomeRenderer ToCTermRenderer)         (long "toc" <> help "Output a table of contents for a file"))
      <*> (   Right <$> some (argument filePathReader (metavar "FILES..."))
          <|> pure (Left stdin) )

@ -69,3 +75,7 @@ arguments = info (version <*> helper <*> argumentsParser) description
               | Just lang <- readMaybe b -> Right (a, Just lang)
        [path] -> Right (path, languageForFilePath path)
        _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE")
+
+    optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
+    options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))
+    findOption options value = maybe "" fst (find ((== value) . snd) options)
--- a/src/SplitDiff.hs
+++ b/src/SplitDiff.hs
@ -3,7 +3,6 @@ module SplitDiff where
 import Data.Record
 import Info
 import Prologue
-import Syntax
 import Term (Term, TermF)

 -- | A patch to only one side of a diff.
@ -24,4 +23,3 @@ getRange diff = byteRange $ case runFree diff of

 -- | A diff with only one side’s annotations.
 type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation))
-type SplitSyntaxDiff fields = SplitDiff Syntax (Record fields)
--- a/src/Syntax.hs
+++ b/src/Syntax.hs
@ -26,7 +26,7 @@ data Syntax f
  -- | A ternary has a condition, a true case and a false case
  | Ternary f [f]
  -- | An anonymous function has a list of expressions and params.
-  | AnonymousFunction [f] [f]
+  | AnonymousFunction  [f] [f]
  -- | A function has an identifier, possible type arguments, params, a possible type, and list of expressions.
  | Function f [f] [f]
  -- | An assignment has an identifier where f can be a member access, and the value is another syntax element (function call, leaf, etc.)
@ -110,10 +110,10 @@ data Syntax f
  | Ty [f]
  -- | A send statement has a channel and an expression in Go.
  | Send f f
-  deriving (Eq, Foldable, Functor, GAlign, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData)
+  deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData)


-extractLeafValue :: Syntax b -> Maybe Text
+extractLeafValue :: Syntax a -> Maybe Text
 extractLeafValue syntax = case syntax of
  Leaf a -> Just a
  _ -> Nothing
@ -182,3 +182,5 @@ instance Listable recur => Listable (Syntax recur) where

 instance Eq1 Syntax where
  liftEq = genericLiftEq
+
+instance GAlign Syntax
--- a/src/TreeSitter.hs
+++ b/src/TreeSitter.hs
@ -7,6 +7,7 @@ module TreeSitter

 import Prologue hiding (Constructor)
 import Category
+import Data.Blob
 import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import Data.Functor.Foldable hiding (Nil)
 import Data.Range
@ -19,7 +20,6 @@ import qualified Language.C as C
 import qualified Language.Go as Go
 import qualified Language.TypeScript as TS
 import qualified Language.Ruby as Ruby
-import qualified Syntax
 import Foreign
 import Foreign.C.String (peekCString)
 import Foreign.Marshal.Array (allocaArray)
@ -27,24 +27,28 @@ import qualified Syntax as S
 import Term
 import Text.Parser.TreeSitter hiding (Language(..))
 import qualified Text.Parser.TreeSitter as TS
+import qualified Text.Parser.TreeSitter.C as TS
+import qualified Text.Parser.TreeSitter.Go as TS
+import qualified Text.Parser.TreeSitter.Ruby as TS
+import qualified Text.Parser.TreeSitter.TypeScript as TS
 import Info

 -- | Returns a TreeSitter parser for the given language and TreeSitter grammar.
-treeSitterParser :: Language -> Ptr TS.Language -> Source -> IO (SyntaxTerm DefaultFields)
-treeSitterParser language grammar source = bracket ts_document_new ts_document_free $ \ document -> do
-  ts_document_set_language document grammar
-  unsafeUseAsCStringLen (sourceBytes source) $ \ (sourceBytes, len) -> do
+treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm DefaultFields)
+treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ document -> do
+  ts_document_set_language document language
+  unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do
    ts_document_set_input_string_with_length document sourceBytes len
    ts_document_parse_halt_on_error document
-    term <- documentToTerm language document source
+    term <- documentToTerm language document blob
    pure term


 -- | Parse 'Source' with the given 'TS.Language' and return its AST.
-parseToAST :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Source -> IO (A.AST grammar)
-parseToAST language source = bracket ts_document_new ts_document_free $ \ document -> do
+parseToAST :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Blob -> IO (A.AST grammar)
+parseToAST language Blob{..} = bracket ts_document_new ts_document_free $ \ document -> do
  ts_document_set_language document language
-  root <- unsafeUseAsCStringLen (sourceBytes source) $ \ (source, len) -> do
+  root <- unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do
    ts_document_set_input_string_with_length document source len
    ts_document_parse_halt_on_error document
    alloca (\ rootPtr -> do
@ -66,27 +70,27 @@ anaM g = a where a = pure . embed <=< traverse a <=< g


 -- | Return a parser for a tree sitter language & document.
-documentToTerm :: Language -> Ptr Document -> Source -> IO (SyntaxTerm DefaultFields)
-documentToTerm language document allSource = do
+documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm DefaultFields)
+documentToTerm language document Blob{..} = do
  root <- alloca (\ rootPtr -> do
    ts_document_root_node_p document rootPtr
    peek rootPtr)
-  toTerm root (slice (nodeRange root) allSource)
-  where toTerm :: Node -> Source -> IO (SyntaxTerm DefaultFields)
-        toTerm node source = do
+  toTerm root
+  where toTerm :: Node -> IO (SyntaxTerm DefaultFields)
+        toTerm node = do
          name <- peekCString (nodeType node)

          children <- getChildren (fromIntegral (nodeNamedChildCount node)) copyNamed
          let allChildren = getChildren (fromIntegral (nodeChildCount node)) copyAll

+          let source = slice (nodeRange node) blobSource
          assignTerm language source (range :. categoryForLanguageProductionName language (toS name) :. nodeSpan node :. Nil) children allChildren
          where getChildren count copy = do
                  nodes <- allocaArray count $ \ childNodesPtr -> do
                    _ <- with (nodeTSNode node) (\ nodePtr -> copy nodePtr childNodesPtr (fromIntegral count))
                    peekArray count childNodesPtr
-                  children <- traverse childNodeToTerm nodes
+                  children <- traverse toTerm nodes
                  return $! filter isNonEmpty children
-                childNodeToTerm childNode = toTerm childNode (slice (offsetRange (nodeRange childNode) (negate (start range))) source)
                range = nodeRange node
        copyNamed = ts_node_copy_named_child_nodes document
        copyAll = ts_node_copy_child_nodes document
@ -101,17 +105,17 @@ nodeSpan :: Node -> Span
 nodeSpan Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint)
  where pointPos TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)

-assignTerm :: Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
+assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
 assignTerm language source annotation children allChildren =
-  cofree . (annotation :<) <$> case assignTermByLanguage language source (category annotation) children of
+  cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of
    Just a -> pure a
    _ -> defaultTermAssignment source (category annotation) children allChildren
-  where assignTermByLanguage :: Language -> Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
-        assignTermByLanguage language = case language of
-          C -> C.termAssignment
-          Language.Go -> Go.termAssignment
-          Ruby -> Ruby.termAssignment
-          TypeScript -> TS.termAssignment
+  where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
+        assignTermByLanguage = case languageForTSLanguage language of
+          Just C -> C.termAssignment
+          Just Language.Go -> Go.termAssignment
+          Just Ruby -> Ruby.termAssignment
+          Just TypeScript -> TS.termAssignment
          _ -> \ _ _ _ -> Nothing

 defaultTermAssignment :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (S.Syntax (SyntaxTerm DefaultFields))
@ -154,16 +158,25 @@ defaultTermAssignment source category children allChildren
          ]


-categoryForLanguageProductionName :: Language -> Text -> Category
+categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category
 categoryForLanguageProductionName = withDefaults . byLanguage
  where
    withDefaults productionMap name = case name of
      "ERROR" -> ParseError
      s -> productionMap s

-    byLanguage language = case language of
-      C -> C.categoryForCProductionName
-      Ruby -> Ruby.categoryForRubyName
-      Language.Go -> Go.categoryForGoName
-      TypeScript -> TS.categoryForTypeScriptName
+    byLanguage language = case languageForTSLanguage language of
+      Just C -> C.categoryForCProductionName
+      Just Ruby -> Ruby.categoryForRubyName
+      Just Language.Go -> Go.categoryForGoName
+      Just TypeScript -> TS.categoryForTypeScriptName
      _ -> Other
+
+
+languageForTSLanguage :: Ptr TS.Language -> Maybe Language
+languageForTSLanguage = flip lookup
+  [ (TS.tree_sitter_c, C)
+  , (TS.tree_sitter_go, Language.Go)
+  , (TS.tree_sitter_ruby, Ruby)
+  , (TS.tree_sitter_typescript, TypeScript)
+  ]
--- a/test/AlignmentSpec.hs
+++ b/test/AlignmentSpec.hs
@ -256,7 +256,7 @@ instance Listable BranchElement where
 counts :: [Join These (Int, a)] -> Both Int
 counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))

-align :: Both Source.Source -> ConstructibleFree Syntax (Patch (SyntaxTerm '[Range])) (Both (Record '[Range])) -> PrettyDiff (SplitDiff [] (Record '[Range]))
+align :: Both Source.Source -> ConstructibleFree Syntax (Patch (Term Syntax (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff [] (Record '[Range]))
 align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct

 info :: Int -> Int -> Record '[Range]
@ -281,14 +281,14 @@ newtype ConstructibleFree f patch annotation = ConstructibleFree { deconstruct :


 class PatchConstructible p where
-  insert :: SyntaxTerm '[Range] -> p
-  delete :: SyntaxTerm '[Range] -> p
+  insert :: Term Syntax (Record '[Range]) -> p
+  delete :: Term Syntax (Record '[Range]) -> p

-instance PatchConstructible (Patch (SyntaxTerm '[Range])) where
+instance PatchConstructible (Patch (Term Syntax (Record '[Range]))) where
  insert = Insert
  delete = Delete

-instance PatchConstructible (SplitPatch (SyntaxTerm '[Range])) where
+instance PatchConstructible (SplitPatch (Term Syntax (Record '[Range]))) where
  insert = SplitInsert
  delete = SplitDelete

--- a/test/Data/RandomWalkSimilarity/Spec.hs
+++ b/test/Data/RandomWalkSimilarity/Spec.hs
@ -7,7 +7,6 @@ import Data.Bifunctor
 import Data.Functor.Listable
 import RWS
 import Data.Record
-import Data.String
 import Data.These
 import Diff
 import Info
--- a/test/Data/Syntax/Assignment/Spec.hs
+++ b/test/Data/Syntax/Assignment/Spec.hs
@ -5,7 +5,7 @@ import Data.ByteString.Char8 as B (words, length)
 import Data.Source
 import Data.Syntax.Assignment
 import Info
-import Prologue hiding (Symbol)
+import Prologue hiding (State, Symbol)
 import Test.Hspec
 import Text.Parser.TreeSitter.Language (Symbol(..), SymbolType(..))

@ -13,13 +13,13 @@ spec :: Spec
 spec = do
  describe "Applicative" $
    it "matches in sequence" $
-      fst <$> runAssignment "helloworld" headF ((,) <$> red <*> red) (makeState [node Red 0 5 [], node Red 5 10 []])
+      fst <$> runAssignment headF "helloworld" ((,) <$> red <*> red) (makeState [node Red 0 5 [], node Red 5 10 []])
      `shouldBe`
        Right (Out "hello", Out "world")

  describe "Alternative" $ do
    it "attempts multiple alternatives" $
-      fst <$> runAssignment "hello" headF (green <|> red) (makeState [node Red 0 5 []])
+      fst <$> runAssignment headF "hello" (green <|> red) (makeState [node Red 0 5 []])
      `shouldBe`
        Right (Out "hello")

@ -27,63 +27,62 @@ spec = do
      let s = "colourless green ideas sleep furiously"
          w = words s
          (_, nodes) = foldl (\ (i, prev) word -> (i + B.length word + 1, prev <> [node Red i (i + B.length word) []])) (0, []) w in
-      fst <$> runAssignment (fromBytes s) headF (many red) (makeState nodes)
+      fst <$> runAssignment headF (fromBytes s) (many red) (makeState nodes)
      `shouldBe`
        Right (Out <$> w)

    it "matches one-or-more repetitions against one or more input nodes" $
-      fst <$> runAssignment "hello" headF (some red) (makeState [node Red 0 5 []])
+      fst <$> runAssignment headF "hello" (some red) (makeState [node Red 0 5 []])
      `shouldBe`
        Right [Out "hello"]

  describe "symbol" $ do
    it "matches nodes with the same symbol" $
-      fst <$> runAssignment "hello" headF red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello")
+      fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello")

    it "does not advance past the current node" $
-      let initialState = makeState [ node Red 0 2 [] ] in
-      snd <$> runAssignment "hi" headF (symbol Red) initialState `shouldBe` Right initialState
+      runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) [] (Just Red))

  describe "without catchError" $ do
-    it "assignment returns UnexpectedSymbol" $
-      runAssignment "A" headF
+    it "assignment returns unexpected symbol error" $
+      runAssignment headF "A"
        red
        (makeState [node Green 0 1 []])
        `shouldBe`
-          Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green))
+          Left (Error (Info.Pos 1 1) [Red] (Just Green))

-    it "assignment returns UnexpectedEndOfInput" $
-      runAssignment "A" headF
+    it "assignment returns unexpected end of input" $
+      runAssignment headF "A"
        (symbol Green *> children (some red))
        (makeState [node Green 0 1 []])
        `shouldBe`
-          Left (Error (Info.Pos 1 1) (UnexpectedEndOfInput [Red]))
+          Left (Error (Info.Pos 1 1) [Red] Nothing)

  describe "catchError" $ do
    it "handler that always matches" $
-      fst <$> runAssignment "A" headF
+      fst <$> runAssignment headF "A"
        (red `catchError` (\ _ -> OutError <$ location <*> source))
        (makeState [node Green 0 1 []])
        `shouldBe`
          Right (OutError "A")

    it "handler that matches" $
-      fst <$> runAssignment "A" headF
+      fst <$> runAssignment headF "A"
        (red `catchError` const green)
        (makeState [node Green 0 1 []])
        `shouldBe`
          Right (Out "A")

    it "handler that doesn't match produces error" $
-      runAssignment "A" headF
+      runAssignment headF "A"
        (red `catchError` const blue)
        (makeState [node Green 0 1 []])
        `shouldBe`
-          Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Blue] Green))
+          Left (Error (Info.Pos 1 1) [Blue] (Just Green))

    describe "in many" $ do
      it "handler that always matches" $
-        fst <$> runAssignment "PG" headF
+        fst <$> runAssignment headF "PG"
          (symbol Palette *> children (
            many (red `catchError` (\ _ -> OutError <$ location <*> source))
          ))
@ -92,30 +91,30 @@ spec = do
            Right [OutError "G"]

      it "handler that matches" $
-        fst <$> runAssignment "PG" headF
+        fst <$> runAssignment headF "PG"
          (symbol Palette *> children ( many (red `catchError` const green) ))
          (makeState [node Palette 0 1 [node Green 1 2 []]])
          `shouldBe`
            Right [Out "G"]

      it "handler that doesn't match produces error" $
-        runAssignment "PG" headF
+        runAssignment headF "PG"
          (symbol Palette *> children ( many (red `catchError` const blue) ))
          (makeState [node Palette 0 1 [node Green 1 2 []]])
          `shouldBe`
-            Left (Error (Info.Pos 1 2) (UnexpectedSymbol [Blue] Green))
+            Left (Error (Info.Pos 1 2) [Blue] (Just Green))

      it "handler that always matches with apply consumes and then errors" $
-        runAssignment "PG" headF
+        runAssignment headF "PG"
          (symbol Palette *> children (
            (,) <$> many (red `catchError` (\ _ -> OutError <$ location <*> source)) <*> green
          ))
          (makeState [node Palette 0 1 [node Green 1 2 []]])
          `shouldBe`
-            Left (Error (Info.Pos 1 3) (UnexpectedEndOfInput [Green]))
+            Left (Error (Info.Pos 1 3) [Green] Nothing)

      it "handler that doesn't match with apply" $
-        fst <$> runAssignment "PG" headF
+        fst <$> runAssignment headF "PG"
          (symbol Palette *> children (
            (,) <$> many (red `catchError` const blue) <*> green
          ))
@ -125,7 +124,7 @@ spec = do

  describe "many" $ do
    it "takes ones and only one zero width repetition" $
-      fst <$> runAssignment "PGG" headF
+      fst <$> runAssignment headF "PGG"
        (symbol Palette *> children ( many (green <|> pure (Out "always")) ))
        (makeState [node Palette 0 1 [node Green 1 2 [], node Green 2 3 []]])
        `shouldBe`
@ -133,38 +132,38 @@ spec = do

  describe "source" $ do
    it "produces the node’s source" $
-      assignBy headF source "hi" (node Red 0 2 []) `shouldBe` Right "hi"
+      assignBy headF "hi" source (node Red 0 2 []) `shouldBe` Right "hi"

    it "advances past the current node" $
-      snd <$> runAssignment "hi" headF source (makeState [ node Red 0 2 [] ])
+      snd <$> runAssignment headF "hi" source (makeState [ node Red 0 2 [] ])
      `shouldBe`
-        Right (AssignmentState 2 (Info.Pos 1 3) Nothing 1 [])
+        Right (State 2 (Info.Pos 1 3) Nothing 1 [])

  describe "children" $ do
    it "advances past the current node" $
-      snd <$> runAssignment "a" headF (children (pure (Out ""))) (makeState [node Red 0 1 []])
+      snd <$> runAssignment headF "a" (children (pure (Out ""))) (makeState [node Red 0 1 []])
      `shouldBe`
-        Right (AssignmentState 1 (Info.Pos 1 2) Nothing 1 [])
+        Right (State 1 (Info.Pos 1 2) Nothing 1 [])

    it "matches if its subrule matches" $
-      () <$ runAssignment "a" headF (children red) (makeState [node Blue 0 1 [node Red 0 1 []]])
+      () <$ runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Red 0 1 []]])
      `shouldBe`
        Right ()

    it "does not match if its subrule does not match" $
-      runAssignment "a" headF (children red) (makeState [node Blue 0 1 [node Green 0 1 []]])
+      runAssignment headF "a" (children red) (makeState [node Blue 0 1 [node Green 0 1 []]])
      `shouldBe`
-        Left (Error (Info.Pos 1 1) (UnexpectedSymbol [Red] Green))
+        Left (Error (Info.Pos 1 1) [Red] (Just Green))

    it "matches nested children" $
-      fst <$> runAssignment "1" headF
+      fst <$> runAssignment headF "1"
        (symbol Red *> children (symbol Green *> children (symbol Blue *> source)))
        (makeState [ node Red 0 1 [ node Green 0 1 [ node Blue 0 1 [] ] ] ])
      `shouldBe`
        Right "1"

    it "continues after children" $
-      fst <$> runAssignment "BC" headF
+      fst <$> runAssignment headF "BC"
        (many (symbol Red *> children (symbol Green *> source)
           <|> symbol Blue *> source))
        (makeState [ node Red 0 1 [ node Green 0 1 [] ]
@ -173,7 +172,7 @@ spec = do
        Right ["B", "C"]

    it "matches multiple nested children" $
-      fst <$> runAssignment "12" headF
+      fst <$> runAssignment headF "12"
        (symbol Red *> children (many (symbol Green *> children (symbol Blue *> source))))
        (makeState [ node Red 0 2 [ node Green 0 1 [ node Blue 0 1 [] ]
                                  , node Green 1 2 [ node Blue 1 2 [] ] ] ])
@ -182,17 +181,17 @@ spec = do

  describe "runAssignment" $ do
    it "drops anonymous nodes before matching symbols" $
-      fst <$> runAssignment "magenta red" headF red (makeState [node Magenta 0 7 [], node Red 8 11 []])
+      fst <$> runAssignment headF "magenta red" red (makeState [node Magenta 0 7 [], node Red 8 11 []])
      `shouldBe`
        Right (Out "red")

    it "does not drop anonymous nodes after matching" $
-      stateNodes . snd <$> runAssignment "red magenta" headF red (makeState [node Red 0 3 [], node Magenta 4 11 []])
+      stateNodes . snd <$> runAssignment headF "red magenta" red (makeState [node Red 0 3 [], node Magenta 4 11 []])
      `shouldBe`
        Right [node Magenta 4 11 []]

    it "does not drop anonymous nodes when requested" $
-      fst <$> runAssignment "magenta red" headF ((,) <$> magenta <*> red) (makeState [node Magenta 0 7 [], node Red 8 11 []])
+      fst <$> runAssignment headF "magenta red" ((,) <$> magenta <*> red) (makeState [node Magenta 0 7 [], node Red 8 11 []])
      `shouldBe`
        Right (Out "magenta", Out "red")

--- a/test/DiffSpec.hs
+++ b/test/DiffSpec.hs
@ -5,7 +5,6 @@ import Category
 import Data.Functor.Both
 import Data.Functor.Listable
 import RWS
-import Data.String
 import Diff
 import Info
 import Interpreter
--- a/test/InterpreterSpec.hs
+++ b/test/InterpreterSpec.hs
@ -6,7 +6,6 @@ import Data.Functor.Both
 import Data.Functor.Foldable hiding (Nil)
 import Data.Functor.Listable
 import Data.Record
-import Data.String
 import Diff
 import Interpreter
 import Patch
--- a/test/TOCSpec.hs
+++ b/test/TOCSpec.hs
@ -42,7 +42,7 @@ spec = parallel $ do
      \ diff -> let diff' = (unListableDiff diff :: Diff Syntax ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()

    prop "produces an unchanged entry for identity diffs" $
-      \ term -> let term' = (unListableF term :: SyntaxTerm '[Category]) in tableOfContentsBy (Just . headF) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')]
+      \ term -> let term' = (unListableF term :: Term Syntax (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')]

    prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
      \ patch -> let patch' = (unListableF <$> patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch'))
--- a/test/TermSpec.hs
+++ b/test/TermSpec.hs
@ -3,7 +3,6 @@ module TermSpec where

 import Category
 import Data.Functor.Listable
-import Data.String (String)
 import Prologue
 import Term
 import Test.Hspec (Spec, describe, parallel)