{- |
    Module      :  $Header$
    Description :  Monads for message handling
    Copyright   :  2009        Holger Siegel
                   2012 - 2015 Björn Peemöller
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    The type message represents a compiler message with an optional source
    code position.
-}
{-# 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

-- ---------------------------------------------------------------------------
-- Message
-- ---------------------------------------------------------------------------

-- |Compiler message
data Message = Message
  { Message -> SpanInfo
msgSpanInfo :: SpanInfo -- ^ span in the source code
  , Message -> Doc
msgTxt      :: Doc      -- ^ the message itself
  }

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

-- |Construct a 'Message' without a 'SpanInfo'
message :: Doc -> Message
message :: Doc -> Message
message = SpanInfo -> Doc -> Message
Message SpanInfo
NoSpanInfo

-- |Construct a message from a position.
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

-- |Construct a message from a span and a text
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

-- |Construct a message from an entity with a 'SpanInfo' and a text
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

-- |Show a 'Message' as a warning
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

-- |Show a 'Message' as an error
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

-- |Pretty print a 'Message'
ppMessage :: Message -> Doc
ppMessage :: Message -> Doc
ppMessage = String -> Message -> Doc
ppAs ""

-- |Pretty print a 'Message' as a warning
ppWarning :: Message -> Doc
ppWarning :: Message -> Doc
ppWarning = String -> Message -> Doc
ppAs "Warning"

-- |Pretty print a 'Message' as an error
ppError :: Message -> Doc
ppError :: Message -> Doc
ppError = String -> Message -> Doc
ppAs "Error"

-- |Pretty print a 'Message' with a given key
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

-- |Pretty print a list of 'Message's by vertical concatenation
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

-- |Pretty print a list of 'Message's with previews by vertical concatenation
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