{-# LANGUAGE CPP #-}
module Curry.Base.Message
( Message (..), message, posMessage, showWarning, showError
, ppMessage, ppWarning, ppError, ppMessages
) where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
import Data.Maybe (fromMaybe)
import Curry.Base.Position
import Curry.Base.Pretty
data Message = Message
{ Message -> Maybe Position
msgPos :: Maybe Position
, Message -> Doc
msgTxt :: Doc
}
instance Eq Message where
Message p1 :: Maybe Position
p1 t1 :: Doc
t1 == :: Message -> Message -> Bool
== Message p2 :: Maybe Position
p2 t2 :: Doc
t2 = (Maybe Position
p1, Doc -> String
forall a. Show a => a -> String
show Doc
t1) (Maybe Position, String) -> (Maybe Position, String) -> Bool
forall a. Eq a => a -> a -> Bool
== (Maybe Position
p2, Doc -> String
forall a. Show a => a -> String
show Doc
t2)
instance Ord Message where
Message p1 :: Maybe Position
p1 t1 :: Doc
t1 compare :: Message -> Message -> Ordering
`compare` Message p2 :: Maybe Position
p2 t2 :: Doc
t2 = (Maybe Position, String) -> (Maybe Position, String) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Maybe Position
p1, Doc -> String
forall a. Show a => a -> String
show Doc
t1) (Maybe Position
p2, Doc -> String
forall a. Show a => a -> String
show Doc
t2)
instance Show Message where
showsPrec :: Int -> Message -> ShowS
showsPrec _ = Doc -> ShowS
forall a. Show a => a -> ShowS
shows (Doc -> ShowS) -> (Message -> Doc) -> Message -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Doc
ppMessage
instance HasPosition Message where
getPosition :: Message -> Position
getPosition = Position -> Maybe Position -> Position
forall a. a -> Maybe a -> a
fromMaybe Position
NoPos (Maybe Position -> Position)
-> (Message -> Maybe Position) -> Message -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Maybe Position
msgPos
setPosition :: Position -> Message -> Message
setPosition p :: Position
p m :: Message
m = Message
m { msgPos :: Maybe Position
msgPos = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
p }
instance Pretty Message where
pPrint :: Message -> Doc
pPrint = Message -> Doc
ppMessage
message :: Doc -> Message
message :: Doc -> Message
message = Maybe Position -> Doc -> Message
Message Maybe Position
forall a. Maybe a
Nothing
posMessage :: HasPosition p => p -> Doc -> Message
posMessage :: p -> Doc -> Message
posMessage p :: p
p msg :: Doc
msg = Maybe Position -> Doc -> Message
Message (Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ p -> Position
forall a. HasPosition a => a -> Position
getPosition p
p) Doc
msg
showWarning :: Message -> String
showWarning :: Message -> String
showWarning = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Message -> Doc) -> Message -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Doc
ppWarning
showError :: Message -> String
showError :: Message -> String
showError = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Message -> Doc) -> Message -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Doc
ppError
ppMessage :: Message -> Doc
ppMessage :: Message -> Doc
ppMessage = String -> Message -> Doc
ppAs ""
ppWarning :: Message -> Doc
ppWarning :: Message -> Doc
ppWarning = String -> Message -> Doc
ppAs "Warning"
ppError :: Message -> Doc
ppError :: Message -> Doc
ppError = String -> Message -> Doc
ppAs "Error"
ppAs :: String -> Message -> Doc
ppAs :: String -> Message -> Doc
ppAs key :: String
key (Message mbPos :: Maybe Position
mbPos txt :: Doc
txt) = Doc
posPP Doc -> Doc -> Doc
<+> Doc
keyPP Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 Doc
txt
where
posPP :: Doc
posPP = Doc -> (Position -> Doc) -> Maybe Position -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty ((Doc -> Doc -> Doc
<> Doc
colon) (Doc -> Doc) -> (Position -> Doc) -> Position -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Doc
ppPosition) Maybe Position
mbPos
keyPP :: Doc
keyPP = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
key then Doc
empty else String -> Doc
text String
key Doc -> Doc -> Doc
<> Doc
colon
ppMessages :: (Message -> Doc) -> [Message] -> Doc
ppMessages :: (Message -> Doc) -> [Message] -> Doc
ppMessages ppFun :: Message -> Doc
ppFun = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\m :: Doc
m ms :: Doc
ms -> String -> Doc
text "" Doc -> Doc -> Doc
$+$ Doc
m Doc -> Doc -> Doc
$+$ Doc
ms) Doc
empty ([Doc] -> Doc) -> ([Message] -> [Doc]) -> [Message] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> Doc) -> [Message] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Message -> Doc
ppFun