{- |
    Module      :  $Header$
    Description :  Construction and output of compiler messages
    Copyright   :  (c) 2011 - 2016 Björn Peemöller
    License     :  BSD-3-clause

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

    This module defines several operations to construct and emit compiler
    messages to the user.
-}
module Base.Messages
  ( -- * Output of user information
    MonadIO (..), status, putMsg, putErrLn, putErrsLn
    -- * program abortion
  , abortWith, abortWithMessage, abortWithMessages, warnOrAbort, internalError
    -- * creating messages
  , Message, message, posMessage
  ) where

import Control.Monad              (unless, when)
import Control.Monad.IO.Class     (MonadIO(..))
import Data.List                  (sort)
import System.IO                  (hFlush, hPutStrLn, stderr, stdout)
import System.Exit                (exitFailure)

import Curry.Base.Message         ( Message, message, posMessage, ppWarning
                                  , ppMessages, ppError)
import Curry.Base.Pretty          (Doc, text)
import CompilerOpts               (Options (..), WarnOpts (..), Verbosity (..))

-- |Print a status message, depending on the current verbosity
status :: MonadIO m => Options -> String -> m ()
status :: Options -> String -> m ()
status opts :: Options
opts msg :: String
msg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Options -> Verbosity
optVerbosity Options
opts Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
< Verbosity
VerbStatus) (String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putMsg String
msg)

-- |Print a message on 'stdout'
putMsg :: MonadIO m => String -> m ()
putMsg :: String -> m ()
putMsg msg :: String
msg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStrLn String
msg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout)

-- |Print an error message on 'stderr'
putErrLn :: MonadIO m => String -> m ()
putErrLn :: String -> m ()
putErrLn msg :: String
msg = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr)

-- |Print a list of error messages on 'stderr'
putErrsLn :: MonadIO m => [String] -> m ()
putErrsLn :: [String] -> m ()
putErrsLn = (String -> m ()) -> [String] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putErrLn

-- |Print a list of 'String's as error messages on 'stderr'
-- and abort the program
abortWith :: [String] -> IO a
abortWith :: [String] -> IO a
abortWith errs :: [String]
errs = [String] -> IO ()
forall (m :: * -> *). MonadIO m => [String] -> m ()
putErrsLn [String]
errs IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
exitFailure

-- |Print a single error message on 'stderr' and abort the program
abortWithMessage :: Message -> IO a
abortWithMessage :: Message -> IO a
abortWithMessage msg :: Message
msg = [Message] -> IO a
forall a. [Message] -> IO a
abortWithMessages [Message
msg]

-- |Print a list of error messages on 'stderr' and abort the program
abortWithMessages :: [Message] -> IO a
abortWithMessages :: [Message] -> IO a
abortWithMessages msgs :: [Message]
msgs = (Message -> Doc) -> [Message] -> IO ()
printMessages Message -> Doc
ppError [Message]
msgs IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
exitFailure

-- |Print a list of warning messages on 'stderr' and abort the program
-- |if the -Werror option is set
warnOrAbort :: WarnOpts -> [Message] -> IO ()
warnOrAbort :: WarnOpts -> [Message] -> IO ()
warnOrAbort opts :: WarnOpts
opts msgs :: [Message]
msgs = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarnOpts -> Bool
wnWarn WarnOpts
opts Bool -> Bool -> Bool
&& Bool -> Bool
not ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  if WarnOpts -> Bool
wnWarnAsError WarnOpts
opts
    then [Message] -> IO ()
forall a. [Message] -> IO a
abortWithMessages ([Message]
msgs [Message] -> [Message] -> [Message]
forall a. [a] -> [a] -> [a]
++ [Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Failed due to -Werror"])
    else (Message -> Doc) -> [Message] -> IO ()
printMessages Message -> Doc
ppWarning [Message]
msgs

-- |Print a list of messages on 'stderr'
printMessages :: (Message -> Doc) -> [Message] -> IO ()
printMessages :: (Message -> Doc) -> [Message] -> IO ()
printMessages msgType :: Message -> Doc
msgType msgs :: [Message]
msgs
  = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putErrLn (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ (Message -> Doc) -> [Message] -> Doc
ppMessages Message -> Doc
msgType ([Message] -> Doc) -> [Message] -> Doc
forall a b. (a -> b) -> a -> b
$ [Message] -> [Message]
forall a. Ord a => [a] -> [a]
sort [Message]
msgs)

-- |Raise an internal error
internalError :: String -> a
internalError :: String -> a
internalError msg :: String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "Internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg