Implement initial BindLeft and MonadLeft

src/Control/ApplicativeLeft.purs

@@ -0,0 +1,19 @@
+module Control.ApplicativeLeft where
+
+import Prelude
+import Control.ApplyLeft (class ApplyLeft)
+
+-- | Same as `Applicative` but works on the left parameter in a Bifunctor.
+class ApplicativeLeft :: (Type -> Type -> Type) -> Constraint
+class ApplyLeft m <= ApplicativeLeft m where
+  lpure :: forall a b. a -> m a b
+
+-- | Perform an applicative action when a condition is true.
+whenLeft :: forall m c. ApplicativeLeft m => Boolean -> m Unit c -> m Unit c
+whenLeft true m = m
+whenLeft false _ = lpure unit
+
+-- | Perform an applicative action unless a condition is true.
+unlessLeft :: forall m c. ApplicativeLeft m => Boolean -> m Unit c -> m Unit c
+unlessLeft false m = m
+unlessLeft true _ = lpure unit

src/Control/ApplyLeft.purs

@@ -0,0 +1,37 @@
+module Control.ApplyLeft where
+
+import Prelude
+import Data.Bifunctor (class Bifunctor, lmap)
+
+-- | Same as `Apply` but works on the left parameter in a Bifunctor.
+class ApplyLeft :: (Type -> Type -> Type) -> Constraint
+class Bifunctor m <= ApplyLeft m where
+  lapply :: forall a b c. m (a -> b) c -> m a c -> m b c
+
+-- | Combine two effectful actions, keeping only the result of the first.
+applyFirstLeft :: forall a b c m. ApplyLeft m => m a c -> m b c -> m a c
+applyFirstLeft a b = lapply (lmap const a) b
+
+-- | Combine two effectful actions, keeping only the result of the second.
+applySecondLeft :: forall m a b c. ApplyLeft m => m a c -> m b c -> m b c
+applySecondLeft a b = lapply (lmap (const identity) a) b
+
+-- | Lift a function of two arguments to a function which accepts and returns
+-- | values wrapped with the type constructor `f`.
+lift2Left :: forall a b c m x. ApplyLeft m => (a -> b -> c) -> m a x -> m b x -> m c x
+lift2Left f a b = f `lmap` a `lapply` b
+
+-- | Lift a function of three arguments to a function which accepts and returns
+-- | values wrapped with the type constructor `f`.
+lift3Left :: forall a b c d m x. ApplyLeft m => (a -> b -> c -> d) -> m a x -> m b x -> m c x -> m d x
+lift3Left f a b c = f `lmap` a `lapply` b `lapply` c
+
+-- | Lift a function of four arguments to a function which accepts and returns
+-- | values wrapped with the type constructor `f`.
+lift4Left :: forall a b c d e m x. ApplyLeft m => (a -> b -> c -> d -> e) -> m a x -> m b x -> m c x -> m d x -> m e x
+lift4Left f a b c d = f `lmap` a `lapply` b `lapply` c `lapply` d
+
+-- | Lift a function of five arguments to a function which accepts and returns
+-- | values wrapped with the type constructor `f`.
+lift5Left :: forall a b c d e g m x. ApplyLeft m => (a -> b -> c -> d -> e -> g) -> m a x -> m b x -> m c x -> m d x -> m e x -> m g x
+lift5Left f a b c d e = f `lmap` a `lapply` b `lapply` c `lapply` d `lapply` e

src/Control/Biapplicative.purs

@@ -5,8 +5,8 @@ import Data.Tuple (Tuple(..))
 
 -- | `Biapplicative` captures type constructors of two arguments which support lifting of
 -- | functions of zero or more arguments, in the sense of `Applicative`.
-class Biapply w <= Biapplicative w where
-  bipure :: forall a b. a -> b -> w a b
+class Biapply m <= Biapplicative m where
+  bipure :: forall a b. a -> b -> m a b
 
 instance biapplicativeTuple :: Biapplicative Tuple where
   bipure = Tuple

src/Control/Biapply.purs

@@ -15,44 +15,44 @@ infixl 4 identity as <<$>>
 
 -- | `Biapply` captures type constructors of two arguments which support lifting of
 -- | functions of one or more arguments, in the sense of `Apply`.
-class Bifunctor w <= Biapply w where
-  biapply :: forall a b c d. w (a -> b) (c -> d) -> w a c -> w b d
+class Bifunctor m <= Biapply m where
+  biapply :: forall a b c d. m (a -> b) (c -> d) -> m a c -> m b d
 
 infixl 4 biapply as <<*>>
 
 -- | Keep the results of the second computation.
-biapplyFirst :: forall w a b c d. Biapply w => w a b -> w c d -> w c d
+biapplyFirst :: forall m a b c d. Biapply m => m a b -> m c d -> m c d
 biapplyFirst a b = bimap (const identity) (const identity) <<$>> a <<*>> b
 
 infixl 4 biapplyFirst as *>>
 
 -- | Keep the results of the first computation.
-biapplySecond :: forall w a b c d. Biapply w => w a b -> w c d -> w a b
+biapplySecond :: forall m a b c d. Biapply m => m a b -> m c d -> m a b
 biapplySecond a b = bimap const const <<$>> a <<*>> b
 
 infixl 4 biapplySecond as <<*
 
 -- | Lift a function of two arguments.
 bilift2
-  :: forall w a b c d e f
-   . Biapply w
+  :: forall m a b c d e f
+   . Biapply m
   => (a -> b -> c)
   -> (d -> e -> f)
-  -> w a d
-  -> w b e
-  -> w c f
+  -> m a d
+  -> m b e
+  -> m c f
 bilift2 f g a b = bimap f g <<$>> a <<*>> b
 
 -- | Lift a function of three arguments.
 bilift3
-  :: forall w a b c d e f g h
-   . Biapply w
+  :: forall m a b c d e f g h
+   . Biapply m
   => (a -> b -> c -> d)
   -> (e -> f -> g -> h)
-  -> w a e
-  -> w b f
-  -> w c g
-  -> w d h
+  -> m a e
+  -> m b f
+  -> m c g
+  -> m d h
 bilift3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c
 
 instance biapplyTuple :: Biapply Tuple where

src/Control/BindLeft.purs

@@ -0,0 +1,31 @@
+module Control.BindLeft where
+
+import Control.ApplicativeLeft (class ApplicativeLeft)
+import Control.Category (identity)
+import Data.Unit (Unit)
+
+-- | Same as `Discard` but works on the left parameter of the bifunctor
+-- | rather than the right parameter, which is the default for `Discard`.
+class DiscardLeft a where
+  ldiscard :: forall m b r. BindLeft m => m a r -> (a -> m b r) -> m b r
+
+instance discardLeftUnit :: DiscardLeft Unit where
+  ldiscard = lbind
+
+-- | Same as `Bind` but works on the left parameter of the bifunctor
+-- | rather than the right parameter, which is the default for `Bind`.
+class BindLeft :: (Type -> Type -> Type) -> Constraint
+class ApplicativeLeft m <= BindLeft m where
+  lbind :: forall a b r. m a r -> (a -> m b r) -> m b r
+
+joinLeft :: forall m a r. BindLeft m => m (m a r) r -> m a r
+joinLeft m = lbind m identity
+
+composeKleisliLeft :: forall m a b c r. BindLeft m => (a -> m b r) -> (b -> m c r) -> a -> m c r
+composeKleisliLeft f g a = lbind (f a) g
+
+composeKleisliFlippedLeft :: forall m a b c r. BindLeft m => (b -> m c r) -> (a -> m b r) -> a -> m c r
+composeKleisliFlippedLeft f g a = lbind (g a) f
+
+ifMLeft :: forall m a r. BindLeft m => m Boolean r -> m a r -> m a r -> m a r
+ifMLeft cond truePath falsePath = lbind cond \b -> if b then truePath else falsePath

src/Control/MonadLeft.purs

@@ -0,0 +1,18 @@
+module Control.MonadLeft where
+
+import Control.ApplicativeLeft (class ApplicativeLeft, whenLeft, unlessLeft)
+import Control.BindLeft (class BindLeft, lbind)
+import Data.Unit (Unit)
+
+class MonadLeft :: (Type -> Type -> Type) -> Constraint
+class (ApplicativeLeft m, BindLeft m) <= MonadLeft m
+
+-- | Perform a monadic action when a condition is true, where the conditional
+-- | value is also in a monadic context.
+whenMLeft :: forall m c. MonadLeft m => m Boolean c -> m Unit c -> m Unit c
+whenMLeft mb m = lbind mb \b -> whenLeft b m
+
+-- | Perform a monadic action unless a condition is true, where the conditional
+-- | value is also in a monadic context.
+unlessMLeft :: forall m c. MonadLeft m => m Boolean c -> m Unit c -> m Unit c
+unlessMLeft mb m = lbind mb \b -> unlessLeft b m

src/Control/MonadLeft/Qualified.purs

@@ -0,0 +1,44 @@
+-- | Enables one to use `ado notation` and `do notation` on the left parameter
+-- | of a Bifunctor.
+-- |
+-- | `ado notation` example
+-- | ```
+-- | import Control.MonadLeft.Qualified as BiLeft
+-- |
+-- | foo :: Either Int String -> Either String String
+-- | foo comp = BiLeft.ado
+-- |   a <- comp
+-- |   b <- comp
+-- |   in show $ a + b
+-- | ```
+-- | `do notation` example
+-- | ```
+-- | import Control.MonadLeft.Qualified as BiLeft
+-- |
+-- | foo :: Either Int String -> Either String String
+-- | foo comp = BiLeft.do
+-- |   a <- comp
+-- |   b <- comp
+-- |   lpure $ show $ a + b
+-- | ```
+module Control.MonadLeft.Qualified where
+
+import Control.ApplyLeft (class ApplyLeft, lapply)
+import Control.ApplicativeLeft (class ApplicativeLeft, lpure)
+import Control.BindLeft (class BindLeft, lbind, class DiscardLeft, ldiscard)
+import Data.Bifunctor (class Bifunctor, lmap)
+
+discard :: forall m a b r. DiscardLeft a => BindLeft m => m a r -> (a -> m b r) -> m b r
+discard = ldiscard
+
+bind :: forall m a b r. BindLeft m => m a r -> (a -> m b r) -> m b r
+bind = lbind
+
+apply :: forall m a b c. ApplyLeft m => m (a -> b) c -> m a c -> m b c
+apply = lapply
+
+map :: forall m a b c. Bifunctor m => (a -> b) -> m a c -> m b c
+map = lmap
+
+pure :: forall m a b. ApplicativeLeft m => a -> m a b
+pure = lpure