From 49f4a26867eb81eb59cfea78374bb09dd45edfa3 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Mon, 26 Feb 2024 21:27:58 +0100 Subject: Diagnostics refactor --- app/Main.hs | 10 +++++----- hs-visinter.cabal | 1 + lsp/Main.hs | 23 +++++++++++------------ src/HSVIS/Diagnostic.hs | 42 +++++++++++++++++++++++++++++++++++++++++ src/HSVIS/Parser.hs | 50 ++++++++++--------------------------------------- 5 files changed, 69 insertions(+), 57 deletions(-) create mode 100644 src/HSVIS/Diagnostic.hs diff --git a/app/Main.hs b/app/Main.hs index b88d508..bf4fcfd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,6 +6,7 @@ import Data.List (intersperse) import System.Environment (getArgs) import System.Exit (die, exitFailure) +import HSVIS.Diagnostic import HSVIS.Parser @@ -17,12 +18,11 @@ main = do _ -> die "Usage: hs-visinter [filename.hs]" prog <- case parse fname source of - This errs -> do - sequence_ $ intersperse (putStrLn "") (map (putStrLn . printErrMsg) errs) + (errs, Nothing) -> do + sequence_ $ intersperse (putStrLn "") (map (putStrLn . printDiagnostic) errs) exitFailure - These errs res -> do - sequence_ $ intersperse (putStrLn "") (map (putStrLn . printErrMsg) errs) + (errs, res) -> do + sequence_ $ intersperse (putStrLn "") (map (putStrLn . printDiagnostic) errs) return res - That res -> return res print prog diff --git a/hs-visinter.cabal b/hs-visinter.cabal index 0a179fb..0c41aa2 100644 --- a/hs-visinter.cabal +++ b/hs-visinter.cabal @@ -11,6 +11,7 @@ library exposed-modules: Control.FAlternative HSVIS.AST + HSVIS.Diagnostic HSVIS.Parser HSVIS.Pretty build-depends: diff --git a/lsp/Main.hs b/lsp/Main.hs index c3928d6..1784aec 100644 --- a/lsp/Main.hs +++ b/lsp/Main.hs @@ -15,29 +15,28 @@ import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.VFS as L import Language.LSP.Server +import qualified HSVIS.Diagnostic as HV import qualified HSVIS.Parser as HV parseFile :: NormalizedUri -> T.Text -> [Diagnostic] parseFile (NormalizedUri _ fpath) source = - case HV.parse (T.unpack fpath) (T.unpack source) of - HV.This errs -> map mkDiag errs - HV.These errs _ -> map mkDiag errs - HV.That _ -> [] + let (errs, _) = HV.parse (T.unpack fpath) (T.unpack source) + in map mkDiag errs where - mkDiag :: HV.ErrMsg -> Diagnostic + mkDiag :: HV.Diagnostic -> Diagnostic mkDiag msg = Diagnostic { _range = - let HV.Pos line col = HV.errPos msg - -- TODO: col needs to be UTF-16 based, which this is not - pos = Position (fromIntegral line) (fromIntegral col) - in Range pos pos + let -- TODO: col needs to be UTF-16 based, which this is not + mkPos (HV.Pos line col) = Position (fromIntegral line) (fromIntegral col) + HV.Range from to = HV.dRange msg + in Range (mkPos from) (mkPos to) , _severity = Just DiagnosticSeverity_Error , _code = Nothing , _codeDescription = Nothing , _source = Just "hs-vis" , _message = T.pack $ intercalate "\n" $ - HV.errMsg msg : ["In " ++ entry | entry <- reverse (HV.errStk msg)] + HV.dMsg msg : ["In " ++ entry | entry <- reverse (HV.dStk msg)] , _tags = Nothing , _relatedInformation = Nothing , _data_ = Nothing @@ -49,7 +48,7 @@ publishDiagsForUri fileUri = do Just vfile -> do let diags = parseFile (toNormalizedUri fileUri) (Rope.toText (vfile ^. L.file_text)) - liftIO $ appendFile "/home/tom/hsvislsplog.txt" (" -> publishing diags: " ++ show diags ++ "\n") + -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" (" -> publishing diags: " ++ show diags ++ "\n") sendNotification SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams { _uri = fileUri , _version = Just (vfile ^. L.lsp_version) @@ -61,7 +60,7 @@ handlers = mconcat [ notificationHandler SMethod_Initialized $ \_notif -> do sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "initialized!") - liftIO $ appendFile "/home/tom/hsvislsplog.txt" "initialized\n" + -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" "initialized\n" pure () , notificationHandler SMethod_TextDocumentDidOpen $ \notif -> do let fileUri = notif ^. L.params . L.textDocument . L.uri diff --git a/src/HSVIS/Diagnostic.hs b/src/HSVIS/Diagnostic.hs new file mode 100644 index 0000000..75a677f --- /dev/null +++ b/src/HSVIS/Diagnostic.hs @@ -0,0 +1,42 @@ +module HSVIS.Diagnostic where + +import Data.List (intercalate) + + +data Pos = Pos + { posLine :: Int -- ^ zero-based + , posCol :: Int -- ^ zero-based + } + deriving (Show) + +-- | Inclusive-exclusive range of positions in a file. +data Range = Range Pos Pos + deriving (Show) + +data Diagnostic = Diagnostic + { dFile :: FilePath -- ^ The file for which the diagnostic was raised + , dRange :: Range -- ^ Where in the file + , dStk :: [String] -- ^ Stack of contexts (innermost at head) of the diagnostic + , dSourceLine :: String -- ^ The line in the source file of the start of the range + , dMsg :: String -- ^ The error message + } + deriving (Show) + +printDiagnostic :: Diagnostic -> String +printDiagnostic (Diagnostic fp (Range (Pos y1 x1) (Pos y2 x2)) stk srcline msg) = + let linenum = show (y1 + 1) + locstr | y1 == y2, x1 == x2 = show y1 ++ ":" ++ show x1 + | y1 == y2 = show y1 ++ ":" ++ show x1 ++ "-" ++ show x2 + | otherwise = "(" ++ show y1 ++ ":" ++ show x1 ++ ")-(" ++ + show y1 ++ ":" ++ show x1 ++ ")" + ncarets | y1 == y2 = max 1 (x2 - x1 + 1) + | otherwise = length srcline - x1 + caretsuffix | y1 == y2 = "" + | otherwise = "..." + in intercalate "\n" $ + map (\descr -> "In " ++ descr ++ ":") (reverse stk) + ++ [fp ++ ":" ++ locstr ++ ": " ++ msg + ,map (\_ -> ' ') linenum ++ " |" + ,linenum ++ " | " ++ srcline + ,map (\_ -> ' ') linenum ++ " | " ++ replicate x1 ' ' ++ + replicate ncarets '^' ++ caretsuffix] diff --git a/src/HSVIS/Parser.hs b/src/HSVIS/Parser.hs index 23ce28e..f153e16 100644 --- a/src/HSVIS/Parser.hs +++ b/src/HSVIS/Parser.hs @@ -17,11 +17,6 @@ {-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} module HSVIS.Parser ( parse, - Pos(..), - ErrMsg(..), - printErrMsg, - -- * Re-exports - These(..), ) where -- import Control.Applicative @@ -32,7 +27,6 @@ import Control.Monad.State.Lazy import Data.Char import Data.Either (partitionEithers) import Data.Foldable -import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty(..)) import Data.These @@ -40,15 +34,10 @@ import Data.These import Control.FAlternative import HSVIS.AST +import HSVIS.Diagnostic import HSVIS.Pretty -data Pos = Pos - { posLine :: Int -- ^ zero-based - , posCol :: Int -- ^ zero-based - } - deriving (Show) - -- Positions are zero-based in both dimensions. -- See 'isInsideBlock' and 'isAtBlockLeft' for the two relevant "inside the -- block" conditions. @@ -75,8 +64,8 @@ newtype Parser fail a = Parser :: forall r. Context -> PS - -> (PS -> [ErrMsg] -> a -> r) -- ^ OK: some diagnostics, but parsing succeeded - -> ([ErrMsg] -> r) -- ^ Fatal: error that prevented parsing from proceeding + -> (PS -> [Diagnostic] -> a -> r) -- ^ OK: some diagnostics, but parsing succeeded + -> ([Diagnostic] -> r) -- ^ Fatal: error that prevented parsing from proceeding -> BacktrackPath fail r -- ^ Backtrack: alternative was exhausted without success -> r } @@ -125,7 +114,7 @@ instance MonadReader Context (Parser fail) where reader f = Parser $ \ctx ps kok _ _ -> kok ps [] (f ctx) local f (Parser g) = Parser (\ctx -> g (f ctx)) -instance KnownFallible fail => MonadChronicle [ErrMsg] (Parser fail) where +instance KnownFallible fail => MonadChronicle [Diagnostic] (Parser fail) where dictate errs = Parser $ \_ ps kok _ _ -> kok ps errs () confess errs = Parser $ \_ _ _ kfat _ -> kfat errs memento (Parser f) = Parser $ \ctx ps kok _ kbt -> @@ -155,33 +144,14 @@ instance KnownFallible fail => MonadChronicle [ErrMsg] (Parser fail) where That res -> Parser (\_ ps kok _ _ -> kok ps [] res) These errs res -> Parser (\_ ps kok _ _ -> kok ps errs res) --- Positions are zero-based in both dimensions -data ErrMsg = ErrMsg - { errFile :: FilePath - , errStk :: [String] - , errPos :: Pos - , errMsg :: String - , errSourceLine :: String } - deriving (Show) - -printErrMsg :: ErrMsg -> String -printErrMsg (ErrMsg fp stk (Pos y x) s srcline) = - let linenum = show (y + 1) - in intercalate "\n" $ - map (\descr -> "In " ++ descr ++ ":") (reverse stk) - ++ [fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s - ,map (\_ -> ' ') linenum ++ " |" - ,linenum ++ " | " ++ srcline - ,map (\_ -> ' ') linenum ++ " | " ++ replicate x ' ' ++ "^"] - -parse :: FilePath -> String -> These [ErrMsg] (Program ()) +parse :: FilePath -> String -> ([Diagnostic], Maybe (Program ())) parse fp source = runParser pProgram (Context fp (lines source) []) (PS (Pos 0 0) (Pos 0 0) source) (\_ errs res -> case errs of - [] -> That res - _ -> These errs res) - (\errs -> This errs) - () -- (This [ErrMsg fp [] (Pos 0 0) "Parse error, no grammar alternatives match your source"]) + [] -> ([], Just res) + _ -> (errs, Just res)) + (\errs -> (errs, Nothing)) + () -- the program parser cannot fail! :D pProgram :: IParser (Program ()) pProgram = do @@ -825,7 +795,7 @@ raise fat msg = gets psCur >>= \pos -> raiseAt pos fat msg raiseAt :: (KnownFallible fail, FatalCtx fatal a) => Pos -> Fatality fatal -> String -> Parser fail a raiseAt pos fat msg = do Context { ctxFile = fp , ctxStack = stk, ctxLines = srcLines } <- ask - let err = ErrMsg fp stk pos msg (srcLines !! posLine pos) + let err = Diagnostic fp (Range pos pos) stk (srcLines !! posLine pos) msg case fat of Error -> dictate (pure err) Fatal -> confess (pure err) -- cgit v1.2.3-70-g09d2