module HSVIS.Diagnostic where

import Data.List (intercalate)

import HSVIS.Pretty


data Pos = Pos
  { posLine :: Int  -- ^ zero-based
  , posCol :: Int   -- ^ zero-based
  }
  deriving (Show, Eq, Ord)

instance Pretty Pos where
  prettysPrec _ (Pos y x) = showString (show (y + 1) ++ ":" ++ show (x + 1))

-- | Inclusive-exclusive range of positions in a file.
data Range = Range Pos Pos
  deriving (Show)

instance Semigroup Range where
  Range a b <> Range c d = Range (min a c) (max b d)

instance Pretty Range where
  prettysPrec _ (Range (Pos y1 x1) (Pos y2 x2))
    | y2 <= y1 + 1, x2 <= x1 + 1 = showString (show (y1 + 1) ++ ":" ++ show (x1 + 1))
    | y2 <= y1 + 1               = showString (show (y1 + 1) ++ ":" ++ show (x1 + 1) ++ "-" ++ show x2)
    | otherwise                  =
        showString ("(" ++ show (y1 + 1) ++ ":" ++ show (x1 + 1) ++ ")-(" ++ show (y2 + 1) ++ ":" ++ show x2 ++ ")") 
                                                                           
data Diagnostic = Diagnostic                                               
  { dFile :: FilePath      -- ^ The file for which the diagnostic was rai  sed
  , 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 rng@(Range (Pos y1 x1) (Pos y2 x2)) stk srcline msg) =
  let linenum = show (y1 + 1)
      locstr = pretty rng
      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]