{-# LANGUAGE NoImplicitPrelude #-}
module RIO.PrettyPrint.Simple
( SimplePrettyApp
, mkSimplePrettyApp
, runSimplePrettyApp
) where
import RIO
( Bool (..), HasLogFunc (..), Int, LogFunc, Maybe (..)
, MonadIO, RIO, ($), (<$>), isJust, lens, liftIO
, logOptionsHandle, maybe, pure, runRIO, setLogUseColor
, stderr, withLogFunc
)
import RIO.PrettyPrint ( HasTerm (..) )
import RIO.PrettyPrint.StylesUpdate
( HasStylesUpdate (..), StylesUpdate (..) )
import RIO.Process
( HasProcessContext (..), ProcessContext
, mkDefaultProcessContext
)
import System.Environment ( lookupEnv )
data SimplePrettyApp = SimplePrettyApp
{ SimplePrettyApp -> LogFunc
spaLogFunc :: !LogFunc
, SimplePrettyApp -> ProcessContext
spaProcessContext :: !ProcessContext
, SimplePrettyApp -> Bool
spaUseColor :: !Bool
, SimplePrettyApp -> Int
spaTermWidth :: !Int
, SimplePrettyApp -> StylesUpdate
spaStylesUpdate :: !StylesUpdate
}
instance HasLogFunc SimplePrettyApp where
logFuncL :: Lens' SimplePrettyApp LogFunc
logFuncL = (SimplePrettyApp -> LogFunc)
-> (SimplePrettyApp -> LogFunc -> SimplePrettyApp)
-> Lens' SimplePrettyApp LogFunc
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SimplePrettyApp -> LogFunc
spaLogFunc (\SimplePrettyApp
x LogFunc
y -> SimplePrettyApp
x { spaLogFunc :: LogFunc
spaLogFunc = LogFunc
y })
instance HasProcessContext SimplePrettyApp where
processContextL :: Lens' SimplePrettyApp ProcessContext
processContextL = (SimplePrettyApp -> ProcessContext)
-> (SimplePrettyApp -> ProcessContext -> SimplePrettyApp)
-> Lens' SimplePrettyApp ProcessContext
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SimplePrettyApp -> ProcessContext
spaProcessContext (\SimplePrettyApp
x ProcessContext
y -> SimplePrettyApp
x { spaProcessContext :: ProcessContext
spaProcessContext = ProcessContext
y })
instance HasStylesUpdate SimplePrettyApp where
stylesUpdateL :: Lens' SimplePrettyApp StylesUpdate
stylesUpdateL = (SimplePrettyApp -> StylesUpdate)
-> (SimplePrettyApp -> StylesUpdate -> SimplePrettyApp)
-> Lens' SimplePrettyApp StylesUpdate
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SimplePrettyApp -> StylesUpdate
spaStylesUpdate (\SimplePrettyApp
x StylesUpdate
y -> SimplePrettyApp
x { spaStylesUpdate :: StylesUpdate
spaStylesUpdate = StylesUpdate
y })
instance HasTerm SimplePrettyApp where
useColorL :: Lens' SimplePrettyApp Bool
useColorL = (SimplePrettyApp -> Bool)
-> (SimplePrettyApp -> Bool -> SimplePrettyApp)
-> Lens' SimplePrettyApp Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SimplePrettyApp -> Bool
spaUseColor (\SimplePrettyApp
x Bool
y -> SimplePrettyApp
x { spaUseColor :: Bool
spaUseColor = Bool
y })
termWidthL :: Lens' SimplePrettyApp Int
termWidthL = (SimplePrettyApp -> Int)
-> (SimplePrettyApp -> Int -> SimplePrettyApp)
-> Lens' SimplePrettyApp Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens SimplePrettyApp -> Int
spaTermWidth (\SimplePrettyApp
x Int
y -> SimplePrettyApp
x { spaTermWidth :: Int
spaTermWidth = Int
y })
mkSimplePrettyApp ::
MonadIO m
=> LogFunc
-> Maybe ProcessContext
-> Bool
-> Int
-> StylesUpdate
-> m SimplePrettyApp
mkSimplePrettyApp :: forall (m :: * -> *).
MonadIO m =>
LogFunc
-> Maybe ProcessContext
-> Bool
-> Int
-> StylesUpdate
-> m SimplePrettyApp
mkSimplePrettyApp LogFunc
logFunc Maybe ProcessContext
mProcessContext Bool
useColor Int
termWidth StylesUpdate
stylesUpdate = do
ProcessContext
processContext <- m ProcessContext
-> (ProcessContext -> m ProcessContext)
-> Maybe ProcessContext
-> m ProcessContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ProcessContext
forall (m :: * -> *). MonadIO m => m ProcessContext
mkDefaultProcessContext ProcessContext -> m ProcessContext
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProcessContext
mProcessContext
SimplePrettyApp -> m SimplePrettyApp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimplePrettyApp -> m SimplePrettyApp)
-> SimplePrettyApp -> m SimplePrettyApp
forall a b. (a -> b) -> a -> b
$ SimplePrettyApp
{ spaLogFunc :: LogFunc
spaLogFunc = LogFunc
logFunc
, spaProcessContext :: ProcessContext
spaProcessContext = ProcessContext
processContext
, spaUseColor :: Bool
spaUseColor = Bool
useColor
, spaTermWidth :: Int
spaTermWidth = Int
termWidth
, spaStylesUpdate :: StylesUpdate
spaStylesUpdate = StylesUpdate
stylesUpdate
}
runSimplePrettyApp ::
MonadIO m
=> Int
-> StylesUpdate
-> RIO SimplePrettyApp a
-> m a
runSimplePrettyApp :: forall (m :: * -> *) a.
MonadIO m =>
Int -> StylesUpdate -> RIO SimplePrettyApp a -> m a
runSimplePrettyApp Int
termWidth StylesUpdate
stylesUpdate RIO SimplePrettyApp a
m = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
Bool
verbose <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"RIO_VERBOSE"
LogOptions
lo <- Bool -> LogOptions -> LogOptions
setLogUseColor Bool
True (LogOptions -> LogOptions) -> IO LogOptions -> IO LogOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Bool -> IO LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
verbose
LogOptions -> (LogFunc -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
lo ((LogFunc -> IO a) -> IO a) -> (LogFunc -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \LogFunc
lf -> do
SimplePrettyApp
simplePrettyApp <- LogFunc
-> Maybe ProcessContext
-> Bool
-> Int
-> StylesUpdate
-> IO SimplePrettyApp
forall (m :: * -> *).
MonadIO m =>
LogFunc
-> Maybe ProcessContext
-> Bool
-> Int
-> StylesUpdate
-> m SimplePrettyApp
mkSimplePrettyApp LogFunc
lf Maybe ProcessContext
forall a. Maybe a
Nothing Bool
True Int
termWidth StylesUpdate
stylesUpdate
SimplePrettyApp -> RIO SimplePrettyApp a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO SimplePrettyApp
simplePrettyApp RIO SimplePrettyApp a
m