{-# LANGUAGE NoImplicitPrelude #-}

{-|
This module exports a 'SimplePrettyApp' type, for providing a basic environment
including pretty printing functionality.
-}
module RIO.PrettyPrint.Simple
  ( SimplePrettyApp
  , mkSimplePrettyApp
  , runSimplePrettyApp
  ) where

import System.Environment (lookupEnv)

import RIO
         ( Bool (..), HasLogFunc (..), Int, LogFunc, Maybe (..), MonadIO, RIO
         , ($), (<$>), isJust, lens, liftIO, logOptionsHandle, maybe, pure
         , runRIO, setLogUseColor, stderr, withLogFunc
         )
import RIO.Process
         ( HasProcessContext (..), ProcessContext, mkDefaultProcessContext )

import RIO.PrettyPrint (HasTerm (..))
import RIO.PrettyPrint.StylesUpdate (HasStylesUpdate (..), StylesUpdate (..))

-- | A simple, non-customizable environment type, which provides
-- pretty printing functionality.
--
-- @since 0.1.3.0
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 = 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 = 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 = 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 = 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 = 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 })

-- | Constructor for 'SimplePrettyApp'. If 'ProcessContext' is not supplied
-- 'mkDefaultProcessContext' will be used to create it.
--
-- @since 0.1.3.0
mkSimplePrettyApp
  :: MonadIO m
  => LogFunc
  -> Maybe ProcessContext
  -> Bool
     -- ^ Use color?
  -> Int
     -- ^ Terminal width
  -> 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadIO m => m ProcessContext
mkDefaultProcessContext forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProcessContext
mProcessContext
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
    }

-- | Run with a default configured @SimplePrettyApp@, consisting of:
--
-- * Logging to 'stderr'
--
-- * If the @RIO_VERBOSE@ environment variable is set, turns on verbose logging
--
-- * Default process context
--
-- * Logging using color
--
-- @since 0.1.3.0
runSimplePrettyApp
  :: MonadIO m
  => Int
     -- ^ Terminal width
  -> 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Bool
verbose <- forall a. Maybe a -> Bool
isJust 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
verbose
  forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
lo forall a b. (a -> b) -> a -> b
$ \LogFunc
lf -> do
    SimplePrettyApp
simplePrettyApp <- forall (m :: * -> *).
MonadIO m =>
LogFunc
-> Maybe ProcessContext
-> Bool
-> Int
-> StylesUpdate
-> m SimplePrettyApp
mkSimplePrettyApp LogFunc
lf forall a. Maybe a
Nothing Bool
True Int
termWidth StylesUpdate
stylesUpdate
    forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO SimplePrettyApp
simplePrettyApp RIO SimplePrettyApp a
m