{-# LANGUAGE CPP #-}
module Curry.Base.Message
( Message (..), message, posMessage, spanMessage, spanInfoMessage
, showWarning, showError
, ppMessage, ppWarning, ppError, ppMessages, ppMessagesWithPreviews
) where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.Span
import Curry.Base.SpanInfo
data Message = Message
{ msgSpanInfo :: SpanInfo
, msgTxt :: Doc
}
instance Eq Message where
Message s1 t1 == Message s2 t2 = (s1, show t1) == (s2, show t2)
instance Ord Message where
Message s1 t1 `compare` Message s2 t2 = compare (s1, show t1) (s2, show t2)
instance Show Message where
showsPrec _ = shows . ppMessage
instance HasPosition Message where
getPosition = getStartPosition
setPosition = setStartPosition
instance HasSpanInfo Message where
getSpanInfo = msgSpanInfo
setSpanInfo spi m = m { msgSpanInfo = spi }
instance Pretty Message where
pPrint = ppMessage
message :: Doc -> Message
message = Message NoSpanInfo
posMessage :: HasPosition p => p -> Doc -> Message
posMessage p = spanMessage $ pos2Span $ getPosition p
spanMessage :: Span -> Doc -> Message
spanMessage s = spanInfoMessage $ fromSrcSpan s
spanInfoMessage :: HasSpanInfo s => s -> Doc -> Message
spanInfoMessage s msg = Message (getSpanInfo s) msg
showWarning :: Message -> String
showWarning = show . ppWarning
showError :: Message -> String
showError = show . ppError
ppMessage :: Message -> Doc
ppMessage = ppAs ""
ppWarning :: Message -> Doc
ppWarning = ppAs "Warning"
ppError :: Message -> Doc
ppError = ppAs "Error"
ppAs :: String -> Message -> Doc
ppAs key (Message mbSpanInfo txt) = (hsep $ filter (not . isEmpty) [spanPP, keyPP]) $$ nest 4 txt
where
spanPP = ppCompactSpan $ getSrcSpan $ mbSpanInfo
keyPP = if null key then empty else text key <> colon
ppMessages :: (Message -> Doc) -> [Message] -> Doc
ppMessages ppFun = foldr (\m ms -> text "" $+$ m $+$ ms) empty . map ppFun
ppMessagesWithPreviews :: (Message -> Doc) -> [Message] -> IO Doc
ppMessagesWithPreviews ppFun = (fmap $ foldr (\m ms -> text "" $+$ m $+$ ms) empty) . mapM ppFunWithPreview
where ppFunWithPreview m = do preview <- case m of
Message (SpanInfo sp _) _ -> ppSpanPreview sp
_ -> return empty
return $ ppFun m $+$ preview