diff --git a/fx.cabal b/fx.cabal --- a/fx.cabal +++ b/fx.cabal @@ -1,7 +1,7 @@ name: fx version: - 0.7 + 0.10 synopsis: Horizontally composable effects description: @@ -43,10 +43,9 @@ Haskell2010 exposed-modules: Fx.EitherEffect - Fx.Executor + Fx.Transform other-modules: + Fx.EitherEffect.Types Fx.Prelude build-depends: - transformers >= 0.3 && < 0.6, - base-prelude >= 1 && < 2, - base >= 4.6 && < 5 + base >= 4.10 && < 5 diff --git a/library/Fx/EitherEffect.hs b/library/Fx/EitherEffect.hs --- a/library/Fx/EitherEffect.hs +++ b/library/Fx/EitherEffect.hs @@ -1,48 +1,47 @@ module Fx.EitherEffect ( EitherEffect, - liftEffect1, - liftEffect2, - executor, + liftLeft, + liftRight, ) where import Fx.Prelude -import qualified Fx.Executor as A +import Fx.EitherEffect.Types -{-| -A sum of two effects (@effect1@ and @effect2@) to be executed -in @context@ producing @result@. --} -newtype EitherEffect effect1 effect2 context result = - EitherEffect (ReaderT (A.Executor effect1 context, A.Executor effect2 context) context result) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO) +instance Functor either => Functor (EitherEffect left right either) where + fmap mapping (EitherEffect either) = + EitherEffect (\ leftContext rightContext -> fmap mapping (either leftContext rightContext)) -instance MonadTrans (EitherEffect effect1 effect2) where - lift = - EitherEffect . lift +instance Applicative either => Applicative (EitherEffect left right either) where + pure x = + EitherEffect (\ _ _ -> pure x) + (<*>) (EitherEffect left) (EitherEffect right) = + EitherEffect (\ leftContext rightContext -> left leftContext rightContext <*> right leftContext rightContext) +instance Monad either => Monad (EitherEffect left right either) where + return = pure + (>>=) (EitherEffect left) rightK = + EitherEffect $ \ leftContext rightContext -> do + leftResult <- left leftContext rightContext + case rightK leftResult of + EitherEffect right -> right leftContext rightContext + +instance MonadIO either => MonadIO (EitherEffect left right either) where + liftIO io = + EitherEffect (\ _ _ -> liftIO io) + {-| Lift the first of the two effects. -} -liftEffect1 :: effect1 result -> EitherEffect effect1 effect2 context result -liftEffect1 effect = - EitherEffect (ReaderT (\(executor, _) -> A.execute executor effect)) +liftLeft :: left result -> EitherEffect left right either result +liftLeft effect = + EitherEffect (\ leftContext rightContext -> leftContext effect) {-| Lift the second of the two effects. -} -liftEffect2 :: effect2 result -> EitherEffect effect1 effect2 context result -liftEffect2 effect = - EitherEffect (ReaderT (\(_, executor) -> A.execute executor effect)) - -{-| -Compose the executors of each effect into an executor of either. --} -executor - :: A.Executor effect1 context - -> A.Executor effect2 context - -> A.Executor (EitherEffect effect1 effect2 context) context -executor executor1 executor2 = - A.Executor (\(EitherEffect reader) -> runReaderT reader (executor1, executor2)) +liftRight :: right result -> EitherEffect left right either result +liftRight effect = + EitherEffect (\ leftContext rightContext -> rightContext effect) diff --git a/library/Fx/EitherEffect/Types.hs b/library/Fx/EitherEffect/Types.hs new file mode 100644 --- /dev/null +++ b/library/Fx/EitherEffect/Types.hs @@ -0,0 +1,13 @@ +module Fx.EitherEffect.Types +where + +import Fx.Prelude + +{-| +A sum of two effects. +Allows for horizontal composition of monads instead of nesting as with monad transformers. + +To execute it use 'Fx.Transform.eitherEffect'. +-} +newtype EitherEffect leftEffect rightEffect context result = + EitherEffect ((forall x. leftEffect x -> context x) -> (forall x. rightEffect x -> context x) -> context result) diff --git a/library/Fx/Executor.hs b/library/Fx/Executor.hs deleted file mode 100644 --- a/library/Fx/Executor.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Fx.Executor -( - Executor(..), - mapEffect, - mapContext, - execute, -) -where - -import Fx.Prelude - - -{-| -An abstraction over the execution of @effect@ in @context@, both producing the same @result@. --} -newtype Executor effect context = - Executor (forall result. effect result -> context result) - -{-| -Use the executor to run an effect in a context. --} -execute :: Executor effect context -> effect result -> context result -execute (Executor def) effect = - def effect - -{-| -Map the effect part of an executor (contravariantly). --} -mapEffect :: (forall result. newEffect result -> oldEffect result) -> Executor oldEffect context -> Executor newEffect context -mapEffect mapping (Executor fn) = - Executor (fn . mapping) - -{-| -Map the context part of an executor. --} -mapContext :: (forall result. oldContext result -> newContext result) -> Executor effect oldContext -> Executor effect newContext -mapContext mapping (Executor fn) = - Executor (mapping . fn) diff --git a/library/Fx/Prelude.hs b/library/Fx/Prelude.hs --- a/library/Fx/Prelude.hs +++ b/library/Fx/Prelude.hs @@ -5,18 +5,68 @@ where --- base-prelude +-- base ------------------------- -import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, (<>), First(..), Last(..), ProtocolError, traceEvent, traceEventIO, traceMarker, traceMarkerIO) +import Control.Applicative as Exports +import Control.Arrow as Exports hiding (first, second) +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports hiding (bool) +import Data.Char as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports +import Data.Function as Exports hiding ((.), id, (&)) +import Data.Functor as Exports hiding (($>)) +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.Maybe as Exports +import Data.Monoid as Exports +import Data.Ord as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.String as Exports +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports hiding (traceShowId, traceM, traceShowM) +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports +import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) +import GHC.Exts as Exports (lazy, inline, sortWith, groupWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import Numeric as Exports +import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports (Handle, hClose) +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) +import Text.Printf as Exports (printf, hPrintf) +import Text.Read as Exports (Read(..), readMaybe, readEither) +import Unsafe.Coerce as Exports + -- transformers ------------------------- import Control.Monad.IO.Class as Exports -import Control.Monad.Trans.Class as Exports -import Control.Monad.Trans.Cont as Exports hiding (shift, callCC) -import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE) -import Control.Monad.Trans.Maybe as Exports -import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT) -import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT) -import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT) -import Data.Functor.Compose as Exports diff --git a/library/Fx/Transform.hs b/library/Fx/Transform.hs new file mode 100644 --- /dev/null +++ b/library/Fx/Transform.hs @@ -0,0 +1,25 @@ +module Fx.Transform +where + +import Fx.Prelude +import Fx.EitherEffect.Types + + +{-| +Natural transformation. +An abstraction over the transformation of kind-2 @input@ to @output@, both producing the same @result@. +-} +newtype input --> output = + Transform (forall result. input result -> output result) + +{-| +Given a natural transformation of the left monad and a natural transformation of the right monad, +produces a natural transformation of either of them. +-} +eitherEffect :: Monad either => (left --> either) -> (right --> either) -> (EitherEffect left right either --> either) +eitherEffect (Transform leftTrans) (Transform rightTrans) = + Transform (\ (EitherEffect context) -> context leftTrans rightTrans) + +instance Category (-->) where + id = Transform id + (.) (Transform left) (Transform right) = Transform (left . right)