{-# LANGUAGE UndecidableInstances, TypeFamilies #-}
module Control.Monad.Log
    ( MonadLog(..)
    , Level(..)
    , LoggingConf(..)
    , Logged(..)
    , LIO
    , withLogging
    , withLogging_
    , logOptions
    , execWithParser
    , execWithParser_
    , PanicCall(..)
    , panic
    ) where

import BasePrelude           hiding ( try, catchIOError )
import Control.Monad.Base           ( MonadBase(..) )
import Control.Monad.Catch
import Control.Monad.Primitive
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Reader
import Control.Monad.Trans.RWS.Strict ( RWST )
import GitVersion                   ( gitFullVersion )
import Options.Applicative
import Paths_biohazard              ( version )
import Streaming
import System.IO                    ( hPutStr, hPutStrLn, hFlush, stderr, openFile, IOMode(..) )

import qualified Data.Vector                 as V

-- | Severity levels for logging.
data Level = Debug      -- ^ Message only useful for debugging.  Typically ignored.
           | Info       -- ^ Purely informative message, e.g. progress reports.  Sometimes printed.
           | Notice     -- ^ Something remarkable, but harmless.  Sometimes printed, but not collected.
           | Warning    -- ^ Something unexpected, but usually not a problem.  Typically printed, but not collected.
           | Error      -- ^ Recoverable error, will normally result in `ExitFailure 1`.  Printed and collected.
    deriving ( Int -> Level -> ShowS
[Level] -> ShowS
Level -> String
(Int -> Level -> ShowS)
-> (Level -> String) -> ([Level] -> ShowS) -> Show Level
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Level] -> ShowS
$cshowList :: [Level] -> ShowS
show :: Level -> String
$cshow :: Level -> String
showsPrec :: Int -> Level -> ShowS
$cshowsPrec :: Int -> Level -> ShowS
Show, Level -> Level -> Bool
(Level -> Level -> Bool) -> (Level -> Level -> Bool) -> Eq Level
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Level -> Level -> Bool
$c/= :: Level -> Level -> Bool
== :: Level -> Level -> Bool
$c== :: Level -> Level -> Bool
Eq, Eq Level
Eq Level =>
(Level -> Level -> Ordering)
-> (Level -> Level -> Bool)
-> (Level -> Level -> Bool)
-> (Level -> Level -> Bool)
-> (Level -> Level -> Bool)
-> (Level -> Level -> Level)
-> (Level -> Level -> Level)
-> Ord Level
Level -> Level -> Bool
Level -> Level -> Ordering
Level -> Level -> Level
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Level -> Level -> Level
$cmin :: Level -> Level -> Level
max :: Level -> Level -> Level
$cmax :: Level -> Level -> Level
>= :: Level -> Level -> Bool
$c>= :: Level -> Level -> Bool
> :: Level -> Level -> Bool
$c> :: Level -> Level -> Bool
<= :: Level -> Level -> Bool
$c<= :: Level -> Level -> Bool
< :: Level -> Level -> Bool
$c< :: Level -> Level -> Bool
compare :: Level -> Level -> Ordering
$ccompare :: Level -> Level -> Ordering
$cp1Ord :: Eq Level
Ord, Int -> Level
Level -> Int
Level -> [Level]
Level -> Level
Level -> Level -> [Level]
Level -> Level -> Level -> [Level]
(Level -> Level)
-> (Level -> Level)
-> (Int -> Level)
-> (Level -> Int)
-> (Level -> [Level])
-> (Level -> Level -> [Level])
-> (Level -> Level -> [Level])
-> (Level -> Level -> Level -> [Level])
-> Enum Level
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Level -> Level -> Level -> [Level]
$cenumFromThenTo :: Level -> Level -> Level -> [Level]
enumFromTo :: Level -> Level -> [Level]
$cenumFromTo :: Level -> Level -> [Level]
enumFromThen :: Level -> Level -> [Level]
$cenumFromThen :: Level -> Level -> [Level]
enumFrom :: Level -> [Level]
$cenumFrom :: Level -> [Level]
fromEnum :: Level -> Int
$cfromEnum :: Level -> Int
toEnum :: Int -> Level
$ctoEnum :: Int -> Level
pred :: Level -> Level
$cpred :: Level -> Level
succ :: Level -> Level
$csucc :: Level -> Level
Enum, Level
Level -> Level -> Bounded Level
forall a. a -> a -> Bounded a
maxBound :: Level
$cmaxBound :: Level
minBound :: Level
$cminBound :: Level
Bounded, Ord Level
Ord Level =>
((Level, Level) -> [Level])
-> ((Level, Level) -> Level -> Int)
-> ((Level, Level) -> Level -> Int)
-> ((Level, Level) -> Level -> Bool)
-> ((Level, Level) -> Int)
-> ((Level, Level) -> Int)
-> Ix Level
(Level, Level) -> Int
(Level, Level) -> [Level]
(Level, Level) -> Level -> Bool
(Level, Level) -> Level -> Int
forall a.
Ord a =>
((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (Level, Level) -> Int
$cunsafeRangeSize :: (Level, Level) -> Int
rangeSize :: (Level, Level) -> Int
$crangeSize :: (Level, Level) -> Int
inRange :: (Level, Level) -> Level -> Bool
$cinRange :: (Level, Level) -> Level -> Bool
unsafeIndex :: (Level, Level) -> Level -> Int
$cunsafeIndex :: (Level, Level) -> Level -> Int
index :: (Level, Level) -> Level -> Int
$cindex :: (Level, Level) -> Level -> Int
range :: (Level, Level) -> [Level]
$crange :: (Level, Level) -> [Level]
$cp1Ix :: Ord Level
Ix )

color_coded :: Level -> String -> String
color_coded :: Level -> ShowS
color_coded Debug   s :: String
s = "\27[90m"   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[0m"        -- gray
color_coded Info    s :: String
s = "\27[34m"   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[0m"        -- blue
color_coded Notice  s :: String
s = "\27[32;1m" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[0m"        -- bold green
color_coded Warning s :: String
s = "\27[33m"   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[0m"        -- yellow
color_coded Error   s :: String
s = "\27[31;1m" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[0m"        -- bold red

-- | Monads in which messages can be logged.  Any 'Exception' can be
-- logged; it is reported and/or collected, but does not abort any
-- computation.
class Monad m => MonadLog m where
    -- | Logs a message at a given level.  Depending on settings, the
    -- message may be printed and/or stored.
    logMsg :: Exception e => Level -> e -> m ()

    -- | Updates the progress indicator.  The message should not contain
    -- line feeds, as it is intended to fit on one line and be
    -- overwritten repeatedly.
    logString_ :: String -> m ()

    -- | Prints a progress indication.  The message should persist on
    -- the user's terminal.
    logStringLn :: String -> m ()

instance (MonadLog m, Monoid w) => MonadLog (RWST r w s m) where
    logMsg :: Level -> e -> RWST r w s m ()
logMsg    l :: Level
l e :: e
e = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Level -> e -> m ()
forall (m :: * -> *) e.
(MonadLog m, Exception e) =>
Level -> e -> m ()
logMsg    Level
l e
e)
    logString_ :: String -> RWST r w s m ()
logString_  e :: String
e = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m ()
forall (m :: * -> *). MonadLog m => String -> m ()
logString_  String
e)
    logStringLn :: String -> RWST r w s m ()
logStringLn e :: String
e = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m ()
forall (m :: * -> *). MonadLog m => String -> m ()
logStringLn String
e)


-- | Adds logging to any 'MonadIO' type.  Warnings are printed
-- to stderr immediately, but we remember whether any were emitted.  If
-- so, we exit with an error code.  The advantage over @WarningT IO@ is
-- that the warnings are tracked even if the computation exits with an
-- exception.  Progress indicators are sent to the controlling terminal,
-- and dicarded if none exists.
newtype Logged m a = Logged { Logged m a -> ReaderT (LoggingConf, Journal) m a
runLogged :: ReaderT (LoggingConf, Journal) m a }
  deriving ( a -> Logged m b -> Logged m a
(a -> b) -> Logged m a -> Logged m b
(forall a b. (a -> b) -> Logged m a -> Logged m b)
-> (forall a b. a -> Logged m b -> Logged m a)
-> Functor (Logged m)
forall a b. a -> Logged m b -> Logged m a
forall a b. (a -> b) -> Logged m a -> Logged m b
forall (m :: * -> *) a b.
Functor m =>
a -> Logged m b -> Logged m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Logged m a -> Logged m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Logged m b -> Logged m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Logged m b -> Logged m a
fmap :: (a -> b) -> Logged m a -> Logged m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Logged m a -> Logged m b
Functor, Functor (Logged m)
a -> Logged m a
Functor (Logged m) =>
(forall a. a -> Logged m a)
-> (forall a b. Logged m (a -> b) -> Logged m a -> Logged m b)
-> (forall a b c.
    (a -> b -> c) -> Logged m a -> Logged m b -> Logged m c)
-> (forall a b. Logged m a -> Logged m b -> Logged m b)
-> (forall a b. Logged m a -> Logged m b -> Logged m a)
-> Applicative (Logged m)
Logged m a -> Logged m b -> Logged m b
Logged m a -> Logged m b -> Logged m a
Logged m (a -> b) -> Logged m a -> Logged m b
(a -> b -> c) -> Logged m a -> Logged m b -> Logged m c
forall a. a -> Logged m a
forall a b. Logged m a -> Logged m b -> Logged m a
forall a b. Logged m a -> Logged m b -> Logged m b
forall a b. Logged m (a -> b) -> Logged m a -> Logged m b
forall a b c.
(a -> b -> c) -> Logged m a -> Logged m b -> Logged m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (Logged m)
forall (m :: * -> *) a. Applicative m => a -> Logged m a
forall (m :: * -> *) a b.
Applicative m =>
Logged m a -> Logged m b -> Logged m a
forall (m :: * -> *) a b.
Applicative m =>
Logged m a -> Logged m b -> Logged m b
forall (m :: * -> *) a b.
Applicative m =>
Logged m (a -> b) -> Logged m a -> Logged m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Logged m a -> Logged m b -> Logged m c
<* :: Logged m a -> Logged m b -> Logged m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
Logged m a -> Logged m b -> Logged m a
*> :: Logged m a -> Logged m b -> Logged m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
Logged m a -> Logged m b -> Logged m b
liftA2 :: (a -> b -> c) -> Logged m a -> Logged m b -> Logged m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Logged m a -> Logged m b -> Logged m c
<*> :: Logged m (a -> b) -> Logged m a -> Logged m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
Logged m (a -> b) -> Logged m a -> Logged m b
pure :: a -> Logged m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> Logged m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (Logged m)
Applicative, Applicative (Logged m)
Logged m a
Applicative (Logged m) =>
(forall a. Logged m a)
-> (forall a. Logged m a -> Logged m a -> Logged m a)
-> (forall a. Logged m a -> Logged m [a])
-> (forall a. Logged m a -> Logged m [a])
-> Alternative (Logged m)
Logged m a -> Logged m a -> Logged m a
Logged m a -> Logged m [a]
Logged m a -> Logged m [a]
forall a. Logged m a
forall a. Logged m a -> Logged m [a]
forall a. Logged m a -> Logged m a -> Logged m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (m :: * -> *). Alternative m => Applicative (Logged m)
forall (m :: * -> *) a. Alternative m => Logged m a
forall (m :: * -> *) a. Alternative m => Logged m a -> Logged m [a]
forall (m :: * -> *) a.
Alternative m =>
Logged m a -> Logged m a -> Logged m a
many :: Logged m a -> Logged m [a]
$cmany :: forall (m :: * -> *) a. Alternative m => Logged m a -> Logged m [a]
some :: Logged m a -> Logged m [a]
$csome :: forall (m :: * -> *) a. Alternative m => Logged m a -> Logged m [a]
<|> :: Logged m a -> Logged m a -> Logged m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
Logged m a -> Logged m a -> Logged m a
empty :: Logged m a
$cempty :: forall (m :: * -> *) a. Alternative m => Logged m a
$cp1Alternative :: forall (m :: * -> *). Alternative m => Applicative (Logged m)
Alternative, Applicative (Logged m)
a -> Logged m a
Applicative (Logged m) =>
(forall a b. Logged m a -> (a -> Logged m b) -> Logged m b)
-> (forall a b. Logged m a -> Logged m b -> Logged m b)
-> (forall a. a -> Logged m a)
-> Monad (Logged m)
Logged m a -> (a -> Logged m b) -> Logged m b
Logged m a -> Logged m b -> Logged m b
forall a. a -> Logged m a
forall a b. Logged m a -> Logged m b -> Logged m b
forall a b. Logged m a -> (a -> Logged m b) -> Logged m b
forall (m :: * -> *). Monad m => Applicative (Logged m)
forall (m :: * -> *) a. Monad m => a -> Logged m a
forall (m :: * -> *) a b.
Monad m =>
Logged m a -> Logged m b -> Logged m b
forall (m :: * -> *) a b.
Monad m =>
Logged m a -> (a -> Logged m b) -> Logged m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Logged m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> Logged m a
>> :: Logged m a -> Logged m b -> Logged m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Logged m a -> Logged m b -> Logged m b
>>= :: Logged m a -> (a -> Logged m b) -> Logged m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Logged m a -> (a -> Logged m b) -> Logged m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (Logged m)
Monad, m a -> Logged m a
(forall (m :: * -> *) a. Monad m => m a -> Logged m a)
-> MonadTrans Logged
forall (m :: * -> *) a. Monad m => m a -> Logged m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> Logged m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> Logged m a
MonadTrans, Monad (Logged m)
Monad (Logged m) =>
(forall a. IO a -> Logged m a) -> MonadIO (Logged m)
IO a -> Logged m a
forall a. IO a -> Logged m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (Logged m)
forall (m :: * -> *) a. MonadIO m => IO a -> Logged m a
liftIO :: IO a -> Logged m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Logged m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (Logged m)
MonadIO, Monad (Logged m)
e -> Logged m a
Monad (Logged m) =>
(forall e a. Exception e => e -> Logged m a)
-> MonadThrow (Logged m)
forall e a. Exception e => e -> Logged m a
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (Logged m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Logged m a
throwM :: e -> Logged m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Logged m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (Logged m)
MonadThrow, MonadThrow (Logged m)
MonadThrow (Logged m) =>
(forall e a.
 Exception e =>
 Logged m a -> (e -> Logged m a) -> Logged m a)
-> MonadCatch (Logged m)
Logged m a -> (e -> Logged m a) -> Logged m a
forall e a.
Exception e =>
Logged m a -> (e -> Logged m a) -> Logged m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *). MonadCatch m => MonadThrow (Logged m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Logged m a -> (e -> Logged m a) -> Logged m a
catch :: Logged m a -> (e -> Logged m a) -> Logged m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Logged m a -> (e -> Logged m a) -> Logged m a
$cp1MonadCatch :: forall (m :: * -> *). MonadCatch m => MonadThrow (Logged m)
MonadCatch, MonadCatch (Logged m)
MonadCatch (Logged m) =>
(forall b.
 ((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b)
-> (forall b.
    ((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b)
-> (forall a b c.
    Logged m a
    -> (a -> ExitCase b -> Logged m c)
    -> (a -> Logged m b)
    -> Logged m (b, c))
-> MonadMask (Logged m)
Logged m a
-> (a -> ExitCase b -> Logged m c)
-> (a -> Logged m b)
-> Logged m (b, c)
((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
forall b.
((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
forall a b c.
Logged m a
-> (a -> ExitCase b -> Logged m c)
-> (a -> Logged m b)
-> Logged m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
forall (m :: * -> *). MonadMask m => MonadCatch (Logged m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
forall (m :: * -> *) a b c.
MonadMask m =>
Logged m a
-> (a -> ExitCase b -> Logged m c)
-> (a -> Logged m b)
-> Logged m (b, c)
generalBracket :: Logged m a
-> (a -> ExitCase b -> Logged m c)
-> (a -> Logged m b)
-> Logged m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
Logged m a
-> (a -> ExitCase b -> Logged m c)
-> (a -> Logged m b)
-> Logged m (b, c)
uninterruptibleMask :: ((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
mask :: ((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Logged m a -> Logged m a) -> Logged m b) -> Logged m b
$cp1MonadMask :: forall (m :: * -> *). MonadMask m => MonadCatch (Logged m)
MonadMask, (forall a. m a -> n a) -> Logged m b -> Logged n b
(forall (m :: * -> *) (n :: * -> *) b.
 Monad m =>
 (forall a. m a -> n a) -> Logged m b -> Logged n b)
-> MFunctor Logged
forall k (t :: (* -> *) -> k -> *).
(forall (m :: * -> *) (n :: * -> *) (b :: k).
 Monad m =>
 (forall a. m a -> n a) -> t m b -> t n b)
-> MFunctor t
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> Logged m b -> Logged n b
hoist :: (forall a. m a -> n a) -> Logged m b -> Logged n b
$choist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> Logged m b -> Logged n b
MFunctor )

instance MonadTransControl Logged where
    type StT Logged a = StT (ReaderT (LoggingConf, Journal)) a
    liftWith :: (Run Logged -> m a) -> Logged m a
liftWith = (forall b. ReaderT (LoggingConf, Journal) m b -> Logged m b)
-> (forall (o :: * -> *) b.
    Logged o b -> ReaderT (LoggingConf, Journal) o b)
-> (RunDefault Logged (ReaderT (LoggingConf, Journal)) -> m a)
-> Logged m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *)
       (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTransControl n) =>
(forall b. n m b -> t m b)
-> (forall (o :: * -> *) b. t o b -> n o b)
-> (RunDefault t n -> m a)
-> t m a
defaultLiftWith forall b. ReaderT (LoggingConf, Journal) m b -> Logged m b
forall (m :: * -> *) a.
ReaderT (LoggingConf, Journal) m a -> Logged m a
Logged forall (o :: * -> *) b.
Logged o b -> ReaderT (LoggingConf, Journal) o b
runLogged
    restoreT :: m (StT Logged a) -> Logged m a
restoreT = (ReaderT (LoggingConf, Journal) m a -> Logged m a)
-> m (StT (ReaderT (LoggingConf, Journal)) a) -> Logged m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *) a
       (t :: (* -> *) -> * -> *).
(Monad m, MonadTransControl n) =>
(n m a -> t m a) -> m (StT n a) -> t m a
defaultRestoreT ReaderT (LoggingConf, Journal) m a -> Logged m a
forall (m :: * -> *) a.
ReaderT (LoggingConf, Journal) m a -> Logged m a
Logged

instance MonadBase b m => MonadBase b (Logged m) where
    liftBase :: b α -> Logged m α
liftBase = m α -> Logged m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> Logged m α) -> (b α -> m α) -> b α -> Logged m α
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance MonadBaseControl b m => MonadBaseControl b (Logged m) where
    type StM (Logged m) a = StM (ReaderT (LoggingConf, Journal) m) a
    liftBaseWith :: (RunInBase (Logged m) b -> b a) -> Logged m a
liftBaseWith f :: RunInBase (Logged m) b -> b a
f        = (RunInBaseDefault Logged m b -> b a) -> Logged m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith RunInBaseDefault Logged m b -> b a
RunInBase (Logged m) b -> b a
f
    restoreM :: StM (Logged m) a -> Logged m a
restoreM              = StM (Logged m) a -> Logged m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

instance PrimMonad m => PrimMonad (Logged m) where
    type PrimState (Logged m) = PrimState m
    primitive :: (State# (PrimState (Logged m))
 -> (# State# (PrimState (Logged m)), a #))
-> Logged m a
primitive                 = m a -> Logged m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Logged m a)
-> ((State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> (State# (PrimState m) -> (# State# (PrimState m), a #))
-> Logged m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive

type LIO = Logged IO

data LoggingConf = LoggingConf
    { LoggingConf -> Level
reporting_level :: Level      -- ^ minimum 'Level' to print a message
    , LoggingConf -> Level
logging_level   :: Level      -- ^ minimum 'Level' to remember a message
    , LoggingConf -> Level
error_level     :: Level      -- ^ minimum 'Level' that results in a call to 'exitFailure'
    , LoggingConf -> Int
max_log_size    :: Int        -- ^ number of messages to keep at any given level
    , LoggingConf -> Bool
want_progress   :: Bool }
  deriving Int -> LoggingConf -> ShowS
[LoggingConf] -> ShowS
LoggingConf -> String
(Int -> LoggingConf -> ShowS)
-> (LoggingConf -> String)
-> ([LoggingConf] -> ShowS)
-> Show LoggingConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoggingConf] -> ShowS
$cshowList :: [LoggingConf] -> ShowS
show :: LoggingConf -> String
$cshow :: LoggingConf -> String
showsPrec :: Int -> LoggingConf -> ShowS
$cshowsPrec :: Int -> LoggingConf -> ShowS
Show

data Journal = Journal
    { Journal -> Vector (IORef [SomeException])
logged_messages :: V.Vector (IORef [SomeException])     -- ^ collected messages per level
    , Journal -> Vector (IORef Int)
num_messages    :: V.Vector (IORef Int)                 -- ^ number of collected messages per level
    , Journal -> IORef Bool
error_exit      :: IORef Bool
    , Journal -> Maybe Handle
cterminal       :: Maybe Handle
    , Journal -> IORef String
spinner         :: IORef String }

instance MonadIO m => MonadLog (Logged m) where
    logMsg :: Level -> e -> Logged m ()
logMsg lv :: Level
lv e :: e
e = ReaderT (LoggingConf, Journal) m () -> Logged m ()
forall (m :: * -> *) a.
ReaderT (LoggingConf, Journal) m a -> Logged m a
Logged (ReaderT (LoggingConf, Journal) m () -> Logged m ())
-> ReaderT (LoggingConf, Journal) m () -> Logged m ()
forall a b. (a -> b) -> a -> b
$ ((LoggingConf, Journal) -> m ())
-> ReaderT (LoggingConf, Journal) m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((LoggingConf, Journal) -> m ())
 -> ReaderT (LoggingConf, Journal) m ())
-> ((LoggingConf, Journal) -> m ())
-> ReaderT (LoggingConf, Journal) m ()
forall a b. (a -> b) -> a -> b
$ \(LoggingConf{..},Journal{..}) -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
lv Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
reporting_level) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            -- clear spinner
            Maybe Handle -> (Handle -> IO (Maybe ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
cterminal ((Handle -> IO (Maybe ())) -> IO ())
-> (Handle -> IO (Maybe ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> IO () -> IO (Maybe ())
forall k. IO k -> IO (Maybe k)
tryIO (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h "\r\27[K" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h
            String
pn <- IO String
getProgName
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Level -> ShowS
color_coded Level
lv ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf "%s: [%s] %s" String
pn (Level -> String
forall a. Show a => a -> String
show Level
lv) (e -> String
forall e. Exception e => e -> String
displayException e
e)
            Handle -> IO ()
hFlush Handle
stderr
            -- restore spinner
            Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
cterminal ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> IORef String -> IO String
forall a. IORef a -> IO a
readIORef IORef String
spinner IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: String
s ->
                Handle -> String -> IO ()
hPutStr Handle
h ("\27[?7l" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[?7h") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
lv Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
logging_level) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
            IORef Int -> (Int -> (Int, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Vector (IORef Int)
num_messages Vector (IORef Int) -> Int -> IORef Int
forall a. Vector a -> Int -> a
V.! Level -> Int
forall a. Enum a => a -> Int
fromEnum Level
lv)
                (\num :: Int
num -> if Int
num Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max_log_size then (Int -> Int
forall a. Enum a => a -> a
succ Int
num, Bool
True) else (Int
num, Bool
False)) IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IORef [SomeException]
-> ([SomeException] -> ([SomeException], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (Vector (IORef [SomeException])
logged_messages Vector (IORef [SomeException]) -> Int -> IORef [SomeException]
forall a. Vector a -> Int -> a
V.! Level -> Int
forall a. Enum a => a -> Int
fromEnum Level
lv)
                (\es :: [SomeException]
es -> (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e SomeException -> [SomeException] -> [SomeException]
forall a. a -> [a] -> [a]
: [SomeException]
es, ())))
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
lv Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
error_level) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
error_exit Bool
True

    logString_ :: String -> Logged m ()
logString_ m :: String
m = ReaderT (LoggingConf, Journal) m () -> Logged m ()
forall (m :: * -> *) a.
ReaderT (LoggingConf, Journal) m a -> Logged m a
Logged (ReaderT (LoggingConf, Journal) m () -> Logged m ())
-> ReaderT (LoggingConf, Journal) m () -> Logged m ()
forall a b. (a -> b) -> a -> b
$ ((LoggingConf, Journal) -> m ())
-> ReaderT (LoggingConf, Journal) m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((LoggingConf, Journal) -> m ())
 -> ReaderT (LoggingConf, Journal) m ())
-> ((LoggingConf, Journal) -> m ())
-> ReaderT (LoggingConf, Journal) m ()
forall a b. (a -> b) -> a -> b
$ \(LoggingConf{..},Journal{..}) ->
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Handle -> (Handle -> IO (Maybe ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
cterminal ((Handle -> IO (Maybe ())) -> IO ())
-> (Handle -> IO (Maybe ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
            String
pn <- IO String
getProgName
            let s :: String
s = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
m then String
m else String
pn String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m
            IORef String -> String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef String
spinner String
s
            IO () -> IO (Maybe ())
forall k. IO k -> IO (Maybe k)
tryIO (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h ("\r\27[K\27[?7l" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[?7h") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h

    logStringLn :: String -> Logged m ()
logStringLn m :: String
m = ReaderT (LoggingConf, Journal) m () -> Logged m ()
forall (m :: * -> *) a.
ReaderT (LoggingConf, Journal) m a -> Logged m a
Logged (ReaderT (LoggingConf, Journal) m () -> Logged m ())
-> ReaderT (LoggingConf, Journal) m () -> Logged m ()
forall a b. (a -> b) -> a -> b
$ ((LoggingConf, Journal) -> m ())
-> ReaderT (LoggingConf, Journal) m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((LoggingConf, Journal) -> m ())
 -> ReaderT (LoggingConf, Journal) m ())
-> ((LoggingConf, Journal) -> m ())
-> ReaderT (LoggingConf, Journal) m ()
forall a b. (a -> b) -> a -> b
$ \(LoggingConf{..},Journal{..}) ->
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Handle -> (Handle -> IO (Maybe ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
cterminal ((Handle -> IO (Maybe ())) -> IO ())
-> (Handle -> IO (Maybe ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
            String
s <- IORef String -> IO String
forall a. IORef a -> IO a
readIORef IORef String
spinner
            IO () -> IO (Maybe ())
forall k. IO k -> IO (Maybe k)
tryIO (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h ("\r\27[K" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n\27[?7l" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\27[?7h") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h


withLogging_ :: (MonadIO m, MonadMask m) => LoggingConf -> Logged m a -> m a
withLogging_ :: LoggingConf -> Logged m a -> m a
withLogging_ conf :: LoggingConf
conf = LoggingConf -> Logged m a -> m (Either ExitCode a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
LoggingConf -> Logged m a -> m (Either ExitCode a)
withLogging LoggingConf
conf (Logged m a -> m (Either ExitCode a))
-> (Either ExitCode a -> m a) -> Logged m a -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ExitCode -> m a) -> (a -> m a) -> Either ExitCode a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (ExitCode -> IO a) -> ExitCode -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

withLogging :: (MonadIO m, MonadMask m) => LoggingConf -> Logged m a -> m (Either ExitCode a)
withLogging :: LoggingConf -> Logged m a -> m (Either ExitCode a)
withLogging conf :: LoggingConf
conf (Logged k :: ReaderT (LoggingConf, Journal) m a
k) = do
    Journal
journal <- let n :: Int
n = Level -> Int
forall a. Enum a => a -> Int
fromEnum (Level
forall a. Bounded a => a
maxBound :: Level) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Level -> Int
forall a. Enum a => a -> Int
fromEnum (Level
forall a. Bounded a => a
minBound :: Level) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
               in IO Journal -> m Journal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Journal -> m Journal) -> IO Journal -> m Journal
forall a b. (a -> b) -> a -> b
$ Vector (IORef [SomeException])
-> Vector (IORef Int)
-> IORef Bool
-> Maybe Handle
-> IORef String
-> Journal
Journal (Vector (IORef [SomeException])
 -> Vector (IORef Int)
 -> IORef Bool
 -> Maybe Handle
 -> IORef String
 -> Journal)
-> IO (Vector (IORef [SomeException]))
-> IO
     (Vector (IORef Int)
      -> IORef Bool -> Maybe Handle -> IORef String -> Journal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> IO (IORef [SomeException])
-> IO (Vector (IORef [SomeException]))
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
n ([SomeException] -> IO (IORef [SomeException])
forall a. a -> IO (IORef a)
newIORef [])
                                   IO
  (Vector (IORef Int)
   -> IORef Bool -> Maybe Handle -> IORef String -> Journal)
-> IO (Vector (IORef Int))
-> IO (IORef Bool -> Maybe Handle -> IORef String -> Journal)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IORef Int) -> IO (Vector (IORef Int))
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
n (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0)
                                   IO (IORef Bool -> Maybe Handle -> IORef String -> Journal)
-> IO (IORef Bool) -> IO (Maybe Handle -> IORef String -> Journal)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
                                   IO (Maybe Handle -> IORef String -> Journal)
-> IO (Maybe Handle) -> IO (IORef String -> Journal)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe Handle) -> IO (Maybe Handle) -> Bool -> IO (Maybe Handle)
forall a. a -> a -> Bool -> a
bool (Maybe Handle -> IO (Maybe Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Handle
forall a. Maybe a
Nothing) (IO Handle -> IO (Maybe Handle)
forall k. IO k -> IO (Maybe k)
tryIO (IO Handle -> IO (Maybe Handle)) -> IO Handle -> IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO Handle
openFile "/dev/tty" IOMode
WriteMode) (LoggingConf -> Bool
want_progress LoggingConf
conf)
                                   IO (IORef String -> Journal) -> IO (IORef String) -> IO Journal
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (IORef String)
forall a. a -> IO (IORef a)
newIORef []

    Either SomeException a
r  <- m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either SomeException a))
-> m a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ ReaderT (LoggingConf, Journal) m a -> (LoggingConf, Journal) -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (LoggingConf, Journal) m a
k (LoggingConf
conf,Journal
journal)
    IO (Either ExitCode a) -> m (Either ExitCode a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ExitCode a) -> m (Either ExitCode a))
-> IO (Either ExitCode a) -> m (Either ExitCode a)
forall a b. (a -> b) -> a -> b
$ do
        Vector [SomeException]
ws  <- (IORef [SomeException] -> IO [SomeException])
-> Vector (IORef [SomeException]) -> IO (Vector [SomeException])
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM IORef [SomeException] -> IO [SomeException]
forall a. IORef a -> IO a
readIORef (Journal -> Vector (IORef [SomeException])
logged_messages Journal
journal)
        Vector Int
nws <- (IORef Int -> IO Int) -> Vector (IORef Int) -> IO (Vector Int)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (Journal -> Vector (IORef Int)
num_messages Journal
journal)
        String
pn  <- IO String
getProgName
        Maybe Handle -> (Handle -> IO (Maybe ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Journal -> Maybe Handle
cterminal Journal
journal) ((Handle -> IO (Maybe ())) -> IO ())
-> (Handle -> IO (Maybe ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
            String
s <- IORef String -> IO String
forall a. IORef a -> IO a
readIORef (Journal -> IORef String
spinner Journal
journal)
            IO () -> IO (Maybe ())
forall k. IO k -> IO (Maybe k)
tryIO (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (Handle -> String -> IO ()
hPutStrLn Handle
h []) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
h

        do let eff_warnings :: [(Level, SomeException)]
eff_warnings  =     [ (Level
l,SomeException
e) | Level
l <- [Level
forall a. Bounded a => a
minBound ..], Level
l Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
< LoggingConf -> Level
error_level LoggingConf
conf,     SomeException
e <- Vector [SomeException]
ws Vector [SomeException] -> Int -> [SomeException]
forall a. Vector a -> Int -> a
V.! Level -> Int
forall a. Enum a => a -> Int
fromEnum Level
l ]
               neff_warnings :: Int
neff_warnings = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [   Int
n   | Level
l <- [Level
forall a. Bounded a => a
minBound ..], Level
l Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
< LoggingConf -> Level
error_level LoggingConf
conf, let n :: Int
n = Vector Int
nws Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Level -> Int
forall a. Enum a => a -> Int
fromEnum Level
l ]
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
neff_warnings Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
               Handle -> String -> String -> Int -> IO ()
forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
stderr "%s: there were %d warnings\n" String
pn Int
neff_warnings
               [(Level, SomeException)]
-> ((Level, SomeException) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Level, SomeException)]
eff_warnings (((Level, SomeException) -> IO ()) -> IO ())
-> ((Level, SomeException) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(l :: Level
l,e :: SomeException
e) -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> ShowS -> String -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Level -> ShowS
color_coded Level
l (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
neff_warnings Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Level, SomeException)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Level, SomeException)]
eff_warnings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| [(Level, SomeException)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Level, SomeException)]
eff_warnings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                   Handle -> String -> Int -> IO ()
forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
stderr "(and %d more)\n" (Int
neff_warnings Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Level, SomeException)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Level, SomeException)]
eff_warnings)

        do let eff_errors :: [(Level, SomeException)]
eff_errors    =     [ (Level
l,SomeException
e) | Level
l <- [LoggingConf -> Level
error_level LoggingConf
conf ..],                   SomeException
e <- Vector [SomeException]
ws Vector [SomeException] -> Int -> [SomeException]
forall a. Vector a -> Int -> a
V.! Level -> Int
forall a. Enum a => a -> Int
fromEnum Level
l ]
               neff_errors :: Int
neff_errors   = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [     Int
n | Level
l <- [LoggingConf -> Level
error_level LoggingConf
conf ..],               let n :: Int
n = Vector Int
nws Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Level -> Int
forall a. Enum a => a -> Int
fromEnum Level
l ]
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Level, SomeException)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Level, SomeException)]
eff_errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
               Handle -> String -> String -> Int -> IO ()
forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
stderr "%s: there were %d (non-catastrophic) errors\n" String
pn Int
neff_errors
               [(Level, SomeException)]
-> ((Level, SomeException) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Level, SomeException)]
eff_errors (((Level, SomeException) -> IO ()) -> IO ())
-> ((Level, SomeException) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(l :: Level
l,e :: SomeException
e) -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> ShowS -> String -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Level -> ShowS
color_coded Level
l (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
neff_errors Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Level, SomeException)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Level, SomeException)]
eff_errors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| [(Level, SomeException)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Level, SomeException)]
eff_errors) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                   Handle -> String -> Int -> IO ()
forall r. HPrintfType r => Handle -> String -> r
hPrintf Handle
stderr "(and %d more)\n" (Int
neff_errors Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Level, SomeException)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Level, SomeException)]
eff_errors)

        case Either SomeException a
r of
          Left  e :: SomeException
e -> do case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                            Just UserInterrupt -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
pn String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": Interrupted"
                            _                  -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
pn String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": catastrophic error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
                        Either ExitCode a -> IO (Either ExitCode a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ExitCode a -> IO (Either ExitCode a))
-> (ExitCode -> Either ExitCode a)
-> ExitCode
-> IO (Either ExitCode a)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExitCode -> Either ExitCode a
forall a b. a -> Either a b
Left (ExitCode -> IO (Either ExitCode a))
-> ExitCode -> IO (Either ExitCode a)
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 2

          Right x :: a
x -> Either ExitCode a -> Either ExitCode a -> Bool -> Either ExitCode a
forall a. a -> a -> Bool -> a
bool (a -> Either ExitCode a
forall a b. b -> Either a b
Right a
x) (ExitCode -> Either ExitCode a
forall a b. a -> Either a b
Left (ExitCode -> Either ExitCode a) -> ExitCode -> Either ExitCode a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 1) (Bool -> Either ExitCode a) -> IO Bool -> IO (Either ExitCode a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Journal -> IORef Bool
error_exit Journal
journal)


-- | General wrapper around main.  Runs a command line parser with added
-- standard options (logging and usage related), runs the actual main
-- function, prints collected warnings and caught exceptions, and exits
-- appropriately:  `exitWith (ExitFailure 2)` if an exception was
-- caught, `exitFailure` if there were warnings of sufficient severity,
-- and `exitSuccess` otherwise.

execWithParser_ :: Parser a -> Maybe Version -> Maybe String -> InfoMod (a,LoggingConf) -> (a -> LIO b) -> IO b
execWithParser_ :: Parser a
-> Maybe Version
-> Maybe String
-> InfoMod (a, LoggingConf)
-> (a -> LIO b)
-> IO b
execWithParser_ opts :: Parser a
opts prog_ver :: Maybe Version
prog_ver prog_git_ver :: Maybe String
prog_git_ver inf :: InfoMod (a, LoggingConf)
inf =
    Parser a
-> Maybe Version
-> Maybe String
-> InfoMod (a, LoggingConf)
-> (a -> LIO b)
-> IO (Either ExitCode b)
forall a b.
Parser a
-> Maybe Version
-> Maybe String
-> InfoMod (a, LoggingConf)
-> (a -> LIO b)
-> IO (Either ExitCode b)
execWithParser Parser a
opts Maybe Version
prog_ver Maybe String
prog_git_ver InfoMod (a, LoggingConf)
inf ((a -> LIO b) -> IO (Either ExitCode b))
-> (Either ExitCode b -> IO b) -> (a -> LIO b) -> IO b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ExitCode -> IO b) -> (b -> IO b) -> Either ExitCode b -> IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure

execWithParser :: Parser a -> Maybe Version -> Maybe String -> InfoMod (a,LoggingConf)
               -> (a -> LIO b) -> IO (Either ExitCode b)
execWithParser :: Parser a
-> Maybe Version
-> Maybe String
-> InfoMod (a, LoggingConf)
-> (a -> LIO b)
-> IO (Either ExitCode b)
execWithParser opts :: Parser a
opts prog_ver :: Maybe Version
prog_ver prog_git_ver :: Maybe String
prog_git_ver inf :: InfoMod (a, LoggingConf)
inf k :: a -> LIO b
k = do
    String
pn <- IO String
getProgName
    let verStr :: String
verStr = String -> String -> String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf "%s%s (%s) using biohazard-%s (%s)" String
pn
                        (String -> (Version -> String) -> Maybe Version -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (('-'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (Version -> String) -> Version -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version -> String
showVersion) Maybe Version
prog_ver) (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "release" Maybe String
prog_git_ver)
                        (Version -> String
showVersion Version
version) (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "release" Maybe String
gitFullVersion)
        verOpt :: Parser (Any -> Any)
verOpt = String -> Mod OptionFields (Any -> Any) -> Parser (Any -> Any)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption String
verStr (Char -> Mod OptionFields (Any -> Any)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short 'V' Mod OptionFields (Any -> Any)
-> Mod OptionFields (Any -> Any) -> Mod OptionFields (Any -> Any)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Any -> Any)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "version" Mod OptionFields (Any -> Any)
-> Mod OptionFields (Any -> Any) -> Mod OptionFields (Any -> Any)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Any -> Any)
forall (f :: * -> *) a. String -> Mod f a
help "Print version number and exit")
    (a :: a
a,cf :: LoggingConf
cf) <- ParserInfo (a, LoggingConf) -> IO (a, LoggingConf)
forall a. ParserInfo a -> IO a
execParser (ParserInfo (a, LoggingConf) -> IO (a, LoggingConf))
-> ParserInfo (a, LoggingConf) -> IO (a, LoggingConf)
forall a b. (a -> b) -> a -> b
$ Parser (a, LoggingConf)
-> InfoMod (a, LoggingConf) -> ParserInfo (a, LoggingConf)
forall a. Parser a -> InfoMod a -> ParserInfo a
info ((,) (a -> LoggingConf -> (a, LoggingConf))
-> Parser a -> Parser (LoggingConf -> (a, LoggingConf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
opts Parser (LoggingConf -> (a, LoggingConf))
-> Parser LoggingConf -> Parser (a, LoggingConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser LoggingConf
logOptions Parser (a, LoggingConf)
-> Parser (Any -> Any) -> Parser (a, LoggingConf)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser (Any -> Any)
verOpt Parser (a, LoggingConf)
-> Parser (Any -> Any) -> Parser (a, LoggingConf)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser (Any -> Any)
forall a. Parser (a -> a)
helper) InfoMod (a, LoggingConf)
inf
    LoggingConf -> LIO b -> IO (Either ExitCode b)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
LoggingConf -> Logged m a -> m (Either ExitCode a)
withLogging LoggingConf
cf (a -> LIO b
k a
a)

logOptions :: Parser LoggingConf
logOptions :: Parser LoggingConf
logOptions =
    Level -> Level -> Level -> Int -> Bool -> LoggingConf
LoggingConf
    (Level -> Level -> Level -> Int -> Bool -> LoggingConf)
-> Parser Level
-> Parser (Level -> Level -> Int -> Bool -> LoggingConf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Level -> (Level -> Level) -> Level)
-> Level -> [Level -> Level] -> Level
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Level -> (Level -> Level) -> Level
forall a b. a -> (a -> b) -> b
(&) Level
Notice ([Level -> Level] -> Level)
-> Parser [Level -> Level] -> Parser Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Level -> Level) -> Parser [Level -> Level]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
            ((Level -> Level)
-> Mod FlagFields (Level -> Level) -> Parser (Level -> Level)
forall a. a -> Mod FlagFields a -> Parser a
flag' Level -> Level
forall a. (Enum a, Bounded a, Eq a) => a -> a
more (String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "quiet" Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. String -> Mod f a
help "Print only important messages") Parser (Level -> Level)
-> Parser (Level -> Level) -> Parser (Level -> Level)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             (Level -> Level)
-> Mod FlagFields (Level -> Level) -> Parser (Level -> Level)
forall a. a -> Mod FlagFields a -> Parser a
flag' Level -> Level
forall a. (Enum a, Bounded a, Eq a) => a -> a
less (String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "verbose" Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. String -> Mod f a
help "Print also trivial messages")))

    Parser (Level -> Level -> Int -> Bool -> LoggingConf)
-> Parser Level -> Parser (Level -> Int -> Bool -> LoggingConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Level -> (Level -> Level) -> Level)
-> Level -> [Level -> Level] -> Level
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Level -> (Level -> Level) -> Level
forall a b. a -> (a -> b) -> b
(&) Level
Warning ([Level -> Level] -> Level)
-> Parser [Level -> Level] -> Parser Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Level -> Level) -> Parser [Level -> Level]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
            ((Level -> Level)
-> Mod FlagFields (Level -> Level) -> Parser (Level -> Level)
forall a. a -> Mod FlagFields a -> Parser a
flag' Level -> Level
forall a. (Enum a, Bounded a, Eq a) => a -> a
more (String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "drop-errors" Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. String -> Mod f a
help "Remember only critical messages") Parser (Level -> Level)
-> Parser (Level -> Level) -> Parser (Level -> Level)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             (Level -> Level)
-> Mod FlagFields (Level -> Level) -> Parser (Level -> Level)
forall a. a -> Mod FlagFields a -> Parser a
flag' Level -> Level
forall a. (Enum a, Bounded a, Eq a) => a -> a
less (String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "keep-warnings" Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. String -> Mod f a
help "Remember also minor messages")))

    Parser (Level -> Int -> Bool -> LoggingConf)
-> Parser Level -> Parser (Int -> Bool -> LoggingConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Level -> (Level -> Level) -> Level)
-> Level -> [Level -> Level] -> Level
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Level -> (Level -> Level) -> Level
forall a b. a -> (a -> b) -> b
(&) Level
Error ([Level -> Level] -> Level)
-> Parser [Level -> Level] -> Parser Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Level -> Level) -> Parser [Level -> Level]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
            ((Level -> Level)
-> Mod FlagFields (Level -> Level) -> Parser (Level -> Level)
forall a. a -> Mod FlagFields a -> Parser a
flag' Level -> Level
forall a. (Enum a, Bounded a, Eq a) => a -> a
more (String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "warn-ignore" Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. String -> Mod f a
help "Fail only after critical errors") Parser (Level -> Level)
-> Parser (Level -> Level) -> Parser (Level -> Level)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             (Level -> Level)
-> Mod FlagFields (Level -> Level) -> Parser (Level -> Level)
forall a. a -> Mod FlagFields a -> Parser a
flag' Level -> Level
forall a. (Enum a, Bounded a, Eq a) => a -> a
less (String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "warn-error" Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
-> Mod FlagFields (Level -> Level)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Level -> Level)
forall (f :: * -> *) a. String -> Mod f a
help "Fail also after warnings")))

    Parser (Int -> Bool -> LoggingConf)
-> Parser Int -> Parser (Bool -> LoggingConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "journal-size" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "NUM" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help "Hold up to NUM errors in memory" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value 20)
    Parser (Bool -> LoggingConf) -> Parser Bool -> Parser LoggingConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "progress" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help "Print progress reports to the terminal")
  where
    more, less :: (Enum a, Bounded a, Eq a) => a -> a
    more :: a -> a
more a :: a
a = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
maxBound then a
a else a -> a
forall a. Enum a => a -> a
succ a
a
    less :: a -> a
less a :: a
a = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Bounded a => a
minBound then a
a else a -> a
forall a. Enum a => a -> a
pred a
a


-- | An exception than can be thrown when it doesn't seem warranted to
-- define a custom exception.  Transports a message.
data PanicCall = PanicCall String deriving (Typeable, Int -> PanicCall -> ShowS
[PanicCall] -> ShowS
PanicCall -> String
(Int -> PanicCall -> ShowS)
-> (PanicCall -> String)
-> ([PanicCall] -> ShowS)
-> Show PanicCall
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PanicCall] -> ShowS
$cshowList :: [PanicCall] -> ShowS
show :: PanicCall -> String
$cshow :: PanicCall -> String
showsPrec :: Int -> PanicCall -> ShowS
$cshowsPrec :: Int -> PanicCall -> ShowS
Show)
instance Exception PanicCall where displayException :: PanicCall -> String
displayException (PanicCall msg :: String
msg) = String
msg

panic :: MonadIO m => String -> m a
panic :: String -> m a
panic = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (String -> IO a) -> String -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PanicCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (PanicCall -> IO a) -> (String -> PanicCall) -> String -> IO a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> PanicCall
PanicCall

tryIO :: IO k -> IO (Maybe k)
tryIO :: IO k -> IO (Maybe k)
tryIO k :: IO k
k = IO (Maybe k) -> (IOError -> IO (Maybe k)) -> IO (Maybe k)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOError -> m a) -> m a
catchIOError (k -> Maybe k
forall a. a -> Maybe a
Just (k -> Maybe k) -> IO k -> IO (Maybe k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO k
k) (\_ -> Maybe k -> IO (Maybe k)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe k
forall a. Maybe a
Nothing)