module FrontEnd.Diagnostic (
Diagnostic(..),
makeMsg,
locMsg,
locSimple,
simpleMsg,
dumpDiagnostic,
typeError,
TypeError (..),
) where
import Data.List as List(find)
import Data.Maybe (isJust)
import Data.Monoid
import FrontEnd.SrcLoc
import PackedString
data TypeError
= Unification String
| Failure String
typeError :: Monad m => TypeError -> [Diagnostic] -> m a
typeError err ds
= fail $ "\n" ++
"What: " ++ whatStr ++ "\n" ++
"Why: " ++ whyStr ++ "\n" ++
"Where: " ++ dumpDiagnostic 3 ds
where
(whatStr, whyStr) =
case err of
Unification s -> ("type unification error", s)
Failure s -> ("failure", s)
data Diagnostic = Msg (Maybe SrcLoc) String
deriving Show
type Description = String
simpleMsg :: Description -> Diagnostic
simpleMsg description
= Msg Nothing description
makeMsg :: Description -> String -> Diagnostic
makeMsg description val
= simpleMsg (description ++ "\n " ++ val)
locSimple :: SrcLoc -> Description -> Diagnostic
locSimple loc desc = withASrcLoc loc (simpleMsg desc)
locMsg :: SrcLoc -> Description -> String -> Diagnostic
locMsg loc desc val = locSimple loc (desc ++ "\n " ++ val)
dumpDiagnostic :: Int -> [Diagnostic] -> String
dumpDiagnostic maxContext diagnostics
= mostRecentASrcLoc ++ "\n"
++ (showDiagnostics . take maxContext $ diagnostics)
where
hasASrcLoc diag
= case diag of
Msg maybeloc _ -> isJust maybeloc
mostRecentASrcLoc
= case List.find hasASrcLoc diagnostics of
Just (Msg (Just (SrcLoc fn line col)) _)
-> "on line " ++ show line ++ " in " ++ unpackPS fn
_ -> "no line information"
showDiagnostics :: [Diagnostic] -> String
showDiagnostics diags
= case diags of
[onlyOne] -> "The error was " ++ showDiag onlyOne
_ -> showDiagnostics' diags
where
showDiagnostics' [] = ""
showDiagnostics' (diag:diags)
= case diags of
[] -> showDiag diag
_ -> showDiag diag ++ "\n" ++ showDiagnostics' diags
showDiag (Msg maybeLoc msg)
= msg
++ case maybeLoc of
Just srcloc -> "\t\t{- on line " ++ show (srcLine srcloc) ++ " -}"
_ -> ""
srcLine :: SrcLoc -> Int
srcLine = srcLocLine
withASrcLoc :: SrcLoc -> Diagnostic -> Diagnostic
withASrcLoc loc x | loc == mempty = x
withASrcLoc loc (Msg _ description) = Msg (Just loc) description