{- |
    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, 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

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

-- |Compiler message
data Message = Message
  { Message -> Maybe Position
msgPos :: Maybe Position -- ^ optional source code position
  , Message -> Doc
msgTxt :: Doc            -- ^ the message itself
  }

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

-- |Construct a 'Message' without a 'Position'
message :: Doc -> Message
message :: Doc -> Message
message = Maybe Position -> Doc -> Message
Message Maybe Position
forall a. Maybe a
Nothing

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

-- |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 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

-- |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