module Base.Messages
(
MonadIO (..), status, putMsg, putErrLn, putErrsLn
, abortWith, abortWithMessage, abortWithMessages, warnOrAbort, internalError
, Message, message, posMessage, spanInfoMessage
) 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, spanInfoMessage
, ppWarning, ppMessagesWithPreviews, ppError)
import Curry.Base.Pretty (Doc, text)
import CompilerOpts (Options (..), WarnOpts (..), 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)
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)
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)
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
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
abortWithMessage :: Message -> IO a
abortWithMessage :: Message -> IO a
abortWithMessage msg :: Message
msg = [Message] -> IO a
forall a. [Message] -> IO a
abortWithMessages [Message
msg]
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
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
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 (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Doc -> String) -> IO Doc -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> String
forall a. Show a => a -> String
show (IO Doc -> IO String) -> IO Doc -> IO String
forall a b. (a -> b) -> a -> b
$ (Message -> Doc) -> [Message] -> IO Doc
ppMessagesWithPreviews Message -> Doc
msgType ([Message] -> IO Doc) -> [Message] -> IO Doc
forall a b. (a -> b) -> a -> b
$ [Message] -> [Message]
forall a. Ord a => [a] -> [a]
sort [Message]
msgs)
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