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) runMUsing :: AppResources -> M a -> IO (Either Error a) runMUsing :: forall a. AppResources -> M a -> IO (Either Error a) runMUsing AppResources res (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) 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 target :: GlobalOptions -> OutputTarget output :: GlobalOptions -> OutputFormat cwd :: GlobalOptions -> Path Abs Dir quiet :: GlobalOptions -> Bool debug :: GlobalOptions -> Bool verbose :: GlobalOptions -> Bool ..} M 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 -> AppResources -> M a -> IO (Either Error a) forall a. AppResources -> M a -> IO (Either Error a) runMUsing AppResources {logger :: 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 target :: OutputTarget output :: OutputFormat quiet :: Bool debug :: Bool verbose :: Bool tmp :: Path Abs Dir cwd :: Path Abs Dir ..} M a ma 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) {GlobalOptions.verbose = True, GlobalOptions.debug = 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 e a. (Text -> e) -> IO a -> ExceptT e 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 tmp :: 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 tmp :: 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)))