monad-effect 0.1.0.0 → 0.2.0.0

raw patch · 15 files changed

+602/−202 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• bench/BenchCatch.hs +2/−2
• monad-effect.cabal +2/−1
• src/Control/Monad/Effect.hs +269/−15
• src/Control/Monad/RS/Class.hs +18/−2
• src/Control/System.hs +59/−120
• src/Control/System/EventLoop.hs +6/−17
• src/Data/TypeList.hs +29/−12
• src/Data/TypeList/ConsFData.hs +12/−1
• src/Data/TypeList/FData.hs +23/−5
• src/Data/TypeList/FData/TH.hs +39/−2
• src/Data/TypeList/Families.hs +5/−0
• src/Module/RS.hs +57/−2
• src/Module/RS/QQ.hs +72/−16
• src/Module/Resource.hs +7/−5
• test/TH.hs +2/−2

@@ -33,8 +33,8 @@  programMonadEffect :: Int -> ME.EffT mods '[ErrorValue "()" ()] ME.Identity () programMonadEffect = \case-    0 -> ME.effThrow (ErrorValue @"()" ())-    n -> ME.effCatchIn' (programMonadEffect (n - 1)) $ \(ErrorValue @"()" ()) -> ME.effThrow (ErrorValue @"()" ())+    0 -> ME.effThrow (ErrorValue @_ @"()" ())+    n -> ME.effCatchIn' (programMonadEffect (n - 1)) $ \(ErrorValue @_ @"()" ()) -> ME.effThrow (ErrorValue @_ @"()" ()) {-# NOINLINE programMonadEffect #-}  catchMonadEffect :: Int -> Either () ()

@@ -7,7 +7,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.1.0.0+version:            0.2.0.0  -- A short (one-line) description of the package. synopsis:  A fast and lightweight effect system.@@ -73,6 +73,7 @@     -- | This is a small library that gets benefit from inlining and specialisation.     -- therefore we turn on these optimisations     ghc-options: -O2 -fexpose-all-unfoldings -fspecialise-aggressively -flate-dmd-anal+    -- -finfo-table-map -fdistinct-constructor-tables -ddump-to-file -ddump-splices      -- Modules exported by the library.     exposed-modules:  Control.Monad.Effect

@@ -1,4 +1,4 @@-{-# LANGUAGE DerivingVia, AllowAmbiguousTypes, UndecidableInstances, PatternSynonyms, LinearTypes #-}+{-# LANGUAGE DerivingVia, AllowAmbiguousTypes, UndecidableInstances, LinearTypes, QuantifiedConstraints #-} -- | Module: Control.Monad.Effect -- Description: The module you should import to use for effectful computation --@@ -7,30 +7,62 @@   ( -- * EffTectful computation     EffT', Eff, Pure, EffT, EffL, PureL, EffLT   , ErrorText(..), errorText, ErrorValue(..), errorValue, MonadThrowError(..)+  , MonadFailError(..)++  -- * Natural Transformation+  , baseTransform++  -- * Embedding effects   , embedEffT, embedMods, embedError++  -- * Running EffT   , runEffT, runEffT_, runEffT0, runEffT01, runEffT00   , runEffTNoError   , runEffTOuter, runEffTOuter', runEffTOuter_   , runEffTIn, runEffTIn', runEffTIn_+  , replaceEffTIn++  -- * Catching and throwing algebraic exceptions   , effCatch, effCatchAll, effCatchSystem   , effCatchIn, effCatchIn'-  , effThrow, effThrowIn+  , effThrow, effThrowIn, effThrowEList, effThrowEListIn++  -- * Catching exceptions from base+  , effTry, effTryIn, effTryWith, effTryInWith   , effTryIO, effTryIOIn, effTryIOWith, effTryIOInWith++  -- * Converting values to error   , effEither, effEitherWith   , effEitherIn, effEitherInWith+  , effEitherSystemException   , effMaybeWith, effMaybeInWith   , pureMaybeInWith, pureEitherInWith   , baseEitherIn, baseEitherInWith, baseMaybeInWith-  , errorToEither, errorToEitherAll, eitherAllToEffect++  -- * Converting error to values+  , errorToEither, errorToEitherAll, eitherAllToEffect, errorInToEither+  , errorToMaybe, errorInToMaybe, errorToResult+  +  -- * Transforming error+  , mapError++  -- * Lifting IO   , liftIOException, liftIOAt, liftIOSafeWith, liftIOText, liftIOPrepend-  , effEitherSystemException +  -- * Bracket pattern+  , maskEffT, generalBracketEffT, bracketEffT++  -- * Looping+  , foreverEffT+   -- * Concurrency-  , forkEffT, forkEffTSafe, asyncEffT+  , forkEffT, forkEffTFinally, forkEffTSafe, asyncEffT+  , restoreAsync, restoreAsync_    -- * No Error-  , declareNoError   , checkNoError+  , declareNoError+  , embedNoError   , NoError    -- * Modules@@ -45,24 +77,24 @@   , SystemError(..)    -- * Re-exports-  , MonadIO(..)+  , MonadIO(..), MonadMask   , ConsFDataList, FList, FData   , Identity(..)   , InList, In'   , In, InL   , module Data.TypeList.ConsFData.Pattern   , fNil+   -- * Result types   , Result(..), EList(..)   ) where --- import Control.Parallel.Strategies import Control.Concurrent import Control.Concurrent.Async import Control.Exception as E hiding (TypeError) import Control.Monad import Control.Monad.Base-import Control.Monad.Catch+import Control.Monad.Catch as Catch import Control.Monad.IO.Class import Control.Monad.RS.Class import Control.Monad.Trans@@ -79,6 +111,7 @@ import Data.TypeList.FData import GHC.TypeError import GHC.TypeLits+import GHC.Stack (HasCallStack)  -- | EffTectful computation, using modules as units of effect -- the tick is used to indicate the polymorphic type c which is the data structure used to store the modules.@@ -180,9 +213,11 @@     return (RSuccess a, ss)   {-# INLINE liftIO #-} -instance Monad m => MonadReadable (SystemRead c mods) (EffT' c mods es m) where+instance Monad m => MonadReadOnly (SystemRead c mods) (EffT' c mods es m) where   query = EffT' $ \rs ss -> return (RSuccess rs, ss)   {-# INLINE query #-}++instance Monad m => MonadReadable (SystemRead c mods) (EffT' c mods es m) where   local f (EffT' eff) = EffT' $ \rs ss -> eff (f rs) ss   {-# INLINE local #-} @@ -223,18 +258,83 @@   -- _  -- | The error in throwM is thrown as MonadThrowError, which is a wrapper for SomeException.-instance (Monad m, ConsFDataList c mods, InList MonadThrowError es) => MonadThrow (EffT' c mods es m) where+instance (Monad m, InList MonadThrowError es) => MonadThrow (EffT' c mods es m) where   throwM = effThrowIn . MonadThrowError . toException   {-# INLINE throwM #-}  -- | this can only catch MonadThrowError, other errors are algebraic and should be caught by effCatch, effCatchIn, effCatchAll-instance (Monad m, ConsFDataList c mods, InList MonadThrowError es) => MonadCatch (EffT' c mods es m) where+instance (Monad m, InList MonadThrowError es) => MonadCatch (EffT' c mods es m) where   catch ma handler = effCatchIn' ma $ \(MonadThrowError e) ->     case fromException e of       Just e' -> handler e'       Nothing -> effThrowIn $ MonadThrowError e   {-# INLINE catch #-} +-- | Used for MonadFail instances only+newtype MonadFailError = MonadFailError String+instance Show MonadFailError where+  show (MonadFailError s) = "MonadFailError { " ++ s ++ " }"++-- | When MonadFailError is in the error list, we can use MonadFail instance+instance (Monad m, InList MonadFailError es) => MonadFail (EffT' c mods es m) where+  fail = effThrowIn . MonadFailError+  {-# INLINE fail #-}++baseTransform :: ( forall a. m a -> n a ) -> EffT' c mods es m b -> EffT' c mods es n b+baseTransform f = \(EffT' eff) -> EffT' $ \rs ss -> f (eff rs ss)+{-# INLINE baseTransform #-}++-- | Do not use Control.Applicative.forever, use this instead+foreverEffT :: Monad m => EffT' c mods es m a -> EffT' c mods es m never_returns+foreverEffT eff = do+  _ <- eff+  foreverEffT eff+{-# INLINE foreverEffT #-}+---------------------------------------------------------+-- bracket patterns+--+-- | Mask asynchronous exceptions in the base monad,+-- an `unMask` function is provided to the argument to selectively unmask parts of the computation+maskEffT+  :: forall c mods es m b+  .  MonadMask m+  => HasCallStack+  => ((forall c' mods' es' a. EffT' c' mods' es' m a -> EffT' c' mods' es' m a) -> EffT' c mods es m b)+  -> EffT' c mods es m b+maskEffT actionUsingUnmask = EffT' $ \rs ss -> Catch.mask $ \unmask ->+  unEffT' (actionUsingUnmask $ \(EffT' eff) -> EffT' $ \rs' ss' -> unmask (eff rs' ss')) rs ss+{-# INLINE maskEffT #-}++-- | The generalized bracket pattern for EffT+-- exceptions outside the error list are not caught.+-- To deal with them, make them into the error list first (like using effTryIOWith).+generalBracketEffT+  :: MonadMask m+  => HasCallStack+  => EffT' c mods es m a                        -- ^ acquire resource+  -> (a -> Result es' b -> EffT' c mods es m o) -- ^ release resource, and return the result+  -> (a -> EffT' c mods es' m b)                -- ^ action using the resource+  -> EffT' c mods es m o+generalBracketEffT acquire release action = maskEffT $ \unMaskEffT -> do+  resource <- acquire+  result <- embedNoError $ unMaskEffT (errorToResult $ action resource)+  release resource result+{-# INLINABLE generalBracketEffT #-}++-- | A simpler version of `generalBracketEffT` where the release function does not depend on the result of the action and error types are the same.+bracketEffT :: (MonadMask m, HasCallStack)+  => EffT' c mods es m a         -- ^ acquire resource+  -> (a -> EffT' c mods es m ()) -- ^ release resource only+  -> (a -> EffT' c mods es m b)  -- ^ action using the resource+  -> EffT' c mods es m b+bracketEffT acquire release = generalBracketEffT+  acquire+  (\a result -> case result of+      RSuccess b -> release a >> return b+      RFailure e -> release a >> EffT' (\_ ss -> return (RFailure e, ss))+  )+{-# INLINABLE bracketEffT #-}+ -- | The states on the separate thread will diverge, and will be discarded. -- when exception occurs, the thread quits forkEffT :: forall c mods es m. (MonadIO m, MonadBaseControl IO m) => EffT' c mods es m () -> EffT' c mods NoError m ThreadId@@ -245,6 +345,24 @@   return (RSuccess forkedEff, ss) {-# INLINE forkEffT #-} +-- | Forks and runs the finalizer when the thread ends, either normally or via exception.+forkEffTFinally :: forall c mods es noError m a.+  ( MonadIO m+  , MonadBaseControl IO m+  , MonadMask m+  , SubListEmbed es (AddIfNotElem SomeAsyncException es)+  , InList SomeAsyncException (AddIfNotElem SomeAsyncException es)+  )+  => EffT' c mods es m a+  -> ((Result (AddIfNotElem SomeAsyncException es) a, SystemState c mods) -> EffT' c mods NoError m ())+  -> EffT' c mods noError m ThreadId+forkEffTFinally eff finalizer = embedError $ do+  rs <- query+  ss <- get+  maskEffT $ \unmask -> forkEffT $ do+    eres <- lift $ unEffT' (effTryIn @SomeAsyncException $ embedError $ unmask eff) rs ss+    finalizer eres+ -- | The states on the separate thread will diverge, and will be discarded. -- forces you to deal with all the exceptions inside the thread, so the thread won't die in an unexpected way. forkEffTSafe :: forall c mods m. (MonadIO m, MonadBaseControl IO m) => EffT' c mods NoError m () -> EffT' c mods NoError m ThreadId@@ -253,13 +371,53 @@  -- | The states on the separate thread will diverge, and will be returned as an Async type. asyncEffT-  :: forall c mods es m a. (MonadIO m, MonadBaseControl IO m)+  :: forall c mods es m a. (MonadBaseControl IO m)   => EffT' c mods es m a -> EffT' c mods NoError m (Async (StM m (Result es a, SystemState c mods))) asyncEffT eff = EffT' $ \rs ss -> do   asyncEff <- liftBaseWith $ \runInBase -> async (runInBase $ unEffT' eff rs ss)   return (RSuccess asyncEff, ss) {-# INLINE asyncEffT #-} +-- | Note: this function seems to be a bit problematic,+-- it seems to cause memory leak. Needs investigation.+-- -- | A simpler version of asyncEffT that only returns the Result value, discarding the new state.+-- asyncEffT_ ::+--   ( MonadIO m+--   , MonadBaseControl IO m+--   , StM m (Result es a, SystemState c mods) ~ (Result es a, SystemState c mods)+--   )+--   => EffT' c mods es m a -> EffT' c mods NoError m (Async (Result es a))+-- asyncEffT_ eff = fmap fst <$> asyncEffT eff+-- {-# INLINE asyncEffT_ #-}++-- | Restores the EffT' computation from an Async value created by asyncEffT.+-- State will be replaced by the state inside the Async when it finishes.+restoreAsync ::+  ( MonadIO m, MonadBaseControl IO m )+  => Async (StM m (Result es a, SystemState c mods)) -> EffT' c mods es m a+restoreAsync asyncSt = EffT' $ \_ _ -> do+  res' <- liftIO $ do+    res <- liftIO (wait asyncSt)+    return $ restoreM res+  (ea, ss') <- res'+  return (ea, ss')+{-# INLINE restoreAsync #-}++-- | Restores the EffT' computation from an Async value created by asyncEffT.+-- But the state on the current thread is kept, discarding the state inside the Async when it finishes.+restoreAsync_ :: forall c mods es m a.+  ( MonadIO m+  , MonadBaseControl IO m+  )+  => Async (StM m (Result es a, SystemState c mods)) -> EffT' c mods es m a+restoreAsync_ asyncSt = EffT' $ \_ ss -> do+  res' <- liftIO $ do+    res <- liftIO (wait asyncSt)+    return $ restoreM res+  (ea, _ss' :: SystemState c mods) <- res'+  return (ea, ss)+{-# INLINE restoreAsync_ #-}+ -- | embed smaller effect into larger effect embedEffT :: forall mods mods' m c es es' a. (SubList c mods mods', SubListEmbed es es', Monad m)   => EffT' c mods es m a -> EffT' c mods' es' m a@@ -285,6 +443,10 @@ embedError = embedEffT {-# INLINE embedError #-} +embedNoError :: forall c mods es m a. (Monad m) => EffT' c mods NoError m a -> EffT' c mods es m a+embedNoError = embedEffT+{-# INLINE embedNoError #-}+ -- | Run the EffT' computation with data needed, returns the potential error result and the new state in the base monad. runEffT :: forall mods es m c a. Monad m => SystemRead c mods -> SystemState c mods -> EffT' c mods es m a -> m (Result es a, SystemState c mods) runEffT rs ss = \eff -> unEffT' eff rs ss@@ -376,6 +538,28 @@   -> EffT' c (Remove (FirstIndex mod mods) mods) es m a runEffTIn_ mread mstate eff = fst <$> runEffTIn @mod @mods mread mstate eff {-# INLINE runEffTIn_ #-}++-- | Replace a module inside EffT' with another module.+replaceEffTIn :: forall mod mod' mods mods' es m c a.+  ( ReplaceElem c mods+  , mods' ~ Replace (FirstIndex mod mods) mod' mods+  , Monad m+  , In' c mod mods+  )+  => (ModuleRead mod -> ModuleState mod -> (ModuleRead mod', ModuleState mod'))+  -> (ModuleRead mod -> ModuleState mod -> ModuleState mod' -> ModuleState mod)+  -> EffT' c mods' es m a+  -> EffT' c mods  es m a+replaceEffTIn replaceFunction recoverFunction eff = EffT' $ \modsRead modsState -> do+  let (mod'Read, mod'State) = replaceFunction (getIn @c @mod modsRead) (getIn @c @mod modsState)+      rs = replaceElem (singFirstIndex @mod @mods) mod'Read modsRead+      ss = replaceElem (singFirstIndex @mod @mods) mod'State modsState+  (ea, ss') <- unEffT' eff rs ss+  case ea of+    RSuccess a  -> returnStrict (RSuccess a , unReplaceElem (singFirstIndex @mod @mods) (Proxy @mod') (recoverFunction (getIn @c @mod modsRead) (getIn @c @mod modsState)) ss')+    RFailure es -> returnStrict (RFailure es, unReplaceElem (singFirstIndex @mod @mods) (Proxy @mod') (recoverFunction (getIn @c @mod modsRead) (getIn @c @mod modsState)) ss')+{-# INLINE replaceEffTIn #-}+ -------------------------------------- instances --------------------------------------  -- | The unit of Effect, a module is a type with certain associated data family types@@ -486,6 +670,38 @@     Left e'  -> return (RFailure $ EHead $ f e', s) {-# INLINE liftIOSafeWith #-} +-- | Try in the base monad (with MonadCatch), adding as the first error in the error list.+effTry :: (Exception e, MonadCatch m) => EffT' c mods es m a -> EffT' c mods (e : es) m a+effTry eff = EffT' $ \rs ss -> do+  ePair <- Catch.try (unEffT' eff rs ss)+  case ePair of+    Left e -> return (RFailure $ EHead e, ss)+    Right (eResult, stateMods) -> return (resultMapErrors ETail eResult, stateMods)+{-# INLINE effTry #-}++effTryWith :: forall e e' es c mods m a. (Exception e, MonadCatch m)+  => (e -> e') -> EffT' c mods es m a -> EffT' c mods (e' : es) m a+effTryWith f eff = EffT' $ \rs ss -> do+  ePair <- Catch.try (unEffT' eff rs ss)+  case ePair of+    Left e -> return (RFailure $ EHead $ f e, ss)+    Right (eResult, stateMods) -> return (resultMapErrors ETail eResult, stateMods)+{-# INLINE effTryWith #-}++effTryInWith :: forall e e' es c mods m a. (Exception e, MonadCatch m, InList e' es)+  => (e -> e') -> EffT' c mods es m a -> EffT' c mods es m a+effTryInWith f eff = EffT' $ \rs ss -> do+  ePair <- Catch.try (unEffT' eff rs ss)+  case ePair of+    Left e                     -> return (RFailure $ embedE $ f e, ss)+    Right (eResult, stateMods) -> return (eResult, stateMods)+{-# INLINE effTryInWith #-}++effTryIn :: forall e es c mods m a. (Exception e, MonadCatch m, InList e es)+  => EffT' c mods es m a -> EffT' c mods es m a+effTryIn = effTryInWith @e id+{-# INLINE effTryIn #-}+ -- | @try@ on the Base monad IO, adding as the first error in the error list. -- It is recommended that you wrap low-level routines into algebraic error in the first place instead of using this function. effTryIO :: Exception e => EffT' c mods es IO a -> EffT' c mods (e : es) IO a@@ -518,6 +734,16 @@     Right (eResult, stateMods) -> return (eResult, stateMods) {-# INLINE effTryIOInWith #-} +-- | Transform the first error in the error list+mapError :: Monad m => (e1 -> e2) -> EffT' c mods (e1 : es) m a -> EffT' c mods (e2 : es) m a+mapError f eff = EffT' $ \rs ss -> do+  (eResult, stateMods) <- unEffT' eff rs ss+  return (resultMapErrors (\case+    EHead e -> EHead (f e)+    ETail es -> ETail es)+      eResult, stateMods)+{-# INLINE mapError #-}+ -- | Convert the first error in the effect to Either errorToEither :: Monad m => EffT' c mods (e : es) m a -> EffT' c mods es m (Either e a) errorToEither eff = EffT' $ \rs ss -> do@@ -528,6 +754,26 @@     RFailure (ETail es) -> return (RFailure es, stateMods) {-# INLINE errorToEither #-} +-- | Convert the first error in the effect to Maybe+errorToMaybe :: Monad m => EffT' c mods (e : es) m a -> EffT' c mods es m (Maybe a)+errorToMaybe = fmap (either (const Nothing) Just) . errorToEither+{-# INLINE errorToMaybe #-}++-- | Specify the error type to convert to Either. Use TypeApplications to specify the error type.+errorInToEither :: forall e es mods m c a. (Monad m, InList e es) => EffT' c mods es m a -> EffT' c mods (Remove (FirstIndex e es) es) m (Either e a)+errorInToEither eff = EffT' $ \rs ss -> do+  (eResult, stateMods) <- unEffT' eff rs ss+  case getElemRemoveResult (singIndex @e @es) eResult of+    Left e -> case proofIndex @e @es of+      Refl -> return (RSuccess (Left e), stateMods)+    Right eResult' -> return (fmap Right eResult', stateMods)+{-# INLINE errorInToEither #-}++-- | Specify the error type to convert to Maybe. Use TypeApplications to specify the error type.+errorInToMaybe :: forall e es mods m c a. (Monad m, InList e es) => EffT' c mods es m a -> EffT' c mods (Remove (FirstIndex e es) es) m (Maybe a)+errorInToMaybe = fmap (either (const Nothing) Just) . errorInToEither @e+{-# INLINE errorInToMaybe #-}+ -- | Convert all errors to Either errorToEitherAll :: Monad m => EffT' c mods es m a -> EffT' c mods NoError m (Either (EList es) a) errorToEitherAll eff = EffT' $ \rs ss -> do@@ -613,14 +859,22 @@ {-# INLINE effCatchAll #-}  -- | Throw into the error list-effThrowIn :: (Monad m, InList e es) => e -> EffT' c mods es m a+effThrowIn :: forall e c mods es m a. (Monad m, InList e es) => e -> EffT' c mods es m a effThrowIn e = EffT' $ \_ s -> pure (RFailure $ embedE e, s) {-# INLINE effThrowIn #-}  -- | Throw into the error list-effThrow :: (Monad m, InList e es) => e -> EffT' c mods es m a+effThrow :: forall e c mods es m a. (Monad m, InList e es) => e -> EffT' c mods es m a effThrow = effThrowIn {-# INLINE effThrow #-}++effThrowEList :: forall es c mods m a. (Monad m) => EList es -> EffT' c mods es m a+effThrowEList es = EffT' $ \_ s -> pure (RFailure es, s)+{-# INLINE effThrowEList #-}++effThrowEListIn :: forall es es' c mods m a. (Monad m, NonEmptySubList es es') => EList es -> EffT' c mods es' m a+effThrowEListIn es = EffT' $ \_ s -> pure (RFailure $ subListEListEmbed es, s)+{-# INLINE effThrowEListIn #-}  -- | Turn an Either return type into the error list with a function, adding the error type if it is not already in the error list. -- The inner monad type needs to be precise due to the way type inference works.

@@ -3,10 +3,12 @@ -- simple and extensible state and read effects. module Control.Monad.RS.Class where +import Control.Monad.Trans+ -- | A class for monads that can read a value of type 'r'. -- without the functional dependencies, so you can read different types of values-class Monad m => MonadReadable r m where-  {-# MINIMAL query, local #-}+-- This ReadOnly has no 'local' method+class Monad m => MonadReadOnly r m where   -- | Query the monad for a value of type 'r'.   query :: m r @@ -15,6 +17,9 @@   queries f = f <$> query   {-# INLINE queries #-} +-- | A class for monads that can read a value of type 'r'.+-- without the functional dependencies, so you can read different types of values+class MonadReadOnly r m => MonadReadable r m where   local :: (r -> r) -> m a -> m a  -- | A class for monads that can maintain a state of type 's'.@@ -36,4 +41,15 @@   modify f = do     s <- get     put (f s)+  {-# INLINE modify #-}++instance {-# OVERLAPPABLE #-} (MonadTrans t, MonadReadOnly r m) => MonadReadOnly r (t m) where+  query = lift query+  {-# INLINE query #-}+instance {-# OVERLAPPABLE #-} (MonadTrans t, MonadStateful s m) => MonadStateful s (t m) where+  get = lift get+  {-# INLINE get #-}+  put = lift . put+  {-# INLINE put #-}+  modify = lift . modify   {-# INLINE modify #-}

@@ -1,13 +1,14 @@-{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances, UndecidableSuperClasses #-} module Control.System   (   -- * Module and System     Module(..)--  , System(..), Loadable(..)+  , WithSystem(..) -  , runSystemWithInitData+  , EventLoop(..)+  , EventLoopSystem(..) +  -- * read from module / get state   , askModule, asksModule   , queryModule, queriesModule   , localModule@@ -15,123 +16,85 @@   , putModule, modifyModule    -- * Loadable-  , ModuleInitDataHardCode-  -  , LoadableEnv(..), LoadableArgs(..), SystemEnv(..), SystemArgs(..)-  , SystemInitDataHardCode'-  , SystemInitDataHardCode-  , SystemInitDataHardCodeL-  , Dependency+  , Loadable(..)+  , Dependency, Dependency' +  -- * Small utils+  , detectFlag, detectAllFlags+   ) where  import Control.Applicative import Control.Concurrent.STM import Control.Monad.Effect import Data.Kind+import Data.Maybe+import Data.Text (Text) import Data.TypeList  type family DependencyW (mod :: Type) (deps :: [Type]) (mods :: [Type]) :: Constraint where   DependencyW mod '[] mods = mod `In` (mod : mods)   DependencyW mod (dep ': deps) mods = (dep `In` mods, dep `In` (mod : mods), DependencyW mod deps mods) +type family DependencyW' c (mod :: Type) (deps :: [Type]) (mods :: [Type]) :: Constraint where+  DependencyW' c mod '[] mods = (In' c mod (mod : mods))+  DependencyW' c mod (dep ': deps) mods = (In' c dep mods, In' c dep (mod : mods), DependencyW' c mod deps mods)+ -- | A type family that can be used to generate the constraints -- to make specifying module dependencies easier type family Dependency (mod :: Type) (deps :: [Type]) (mods :: [Type]) :: Constraint where   Dependency mod deps mods = (ConsFDataList FData (mod : mods), DependencyW mod deps mods) -type SystemInitDataHardCode' c mods = c ModuleInitDataHardCode mods-type SystemInitDataHardCode    mods = SystemInitDataHardCode' FData mods-type SystemInitDataHardCodeL   mods = SystemInitDataHardCode' FList mods+type family Dependency' c (mod :: Type) (deps :: [Type]) (mods :: [Type]) :: Constraint where+  Dependency' c mod deps mods = (ConsFDataList c (mod : mods), DependencyW' c mod deps mods)  -- | Run a System of EffT' given initData ----- If error happens at initialization, it will return Left SystemError--- If error happens during normal flow, it will return Right (RFailure SystemError)-runSystemWithInitData :: forall mods es m c a. (ConsFDataList c mods, System c mods, MonadIO m)-  => SystemInitData c mods-  -> EffT' c mods es m a-  -> m-      (Either SystemError -- ^ if error happens at initialization-        ( Result es a     -- ^ if error happens during event loop-        , SystemState c mods)-      )-runSystemWithInitData initData eff = do-  liftIO (runEffT0 (initAllModules @c @mods initData)) >>= \case-    RSuccess (rs, ss)  -> Right <$> runEffT rs ss eff-    RFailure (EHead e) -> return $ Left e---- | Specifies that the module can load after mods are loaded--- in practice we could use--- instance SomeModuleWeNeed `In` mods => Loadable mods SomeModuleToLoad-class Loadable c mod mods where-  {-# MINIMAL initModule #-}-  initModule  :: ModuleInitData mod -> EffT' c mods '[SystemError] IO (ModuleRead mod, ModuleState mod)+class Loadable c mod mods ies where+  {-# MINIMAL withModule #-}+  withModule :: ConsFDataList c (mod : mods) => ModuleInitData mod -> EffT' c (mod : mods) ies IO a -> EffT' c mods ies IO a -  beforeEvent :: EffT' c (mod : mods) NoError IO ()+class EventLoop c mod mods es where+  beforeEvent :: EffT' c (mod : mods) es IO ()   beforeEvent = return ()   {-# INLINE beforeEvent #-} -  afterEvent  :: EffT' c (mod : mods) NoError IO ()+  afterEvent  :: EffT' c (mod : mods) es IO ()   afterEvent = return ()   {-# INLINE afterEvent #-} -  moduleEvent :: EffT' c (mod : mods) NoError IO (STM (ModuleEvent mod))+  moduleEvent :: EffT' c (mod : mods) es IO (STM (ModuleEvent mod))   moduleEvent = return empty   {-# INLINE moduleEvent #-} -  handleEvent :: ModuleEvent mod -> EffT' c (mod : mods) NoError IO ()+  handleEvent :: ModuleEvent mod -> EffT' c (mod : mods) es IO ()   handleEvent _ = return ()   {-# INLINE handleEvent #-} -  releaseModule :: EffT' c (mod : mods) NoError IO () -- ^ release resources, quit module-  releaseModule = return ()-  {-# INLINE releaseModule #-}--data family ModuleInitDataHardCode mod :: Type--class Loadable c mod mods => LoadableEnv c mod mods where-  readInitDataFromEnv :: ModuleInitDataHardCode mod -> EffT' c '[] '[SystemError] IO (ModuleInitData mod)-  -- ^ Read module init data from environment, or other means-  -- one can change this to SystemInitData mods -> IO (ModuleInitData mod)--class Loadable c mod mods => LoadableArgs c mod mods where-  readInitDataFromArgs :: ModuleInitDataHardCode mod -> [String] -> EffT' c '[] '[SystemError] IO (ModuleInitData mod)-  -- ^ Read module init data from command line arguments, or using comand line arguments to read other things-  -- one can change this to SystemInitData mods -> [String] -> IO (ModuleInitData mod)- ------------------------------------------system : a list of modules------------------------------------------ -- | System is a list of modules loaded in sequence with dependency verification -- -- the last module in the list is the first to be loaded -- and also the first to execute beforeEvent and afterEvent-class System c mods where-  initAllModules :: ConsFDataList c mods => SystemInitData c mods -> EffT' c '[] '[SystemError] IO (SystemRead c mods, SystemState c mods)--  listenToEvents :: ConsFDataList c mods => EffT' c mods '[] IO (STM (SystemEvent mods))--  handleEvents :: ConsFDataList c mods => SystemEvent mods -> EffT' c mods '[] IO ()--  beforeSystem :: ConsFDataList c mods => EffT' c mods '[] IO ()+class WithSystem c mods initEs where+  withSystem :: ConsFDataList c mods => SystemInitData c mods -> EffT' c mods initEs IO a -> EffT' c '[] initEs IO a -  afterSystem  :: ConsFDataList c mods => EffT' c mods '[] IO ()+class EventLoopSystem c mods es where+  listenToEvents :: ConsFDataList c mods => EffT' c mods es IO (STM (SystemEvent mods)) -  releaseSystem :: ConsFDataList c mods => EffT' c mods '[] IO ()-  -- ^ safely release all resources system acquired-  -- Warning: releaseSystem is done in reverse order of initAllModules-  -- i.e. the head of the list is the first to be released+  handleEvents :: ConsFDataList c mods => SystemEvent mods -> EffT' c mods es IO () -class System c mods => SystemEnv c mods where-  readSystemInitDataFromEnv :: ConsFDataList c mods => SystemInitDataHardCode' c mods -> EffT' c '[] '[SystemError] IO (SystemInitData c mods)+  beforeSystem :: ConsFDataList c mods => EffT' c mods es IO () -class System c mods => SystemArgs c mods where-  readSystemInitDataFromArgs :: ConsFDataList c mods => SystemInitDataHardCode' c mods -> [String] -> EffT' c '[] '[SystemError] IO (SystemInitData c mods)+  afterSystem  :: ConsFDataList c mods => EffT' c mods es IO ()  -- | base case for system-instance System c '[] where-  initAllModules _ = return (fNil, fNil)-  {-# INLINE initAllModules #-}+instance WithSystem c '[] ies where+  withSystem _ = id+  -- return (fNil, fNil)+  {-# INLINE withSystem #-} +instance EventLoopSystem c '[] es where   listenToEvents = return empty   {-# INLINE listenToEvents #-} @@ -144,63 +107,39 @@   afterSystem = return ()   {-# INLINE afterSystem #-} -  releaseSystem = return ()-  {-# INLINE releaseSystem #-}--instance SystemEnv c '[] where-  readSystemInitDataFromEnv _ = return fNil-  {-# INLINE readSystemInitDataFromEnv #-}--instance SystemArgs c '[] where-  readSystemInitDataFromArgs _ _ = do-    return fNil-  {-# INLINE readSystemInitDataFromArgs #-}- -- | Inductive instance for system-instance (SystemModule mod, System c mods, Loadable c mod mods) => System c (mod ': mods) where-  initAllModules (x :*** xs) = do-    (rs, ss)  <- initAllModules xs-    (er, ss') <- liftIO $ runEffT rs ss $ initModule @c @mod x-    case er of-      RSuccess (r', s') -> return (r' :*** rs, s' :*** ss')-      RFailure (EHead e) -> effThrowIn e-  {-# INLINE initAllModules #-}+instance (SystemModule mod, WithSystem c mods ies, Loadable c mod mods ies) => WithSystem c (mod ': mods) ies where+  withSystem (x :*** xs) = withSystem @c @mods @ies xs . withModule @c @mod @mods @ies x+  {-# INLINE withSystem #-} +instance (SystemModule mod, EventLoop c mod mods es, EventLoopSystem c mods es) => EventLoopSystem c (mod ': mods) es where   beforeSystem = do-    embedEffT $ beforeSystem @c @mods-    beforeEvent @c @mod+    embedMods $ beforeSystem @c @mods @es+    beforeEvent @c @mod @mods @es   {-# INLINE beforeSystem #-}    afterSystem = do-    embedEffT $ afterSystem @c @mods-    afterEvent @c @mod+    embedMods $ afterSystem @c @mods @es+    afterEvent @c @mod @mods @es   {-# INLINE afterSystem #-}    listenToEvents = do-    tailEvents <- embedEffT $ listenToEvents @c @mods-    headEvent  <- moduleEvent @c @mod+    tailEvents <- embedMods $ listenToEvents @c @mods @es+    headEvent  <- moduleEvent @c @mod @mods @es     return $ UHead <$> headEvent <|> UTail <$> tailEvents   {-# INLINE listenToEvents #-} -  handleEvents (UHead x) = handleEvent @c @mod x-  handleEvents (UTail xs) = embedEffT $ handleEvents @_ @mods xs+  handleEvents (UHead x) = handleEvent @c @mod @mods @es x+  handleEvents (UTail xs) = embedMods $ handleEvents @_ @mods @es xs   {-# INLINE handleEvents #-} -  releaseSystem = do-    releaseModule @c @mod-    embedEffT $ releaseSystem @c @mods-  {-# INLINE releaseSystem #-}--instance (SubList c mods (mod:mods), SystemModule mod, SystemEnv c mods, Loadable c mod mods, LoadableEnv c mod mods) => SystemEnv c (mod ': mods) where-  readSystemInitDataFromEnv (im :*** ims) = do-    xs <- readSystemInitDataFromEnv @c @mods ims-    x  <- readInitDataFromEnv @c @mod @mods im-    return $ x :*** xs-  {-# INLINE readSystemInitDataFromEnv #-}+detectFlag :: String -> (String -> Either Text a) -> [String] -> Maybe (Either Text a)+detectFlag flag parser = listToMaybe . detectAllFlags flag parser -instance (SubList c mods (mod:mods), SystemModule mod, SystemArgs c mods, Loadable c mod mods, LoadableArgs c mod mods) => SystemArgs c (mod ': mods) where-  readSystemInitDataFromArgs (im :*** ims) args = do-    xs <- readSystemInitDataFromArgs @c @mods ims args-    x  <- readInitDataFromArgs @c @mod @mods im args-    return $ x :*** xs-  {-# INLINE readSystemInitDataFromArgs #-}+detectAllFlags :: String -> (String -> Either Text a) -> [String] -> [Either Text a]+detectAllFlags _ _ [] = []+detectAllFlags flag parser list = go list+  where+    go (x:y:xs) | x == flag = parser y : go xs+                | otherwise = go (y:xs)+    go _ = []

@@ -1,24 +1,13 @@+{-# LANGUAGE AllowAmbiguousTypes #-} module Control.System.EventLoop where  import Control.System import Control.Monad.Effect import Control.Concurrent.STM -eventLoop :: forall mods . (ConsFDataList FData mods, System FData mods) => Eff mods NoError ()+eventLoop :: forall mods es. (ConsFDataList FData mods, EventLoopSystem FData mods es ) => Eff mods es () eventLoop = do-  beforeSystem-  listenToEvents >>= liftIO . atomically >>= handleEvents @_ @mods-  afterSystem-  eventLoop---- | Avoid runtime error (IO) though, make sure every loop breaking error is in SystemError-eventLoopWithRelease :: forall mods. (ConsFDataList FData mods, System FData mods) => Eff mods NoError ()-eventLoopWithRelease = do-  eventLoop-  releaseSystem---- | When restart, the state is reset to the initial state-eventLoopWithReleaseRestartIO :: forall mods. (ConsFDataList FData mods, System FData mods) => SystemInitData FData mods -> IO ()-eventLoopWithReleaseRestartIO initData = do-  _ <- runSystemWithInitData @mods initData eventLoopWithRelease-  eventLoopWithReleaseRestartIO initData+  beforeSystem @_ @_ @_+  listenToEvents @_ @_ @_ >>= liftIO . atomically >>= handleEvents @_ @mods @es+  afterSystem @_ @_ @_+  eventLoop @mods @es

@@ -46,9 +46,14 @@    modifyIn :: (f e -> f e) -> flist f es -> flist f es   default modifyIn :: (ConsFData flist) => (f e -> f e) -> flist f es -> flist f es-  modifyIn f = modifyInS (singFirstIndex @e @es) f+  modifyIn = modifyInS (singFirstIndex @e @es)   {-# INLINE modifyIn #-} +  lensIn :: forall f fun. Functor fun => (f e -> fun (f e)) -> flist f es -> fun (flist f es)+  default lensIn :: (ConsFData flist) => forall fun. Functor fun => (f e -> fun (f e)) -> flist f es -> fun (flist f es)+  lensIn = lensInS (singFirstIndex @e @es)+  {-# INLINE lensIn #-}+ -- | Axiom firstIndexTraverseNotEqElem :: forall e t ts. (NotEq e t, InList e ts) => FirstIndex e (t : ts) :~: Succ (FirstIndex e ts) firstIndexTraverseNotEqElem = unsafeCoerce Refl@@ -81,7 +86,7 @@   {-# INLINE getIn #-}   modifyIn f = \(x :** xs) -> f x :** xs   {-# INLINE modifyIn #-}-  + -- | InListductive case for the In class. UniqueIn e (t : ts),  instance {-# OVERLAPPABLE #-} (NotEq e t, InList e ts) => InList e (t : ts) where   singIndex = case firstIndexTraverseNotEqElem @e @t @ts of@@ -118,6 +123,18 @@ class SubListEmbed (ys :: [Type]) (xs :: [Type]) where   subListResultEmbed :: Result ys a -> Result xs a -- ^ Embed the result of a sublist operation. +class NonEmptySubList (ys :: [Type]) (xs :: [Type]) where+  subListEListEmbed :: EList ys -> EList xs++instance NonEmptySubList '[x] (x:xs) where+  subListEListEmbed (EHead x) = EHead x+  {-# INLINE subListEListEmbed #-}++instance (InList y xs, NonEmptySubList ys xs) => NonEmptySubList (y:ys) xs where+  subListEListEmbed (EHead y)  = embedE y+  subListEListEmbed (ETail ys) = subListEListEmbed ys+  {-# INLINE subListEListEmbed #-}+ subListUpdateF :: (SubList flist ys xs) => flist f xs -> flist f ys -> flist f xs subListUpdateF xs ys = subListModifyF (const ys) xs {-# INLINE subListUpdateF #-}@@ -138,6 +155,16 @@   subListResultEmbed (RFailure (ETail ys)) = subListResultEmbed (RFailure ys)   {-# INLINE subListResultEmbed #-} +instance {-# INCOHERENT #-} SubList c xs xs where+  getSubListF = id+  {-# INLINE getSubListF #-}+  subListModifyF = id+  {-# INLINE subListModifyF #-}++instance {-# INCOHERENT #-} SubListEmbed xs xs where+  subListResultEmbed = id+  {-# INLINE subListResultEmbed #-}+ -- | Induction case for the SubList class. instance (In' c y xs, ConsFDataList c (y:ys), SubList c ys xs) => SubList c (y : ys) xs where   getSubListF xs = consF0 (getIn xs) (getSubListF xs)@@ -152,13 +179,3 @@   {-# INLINE getSubListF #-}   subListModifyF f (x :*** xs) = x :*** f xs   {-# INLINE subListModifyF #-}--instance {-# INCOHERENT #-} SubList c xs xs where-  getSubListF = id-  {-# INLINE getSubListF #-}-  subListModifyF = id-  {-# INLINE subListModifyF #-}--instance {-# INCOHERENT #-} SubListEmbed xs xs where-  subListResultEmbed = id-  {-# INLINE subListResultEmbed #-}

@@ -5,6 +5,7 @@ import Data.TypeList.Families import Data.Type.Equality import Data.Kind (Type)+import Data.Proxy  class ConsFNil (flist :: (Type -> Type) -> [Type] -> Type) where   fNil  :: flist f '[]@@ -23,6 +24,11 @@    unRemoveElem :: SFirstIndex t ts -> f t -> flist f (Remove (FirstIndex t ts) ts) -> flist f ts +class When (NonEmpty (Tail ts)) (ReplaceElem flist (Tail ts)) => ReplaceElem flist (ts :: [Type]) where+  replaceElem :: SFirstIndex t ts -> f t' -> flist f ts -> flist f (Replace (FirstIndex t ts) t' ts)++  unReplaceElem :: SFirstIndex t ts -> Proxy t' -> (f t' -> f t) -> flist f (Replace (FirstIndex t ts) t' ts) -> flist f ts+ class ConsFNil flist => ConsFData flist where   unConsF :: flist f (t : ts) -> (f t, flist f ts) @@ -32,11 +38,16 @@   getInS SFirstIndexZero          (unConsF -> (x, _)) = x   getInS (SFirstIndexSucc Refl n) (unConsF -> (_, xs)) = getInS n xs   {-# INLINE getInS #-}- +   modifyInS :: SFirstIndex t ts -> (f t -> f t) -> flist f ts -> flist f ts   modifyInS SFirstIndexZero          f (unConsF -> (x, xs)) = f x `consF` xs   modifyInS (SFirstIndexSucc Refl n) f (unConsF -> (x, xs)) = x `consF` modifyInS n f xs   {-# INLINE modifyInS #-}++  lensInS :: forall f fun t ts. Functor fun => SFirstIndex t ts -> (f t -> fun (f t)) -> flist f ts -> fun (flist f ts)+  lensInS SFirstIndexZero          f (unConsF -> (x, xs)) = (`consF` xs) <$> f x+  lensInS (SFirstIndexSucc Refl n) f (unConsF -> (x, xs)) = consF x <$> lensInS n f xs+  {-# INLINE lensInS #-}  class   ( WhenNonEmpty ts (ConsFDataList flist (Tail ts))

@@ -10,14 +10,14 @@   , module Data.TypeList   ) where -import GHC.Generics (Generic) import Control.DeepSeq (NFData(..))-import Data.TypeList-import Data.TypeList.FData.TH+import Data.Default import Data.Kind (Type)-import Data.Type.Equality import Data.Proxy-import Data.Default+import Data.Type.Equality+import Data.TypeList+import Data.TypeList.FData.TH+import GHC.Generics (Generic)  data family FData (f :: k -> Type) (ts :: [k]) :: Type data instance FData f '[] = FData0@@ -29,12 +29,18 @@ instance (FDataConstraint FData e es, InList e es) => In' FData e es where   getIn      = case proofIndex @e @es of Refl -> getFDataByIndex    (Proxy @(FirstIndex e es))   modifyIn f = case proofIndex @e @es of Refl -> modifyFDataByIndex (Proxy @(FirstIndex e es)) f+  lensIn   f = case proofIndex @e @es of Refl -> lensFDataByIndex   (Proxy @(FirstIndex e es)) f   {-# INLINE getIn #-}   {-# INLINE modifyIn #-}+  {-# INLINE lensIn #-}  class FDataByIndex (n :: Nat) (ts :: [Type]) where   getFDataByIndex    :: Proxy n -> FData f ts -> f (AtIndex ts n)   modifyFDataByIndex :: Proxy n -> (f (AtIndex ts n) -> f (AtIndex ts n)) -> FData f ts -> FData f ts+  lensFDataByIndex   :: Proxy n+                     -> forall fun. (Functor fun)+                     => ( f (AtIndex ts n) -> fun (f (AtIndex ts n)) )+                     -> FData f ts -> fun (FData f ts)  instance   ( WhenNonEmpty ts (ConsFDataList FData (Tail ts))@@ -100,36 +106,48 @@ --   modifyFDataByIndex _ f (FData1 x) = FData1 (f x) --   {-# INLINE getFDataByIndex #-} --   {-# INLINE modifyFDataByIndex #-}+--   lensFDataByIndex _ g (FData1 x) = fmap FData1 (g x)+--   {-# INLINE lensFDataByIndex #-} -- -- instance FDataByIndex Zero '[x1, x2] where --   getFDataByIndex    _   (FData2 x1 _ ) = x1 --   modifyFDataByIndex _ f (FData2 x1 x2) = FData2 (f x1) x2 --   {-# INLINE getFDataByIndex #-} --   {-# INLINE modifyFDataByIndex #-}+--   lensFDataByIndex _ g (FData2 x1 x2) = fmap (\x1' -> FData2 x1' x2) (g x1)+--   {-# INLINE lensFDataByIndex #-} --  -- instance FDataByIndex (Succ Zero) '[x1, x2] where --   getFDataByIndex    _ (FData2 _ x2) = x2 --   modifyFDataByIndex _ f (FData2 x1 x2) = FData2 x1 (f x2) --   {-# INLINE getFDataByIndex #-} --   {-# INLINE modifyFDataByIndex #-}+--   lensFDataByIndex _ g (FData2 x1 x2) = fmap (\x2' -> FData2 x1 x2') (g x2)+--   {-# INLINE lensFDataByIndex #-} --  -- instance FDataByIndex Zero '[x1, x2, x3] where --   getFDataByIndex    _   (FData3 x1 _ _) = x1 --   modifyFDataByIndex _ f (FData3 x1 x2 x3) = FData3 (f x1) x2 x3 --   {-# INLINE getFDataByIndex #-} --   {-# INLINE modifyFDataByIndex #-}+--   lensFDataByIndex _ g (FData3 x1 x2 x3) = fmap (\x1' -> FData3 x1' x2 x3) (g x1)+--   {-# INLINE lensFDataByIndex #-} --  -- instance FDataByIndex Zero '[x1, x2, x3, x4] where --   getFDataByIndex    _   (FData4 x1 _ _ _) = x1 --   modifyFDataByIndex _ f (FData4 x1 x2 x3 x4) = FData4 (f x1) x2 x3 x4 --   {-# INLINE getFDataByIndex #-} --   {-# INLINE modifyFDataByIndex #-}+--   lensFDataByIndex _ g (FData4 x1 x2 x3 x4) = fmap (\x1' -> FData4 x1' x2 x3 x4) (g x1)+--   {-# INLINE lensFDataByIndex #-} --  -- instance FDataByIndex Zero '[x1, x2, x3, x4, x5] where --   getFDataByIndex    _   (FData5 x1 _ _ _ _) = x1 --   modifyFDataByIndex _ f (FData5 x1 x2 x3 x4 x5) = FData5 (f x1) x2 x3 x4 x5 --   {-# INLINE getFDataByIndex #-} --   {-# INLINE modifyFDataByIndex #-}+--   lensFDataByIndex _ g (FData5 x1 x2 x3 x4 x5) = fmap (\x1' -> FData5 x1' x2 x3 x4 x5) (g x1)+--   {-# INLINE lensFDataByIndex #-} -- -- instance UnConsFData FData '[x1] where --   unConsFData (FData1 x1) = (x1, FData0)

@@ -102,15 +102,18 @@   let conName   = mkName ("FData" ++ show len)          -- FData1 .. FData5 …       className = mkName "FDataByIndex"                 --''FDataByIndex       fName     = mkName "f"                            -- the function arg+      gName     = mkName "g"                            -- functorial updater       -- x1 .. xn  (term vars)       xNames    = [ mkName ("x" ++ show i) | i <- [1 .. len] ]       xiName    = xNames !! idx                         -- xi (to be focused)+      xiPrime   = mkName (nameBase xiName ++ "'")       -- updated slot       -- x1 .. xn  (type vars)       tNames    = [ mkName ("x" ++ show i) | i <- [1 .. len] ]       tVars     = map VarT tNames        fGetFDataByIndex = mkName "getFDataByIndex"    -- getFDataByIndex       fModifyFDataByIndex  = mkName "modifyFDataByIndex" -- modifyFDataByIndex+      fLensFDataByIndex    = mkName "lensFDataByIndex"    let instHead = AppT                    (AppT (ConT className) (natTy idx))@@ -121,7 +124,7 @@   ----------------------------------------------------------------------       getClause =         Clause [ WildP-               , ConP conName [] (mkGetPats len idx xiName)+               , BangP $ ConP conName [] (mkGetPats len idx xiName)                ]                (NormalB (VarE xiName))                []@@ -140,20 +143,54 @@       modifyClause =         Clause [ WildP                , VarP fName-               , ConP conName [] patVars+               , BangP $ ConP conName [] patVars                ]                (NormalB modifyBody)                []+  ----------------------------------------------------------------------+  -- lensFDataByIndex+  --   lensFDataByIndex _ g (FDataN x1 .. xi .. xn)+  --     = fmap (\xi' -> FDataN x1 .. xi' .. xn) (g xi)+  ----------------------------------------------------------------------+      gCall      = AppE (VarE gName) (VarE xiName) +      rebuiltFields =+        [ if i == idx then VarE xiPrime else VarE (xNames !! i)+        | i <- [0 .. len-1] ]++      rebuildWithXi' = LamE [VarP xiPrime]+                         (foldl AppE (ConE conName) rebuiltFields)++      lensBody = AppE (AppE (VarE 'fmap) rebuildWithXi') gCall++      lensClause =+        Clause [ WildP+               , VarP gName+               , BangP $ ConP conName [] patVars+               ]+               (NormalB lensBody)+               []+   pure $ InstanceD           Nothing           []           instHead           [ FunD fGetFDataByIndex    [getClause]           , FunD fModifyFDataByIndex [modifyClause]+          , FunD fLensFDataByIndex   [lensClause]           , PragmaD $ inline fGetFDataByIndex           , PragmaD $ inline fModifyFDataByIndex+          , PragmaD $ inline fLensFDataByIndex           ]+  -- pure $ InstanceD+  --         Nothing+  --         []+  --         instHead+  --         [ FunD fGetFDataByIndex    [getClause]+  --         , FunD fModifyFDataByIndex [modifyClause]+  --         , PragmaD $ inline fGetFDataByIndex+  --         , PragmaD $ inline fModifyFDataByIndex+  --         ]  generateFDataByIndexInstances :: [(Int, Int)] -> Q [Dec] generateFDataByIndexInstances = mapM (uncurry generateFDataByIndexInstance)

@@ -113,6 +113,11 @@   Remove Zero     (t ': ts) = ts   Remove (Succ n) (t ': ts) = t : Remove n ts +type family Replace (e :: Nat) (t :: Type) (ts :: [Type]) :: [Type] where+  Replace e t '[]              = '[]+  Replace Zero     t (u ': ts) = t ': ts+  Replace (Succ n) t (u ': ts) = u ': Replace n t ts+ type family AtIndex (ts :: [Type]) (n :: Nat) :: Type where   AtIndex (t ': ts) 'Zero = t   AtIndex (t ': ts) ('Succ n) = AtIndex ts n

@@ -1,3 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | This module defines two modules (unit of effect) that provides reader and state functionality. -- -- it can be used in the EffT monad transformer@@ -5,6 +7,7 @@  import GHC.Generics (Generic) import Control.DeepSeq (NFData)+import Control.Monad.RS.Class  import Control.Monad.Effect import Data.Kind@@ -13,6 +16,8 @@ import GHC.TypeLits import qualified Control.Monad.State as S +import Control.System+ -- | A module that provides reader functionality data RModule (r :: Type) @@ -56,6 +61,16 @@   newtype ModuleInitData (SNamed name s) = SNamedInitData { sNamedInitState :: s }   data    ModuleEvent (SNamed name s)    = SNamedEvent +instance Loadable c (RModule r) mods ies where+  withModule (RInitData r) = runEffTOuter_ (RRead r) RState+  {-# INLINE withModule #-}+instance EventLoop c (RModule r) mods es++instance Loadable c (SModule s) mods ies where+  withModule (SInitData s) = runEffTOuter_ SRead (SState s)+  {-# INLINE withModule #-}+instance EventLoop c (SModule s) mods es+ embedStateT :: forall s mods errs m c a. (Monad m, In' c (SModule s) mods) => S.StateT s (EffT' c mods errs m) a -> EffT' c mods errs m a embedStateT action = do   SState s <- getModule @(SModule s)@@ -92,6 +107,26 @@   return a {-# INLINE asStateT #-} +-- | Restrict a state module to be read-only RModule+readOnly :: forall s mods errs m a c. (In' c (SModule s) (SModule s : mods), ConsFDataList c (SModule s : mods), ConsFDataList c (RModule s : mods), Monad m)+  => EffT' c (RModule s : mods) errs m a+  -> EffT' c (SModule s : mods) errs m a+readOnly eff = do+  state <- getS @s+  embedEffT $ runEffTOuter_ (RRead state) RState eff+{-# INLINE readOnly #-}++-- readOnlyIn :: forall s errs m a c mods' mods.+--   ( In' c (SModule s) mods+--   , mods' ~ Replace (FirstIndex (SModule s) mods) (RModule s) mods+--   , ReplaceElem c mods+--   , Monad m+--   )+--   => EffT' c mods' errs m a+--   -> EffT' c mods  errs m a+-- readOnlyIn effRO = EffT' $ \modsRead modsState ->+--   _+ runRModule :: (ConsFDataList c (RModule r : mods), Monad m) => r -> EffT' c (RModule r : mods) errs m a -> EffT' c mods errs m a runRModule r = runEffTOuter_ (RRead r) RState {-# INLINE runRModule #-}@@ -146,8 +181,7 @@ {-# INLINE getsS #-}  putS :: forall s mods errs c m. (Monad m, In' c (SModule s) mods) => s -> EffT' c mods errs m ()-putS s = do-  SState _ <- getModule @(SModule s)+putS !s = do   putModule @(SModule s) (SState s) {-# INLINE putS #-} @@ -156,3 +190,24 @@   s <- getS   putS (f s) {-# INLINE modifyS #-}++-- put here to avoid cyclic dependency+instance {-# OVERLAPPABLE #-} (Monad m, In' c (RModule r) mods) => MonadReadOnly r (EffT' c mods errs m) where+  query = askR+  queries = asksR+  {-# INLINE query #-}+  {-# INLINE queries #-}++instance {-# OVERLAPPABLE #-} (Monad m, In' c (RModule r) mods) => MonadReadable r (EffT' c mods errs m) where+  local = localR+  {-# INLINE local #-}++instance {-# OVERLAPPABLE #-} (Monad m, In' c (SModule s) mods) => MonadStateful s (EffT' c mods errs m) where+  get = getS+  put = putS+  modify = modifyS+  gets = getsS+  {-# INLINE get #-}+  {-# INLINE put #-}+  {-# INLINE modify #-}+  {-# INLINE gets #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards, OverloadedRecordDot, ViewPatterns #-} -- | This module provides Template Haskell utilities for generating RModules and SModules with fixed type -- -- The `makeRModule` function generates a reader module, for example@@ -64,9 +64,17 @@ import Language.Haskell.TH.Quote import Text.Parsec +data DataFieldSpec = DataFieldSpec+  { fieldName   :: Name+  , fieldLens   :: Bool -- ^ Whether to generate a lens for this field+  , fieldStrict :: Bool+  , fieldType   :: Type+  }+  deriving Show+ data DataConsSpec = DataConsSpec   { dataConsName :: Name-  , dataFields   :: [(Name, Bool, Type)] -- ^ (fieldName, strictness, fieldType)+  , dataFields   :: [DataFieldSpec]   }   deriving Show @@ -187,15 +195,22 @@   let moduleName = upperHead : rest   pure $ mkName moduleName -parseField :: ParsecT String () Identity (Name, Bool, Type)+parseField :: ParsecT String () Identity DataFieldSpec parseField = do+  lens <- option False (True <$ try (string "Lens" >> many1 space))   fieldName <- parseFieldName   spaces >> char ':' >> char ':' >> spaces   strictness <- option False (True <$ char '!')   typeString <- manyTill anyChar (try (eof <|> void endOfLine))   case parseType typeString of     Left err -> fail $ "Failed to parse type: " ++ show err-    Right type' -> return (fieldName, strictness, type')+    Right type' -> return $ DataFieldSpec+      { fieldName   = fieldName+      , fieldLens   = lens+      , fieldStrict = strictness+      , fieldType   = type'+      }+    -- (fieldName, strictness, type')   where     parseFieldName = mkName <$> do       lowerHead <- lower@@ -215,12 +230,17 @@ mkBang True  = Bang NoSourceUnpackedness SourceStrict mkBang False = Bang NoSourceUnpackedness NoSourceStrictness -updateBang :: (a, Bool, b) -> (a, Bang, b)-updateBang (a, b, c) = (a, mkBang b, c)+updateBang :: DataFieldSpec -> (Name, Bang, Type)+updateBang DataFieldSpec{..} = (fieldName, mkBang fieldStrict, fieldType) -appendName :: String -> (Name, a, b) -> (Name, a, b)-appendName suffix (name, a, b) =-  (mkName $ nameBase name ++ suffix, a, b)+appendName :: String -> DataFieldSpec -> DataFieldSpec+appendName suffix DataFieldSpec{..} =+  DataFieldSpec+    { fieldName   = mkName $ nameBase fieldName ++ suffix+    , fieldLens   = fieldLens+    , fieldStrict = fieldStrict+    , fieldType   = fieldType+    }  inlinePragma :: Name -> Dec inlinePragma name = PragmaD $ InlineP name Inline FunLike AllPhases@@ -237,7 +257,7 @@ dataInstance :: DataInstanceSpec -> Dec dataInstance DataInstanceSpec{..} =   case dataFields dataFamilyConstructor of-    [(_, True, _)] ->+    [fieldStrict -> True] ->       NewtypeInstD [] Nothing         (AppT dataFamilyType dataFamilyInputType)         Nothing@@ -249,8 +269,39 @@         Nothing         [RecC (dataConsName dataFamilyConstructor) $ updateBang <$> dataFields dataFamilyConstructor]         dataFamilyDerivations-  where cancelBang (a, _, c) = (a, mkBang False, c)+  where cancelBang fspec = (fieldName fspec, mkBang False, fieldType fspec) +-- | If fieldName starts with '_', remove the leading underscore for the lens name.+-- Otherwise, prepend an underscore.+lensName :: Name -> Name+lensName (nameBase -> ('_':rest)) = mkName rest+lensName name                     = mkName $ '_' : nameBase name++generateLens :: Type -> DataFieldSpec -> Q [Dec]+generateLens recType DataFieldSpec{..} | fieldLens = do+  let lensFunName = lensName fieldName+      -- | The body of the lens function+      -- _lensName :: Functor f => (fieldType -> f fieldType) -> (DataConsType -> f DataConsType)+      -- _lensName f s = fmap (\x -> s { fieldName = x }) (f (fieldName s))+      lensTypeSig = ForallT [PlainTV funName SpecifiedSpec]+                            [ConT ''Functor `AppT` VarT funName]+                            (ArrowT `AppT` (ArrowT `AppT` fieldType `AppT` (VarT funName `AppT` fieldType))+                                    `AppT` (ArrowT `AppT` recType   `AppT` (VarT funName `AppT` recType))+                            )+      lensFunBody = LamE [VarP fName, VarP sName]+                    $ VarE 'fmap+                      `AppE` LamE [VarP xName] (RecUpdE (VarE sName) [(fieldName, VarE xName)])+                      `AppE` AppE (VarE fName) (AppE (VarE fieldName) (VarE sName))+      funName = mkName "fun"+      fName   = mkName "f"+      sName   = mkName "s"+      xName   = mkName "x"+  sig <- sigD lensFunName (pure lensTypeSig)+  fun <- funD lensFunName [clause [] (normalB (pure lensFunBody)) []]+  prag <- pragInlD lensFunName Inline FunLike AllPhases+  return [sig, fun, prag]+generateLens _ DataFieldSpec{} = return []+ -- * generate data instances for Module <MyModule> -- * generate run<MyModule>, run<MyModule>', run<MyModule>_ and run<MyModule>In, run<MyModule>In', run<MyModule>In_ functions -- * generate type synonym for ModuleRead <MyModule> and ModuleState <MyModule>@@ -259,7 +310,7 @@   let deriveGeneric = [deriveG  | ConfigDeriveGeneric `elem` dconf]       -- deriveNFData  = [deriveNF | ConfigDeriveNFData  `elem` dconf] -  let warnStateNonStrict = any (\(_, strictness, _) -> not strictness) (dataFields stateSpec)+  let warnStateNonStrict = any (\fspec -> not fspec.fieldStrict) (dataFields stateSpec)    when warnStateNonStrict $ reportWarning     $  "The state record for the module " <> nameBase typeName@@ -281,8 +332,10 @@             , dataFamilyDerivations = deriveGeneric             }         ]-      typeSynRead  = TySynD (dataConsName readSpec) [] (ConT ''ModuleRead `AppT` ConT typeName)-      typeSynState = TySynD (dataConsName stateSpec) [] (ConT ''ModuleState `AppT` ConT typeName)+      readType     = ConT ''ModuleRead  `AppT` ConT typeName+      stateType    = ConT ''ModuleState `AppT` ConT typeName+      typeSynRead  = TySynD (dataConsName readSpec)  [] readType+      typeSynState = TySynD (dataConsName stateSpec) [] stateType        runMyModuleName    = mkName $ "run" ++ nameBase typeName       runMyModule'Name   = mkName $ "run" ++ nameBase typeName ++ "'"@@ -453,7 +506,10 @@                  []         ] -  return [ dataTag+  lensDecsR <- concat <$> mapM (generateLens readType)  (dataFields readSpec)+  lensDecsS <- concat <$> mapM (generateLens stateType) (dataFields stateSpec)++  pure $ [ dataTag          , instanceModule          , typeSynRead          , typeSynState@@ -463,7 +519,7 @@          , runMyModuleInSig  , runMyModuleInFun  , inlinePragma runMyModuleInName          , runMyModuleIn'Sig , runMyModuleIn'Fun , inlinePragma runMyModuleIn'Name          , runMyModuleIn_Sig , runMyModuleIn_Fun , inlinePragma runMyModuleIn_Name-         ]+         ] <> lensDecsR <> lensDecsS  generateRModule :: GenerationConfig -> DataConsSpec -> Q [Dec] generateRModule GenerationConfig{ deriveConfigs = dconf, generateSystemInstance } DataConsSpec{dataConsName = modName, dataFields} = do

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Provides ResourceT functionality for managing resources module Module.Resource where@@ -26,8 +26,10 @@   liftResourceT = \ResourceT{unResourceT} -> do     rMap <- asksModule resourceRead     liftIO $ unResourceT rMap+  {-# INLINE liftResourceT #-} -instance Loadable c Resource mods where-  initModule _ = do-    istate <- createInternalState-    return (ResourceRead istate, ResourceState)+instance ConsFDataList c (Resource : mods) => Loadable c Resource mods es where+  withModule _ act = bracketEffT createInternalState closeInternalState+    (\istate -> runEffTOuter_ (ResourceRead istate) ResourceState act+    )+  {-# INLINE withModule #-}

@@ -6,11 +6,11 @@ [makeRModule| MyModule   field1 :: !Int-  field2 :: Bool+  Lens field2 :: Bool |]  [makeRSModule| MyRSModule-  readField :: !Int+  Lens readField :: !Int   State stateField :: !Int |]