{-# 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
{ Message -> SpanInfo
msgSpanInfo :: SpanInfo
, Message -> Doc
msgTxt :: Doc
}
instance Eq Message where
Message s1 :: SpanInfo
s1 t1 :: Doc
t1 == :: Message -> Message -> Bool
== Message s2 :: SpanInfo
s2 t2 :: Doc
t2 = (SpanInfo
s1, Doc -> String
forall a. Show a => a -> String
show Doc
t1) (SpanInfo, String) -> (SpanInfo, String) -> Bool
forall a. Eq a => a -> a -> Bool
== (SpanInfo
s2, Doc -> String
forall a. Show a => a -> String
show Doc
t2)
instance Ord Message where
Message s1 :: SpanInfo
s1 t1 :: Doc
t1 compare :: Message -> Message -> Ordering
`compare` Message s2 :: SpanInfo
s2 t2 :: Doc
t2 = (SpanInfo, String) -> (SpanInfo, String) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SpanInfo
s1, Doc -> String
forall a. Show a => a -> String
show Doc
t1) (SpanInfo
s2, 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 = Message -> Position
forall a. HasSpanInfo a => a -> Position
getStartPosition
setPosition :: Position -> Message -> Message
setPosition = Position -> Message -> Message
forall a. HasSpanInfo a => Position -> a -> a
setStartPosition
instance HasSpanInfo Message where
getSpanInfo :: Message -> SpanInfo
getSpanInfo = Message -> SpanInfo
msgSpanInfo
setSpanInfo :: SpanInfo -> Message -> Message
setSpanInfo spi :: SpanInfo
spi m :: Message
m = Message
m { msgSpanInfo :: SpanInfo
msgSpanInfo = SpanInfo
spi }
instance Pretty Message where
pPrint :: Message -> Doc
pPrint = Message -> Doc
ppMessage
message :: Doc -> Message
message :: Doc -> Message
message = SpanInfo -> Doc -> Message
Message SpanInfo
NoSpanInfo
posMessage :: HasPosition p => p -> Doc -> Message
posMessage :: p -> Doc -> Message
posMessage p :: p
p = Span -> Doc -> Message
spanMessage (Span -> Doc -> Message) -> Span -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ Position -> Span
pos2Span (Position -> Span) -> Position -> Span
forall a b. (a -> b) -> a -> b
$ p -> Position
forall a. HasPosition a => a -> Position
getPosition p
p
spanMessage :: Span -> Doc -> Message
spanMessage :: Span -> Doc -> Message
spanMessage s :: Span
s = SpanInfo -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage (SpanInfo -> Doc -> Message) -> SpanInfo -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ Span -> SpanInfo
fromSrcSpan Span
s
spanInfoMessage :: HasSpanInfo s => s -> Doc -> Message
spanInfoMessage :: s -> Doc -> Message
spanInfoMessage s :: s
s msg :: Doc
msg = SpanInfo -> Doc -> Message
Message (s -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo s
s) 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 mbSpanInfo :: SpanInfo
mbSpanInfo txt :: Doc
txt) = ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Bool) -> [Doc] -> [Doc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Doc -> Bool) -> Doc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Bool
isEmpty) [Doc
spanPP, Doc
keyPP]) Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 Doc
txt
where
spanPP :: Doc
spanPP = Span -> Doc
ppCompactSpan (Span -> Doc) -> Span -> Doc
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Span
forall a. HasSpanInfo a => a -> Span
getSrcSpan (SpanInfo -> Span) -> SpanInfo -> Span
forall a b. (a -> b) -> a -> b
$ SpanInfo
mbSpanInfo
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
ppMessagesWithPreviews :: (Message -> Doc) -> [Message] -> IO Doc
ppMessagesWithPreviews :: (Message -> Doc) -> [Message] -> IO Doc
ppMessagesWithPreviews ppFun :: Message -> Doc
ppFun = (([Doc] -> Doc) -> IO [Doc] -> IO Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Doc] -> Doc) -> IO [Doc] -> IO Doc)
-> ([Doc] -> Doc) -> IO [Doc] -> IO Doc
forall a b. (a -> b) -> a -> b
$ (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) (IO [Doc] -> IO Doc)
-> ([Message] -> IO [Doc]) -> [Message] -> IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> IO Doc) -> [Message] -> IO [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Message -> IO Doc
ppFunWithPreview
where ppFunWithPreview :: Message -> IO Doc
ppFunWithPreview m :: Message
m = do Doc
preview <- case Message
m of
Message (SpanInfo sp :: Span
sp _) _ -> Span -> IO Doc
ppSpanPreview Span
sp
_ -> Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
empty
Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> IO Doc) -> Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ Message -> Doc
ppFun Message
m Doc -> Doc -> Doc
$+$ Doc
preview