module Hix.Monad (
  module Hix.Monad,
  AppResources (..),
  M,
) where

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT, throwE, ExceptT (ExceptT))
import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask, asks)
import Control.Monad.Trans.State.Strict (StateT, get, put, runStateT)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Exon (exon)
import Path (Abs, Dir, File, Path)
import qualified Path.IO as Path
import Path.IO (withSystemTempDir)
import System.IO (hClose)
import System.IO.Error (tryIOError)

import qualified Hix.Console as Console
import Hix.Data.Error (Error (BootstrapError, Client, EnvError, GhciError, NewError))
import qualified Hix.Data.GlobalOptions as GlobalOptions
import Hix.Data.GlobalOptions (GlobalOptions (GlobalOptions), defaultGlobalOptions)
import Hix.Data.Monad (AppResources (..), LogLevel, M (M), liftE)
import Hix.Error (Error (Fatal), tryIO, tryIOWith)
import qualified Hix.Log as Log
import Hix.Log (logWith)

throwM :: Error -> M a
throwM :: forall a. Error -> M a
throwM = ExceptT Error IO a -> M a
forall a. ExceptT Error IO a -> M a
liftE (ExceptT Error IO a -> M a)
-> (Error -> ExceptT Error IO a) -> Error -> M a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> ExceptT Error IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

clientError :: Text -> M a
clientError :: forall a. Text -> M a
clientError Text
msg = Error -> M a
forall a. Error -> M a
throwM (Text -> Error
Client Text
msg)

fatalError :: Text -> M a
fatalError :: forall a. Text -> M a
fatalError Text
msg = Error -> M a
forall a. Error -> M a
throwM (Text -> Error
Fatal Text
msg)

note :: Error -> Maybe a -> M a
note :: forall a. Error -> Maybe a -> M a
note Error
err =
  M a -> (a -> M a) -> Maybe a -> M a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error -> M a
forall a. Error -> M a
throwM Error
err) a -> M a
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

noteEnv :: Text -> Maybe a -> M a
noteEnv :: forall a. Text -> Maybe a -> M a
noteEnv Text
err =
  Error -> Maybe a -> M a
forall a. Error -> Maybe a -> M a
note (Text -> Error
EnvError Text
err)

noteGhci :: Text -> Maybe a -> M a
noteGhci :: forall a. Text -> Maybe a -> M a
noteGhci Text
err =
  Error -> Maybe a -> M a
forall a. Error -> Maybe a -> M a
note (Text -> Error
GhciError Text
err)

noteNew :: Text -> Maybe a -> M a
noteNew :: forall a. Text -> Maybe a -> M a
noteNew Text
err =
  Error -> Maybe a -> M a
forall a. Error -> Maybe a -> M a
note (Text -> Error
NewError Text
err)

noteBootstrap :: Text -> Maybe a -> M a
noteBootstrap :: forall a. Text -> Maybe a -> M a
noteBootstrap Text
err =
  Error -> Maybe a -> M a
forall a. Error -> Maybe a -> M a
note (Text -> Error
BootstrapError Text
err)

noteClient :: Text -> Maybe a -> M a
noteClient :: forall a. Text -> Maybe a -> M a
noteClient Text
err =
  Error -> Maybe a -> M a
forall a. Error -> Maybe a -> M a
note (Text -> Error
Client Text
err)

noteFatal :: Text -> Maybe a -> M a
noteFatal :: forall a. Text -> Maybe a -> M a
noteFatal Text
err =
  Error -> Maybe a -> M a
forall a. Error -> Maybe a -> M a
note (Text -> Error
Fatal Text
err)

eitherClient :: Either Text a -> M a
eitherClient :: forall a. Either Text a -> M a
eitherClient = (Text -> M a) -> Either Text a -> M a
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
leftA Text -> M a
forall a. Text -> M a
clientError

eitherFatal :: Either Text a -> M a
eitherFatal :: forall a. Either Text a -> M a
eitherFatal = (Text -> M a) -> Either Text a -> M a
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
leftA Text -> M a
forall a. Text -> M a
fatalError

eitherFatalShow ::
  Show b =>
  Text ->
  Either b a ->
  M a
eitherFatalShow :: forall b a. Show b => Text -> Either b a -> M a
eitherFatalShow Text
msg =
  Either Text a -> M a
forall a. Either Text a -> M a
eitherFatal (Either Text a -> M a)
-> (Either b a -> Either Text a) -> Either b a -> M a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Text) -> Either b a -> Either Text a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first b -> Text
mkMsg
  where
    mkMsg :: b -> Text
mkMsg b
err = [exon|#{msg}: #{show err}|]

whenDebug :: M () -> M ()
whenDebug :: M () -> M ()
whenDebug M ()
m =
  M Bool -> M () -> M ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ReaderT AppResources (ExceptT Error IO) Bool -> M Bool
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M ((AppResources -> Bool)
-> ReaderT AppResources (ExceptT Error IO) Bool
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (.debug))) do
    M ()
m

logIORef :: IORef [Text] -> LogLevel -> Text -> IO ()
logIORef :: IORef [Text] -> LogLevel -> Text -> IO ()
logIORef IORef [Text]
ref LogLevel
_ Text
msg =
  IORef [Text] -> ([Text] -> [Text]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Text]
ref (Text
msg :)

withLogIORef :: ((LogLevel -> Text -> IO ()) -> IO a) -> IO ([Text], a)
withLogIORef :: forall a. ((LogLevel -> Text -> IO ()) -> IO a) -> IO ([Text], a)
withLogIORef (LogLevel -> Text -> IO ()) -> IO a
use = do
  IORef [Text]
logRef <- [Text] -> IO (IORef [Text])
forall a. a -> IO (IORef a)
newIORef []
  a
result <- (LogLevel -> Text -> IO ()) -> IO a
use (IORef [Text] -> LogLevel -> Text -> IO ()
logIORef IORef [Text]
logRef)
  [Text]
log <- IORef [Text] -> IO [Text]
forall a. IORef a -> IO a
readIORef IORef [Text]
logRef
  pure ([Text]
log, a
result)

runMLoggerWith :: (LogLevel -> Text -> IO ()) -> GlobalOptions -> M a -> IO (Either Error a)
runMLoggerWith :: forall a.
(LogLevel -> Text -> IO ())
-> GlobalOptions -> M a -> IO (Either Error a)
runMLoggerWith LogLevel -> Text -> IO ()
logger GlobalOptions {Bool
Path Abs Dir
OutputFormat
OutputTarget
verbose :: Bool
debug :: Bool
quiet :: Bool
cwd :: Path Abs Dir
output :: OutputFormat
target :: OutputTarget
$sel:verbose:GlobalOptions :: GlobalOptions -> Bool
$sel:debug:GlobalOptions :: GlobalOptions -> Bool
$sel:quiet:GlobalOptions :: GlobalOptions -> Bool
$sel:cwd:GlobalOptions :: GlobalOptions -> Path Abs Dir
$sel:output:GlobalOptions :: GlobalOptions -> OutputFormat
$sel:target:GlobalOptions :: GlobalOptions -> OutputTarget
..} (M ReaderT AppResources (ExceptT Error IO) a
ma) =
  String
-> (Path Abs Dir -> IO (Either Error a)) -> IO (Either Error a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir String
"hix-cli" \ Path Abs Dir
tmp ->
    ExceptT Error IO a -> IO (Either Error a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT AppResources (ExceptT Error IO) a
-> AppResources -> ExceptT Error IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT AppResources (ExceptT Error IO) a
ma AppResources {$sel:logger:AppResources :: LogLevel -> Text -> M ()
logger = (LogLevel -> Text -> IO ()) -> LogLevel -> Text -> M ()
logWith LogLevel -> Text -> IO ()
logger, Bool
Path Abs Dir
OutputFormat
OutputTarget
verbose :: Bool
debug :: Bool
quiet :: Bool
cwd :: Path Abs Dir
output :: OutputFormat
target :: OutputTarget
tmp :: Path Abs Dir
$sel:cwd:AppResources :: Path Abs Dir
$sel:tmp:AppResources :: Path Abs Dir
$sel:verbose:AppResources :: Bool
$sel:debug:AppResources :: Bool
$sel:quiet:AppResources :: Bool
$sel:output:AppResources :: OutputFormat
$sel:target:AppResources :: OutputTarget
..})

runMLogWith :: GlobalOptions -> M a -> IO ([Text], Either Error a)
runMLogWith :: forall a. GlobalOptions -> M a -> IO ([Text], Either Error a)
runMLogWith GlobalOptions
opts M a
ma =
  ((LogLevel -> Text -> IO ()) -> IO (Either Error a))
-> IO ([Text], Either Error a)
forall a. ((LogLevel -> Text -> IO ()) -> IO a) -> IO ([Text], a)
withLogIORef \ LogLevel -> Text -> IO ()
logger -> (LogLevel -> Text -> IO ())
-> GlobalOptions -> M a -> IO (Either Error a)
forall a.
(LogLevel -> Text -> IO ())
-> GlobalOptions -> M a -> IO (Either Error a)
runMLoggerWith LogLevel -> Text -> IO ()
logger GlobalOptions
opts M a
ma

runMLog :: Path Abs Dir -> M a -> IO ([Text], Either Error a)
runMLog :: forall a. Path Abs Dir -> M a -> IO ([Text], Either Error a)
runMLog = GlobalOptions -> M a -> IO ([Text], Either Error a)
forall a. GlobalOptions -> M a -> IO ([Text], Either Error a)
runMLogWith (GlobalOptions -> M a -> IO ([Text], Either Error a))
-> (Path Abs Dir -> GlobalOptions)
-> Path Abs Dir
-> M a
-> IO ([Text], Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> GlobalOptions
defaultGlobalOptions

runMWith :: GlobalOptions -> M a -> IO (Either Error a)
runMWith :: forall a. GlobalOptions -> M a -> IO (Either Error a)
runMWith = (LogLevel -> Text -> IO ())
-> GlobalOptions -> M a -> IO (Either Error a)
forall a.
(LogLevel -> Text -> IO ())
-> GlobalOptions -> M a -> IO (Either Error a)
runMLoggerWith ((Text -> IO ()) -> LogLevel -> Text -> IO ()
forall a b. a -> b -> a
const Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
Console.err)

runM :: Path Abs Dir -> M a -> IO (Either Error a)
runM :: forall a. Path Abs Dir -> M a -> IO (Either Error a)
runM = GlobalOptions -> M a -> IO (Either Error a)
forall a. GlobalOptions -> M a -> IO (Either Error a)
runMWith (GlobalOptions -> M a -> IO (Either Error a))
-> (Path Abs Dir -> GlobalOptions)
-> Path Abs Dir
-> M a
-> IO (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> GlobalOptions
defaultGlobalOptions

runMDebug :: Path Abs Dir -> M a -> IO (Either Error a)
runMDebug :: forall a. Path Abs Dir -> M a -> IO (Either Error a)
runMDebug Path Abs Dir
cwd =
  GlobalOptions -> M a -> IO (Either Error a)
forall a. GlobalOptions -> M a -> IO (Either Error a)
runMWith (Path Abs Dir -> GlobalOptions
defaultGlobalOptions Path Abs Dir
cwd) {$sel:verbose:GlobalOptions :: Bool
GlobalOptions.verbose = Bool
True, $sel:debug:GlobalOptions :: Bool
GlobalOptions.debug = Bool
True}

tryIOMWithM :: (Text -> M a) -> IO a -> M a
tryIOMWithM :: forall a. (Text -> M a) -> IO a -> M a
tryIOMWithM Text -> M a
handleError IO a
ma =
  IO (Either IOError a) -> M (Either IOError a)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
tryIOError IO a
ma) M (Either IOError a) -> (Either IOError a -> M a) -> M a
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
a -> a -> M a
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left IOError
err -> Text -> M a
handleError (IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show IOError
err)

tryIOMWith :: (Text -> Error) -> IO a -> M a
tryIOMWith :: forall a. (Text -> Error) -> IO a -> M a
tryIOMWith Text -> Error
mkErr IO a
ma = ReaderT AppResources (ExceptT Error IO) a -> M a
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M (ExceptT Error IO a -> ReaderT AppResources (ExceptT Error IO) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT AppResources m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Text -> Error) -> IO a -> ExceptT Error IO a
forall a. (Text -> Error) -> IO a -> ExceptT Error IO a
tryIOWith Text -> Error
mkErr IO a
ma))

tryIOMAs :: Error -> IO a -> M a
tryIOMAs :: forall a. Error -> IO a -> M a
tryIOMAs Error
err IO a
ma = do
  IO (Either IOError a) -> M (Either IOError a)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
tryIOError IO a
ma) M (Either IOError a) -> (Either IOError a -> M a) -> M a
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
a -> a -> M a
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left IOError
exc -> do
      M () -> M ()
whenDebug do
        Text -> M ()
Log.error [exon|Replaced exception: #{show exc}|]
      Error -> M a
forall a. Error -> M a
throwM Error
err

tryIOM :: IO a -> M a
tryIOM :: forall a. IO a -> M a
tryIOM IO a
ma = ReaderT AppResources (ExceptT Error IO) a -> M a
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M (ExceptT Error IO a -> ReaderT AppResources (ExceptT Error IO) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT AppResources m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ExceptT Error IO a
forall a. IO a -> ExceptT Error IO a
tryIO IO a
ma))

catchIOM :: IO a -> (Text -> M a) -> M a
catchIOM :: forall a. IO a -> (Text -> M a) -> M a
catchIOM IO a
ma Text -> M a
handle =
  IO (Either IOError a) -> M (Either IOError a)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
tryIOError IO a
ma) M (Either IOError a) -> (Either IOError a -> M a) -> M a
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
a -> a -> M a
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left IOError
err -> Text -> M a
handle (IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show IOError
err)

withTempDir :: String -> (Path Abs Dir -> M a) -> M a
withTempDir :: forall a. String -> (Path Abs Dir -> M a) -> M a
withTempDir String
name Path Abs Dir -> M a
use = do
  AppResources {Path Abs Dir
$sel:tmp:AppResources :: AppResources -> Path Abs Dir
tmp :: Path Abs Dir
tmp} <- ReaderT AppResources (ExceptT Error IO) AppResources
-> M AppResources
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M ReaderT AppResources (ExceptT Error IO) AppResources
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Path Abs Dir -> String -> (Path Abs Dir -> M a) -> M a
forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> String -> (Path Abs Dir -> m a) -> m a
Path.withTempDir Path Abs Dir
tmp String
name Path Abs Dir -> M a
use

withTempFile :: String -> Maybe [Text] -> (Path Abs File -> M a) -> M a
withTempFile :: forall a. String -> Maybe [Text] -> (Path Abs File -> M a) -> M a
withTempFile String
name Maybe [Text]
content Path Abs File -> M a
use = do
  AppResources {Path Abs Dir
$sel:tmp:AppResources :: AppResources -> Path Abs Dir
tmp :: Path Abs Dir
tmp} <- ReaderT AppResources (ExceptT Error IO) AppResources
-> M AppResources
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M ReaderT AppResources (ExceptT Error IO) AppResources
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Path Abs Dir -> String -> (Path Abs File -> Handle -> M a) -> M a
forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> String -> (Path Abs File -> Handle -> m a) -> m a
Path.withTempFile Path Abs Dir
tmp String
name \ Path Abs File
file Handle
handle -> do
    Maybe [Text] -> ([Text] -> M ()) -> M ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [Text]
content \ [Text]
lns -> IO () -> M ()
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Text -> IO ()
Text.hPutStr Handle
handle ([Text] -> Text
Text.unlines [Text]
lns))
    IO () -> M ()
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
hClose Handle
handle)
    Path Abs File -> M a
use Path Abs File
file

stateM ::
  Monad m =>
  (s -> a -> m (s, b)) ->
  a ->
  StateT s m b
stateM :: forall (m :: * -> *) s a b.
Monad m =>
(s -> a -> m (s, b)) -> a -> StateT s m b
stateM s -> a -> m (s, b)
f a
a = do
  s
s <- StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
get
  (s
s', b
b) <- m (s, b) -> StateT s m (s, b)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (s -> a -> m (s, b)
f s
s a
a)
  s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put s
s'
  pure b
b

mapAccumM ::
  Traversable t =>
  Monad m =>
  (s -> a -> m (s, b)) ->
  s ->
  t a ->
  m (s, t b)
mapAccumM :: forall (t :: * -> *) (m :: * -> *) s a b.
(Traversable t, Monad m) =>
(s -> a -> m (s, b)) -> s -> t a -> m (s, t b)
mapAccumM s -> a -> m (s, b)
f s
s t a
as =
  (t b, s) -> (s, t b)
forall a b. (a, b) -> (b, a)
swap ((t b, s) -> (s, t b)) -> m (t b, s) -> m (s, t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m (t b) -> s -> m (t b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((a -> StateT s m b) -> t a -> StateT s m (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse ((s -> a -> m (s, b)) -> a -> StateT s m b
forall (m :: * -> *) s a b.
Monad m =>
(s -> a -> m (s, b)) -> a -> StateT s m b
stateM s -> a -> m (s, b)
f) t a
as) s
s

withLower :: (∀ b . (M a -> IO b) -> IO b) -> M a
withLower :: forall a. (forall b. (M a -> IO b) -> IO b) -> M a
withLower forall b. (M a -> IO b) -> IO b
f = do
  AppResources
res <- ReaderT AppResources (ExceptT Error IO) AppResources
-> M AppResources
forall a. ReaderT AppResources (ExceptT Error IO) a -> M a
M ReaderT AppResources (ExceptT Error IO) AppResources
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ExceptT Error IO a -> M a
forall a. ExceptT Error IO a -> M a
liftE (IO (Either Error a) -> ExceptT Error IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((M a -> IO (Either Error a)) -> IO (Either Error a)
forall b. (M a -> IO b) -> IO b
f \ (M ReaderT AppResources (ExceptT Error IO) a
ma) -> ExceptT Error IO a -> IO (Either Error a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT AppResources (ExceptT Error IO) a
-> AppResources -> ExceptT Error IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT AppResources (ExceptT Error IO) a
ma AppResources
res)))