{-# 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           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 )

-- | 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 = (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 = 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 = 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 = 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 = 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 = 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 <- 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
  pure $ SimplePrettyApp
    { spaLogFunc = logFunc
    , spaProcessContext = processContext
    , spaUseColor = useColor
    , spaTermWidth = termWidth
    , spaStylesUpdate = 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 = 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
  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"
  lo <- setLogUseColor True <$> logOptionsHandle stderr verbose
  withLogFunc lo $ \LogFunc
lf -> do
    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
    runRIO simplePrettyApp m