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

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

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
+data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: Maybe grammar }
-  Error
-    :: HasCallStack
-    => { errorPos :: Info.Pos
-       , errorCause :: ErrorCause grammar
-       } -> Error grammar
 
 deriving instance Eq grammar => Eq (Error grammar)
 deriving instance Show grammar => Show (Error grammar)
 
-data ErrorCause grammar
+nodeError :: [grammar] -> Node grammar -> Error grammar
-  = UnexpectedSymbol [grammar] grammar
+nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart expected (Just actual)
-  | UnexpectedEndOfInput [grammar]
-  deriving (Eq, Show)
 
--- | 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
+printError blob error = do
-  withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr $ showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": "
+  options <- optionsForHandle stderr
-  withSGRCode [SetColor Foreground Vivid Red] . putStrErr $ showString "error" . showString ": " . showExpectation error . showChar '\n'
+  hPutStr stderr $ formatErrorWithOptions options blob error
-  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'
+-- | Format an 'Error', optionally with reference to the source where it occurred.
-  putStrErr $ showString (prettyCallStack callStack) . showChar '\n'
+--
+-- > 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 :: Bool -> [SGR] -> ShowS -> ShowS
-withSGRCode code action = do
+withSGRCode useColour code content =
-  isTerm <- hIsTerminalDevice stderr
+  if useColour then
-  if isTerm then do
+    showString (setSGRCode code)
-    _ <- hSetSGR stderr code
+    . content
-    _ <- action
+    . showString (setSGRCode [])
-    hSetSGR stderr []
+  else
-  else do
+    content
-    _ <- action
-    pure ()
 
-showExpectation :: Show grammar => Error grammar -> ShowS
+showExpectation :: Show grammar => [grammar] -> Maybe grammar -> ShowS
-showExpectation Error{..} = case errorCause of
+showExpectation [] Nothing = showString "no rule to match at end of input nodes"
-  UnexpectedEndOfInput [] -> showString "no rule to match at end of input nodes"
+showExpectation expected Nothing = showString "expected " . showSymbols expected . showString " at end of input nodes"
-  UnexpectedEndOfInput symbols -> showString "expected " . showSymbols symbols . showString " at end of input nodes"
+showExpectation expected (Just actual) = showString "expected " . showSymbols expected . showString ", but got " . shows actual
-  UnexpectedSymbol symbols a -> showString "expected " . showSymbols symbols . showString ", but got " . shows a
 
 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)
+         => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast.
-  -> Assignment ast grammar a
+         -> Source.Source                          -- ^ The source for the parse tree.
-  -> Source.Source
+         -> Assignment ast grammar a               -- ^ The 'Assignment to run.
-  -> ast
+         -> ast                                    -- ^ The root of the ast.
-  -> Either (Error grammar) a
+         -> Either (Error grammar) a               -- ^ 'Either' an 'Error' or the assigned value.
-assignBy toNode assignment source = fmap fst . assignAllFrom source toNode assignment . makeState . pure
+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)
+-- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively.
-  => 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.
 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)        -- ^ A function to project a 'Node' from the ast.
-  -> (forall x. Base ast x -> Node grammar)
+              -> Source.Source                                 -- ^ The source for the parse tree.
-  -> Assignment ast grammar a
+              -> Assignment ast grammar a                      -- ^ The 'Assignment' to run.
-  -> AssignmentState ast grammar
+              -> State ast grammar                             -- ^ The current state.
-  -> Either (Error grammar) (a, AssignmentState ast grammar)
+              -> Either (Error grammar) (a, State ast grammar) -- ^ 'Either' an 'Error' or the pair of the assigned value & updated state.
-runAssignment source toNode = iterFreer run . fmap ((pure .) . (,))
+runAssignment toNode source = (requireExhaustive <=<) . go
-  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)
+  where go :: Assignment ast grammar result -> State ast grammar -> Either (Error grammar) (result, State ast grammar)
-        run assignment yield initialState = case (assignment, stateNodes state) of
+        go = iterFreer run . fmap ((pure .) . (,))
-          (Location, node : _) -> yield (nodeLocation (toNode (F.project node))) state
+        {-# INLINE go #-}
-          (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
+        run :: AssignmentF ast grammar x
-          (Source, node : _) -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode (F.project node))) source)) (advanceState toNode state)
+            -> (x -> State ast grammar -> Either (Error grammar) (result, State ast grammar))
-          (Children childAssignment, node : _) -> do
+            -> State ast grammar
-            (a, state') <- assignAllFrom source toNode childAssignment state { stateNodes = toList (F.project node) }
+            -> Either (Error grammar) (result, State ast grammar)
-            yield a (advanceState toNode state' { stateNodes = stateNodes state })
+        run assignment yield initialState = maybe (anywhere Nothing) (atNode . F.project) (listToMaybe (stateNodes state))
-          (Choose choices, node : _) | Node symbol _ _ <- toNode (F.project node), Just a <- IntMap.lookup (fromEnum symbol) choices -> yield a state
+          where atNode node = case assignment of
-          (Many rule, _) -> uncurry yield (runMany rule state)
+                  Location -> yield (nodeLocation (toNode node)) 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.
+                  Project projection -> yield (projection node) state
-          (Alt a b, _) -> case yield a state of
+                  Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange (toNode node)) source)) (advance state)
-            Left err -> yield b state { stateError = Just err }
+                  Children child -> do
-            r -> r
+                    (a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive
-          (Throw e, _) -> Left e
+                    yield a (advance state' { stateNodes = stateNodes state })
-          (Catch during handler, _) -> case yield during state of
+                  Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state
-            Left err -> yield (handler err) state
+                  _ -> anywhere (Just node)
-            Right (a, state') -> Right (a, state')
+
-          (_, []) -> Left (Error (statePos state) (UnexpectedEndOfInput expectedSymbols))
+                anywhere node = case assignment of
-          (_, ast:_) -> let Node symbol _ (Info.Span spanStart _) = toNode (F.project ast) in Left (Error spanStart (UnexpectedSymbol expectedSymbols symbol))
+                  Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state
-          where state = case assignment of
+                  Many rule -> uncurry yield (runMany rule state)
-                  Choose choices | all ((== Regular) . symbolType) (choiceSymbols choices) -> dropAnonymous toNode initialState
+                  Alt a b -> yield a state `catchError` (yield b . setStateError state . Just)
-                  _ -> initialState
+                  Throw e -> Left e
-                expectedSymbols = case assignment of
+                  Catch during handler -> yield during state `catchError` (flip yield state . handler)
-                  Choose choices -> choiceSymbols choices
+                  _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node)
-                  _ -> []
+
-                choiceSymbols choices = (toEnum :: Int -> grammar) <$> IntMap.keys choices
+                state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState
-                runMany :: Assignment ast grammar v -> AssignmentState ast grammar -> ([v], AssignmentState ast grammar)
+                      | otherwise = initialState
-                runMany rule state = case runAssignment source toNode rule state of
+                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' ->
+                  Right (a, state') | ((/=) `on` stateCounter) state state', (as, state'') <- loop state' -> as `seq` (a : as, state'')
-                                        let (as, state'') = runMany rule state'
-                                        in 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
+        requireExhaustive :: (result, State ast grammar) -> Either (Error grammar) (result, State ast grammar)
-dropAnonymous toNode state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) }
+        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
+        dropAnonymous state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . toNode . F.project) (stateNodes state) }
--- stateNodes & its corresponding bytes off of source, and updating stateOffset &
+
--- statePos to its end. Exhausted 'AssignmentState's (those without any
+        -- 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.
--- remaining nodes) are returned unchanged.
+        advance state@State{..}
-advanceState :: Recursive ast => (forall x. Base ast x -> Node grammar) -> AssignmentState ast grammar -> AssignmentState ast grammar
+          | node : rest <- stateNodes
-advanceState toNode state@AssignmentState{..}
+          , Node{..} <- toNode (F.project node) = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest
-  | node : rest <- stateNodes
+          | otherwise = state
-  , Node{..} <- toNode (F.project node) = AssignmentState (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateError (succ stateCounter) rest
-  | otherwise = state
 
 -- | State kept while running 'Assignment's.
-data AssignmentState ast grammar = AssignmentState
+data State ast grammar = State
-  { stateOffset :: Int -- ^ The offset into the Source thus far reached, measured in bytes.
+  { 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.
+  , statePos :: Info.Pos                -- ^ The (1-indexed) line/column position in the Source thus far reached.
-  , stateError :: Maybe (Error grammar)
+  , 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.
+  , 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.”
+  , 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 :: [ast] -> State ast grammar
-makeState = AssignmentState 0 (Info.Pos 1 1) Nothing 0
+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

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

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

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)

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

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)]

src/Parser.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
 module Parser
-( Parser
+( Parser(..)
-, runParser
 -- 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
+  C -> TreeSitterParser tree_sitter_c
-  Go -> TreeSitterParser Go tree_sitter_go
+  Go -> TreeSitterParser tree_sitter_go
-  JSON -> TreeSitterParser JSON tree_sitter_json
+  JSON -> TreeSitterParser tree_sitter_json
-  JavaScript -> TreeSitterParser TypeScript tree_sitter_typescript
+  JavaScript -> TreeSitterParser tree_sitter_typescript
-  Ruby -> TreeSitterParser Ruby tree_sitter_ruby
+  Ruby -> TreeSitterParser tree_sitter_ruby
-  TypeScript -> TreeSitterParser TypeScript tree_sitter_typescript
+  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

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
+runTask = runTaskWithOptions defaultOptions
-  ReadBlobs source -> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield
+
-  ReadBlobPairs source -> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield
+-- | Execute a 'Task' with the passed 'Options', yielding its result value in 'IO'.
-  WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
+runTaskWithOptions :: Options -> Task a -> IO a
-  Parse parser blob -> runParser parser blob >>= yield
+runTaskWithOptions options task = do
-  Decorate algebra term -> yield (decoratorWithAlgebra algebra term)
+  options <- configureOptionsForHandle stderr options
-  Diff differ terms -> yield (differ terms)
+  logQueue <- newTMQueueIO
-  Render renderer input -> yield (renderer input)
+  logging <- async (logSink options logQueue)
-  Distribute tasks -> Async.mapConcurrently runTask tasks >>= yield . withStrategy (parTraversable rseq)
+
+  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

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 :: ParserInfo (Task.Options, Task.Task ())
-arguments = info (version <*> helper <*> argumentsParser) description
+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 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 JSONDiffRenderer)        (long "json" <> help "Output a json diff")
-          <|> flag' (SomeRenderer SExpressionDiffRenderer)                            (long "sexpression" <> help "Output an s-expression diff tree")
+          <|> 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 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 JSONTermRenderer)        (long "json" <> help "Output JSON parse trees")
-          <|> flag' (SomeRenderer ToCTermRenderer)                                                (long "toc" <> help "Output a table of contents for a file"))
+          <|> 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)

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)

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

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 :: Ptr TS.Language -> Blob -> IO (SyntaxTerm DefaultFields)
-treeSitterParser language grammar source = bracket ts_document_new ts_document_free $ \ document -> do
+treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ document -> do
-  ts_document_set_language document grammar
+  ts_document_set_language document language
-  unsafeUseAsCStringLen (sourceBytes source) $ \ (sourceBytes, len) -> do
+  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 :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Blob -> IO (A.AST grammar)
-parseToAST language source = bracket ts_document_new ts_document_free $ \ document -> do
+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 :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm DefaultFields)
-documentToTerm language document allSource = do
+documentToTerm language document Blob{..} = do
   root <- alloca (\ rootPtr -> do
     ts_document_root_node_p document rootPtr
     peek rootPtr)
-  toTerm root (slice (nodeRange root) allSource)
+  toTerm root
-  where toTerm :: Node -> Source -> IO (SyntaxTerm DefaultFields)
+  where toTerm :: Node -> IO (SyntaxTerm DefaultFields)
-        toTerm node source = do
+        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))
+  where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
-        assignTermByLanguage language = case language of
+        assignTermByLanguage = case languageForTSLanguage language of
-          C -> C.termAssignment
+          Just C -> C.termAssignment
-          Language.Go -> Go.termAssignment
+          Just Language.Go -> Go.termAssignment
-          Ruby -> Ruby.termAssignment
+          Just Ruby -> Ruby.termAssignment
-          TypeScript -> TS.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
+    byLanguage language = case languageForTSLanguage language of
-      C -> C.categoryForCProductionName
+      Just C -> C.categoryForCProductionName
-      Ruby -> Ruby.categoryForRubyName
+      Just Ruby -> Ruby.categoryForRubyName
-      Language.Go -> Go.categoryForGoName
+      Just Language.Go -> Go.categoryForGoName
-      TypeScript -> TS.categoryForTypeScriptName
+      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)
+  ]

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
+  insert :: Term Syntax (Record '[Range]) -> p
-  delete :: SyntaxTerm '[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
 

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

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
+      runAssignment headF "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Info.Pos 1 1) [] (Just Red))
-      snd <$> runAssignment "hi" headF (symbol Red) initialState `shouldBe` Right initialState
 
   describe "without catchError" $ do
-    it "assignment returns UnexpectedSymbol" $
+    it "assignment returns unexpected symbol error" $
-      runAssignment "A" headF
+      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" $
+    it "assignment returns unexpected end of input" $
-      runAssignment "A" headF
+      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")
 

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

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

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'))

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)