aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--app/Main.hs10
-rw-r--r--hs-visinter.cabal1
-rw-r--r--lsp/Main.hs23
-rw-r--r--src/HSVIS/Diagnostic.hs42
-rw-r--r--src/HSVIS/Parser.hs50
5 files changed, 69 insertions, 57 deletions
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)
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-01 07:27:02 +0100