Messages.hs 2.5 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
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)
20 21
import Curry.Base.Monad           (CYIO, failMessages)
import Curry.Base.Pretty          (text)
22
import CompilerOpts               (Options (..), WarnOpts (..), Verbosity (..))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
23

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

27 28 29
-- TODO: bad code: Extend Curry monads (CYT / CYIO) to also track warnings
-- (see ticket 1246)
warn :: WarnOpts -> [Message] -> CYIO ()
30
warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
31 32 33
  if wnWarnAsError opts
    then failMessages (msgs ++ [message $ text "Failed due to -Werror"])
    else liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
Björn Peemöller 's avatar
Björn Peemöller committed
34

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

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

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

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

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

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

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

66
errorMessage :: Message -> a
67
errorMessage = error . show . ppError
68

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