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/Diagnostic.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)
 create mode 100644 src/HSVIS/Diagnostic.hs

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

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]
-- 
cgit v1.2.3-70-g09d2