Skip to content

Instantly share code, notes, and snippets.

@lynn
Last active October 20, 2020 09:29
Show Gist options
  • Save lynn/46dff5b6cff3851bc4a176d3859664e2 to your computer and use it in GitHub Desktop.
Save lynn/46dff5b6cff3851bc4a176d3859664e2 to your computer and use it in GitHub Desktop.
Pretty ParseErrors for Text.Parsec
module PrettyParseError (
prettyParseError,
PrettyParseErrorOptions(PrettyParseErrorOptions),
prettyParseErrorDefaults
) where
import Data.List (intercalate, nub)
import Text.Parsec
import Text.Parsec.Error
import Text.Parsec.Pos
import Text.Parsec.String (Parser)
data PrettyParseErrorOptions =
PrettyParseErrorOptions
{ color :: Bool
, contextLineCount :: Int
, loudEscapeCode :: String
, softEscapeCode :: String
}
prettyParseErrorDefaults :: PrettyParseErrorOptions
prettyParseErrorDefaults =
PrettyParseErrorOptions True 1 "\ESC[31;1m" "\ESC[35m"
prettyParseError :: PrettyParseErrorOptions -> ParseError -> String -> String
prettyParseError (PrettyParseErrorOptions color clc lec sec) error source =
let
-- Colors
dull = if color then "\ESC[0m" else ""
loud = if color then lec else ""
soft = if color then sec else ""
-- Helper functions
spaces n = replicate n ' '
pad n s = spaces (n - length s) ++ s
joinOr [] = ""
joinOr [s] = s
joinOr [s,t] = s ++ " or " ++ t
joinOr (s:t:u) = s ++ ", " ++ joinOr (t:u)
-- Data about the error
msgs = errorMessages error
pos = errorPos error
name = sourceName pos
y = sourceLine pos - 1
x = sourceColumn pos - 1
sourceLines = lines source
address = name ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1)
-- Message display
showMsg (SysUnExpect s) = "unexpected " ++ s
showMsg (UnExpect s) = "unexpected " ++ s
showMsg (Expect s) = "expected " ++ s
showMsg (Message s) = s
showMsgs [] = "unknown parse error"
showMsgs [m] = showMsg m
showMsgs (m:ms) = showMsg m ++ "\n" ++ showMsgs ms
unexpections = joinOr $ nub $ [s | SysUnExpect s <- msgs, s /= ""]
++ [s | UnExpect s <- msgs, s /= ""]
expections = joinOr $ nub [s | Expect s <- msgs, s /= ""]
cleanMsgs = [UnExpect unexpections | unexpections /= ""]
++ [Expect expections | expections /= ""]
++ nub [Message s | Message s <- msgs]
-- Margin display
marginSize = max 3 $ length $ show $ length sourceLines
margin l r = soft ++ pad marginSize l ++ " | " ++ dull ++ r
number i line = margin (show i) line
numbered = zipWith number [1..] sourceLines
-- Explanation display
-- (Wrap lines to "not much more than 50 chars" at any indentation.)
-- (The wrapping is for readability, not to meet a term width)
continue line = margin "" line
pointer = continue (spaces x) ++ loud ++ "^-- "
newline = dull ++ "\n" ++ continue (spaces (x + 4)) ++ loud
wrap n [] = dull
wrap n (w:ws) | n >= 50 = newline ++ w ++ wrap (length w) ws
| otherwise = " " ++ w ++ wrap (n + length w + 1) ws
msgLines = lines (showMsgs cleanMsgs)
wrappedLines = map (drop 1 . wrap 0 . words) msgLines
explanationBody = intercalate newline wrappedLines
explanation = pointer ++ explanationBody
-- Final output
flower = replicate marginSize '~' ++ "~@ "
header = soft ++ flower ++ address ++ dull
before = drop (y - clc) $ take y numbered
focused = numbered !! y
after = take clc $ drop (y + 1) numbered
in
unlines $ header : before ++ (focused : explanation : after)
------------------------------ cut here ------------------------------------
-- An example grammar:
data RValue = Lit Integer | Var String deriving (Eq, Show)
data AssignOp = Set | Add | Sub deriving (Eq, Show)
data CompareOp = Less | Equal | Greater deriving (Eq, Show)
data Condition = Condition RValue CompareOp RValue deriving (Eq, Show)
data Statement = Assign String AssignOp RValue
| While Condition [Statement] deriving (Eq, Show)
tries :: [Parser a] -> Parser a
tries = choice . map try
lvalue :: Parser String
lvalue = many1 lower <* spaces
rvalue :: Parser RValue
rvalue = tries [Lit . read <$> many1 digit, Var <$> many1 lower] <* spaces
assignOp :: Parser AssignOp
assignOp = tries [Set <$ string "=", Add <$ string "+=", Sub <$ string "-="] <* spaces
compareOp :: Parser CompareOp
compareOp = tries [Less <$ string "<", Equal <$ string "=", Greater <$ string ">"] <* spaces
condition :: Parser Condition
condition = Condition <$> rvalue <*> compareOp <*> rvalue
braced :: Parser a -> Parser a
braced p = string "{" *> spaces *> p <* string "}" <* spaces
statement :: Parser Statement
statement = tries [While <$> (string "while" *> spaces *> condition) <*> braced (many statement),
Assign <$> lvalue <*> assignOp <*> (rvalue <* string ";" <* spaces)]
program :: Parser [Statement]
program = spaces *> many statement <* eof
-- And an example input for it:
example :: String
example = unlines [ "x = in;"
, "y = in;"
, "p = 0;"
, "while x > 0 {"
, " x --= 1;" -- oops
, " p += y;"
, "}"
, "out = p;" ]
main :: IO ()
main = do
let Left e = parse program "example.abc" example
putStrLn "\n\ESC[7m Before \ESC[0m\n"
print e
putStrLn "\n\ESC[7m After \ESC[0m\n"
putStrLn (prettyParseError prettyParseErrorDefaults e example)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment