Diagnostics refactor

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)