Messages.hs 2.31 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
module Base.Messages
2
  ( -- * Output of user information
3
    status, warn, putErrLn, putErrsLn
4
    -- * program abortion
Björn Peemöller 's avatar
Björn Peemöller committed
5 6
  , abortWith, abortWithMessage, abortWithMessages
  , internalError, errorMessage, errorMessages
7
    -- * creating messages
Björn Peemöller 's avatar
Björn Peemöller committed
8
  , Message, message, posMessage
9
  , MonadIO (..)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
10 11
  ) where

12 13 14 15 16 17 18 19 20
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, ppMessage
                                  , ppMessages, ppWarning, ppError)
import CompilerOpts               (Options (..), WarnOpts (..), Verbosity (..))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
21

Björn Peemöller 's avatar
Björn Peemöller committed
22 23 24
status :: MonadIO m => Options -> String -> m ()
status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg)

25 26
warn :: MonadIO m => WarnOpts -> [Message] -> m ()
warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
Björn Peemöller 's avatar
Björn Peemöller committed
27
  liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
28
  when (wnWarnAsError opts) $ liftIO $ do
29 30
    putErrLn "Failed due to -Werror"
    exitFailure
Björn Peemöller 's avatar
Björn Peemöller committed
31

Björn Peemöller 's avatar
Björn Peemöller committed
32 33
-- |Print a message on 'stdout'
putMsg :: MonadIO m => String -> m ()
34
putMsg msg = liftIO (putStrLn msg >> hFlush stdout)
Björn Peemöller 's avatar
Björn Peemöller committed
35

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
36
-- |Print an error message on 'stderr'
Björn Peemöller 's avatar
Björn Peemöller committed
37
putErrLn :: MonadIO m => String -> m ()
38
putErrLn msg = liftIO (hPutStrLn stderr msg >> hFlush stderr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
39 40

-- |Print a list of error messages on 'stderr'
Björn Peemöller 's avatar
Björn Peemöller committed
41
putErrsLn :: MonadIO m => [String] -> m ()
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
42 43
putErrsLn = mapM_ putErrLn

Björn Peemöller 's avatar
Björn Peemöller committed
44 45
-- |Print a list of 'String's as error messages on 'stderr'
-- and abort the program
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
46
abortWith :: [String] -> IO a
Björn Peemöller 's avatar
Björn Peemöller committed
47
abortWith errs = putErrsLn errs >> exitFailure
48

Björn Peemöller 's avatar
Björn Peemöller committed
49 50 51 52
-- |Print a single error message on 'stderr' and abort the program
abortWithMessage :: Message -> IO a
abortWithMessage msg = abortWithMessages [msg]

53 54
-- |Print a list of error messages on 'stderr' and abort the program
abortWithMessages :: [Message] -> IO a
55
abortWithMessages msgs = do
56
  unless (null msgs) $ putErrLn (show $ ppMessages ppMessage $ sort msgs)
57
  exitFailure
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
58 59 60

-- |Raise an internal error
internalError :: String -> a
Björn Peemöller 's avatar
Björn Peemöller committed
61
internalError msg = error $ "Internal error: " ++ msg
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
62

63
errorMessage :: Message -> a
64
errorMessage = error . show . ppError
65

Björn Peemöller 's avatar
Björn Peemöller committed
66
errorMessages :: [Message] -> a
67
errorMessages = error . show . ppMessages ppError . sort