From 49f4a26867eb81eb59cfea78374bb09dd45edfa3 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Mon, 26 Feb 2024 21:27:58 +0100
Subject: Diagnostics refactor

---
 src/HSVIS/Parser.hs | 50 ++++++++++----------------------------------------
 1 file changed, 10 insertions(+), 40 deletions(-)

(limited to 'src/HSVIS/Parser.hs')

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