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