-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- | maximum number of messages that are output
-- | severness of diagnostic messages
data DiagKind = FatalError | Error | Warning | Hint | Debug deriving (Eq, Ord, Show)
-- | a diagnostic message with a position
data Diagnosis = Diag { diagKind :: DiagKind
-- | construct a message for a printable item that carries a position
mkDiag :: (PosItem a, PrettyPrint a) => DiagKind -> String -> a -> Diagnosis
Diag k (s ++ " '" ++ showPretty a "'") $ getMyPos a
-- | Check whether a diagnosis list contains errors
hasErrors :: [Diagnosis] -> Bool
hasErrors = any (\d -> diagKind d `elem` [FatalError,Error])
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- | errors for duplicates in argument, selector or constructor lists.
checkUniqueness :: (PrettyPrint a, PosItem a, Ord a) => [a] -> [Diagnosis]
let vd = filter ( not . null . tail) $ group $ sort l
in map ( \ vs -> mkDiag Error ("duplicates at '" ++
showSepList (showString " ") shortPosShow
(map getMyPos (tail vs)) "'"
where shortPosShow :: Pos -> ShowS
shortPosShow p = showParen True
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- A failing 'Result' should include a 'FatalError' message.
-- Otherwise diagnostics should be non-fatal.
data Result a = Result { diags :: [Diagnosis]
, maybeResult :: (Maybe a)
instance Functor Result where
fmap f (Result errs m) = Result errs $ fmap f m
instance Monad Result where
return x = Result [] $ Just x
Result errs Nothing >>= _ = Result errs Nothing
Result errs1 (Just x) >>= f = Result (errs1++errs2) y
where Result errs2 y = f x
fail s = fatal_error s nullPos
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- | merge together repeated or extended items
merge :: a -> a -> Result a
-- with if (c <- a `merge` b) then (c `diff' a == b)
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
ioBind :: IO(Result a) -> (a -> IO(Result b)) -> IO(Result b)
Result errs Nothing -> return (Result errs Nothing)
Result errs1 (Just v) -> do
return (Result (errs1++errs2) y)
newtype IOResult a = IOResult (IO(Result a))
instance Monad IOResult where
return x = IOResult (return (return x))
IOResult x >>= f = IOResult (x `ioBind` (\y -> let IOResult z = f y in z))
ioresToIO :: IOResult a -> IO(Result a)
ioresToIO (IOResult x) = x
ioToIORes :: IO a -> IOResult a
ioToIORes = IOResult . (fmap return)
resToIORes :: Result a -> IOResult a
resToIORes = IOResult . return
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
-- | a failing result with a proper position
fatal_error :: String -> Pos -> Result a
fatal_error s p = Result [Diag FatalError s p] Nothing
-- | add an error message but continue (within do)
plain_error :: a -> String -> Pos -> Result a
plain_error x s p = Result [Diag Error s p] $ Just x
warning :: a -> String -> Pos -> Result a
warning x s p = Result [Diag Warning s p] $ Just x
-- | add a fatal error message to a failure (Nothing)
maybeToResult :: Pos -> String -> Maybe a -> Result a
maybeToResult p s m = Result (case m of
Nothing -> [Diag FatalError s p]
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
instance Show Diagnosis where
instance PrettyPrint Diagnosis where
printText0 _ (Diag k s sp) =
instance PosItem Diagnosis where
up_pos fn1 d = d { diagPos = fn1 $ diagPos d }
instance PrettyPrint a => PrettyPrint (Result a) where
printText0 g (Result ds m) = vcat ((case m of
Just x -> printText0 g x) :