|
|
- module Errors where
-
- import Frontend.Parser.Posn
- import Data.Maybe
- import qualified GHC.IO.Handle.FD
- import System.Posix.Internals (c_isatty)
- import GHC.IO.FD
-
- data AhcError
- = AhcError { errorMessage :: String
- , errorFilename :: String
- , errorInlineDesc :: Maybe String
- , errorBegin :: Posn
- , errorEnd :: Posn
- , errorPointers :: [ErrorPointer]
- }
- deriving (Eq, Show)
-
- emptyError :: AhcError
- emptyError =
- AhcError (error "parse errors must have a message")
- (error "parse errors must have a filename")
- Nothing
- (error "parse errors must have a start pos")
- (error "parse errors must have an end pos")
- []
-
- data ErrorPointer
- = ErrorPointer { errorPointerBegin :: Posn
- , errorPointerEnd :: Posn
- , errorPointerNote :: Maybe String
- , errorPointerDrawSquiggle :: Bool
- }
- deriving (Eq, Show)
-
- showAhcError :: Bool -> [String] -> AhcError -> String
- showAhcError color code pe = do
- unlines $
- [ bold
- ++ errorFilename pe
- ++ ":" ++ show linum ++ ":" ++ show startcol ++ ": "
- ++ red ++ "parse error:" ++ reset
-
- ] ++ map (render bold red sep reset) (mainPointer:errorPointers pe) ++
- [ padToMax "" ++ " " ++ errorMessage pe
- ]
- where
- linum = posnLine (errorBegin pe)
- startcol = posnColm (errorBegin pe)
-
- maxln = maximum [ length (show (posnLine e)) | e <- errorEnd pe:map errorPointerEnd (errorPointers pe)]
-
- (red, bold, reset, sep)
- | color = ("\x1b[31m", "\x1b[1m", "\x1b[0m", "\x1b[1;34m \9474 \x1b[0m")
- | otherwise = ("", "", "", "")
-
- padToMax x
- | length x < maxln = replicate (maxln - length x) ' ' ++ x
- | otherwise = x
-
- mainPointer = ErrorPointer (errorBegin pe) (errorEnd pe) (errorInlineDesc pe) True
-
- render bold red sep reset (ErrorPointer start end note squig) = do
- let
- linum = posnLine start
- startcol = posnColm start
-
- multiline = linum /= posnLine end
-
- width
- | multiline = 0
- | otherwise = max 0 (posnColm (errorEnd pe) - startcol - 1)
-
- linum' = padToMax $ show linum
-
- line = [ show linum ++ sep ++ code !! (linum - 1) | linum <- [ linum .. posnLine (errorEnd pe) ] ]
-
- padding = replicate (length linum') ' ' ++ sep
- padding' = replicate (length linum') ' ' ++ " "
-
- caret = replicate (startcol - 1) ' ' ++ red ++ "^"
- squiggle
- | squig = replicate width '~'
- | otherwise = ""
-
- init $ unlines
- [ padding
- , init (unlines line)
- , padding ++ caret ++ squiggle ++ reset ++ fromMaybe "" ((" " ++) <$> note)
- ]
-
- printParseError :: AhcError -> IO ()
- printParseError pe = do
- code <- lines <$> readFile (errorFilename pe)
- color <- fmap (1 ==) . c_isatty . fdFD =<< GHC.IO.Handle.FD.handleToFd GHC.IO.Handle.FD.stdout
- putStr $ showAhcError color code pe
-
- pointTo :: HasPosn x => x -> x -> String -> [ErrorPointer]
- pointTo s e msg = [ErrorPointer (startPosn s) (endPosn e) (Just msg) False]
|