Errors carry a full Span.

src/Data/Syntax/Assignment.hs

@@ -194,7 +194,7 @@ nodeLocation :: Node grammar -> Record Location
 nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil
 
 
-data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected :: [grammar], errorActual :: Maybe grammar }
+data Error grammar = HasCallStack => Error { errorSpan :: Info.Span, errorExpected :: [grammar], errorActual :: Maybe grammar }
 
 deriving instance Eq grammar => Eq (Error grammar)
 deriving instance Foldable Error
@@ -206,26 +206,26 @@ errorCallStack :: Error grammar -> CallStack
 errorCallStack Error{} = callStack
 
 nodeError :: HasCallStack => [grammar] -> Node grammar -> Error grammar
-nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart expected (Just actual)
+nodeError expected (Node actual _ span) = Error span expected (Just actual)
 
 
 type IncludeSource = Bool
 type Colourize = Bool
 
 -- | Format an 'Error', optionally with reference to the source where it occurred.
-formatError :: IncludeSource -> Colourize -> Blob -> Info.Pos -> [String] -> Maybe String -> String
+formatError :: IncludeSource -> Colourize -> Blob -> Info.Span -> [String] -> Maybe String -> String
-formatError includeSource colourize Blob{..} errorPos errorExpected errorActual
+formatError includeSource colourize Blob{..} errorSpan errorExpected errorActual
   = ($ "")
-  $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ")
+  $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan (maybe Nothing (const (Just blobPath)) blobKind) errorSpan . showString ": ")
   . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation errorExpected errorActual . showChar '\n')
   . (if includeSource
     then showString (unpack context) . (if "\n" `isSuffixOf` context then id else showChar '\n')
-       . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n')
+       . showString (replicate (succ (Info.posColumn (Info.spanStart errorSpan) + lineNumberDigits)) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n')
     else id)
   . showString (prettyCallStack callStack) . showChar '\n'
-  where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (pack (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ])
+  where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (pack (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine (Info.spanStart errorSpan) - 2, Info.posLine (Info.spanStart errorSpan)) i ])
         showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
-        lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine errorPos) :: Double)))
+        lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.posLine (Info.spanStart errorSpan)) :: Double)))
 
 withSGRCode :: Bool -> [SGR] -> ShowS -> ShowS
 withSGRCode useColour code content =
@@ -248,8 +248,9 @@ showSymbols [a, b] = showString a . showString " or " . showString b
 showSymbols [a, b, c] = showString a . showString ", " . showString b . showString ", or " . showString c
 showSymbols (h:t) = showString h . showString ", " . showSymbols t
 
-showPos :: Maybe FilePath -> Info.Pos -> ShowS
+showSpan :: Maybe FilePath -> Info.Span -> ShowS
-showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . shows posLine . showChar ':' . shows posColumn
+showSpan path Info.Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if spanStart == spanEnd then showPos spanStart else showPos spanStart . showChar '-' . showPos spanEnd)
+  where showPos Info.Pos{..} = shows posLine . showChar ':' . shows posColumn
 
 
 firstSet :: Ix grammar => Assignment ast grammar a -> [grammar]
@@ -314,7 +315,7 @@ runAssignment toNode source = (\ assignment state -> go assignment state >>= req
                 state@State{..} = if not (null expectedSymbols) && all ((== Regular) . symbolType) expectedSymbols then dropAnonymous initialState else initialState
                 expectedSymbols = firstSet (assignment `Then` return)
                 makeError :: HasCallStack => Maybe (F.Base ast ast) -> Error grammar
-                makeError node = maybe (Error statePos expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node
+                makeError node = maybe (Error (Info.Span statePos statePos) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node
 
         requireExhaustive :: HasCallStack => (result, State ast) -> Either (Error grammar, State ast) (result, State ast)
         requireExhaustive (a, state) = let state' = dropAnonymous state in case stateNodes state' of

src/Renderer/TOC.hs

@@ -125,7 +125,7 @@ declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syn
 declarationAlgebra blob@Blob{..} (a :< r)
   | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier))
   | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier))
-  | Just (Syntax.Error errorExpected errorActual _) <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (spanStart (sourceSpan a)) errorExpected errorActual)) blobLanguage
+  | Just (Syntax.Error errorExpected errorActual _) <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (sourceSpan a) errorExpected errorActual)) blobLanguage
   | otherwise = Nothing
   where getSource = toText . flip Source.slice blobSource . byteRange
 
@@ -135,7 +135,7 @@ markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fiel
                      -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
 markupSectionAlgebra blob@Blob{..} (a :< r)
   | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level
-  | Just (Syntax.Error errorExpected errorActual _) <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (spanStart (sourceSpan a)) errorExpected errorActual)) blobLanguage
+  | Just (Syntax.Error errorExpected errorActual _) <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (sourceSpan a) errorExpected errorActual)) blobLanguage
   | otherwise = Nothing
   where getSource = firstLine . toText . flip Source.slice blobSource . byteRange
         firstLine = T.takeWhile (/= '\n')

src/Semantic/Task.hs

@@ -199,19 +199,19 @@ runParser Options{..} blob@Blob{..} = go
               Left err -> writeLog Error "failed parsing" blobFields >> pure (Left err)
               Right ast -> logTiming "assign" $ case Assignment.assignBy by blobSource assignment ast of
                 Left Assignment.Error{..} -> do
-                  writeLog Error (Assignment.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob errorPos (show <$> errorExpected) (show <$> errorActual)) blobFields
+                  writeLog Error (Assignment.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob errorSpan (show <$> errorExpected) (show <$> errorActual)) blobFields
                   pure $ Right (Syntax.makeTerm (totalRange blobSource :. totalSpan blobSource :. Nil) (Syntax.Error (show <$> errorExpected) (show <$> errorActual) []))
                 Right term -> do
-                  for_ (errors term) $ \ (errorPos, errorExpected, errorActual) ->
+                  for_ (errors term) $ \ (errorSpan, errorExpected, errorActual) ->
-                    writeLog Warning (Assignment.formatError optionsPrintSource optionsEnableColour blob errorPos errorExpected errorActual) blobFields
+                    writeLog Warning (Assignment.formatError optionsPrintSource optionsEnableColour blob errorSpan errorExpected errorActual) blobFields
                   pure $ Right term
           TreeSitterParser tslanguage -> logTiming "ts parse" $ liftIO (Right <$> treeSitterParser tslanguage blob)
           MarkdownParser -> logTiming "cmark parse" $ pure (Right (cmarkParser blobSource))
           LineByLineParser -> logTiming "line-by-line parse" $ pure (Right (lineByLineParser blobSource))
         blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ]
-        errors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> [(Pos, [String], Maybe String)]
+        errors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> [(Span, [String], Maybe String)]
         errors = cata $ \ (a :< syntax) -> case syntax of
-          _ | Just (Syntax.Error expected actual _) <- prj syntax -> [(spanStart (sourceSpan a), expected, actual)]
+          _ | Just (Syntax.Error expected actual _) <- prj syntax -> [(sourceSpan a, expected, actual)]
           _ -> fold syntax
         logTiming :: String -> Task a -> Task a
         logTiming msg = time msg blobFields