Add source spans to terms

src/DiffSummary.hs

@@ -64,7 +64,7 @@ data DiffSummary a = DiffSummary {
 } deriving (Eq, Functor, Show, Generic)
 
 -- Returns a list of diff summary texts given two source blobs and a diff.
-diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both SourceBlob -> SyntaxDiff leaf fields -> [Either Text Text]
+diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Both SourceBlob -> SyntaxDiff leaf fields -> [Either Text Text]
 diffSummaries blobs diff = summaryToTexts =<< diffToDiffSummaries (source <$> blobs) diff
 
 -- Takes a 'DiffSummary' and returns a list of summary texts representing the LeafInfos
@@ -73,7 +73,7 @@ summaryToTexts :: DiffSummary DiffInfo -> [Either Text Text]
 summaryToTexts DiffSummary{..} = runJoin . fmap (show . (<+> parentContexts parentAnnotation)) <$> (Join <$> summaries patch)
 
 -- Returns a list of 'DiffSummary' given two source blobs and a diff.
-diffToDiffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> SyntaxDiff leaf fields -> [DiffSummary DiffInfo]
+diffToDiffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Both (Source Char) -> SyntaxDiff leaf fields -> [DiffSummary DiffInfo]
 diffToDiffSummaries sources = para $ \diff ->
   let
     diff' = free (Prologue.fst <$> diff)
@@ -170,7 +170,7 @@ toTermName source term = case unwrap term of
   S.Object kvs -> "{ " <> intercalate ", " (toTermName' <$> kvs) <> " }"
   S.Pair a _ -> toTermName' a <> ": …"
   S.Return expr -> maybe "empty" toTermName' expr
-  S.Error _ _ -> termNameFromSource term
+  S.Error _ -> termNameFromSource term
   S.If expr _ _ -> termNameFromSource expr
   S.For clauses _ -> termNameFromChildren term clauses
   S.While expr _ -> toTermName' expr
@@ -209,13 +209,13 @@ parentContexts contexts = hsep $ either identifiableDoc annotatableDoc <$> conte
 toDoc :: Text -> Doc
 toDoc = string . toS
 
-termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
+termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
 termToDiffInfo blob term = case unwrap term of
   S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BIndexed
   S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (toCategoryName term) BFixed
   S.AnonymousFunction _ _ -> LeafInfo "anonymous function" (toTermName' term)
   Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (toCategoryName term) BCommented
-  S.Error sourceSpan _ -> ErrorInfo sourceSpan (toTermName' term)
+  S.Error _ -> ErrorInfo (getField $ extract term) (toTermName' term)
   _ -> LeafInfo (toCategoryName term) (toTermName' term)
   where toTermName' = toTermName blob
         termToDiffInfo' = termToDiffInfo blob

src/Diffing.hs

@@ -36,6 +36,7 @@ import Text.Parser.TreeSitter.Language
 import qualified Data.Text as T
 import Data.Aeson (toJSON, toEncoding)
 import Data.Aeson.Encoding (encodingToLazyByteString)
+import SourceSpan
 
 -- | Given a parser and renderer, diff two sources and return the rendered
 -- | result.
@@ -68,7 +69,7 @@ diffFiles parser renderer sourceBlobs = do
           _ -> Nothing)
 
 -- | Return a parser based on the file extension (including the ".").
-parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category])
+parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan])
 parserForType mediaType = case languageForType mediaType of
   Just C -> treeSitterParser C ts_language_c
   Just JavaScript -> treeSitterParser JavaScript ts_language_javascript
@@ -77,20 +78,19 @@ parserForType mediaType = case languageForType mediaType of
   _ -> lineByLineParser
 
 -- | A fallback parser that treats a file simply as rows of strings.
-lineByLineParser :: Parser (Syntax Text) (Record '[Range, Category])
-lineByLineParser blob = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of
+lineByLineParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan])
+lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of
   (leaves, _) -> cofree <$> leaves
   where
-    input = source blob
-    lines = actualLines input
-    root children = (Range 0 (length input) .: Program .: RNil) :< Indexed children
-    leaf charIndex line = (Range charIndex (charIndex + T.length line) .: Program .: RNil) :< Leaf line
+    lines = actualLines source
+    root children = (Range 0 (length source) .: Program .: sourceRangeToSpan source (toS path) (Range 0 (length source)) .: RNil) :< Indexed children
+    leaf charIndex line = (Range charIndex (charIndex + T.length line) .: Program .: sourceRangeToSpan source (toS path) (Range charIndex (charIndex + T.length line)) .: RNil) :< Leaf line
     annotateLeaves (accum, charIndex) line =
       (accum <> [ leaf charIndex (toText line) ] , charIndex + length line)
     toText = T.pack . Source.toString
 
 -- | Return the parser that should be used for a given path.
-parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category])
+parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan])
 parserForFilepath path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob
 
 -- | Transcode a file to a unicode source.
@@ -128,7 +128,7 @@ diffCostWithCachedTermCosts diff = unCost $ case runFree diff of
   Pure patch -> sum (cost . extract <$> patch)
 
 -- | Returns a rendered diff given a parser, diff arguments and two source blobs.
-textDiff :: (HasField fields Category, HasField fields Cost, HasField fields Range) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output
+textDiff :: (HasField fields SourceSpan, HasField fields Category, HasField fields Cost, HasField fields Range) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output
 textDiff parser arguments = diffFiles parser $ case format arguments of
   Split -> split
   Patch -> patch
@@ -144,7 +144,7 @@ truncatedDiff arguments sources = pure $ case format arguments of
   Summary -> SummaryOutput mempty
 
 -- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs.
-printDiff :: (HasField fields Category, HasField fields Cost, HasField fields Range) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO ()
+printDiff :: (HasField fields SourceSpan, HasField fields Category, HasField fields Cost, HasField fields Range) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO ()
 printDiff parser arguments sources = do
   rendered <- textDiff parser arguments sources
   let renderedText = case rendered of

src/Language.hs

@@ -45,11 +45,14 @@ termConstructor
   -> IO SourceSpan -- ^ The span that the term occupies. This is passed in 'IO' to guarantee some access constraints & encourage its use only when needed (improving performance).
   -> Text -- ^ The name of the production for this node.
   -> Range -- ^ The character range that the term occupies.
-  -> [Term (S.Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
-  -> IO (Term (S.Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
+  -> [Term (S.Syntax Text) (Record '[Range, Category, SourceSpan])] -- ^ The child nodes of the term.
+  -> IO (Term (S.Syntax Text) (Record '[Range, Category, SourceSpan])) -- ^ The resulting term, in IO.
 termConstructor source sourceSpan name range children =
-  withDefaultInfo <$> case (name, children) of
-    ("ERROR", _) -> S.Error <$> sourceSpan <*> pure children
-    (_, []) -> S.Leaf <$> pure (toText $ slice range source)
-    _ -> S.Indexed <$> pure children
-  where withDefaultInfo syntax = cofree ((range .: Other name .: RNil) :< syntax)
+  withDefaultInfo $ case (name, children) of
+    ("ERROR", _) -> S.Error children
+    (_, []) -> S.Leaf (toText $ slice range source)
+    _ -> S.Indexed children
+  where
+    withDefaultInfo syntax = do
+      sourceSpan' <- sourceSpan
+      pure $! cofree ((range .: Other name .: sourceSpan' .: RNil) :< syntax)

src/Language/C.hs

@@ -15,15 +15,17 @@ termConstructor
   -> IO SourceSpan -- ^ The span that the term occupies. This is passed in 'IO' to guarantee some access constraints & encourage its use only when needed (improving performance).
   -> Text -- ^ The name of the production for this node.
   -> Range -- ^ The character range that the term occupies.
-  -> [Term (Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
-  -> IO (Term (Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
+  -> [Term (Syntax Text) (Record '[Range, Category, SourceSpan])] -- ^ The child nodes of the term.
+  -> IO (Term (Syntax Text) (Record '[Range, Category, SourceSpan])) -- ^ The resulting term, in IO.
 termConstructor source sourceSpan name range children
-  | name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children)
+  | name == "ERROR" = withDefaultInfo (S.Error children)
   | otherwise = withDefaultInfo $ case (name, children) of
   (_, []) -> S.Leaf . toText $ slice range source
   _ -> S.Indexed children
-  where withDefaultInfo syntax = pure $! cofree ((range .: categoryForCProductionName name .: RNil) :< syntax)
+  where
+    withDefaultInfo syntax = do
+      sourceSpan' <- sourceSpan
+      pure $! cofree ((range .: categoryForCProductionName name .: sourceSpan' .: RNil) :< syntax)
 
 categoryForCProductionName :: Text -> Category
-categoryForCProductionName name = case name of
-  _ -> Other name
+categoryForCProductionName name = Other name

src/Language/JavaScript.hs

@@ -23,10 +23,10 @@ termConstructor
   -> IO SourceSpan -- ^ The span that the term occupies. This is passed in 'IO' to guarantee some access constraints & encourage its use only when needed (improving performance).
   -> Text -- ^ The name of the production for this node.
   -> Range -- ^ The character range that the term occupies.
-  -> [Term (S.Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
-  -> IO (Term (S.Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
+  -> [Term (S.Syntax Text) (Record '[Range, Category, SourceSpan])] -- ^ The child nodes of the term.
+  -> IO (Term (S.Syntax Text) (Record '[Range, Category, SourceSpan])) -- ^ The resulting term, in IO.
 termConstructor source sourceSpan name range children
-  | name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children)
+  | name == "ERROR" = withDefaultInfo (S.Error children)
   | otherwise = withDefaultInfo $ case (name, children) of
     ("return_statement", _) -> S.Return (listToMaybe children)
     ("assignment", [ identifier, value ]) -> S.Assignment identifier value
@@ -37,16 +37,16 @@ termConstructor source sourceSpan name range children
       S.Indexed rest -> S.Indexed $ a : rest
       _ -> S.Indexed children
     ("function_call", _) -> case runCofree <$> children of
-      [ (_ :< S.MemberAccess{..}), (_ :< S.Args args) ] -> S.MethodCall memberId property args
-      [ (_ :< S.MemberAccess{..}) ] -> S.MethodCall memberId property []
-      [ function, (_ :< S.Args args) ] -> S.FunctionCall (cofree function) args
+      [ _ :< S.MemberAccess{..}, _ :< S.Args args ] -> S.MethodCall memberId property args
+      [ _ :< S.MemberAccess{..} ] -> S.MethodCall memberId property []
+      [ function, _ :< S.Args args ] -> S.FunctionCall (cofree function) args
       (x:xs) -> S.FunctionCall (cofree x) (cofree <$> xs)
       _ -> S.Indexed children
-    ("ternary", (condition:cases)) -> S.Ternary condition cases
+    ("ternary", condition : cases) -> S.Ternary condition cases
     ("arguments", _) -> S.Args children
     ("var_assignment", [ x, y ]) -> S.VarAssignment x y
     ("var_declaration", _) -> S.Indexed $ toVarDecl <$> children
-    ("switch_statement", (expr:rest)) -> S.Switch expr rest
+    ("switch_statement", expr : rest) -> S.Switch expr rest
     ("case", [ expr, body ]) -> S.Case expr body
     ("object", _) -> S.Object $ foldMap toTuple children
     ("pair", _) -> S.Fixed children
@@ -78,8 +78,12 @@ termConstructor source sourceSpan name range children
           _ -> S.Indexed children
     (_, []) -> S.Leaf . toText $ slice range source
     _ -> S.Indexed children
-  where withDefaultInfo syntax@(S.MethodCall _ _ _) = pure $! cofree ((range .:  MethodCall .: RNil) :< syntax)
-        withDefaultInfo syntax = pure $! cofree ((range .: categoryForJavaScriptProductionName name .: RNil) :< syntax)
+  where
+    withDefaultInfo syntax = do
+      sourceSpan' <- sourceSpan
+      pure $! case syntax of
+        S.MethodCall{} -> cofree ((range .:  MethodCall .: sourceSpan' .: RNil) :< syntax)
+        _ -> cofree ((range .: categoryForJavaScriptProductionName name .: sourceSpan' .: RNil) :< syntax)
 
 categoryForJavaScriptProductionName :: Text -> Category
 categoryForJavaScriptProductionName name = case name of
@@ -145,7 +149,7 @@ categoryForJavaScriptProductionName name = case name of
   _ -> Other name
 
 toVarDecl :: (HasField fields Category) => Term (S.Syntax Text) (Record fields) -> Term (S.Syntax Text) (Record fields)
-toVarDecl child = cofree $ (setCategory (extract child) VarDecl :< S.VarDecl child)
+toVarDecl child = cofree $ setCategory (extract child) VarDecl :< S.VarDecl child
 
 toTuple :: Term (S.Syntax Text) (Record fields) -> [Term (S.Syntax Text) (Record fields)]
 toTuple child | S.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]

src/Language/Markdown.hs

@@ -12,16 +12,21 @@ import Source
 import SourceSpan
 import Syntax
 
-cmarkParser :: Parser (Syntax Text) (Record '[Range, Category])
-cmarkParser SourceBlob{..} = pure . toTerm (totalRange source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source)
-  where toTerm :: Range -> Node -> Cofree (Syntax Text) (Record '[Range, Category])
-        toTerm within (Node position t children) = let range = maybe within (sourceSpanToRange source . toSpan) position in cofree $ (range .: toCategory t .: RNil) :< case t of
+cmarkParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan])
+cmarkParser SourceBlob{..} = pure . toTerm (totalRange source) (sourceRangeToSpan source (toS path) $ totalRange source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source)
+  where toTerm :: Range -> SourceSpan -> Node -> Cofree (Syntax Text) (Record '[Range, Category, SourceSpan])
+        toTerm within withinSpan (Node position t children) =
+          let
+            range = maybe within (sourceSpanToRange source . toSpan) position
+            span = maybe withinSpan toSpan position
+          in
+            cofree $ (range .: toCategory t .: span .: RNil) :< case t of
           -- Leaves
           CODE text -> Leaf text
           TEXT text -> Leaf text
           CODE_BLOCK _ text -> Leaf text
           -- Branches
-          _ -> Indexed (toTerm range <$> children)
+          _ -> Indexed (toTerm range span <$> children)
 
         toCategory :: NodeType -> Category
         toCategory (TEXT _) = Other "text"
@@ -29,10 +34,10 @@ cmarkParser SourceBlob{..} = pure . toTerm (totalRange source) $ commonmarkToNod
         toCategory (HTML_BLOCK _) = Other "html"
         toCategory (HTML_INLINE _) = Other "html"
         toCategory (HEADING _) = Other "heading"
-        toCategory (LIST (ListAttributes{..})) = Other $ case listType of
+        toCategory (LIST ListAttributes{..}) = Other $ case listType of
           BULLET_LIST -> "unordered list"
           ORDERED_LIST -> "ordered list"
-        toCategory (LINK{}) = Other "link"
-        toCategory (IMAGE{}) = Other "image"
+        toCategory LINK{} = Other "link"
+        toCategory IMAGE{} = Other "image"
         toCategory t = Other (show t)
         toSpan PosInfo{..} = SourceSpan "" (SourcePos (pred startLine) (pred startColumn)) (SourcePos (pred endLine) endColumn)

src/Renderer/JSON.hs

@@ -94,7 +94,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category
   S.Constructor expr -> [ "constructorExpression" .= expr ]
   S.Comment _ -> []
   S.Commented comments child -> childrenFields (comments <> maybeToList child)
-  S.Error sourceSpan c -> [ "sourceSpan" .= sourceSpan ] <> childrenFields c
+  S.Error c -> childrenFields c
   S.Throw c -> [ "throwExpression" .= c ]
   S.Try body catch finally -> [ "tryBody" .= body ] <> [ "tryCatch" .= catch ] <> [ "tryFinally" .= finally ]
   S.Array c -> childrenFields c

src/Renderer/Summary.hs

@@ -9,8 +9,9 @@ import Range
 import DiffSummary
 import Data.Map as Map hiding (null)
 import Source
+import SourceSpan
 
-summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields)
+summary :: (HasField fields Category, HasField fields Range, HasField fields SourceSpan) => Renderer (Record fields)
 summary blobs diff = SummaryOutput $ Map.fromList [
     ("changes", changes),
     ("errors", errors)

src/Source.hs

@@ -91,7 +91,7 @@ actualLineRanges :: Range -> Source Char -> [Range]
 actualLineRanges range = drop 1 . scanl toRange (Range (start range) (start range)) . actualLines . slice range
   where toRange previous string = Range (end previous) $ end previous + length string
 
--- | Compute the character range corresponding to a given SourceSpan within a Source.
+-- | Compute the character range given a Source and a SourceSpan.
 sourceSpanToRange :: Source Char -> SourceSpan -> Range
 sourceSpanToRange source SourceSpan{..} = Range start end
   where start = sumLengths leadingRanges + column spanStart
@@ -99,6 +99,14 @@ sourceSpanToRange source SourceSpan{..} = Range start end
         (leadingRanges, remainingRanges) = splitAt (line spanStart) (actualLineRanges (totalRange source) source)
         sumLengths = sum . fmap (\ Range{..} -> end - start)
 
+sourceRangeToSpan :: Source Char -> Text -> Range -> SourceSpan
+sourceRangeToSpan source name range@Range{} = SourceSpan name startPos endPos
+  where startPos = maybe (SourcePos 0 0) (toStartPos 0) (head lineRanges)
+        endPos = toEndPos (length lineRanges) (last lineRanges)
+        lineRanges = actualLineRanges range source
+        toStartPos line range = SourcePos line (start range)
+        toEndPos line range = SourcePos line (end range)
+
 
 instance Semigroup (Source a) where
   Source a <> Source b = Source (a Vector.++ b)

src/Syntax.hs

@@ -5,7 +5,6 @@ import Prologue
 import Data.Mergeable
 import GHC.Generics
 import Test.QuickCheck hiding (Fixed)
-import SourceSpan
 
 -- | A node in an abstract syntax tree.
 --
@@ -57,7 +56,7 @@ data Syntax a f
   | Comment a
   -- | A term preceded or followed by any number of comments.
   | Commented [f] (Maybe f)
-  | Error SourceSpan [f]
+  | Error [f]
   | For [f] f
   | DoWhile { doWhileBody :: f, doWhileExpr :: f }
   | While { whileExpr :: f, whileBody :: f }

src/TreeSitter.hs

@@ -19,7 +19,7 @@ import SourceSpan
 import Info
 
 -- | Returns a TreeSitter parser for the given language and TreeSitter grammar.
-treeSitterParser :: Language -> Ptr TS.Language -> Parser (Syntax.Syntax Text) (Record '[Range, Category])
+treeSitterParser :: Language -> Ptr TS.Language -> Parser (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan])
 treeSitterParser language grammar blob = do
   document <- ts_document_make
   ts_document_set_language document grammar
@@ -31,7 +31,7 @@ treeSitterParser language grammar blob = do
     pure term)
 
 -- | Return a parser for a tree sitter language & document.
-documentToTerm :: Language -> Ptr Document -> Parser (Syntax.Syntax Text) (Record '[Range, Category])
+documentToTerm :: Language -> Ptr Document -> Parser (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan])
 documentToTerm language document SourceBlob{..} = alloca $ \ root -> do
   ts_document_root_node_p document root
   toTerm root
@@ -43,9 +43,11 @@ documentToTerm language document SourceBlob{..} = alloca $ \ root -> do
 
           let range = Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node }
 
-          let sourceSpan = SourceSpan { spanName = toS path
+          let sourceSpan = SourceSpan {
+              spanName = toS path
             , spanStart = SourcePos (fromIntegral $! ts_node_p_start_point_row node) (fromIntegral $! ts_node_p_start_point_column node)
-            , spanEnd = SourcePos (fromIntegral $! ts_node_p_end_point_row node) (fromIntegral $! ts_node_p_end_point_column node) }
+            , spanEnd = SourcePos (fromIntegral $! ts_node_p_end_point_row node) (fromIntegral $! ts_node_p_end_point_column node)
+          }
 
           -- Note: The strict application here is semantically important.
           -- Without it, we may not evaluate the range until after we’ve exited