diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HSVIS/Diagnostic.hs | 42 | ||||
| -rw-r--r-- | src/HSVIS/Parser.hs | 50 |
2 files changed, 52 insertions, 40 deletions
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) |