{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Glazier.Command.Exec where
import Data.Kind
import Control.Applicative
import Control.Lens
import Control.Monad.IO.Unlift
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Maybe.Extras
import Data.Diverse.Lens
import qualified Data.DList as DL
import Data.Foldable
import Data.Proxy
import Glazier.Command
import qualified UnliftIO.Concurrent as U
type family CmdTypes c cmd :: [Type]
newtype NoIOCmd cmd = NoIOCmd { unNoIOCmd :: Which (CmdTypes (NoIOCmd cmd) (NoIOCmd cmd)) }
type instance CmdTypes (NoIOCmd c) cmd = Remove (IO cmd) (CmdTypes c cmd)
instance (AsFacet a (Which (CmdTypes (NoIOCmd cmd) (NoIOCmd cmd)))) => AsFacet a (NoIOCmd cmd) where
facet = iso unNoIOCmd NoIOCmd . facet
maybeExec :: (Applicative m, AsFacet a c) => (a -> m b) -> c -> MaybeT m (Proxy '[a], b)
maybeExec k c = MaybeT . sequenceA $ (fmap (\b -> (Proxy, b)) . k) <$> preview facet c
fixExec :: Functor m => ((cmd -> m ()) -> cmd -> MaybeT m (Proxy cmds, ())) -> cmd -> m (Proxy cmds, ())
fixExec fexec = let go = (`evalMaybeT` (Proxy, ())) . fexec (fmap snd . go) in go
verifyExec ::
( AppendUnique '[] ys ~ ys
, AppendUnique xs ys ~ xs
, AppendUnique ys xs ~ ys
, Functor m
)
=> (cmd -> Which xs) -> (cmd -> m (Proxy ys, b)) -> (cmd -> m b)
verifyExec _ g = fmap snd . g
verifyFixExec ::
( AppendUnique '[] ys ~ ys
, AppendUnique xs ys ~ xs
, AppendUnique ys xs ~ ys
, Functor m
, Functor m
) => (cmd -> Which xs) -> ((cmd -> m ()) -> cmd -> MaybeT m (Proxy ys, ())) -> cmd -> m ()
verifyFixExec unCmd maybeExecuteCmd = verifyExec unCmd (fixExec maybeExecuteCmd)
orMaybeExec :: (Monad m, a'' ~ Append a a') => MaybeT m (Proxy a, b) -> MaybeT m (Proxy a', b) -> MaybeT m (Proxy a'', b)
orMaybeExec m n = (\b -> (Proxy, b)) <$> ((snd <$> m) <|> (snd <$> n))
infixl 3 `orMaybeExec`
execConcur ::
MonadUnliftIO m
=> (cmd -> m ())
-> Concur cmd a
-> m a
execConcur executor (Concur m) = do
ea <- execConcur_ executor
liftIO $ either id pure ea
where
execConcur_ executor' = do
(ma, cs) <- liftIO $ unNewEmptyMVar $ runStateT m mempty
traverse_ (void . U.forkIO . executor') (DL.toList cs)
pure ma