summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authoriokasimovmt <>2020-10-17 17:04:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-10-17 17:04:00 (GMT)
commitd93d5d9ca1c8ab27e5edbbc4e94ca431931f0f24 (patch)
tree3e60e209e08c4075593d2c93e64f76bcf77ac836
parentf26a061049dc7e17acd081229899ed6202f5ca60 (diff)
version 0.1.8HEAD0.1.8master
-rw-r--r--Control/Joint/Abilities.hs2
-rw-r--r--Control/Joint/Abilities/Adaptable.hs210
-rw-r--r--Control/Joint/Abilities/Completable.hs6
-rw-r--r--Control/Joint/Abilities/Liftable.hs146
-rw-r--r--Control/Joint/Abilities/Transformer.hs14
-rw-r--r--Control/Joint/Effects.hs1
-rw-r--r--Control/Joint/Effects/Either.hs12
-rw-r--r--Control/Joint/Effects/Maybe.hs18
-rw-r--r--Control/Joint/Effects/Reader.hs12
-rw-r--r--Control/Joint/Effects/State.hs26
-rw-r--r--Control/Joint/Effects/Store.hs20
-rw-r--r--Control/Joint/Effects/Writer.hs12
-rw-r--r--Control/Joint/Schemes/TU.hs12
-rw-r--r--Control/Joint/Schemes/TUT.hs10
-rw-r--r--Control/Joint/Schemes/UT.hs12
-rw-r--r--joint.cabal8
16 files changed, 320 insertions, 201 deletions
diff --git a/Control/Joint/Abilities.hs b/Control/Joint/Abilities.hs
index 3a1f0f9..8e2ac13 100644
--- a/Control/Joint/Abilities.hs
+++ b/Control/Joint/Abilities.hs
@@ -1,6 +1,6 @@
module Control.Joint.Abilities (module Exports) where
-import Control.Joint.Abilities.Liftable as Exports
import Control.Joint.Abilities.Adaptable as Exports
+import Control.Joint.Abilities.Completable as Exports
import Control.Joint.Abilities.Transformer as Exports
import Control.Joint.Abilities.Interpreted as Exports
diff --git a/Control/Joint/Abilities/Adaptable.hs b/Control/Joint/Abilities/Adaptable.hs
index 4f72645..0b3f136 100644
--- a/Control/Joint/Abilities/Adaptable.hs
+++ b/Control/Joint/Abilities/Adaptable.hs
@@ -1,6 +1,212 @@
module Control.Joint.Abilities.Adaptable where
+import "transformers" Control.Monad.Trans.Class (MonadTrans (lift))
+
import Control.Joint.Core (type (~>))
+import Control.Joint.Abilities.Interpreted (Interpreted (run))
+import Control.Joint.Abilities.Transformer (Transformer (build), Schema, (:>) (T, trans))
+
+class Adaptable (eff :: * -> *) (schema :: * -> *) where
+ {-# MINIMAL adapt #-}
+ adapt :: eff ~> schema
+
+type Embedding t u = (Transformer t, Monad u)
+type Building t u = (Transformer t, Applicative u)
+
+instance Adaptable t t where
+ adapt = id
+
+instance (Monad u, MonadTrans ((:>) t)) => Adaptable u (t :> u) where
+ adapt = lift
+
+instance Building t u => Adaptable t (t :> u) where
+ adapt = build
+
+instance
+ ( Embedding t (Schema u v)
+ , MonadTrans ((:>) t)
+ , Building u v
+ ) => Adaptable u (t :> u :> v) where
+ adapt = lift . build
+
+instance
+ ( Embedding t (Schema u v)
+ , Embedding u v
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ ) => Adaptable v (t :> u :> v) where
+ adapt = lift . lift
+
+instance
+ ( Embedding t (Schema u (v :> w))
+ , Embedding u (Schema v w)
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , Building v w
+ ) => Adaptable v (t :> u :> v :> w) where
+ adapt = lift . lift . build
+
+instance
+ ( Embedding t (Schema u v)
+ , Embedding t (Schema u (v :> w))
+ , Embedding u (Schema v w)
+ , Embedding v w
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ ) => Adaptable w (t :> u :> v :> w) where
+ adapt = lift . lift . lift
+
+instance (Embedding t (Schema u (v :> w :> x))
+ , Embedding u (Schema v (w :> x))
+ , Embedding v (Schema w x)
+ , Embedding w x
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ ) => Adaptable x (t :> u :> v :> w :> x) where
+ adapt = lift . lift . lift . lift
+
+instance (Embedding t (Schema u (v :> w :> x))
+ , Embedding u (Schema v (w :> x))
+ , Embedding v (Schema w x)
+ , Building w x
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ ) => Adaptable w (t :> u :> v :> w :> x) where
+ adapt = lift . lift . lift . build
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y))
+ , Embedding u (Schema v (w :> x :> y))
+ , Embedding v (Schema w (x :> y))
+ , Embedding w (Schema x y)
+ , Embedding x y
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ ) => Adaptable y (t :> u :> v :> w :> x :> y) where
+ adapt = lift . lift . lift . lift . lift
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y))
+ , Embedding u (Schema v (w :> x :> y))
+ , Embedding v (Schema w (x :> y))
+ , Embedding w (Schema x y)
+ , Building x y
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ ) => Adaptable x (t :> u :> v :> w :> x :> y) where
+ adapt = lift . lift . lift . lift . build
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y :> z))
+ , Embedding u (Schema v (w :> x :> y :> z))
+ , Embedding v (Schema w (x :> y :> z))
+ , Embedding w (Schema x (y :> z))
+ , Embedding x (Schema y z)
+ , Embedding y z
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ , MonadTrans ((:>) y)
+ ) => Adaptable z (t :> u :> v :> w :> x :> y :> z) where
+ adapt = lift . lift . lift . lift . lift . lift
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y :> z))
+ , Embedding u (Schema v (w :> x :> y :> z))
+ , Embedding v (Schema w (x :> y :> z))
+ , Embedding w (Schema x (y :> z))
+ , Embedding x (Schema y z)
+ , Building y z
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ ) => Adaptable y (t :> u :> v :> w :> x :> y :> z) where
+ adapt = lift . lift . lift . lift . lift . build
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y :> z :> f))
+ , Embedding u (Schema v (w :> x :> y :> z :> f))
+ , Embedding v (Schema w (x :> y :> z :> f))
+ , Embedding w (Schema x (y :> z :> f))
+ , Embedding x (Schema y (z :> f))
+ , Embedding y (Schema z f)
+ , Embedding z f
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ , MonadTrans ((:>) y)
+ , MonadTrans ((:>) z)
+ ) => Adaptable f (t :> u :> v :> w :> x :> y :> z :> f) where
+ adapt = lift . lift . lift . lift . lift . lift . lift
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y :> z :> f))
+ , Embedding u (Schema v (w :> x :> y :> z :> f))
+ , Embedding v (Schema w (x :> y :> z :> f))
+ , Embedding w (Schema x (y :> z :> f))
+ , Embedding x (Schema y (z :> f))
+ , Embedding y (Schema z f)
+ , Building z f
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ , MonadTrans ((:>) y)
+ , MonadTrans ((:>) z)
+ ) => Adaptable z (t :> u :> v :> w :> x :> y :> z :> f) where
+ adapt = lift . lift . lift . lift . lift . lift . build
+
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y :> z :> f :> h))
+ , Embedding u (Schema v (w :> x :> y :> z :> f :> h))
+ , Embedding v (Schema w (x :> y :> z :> f :> h))
+ , Embedding w (Schema x (y :> z :> f :> h))
+ , Embedding x (Schema y (z :> f :> h))
+ , Embedding y (Schema z (f :> h))
+ , Embedding z (Schema f h)
+ , Embedding f h
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ , MonadTrans ((:>) y)
+ , MonadTrans ((:>) z)
+ , MonadTrans ((:>) f)
+ ) => Adaptable h (t :> u :> v :> w :> x :> y :> z :> f :> h) where
+ adapt = lift . lift . lift . lift . lift . lift . lift . lift
-class Adaptable (subeff :: * -> *) (eff :: * -> *) | subeff -> eff where
- adapt :: subeff ~> eff
+instance
+ ( Embedding t (Schema u (v :> w :> x :> y :> z :> f :> h))
+ , Embedding u (Schema v (w :> x :> y :> z :> f :> h))
+ , Embedding v (Schema w (x :> y :> z :> f :> h))
+ , Embedding w (Schema x (y :> z :> f :> h))
+ , Embedding x (Schema y (z :> f :> h))
+ , Embedding y (Schema z (f :> h))
+ , Embedding z (Schema f h)
+ , Building f h
+ , MonadTrans ((:>) t)
+ , MonadTrans ((:>) u)
+ , MonadTrans ((:>) v)
+ , MonadTrans ((:>) w)
+ , MonadTrans ((:>) x)
+ , MonadTrans ((:>) y)
+ , MonadTrans ((:>) z)
+ ) => Adaptable f (t :> u :> v :> w :> x :> y :> z :> f :> h) where
+ adapt = lift . lift . lift . lift . lift . lift . lift . build
diff --git a/Control/Joint/Abilities/Completable.hs b/Control/Joint/Abilities/Completable.hs
new file mode 100644
index 0000000..ab6a54f
--- /dev/null
+++ b/Control/Joint/Abilities/Completable.hs
@@ -0,0 +1,6 @@
+module Control.Joint.Abilities.Completable where
+
+import Control.Joint.Core (type (~>))
+
+class Completable (subeff :: * -> *) (eff :: * -> *) | subeff -> eff where
+ complete :: subeff ~> eff
diff --git a/Control/Joint/Abilities/Liftable.hs b/Control/Joint/Abilities/Liftable.hs
deleted file mode 100644
index 6fac976..0000000
--- a/Control/Joint/Abilities/Liftable.hs
+++ /dev/null
@@ -1,146 +0,0 @@
-module Control.Joint.Abilities.Liftable where
-
-import Control.Joint.Core (type (~>))
-import Control.Joint.Abilities.Interpreted (Interpreted (run))
-import Control.Joint.Abilities.Transformer (Transformer (Schema, build, embed), (:>) (T, trans))
-
-class Liftable (eff :: * -> *) (schema :: * -> *) where
- {-# MINIMAL lift #-}
- lift :: eff ~> schema
-
-type Embedding t u = (Transformer t, Functor u)
-type Building t u = (Transformer t, Applicative u)
-
-instance Liftable t t where
- lift = id
-
-instance Embedding t u => Liftable u (t :> u) where
- lift = embed
-
-instance Building t u => Liftable t (t :> u) where
- lift = build
-
-instance
- ( Embedding t (Schema u v)
- , Building u v
- ) => Liftable u (t :> u :> v) where
- lift = embed . build
-
-instance
- ( Embedding t (Schema u v)
- , Embedding u v
- ) => Liftable v (t :> u :> v) where
- lift = embed . embed
-
-instance
- ( Embedding t (Schema u (v :> w))
- , Embedding u (Schema v w)
- , Building v w
- ) => Liftable v (t :> u :> v :> w) where
- lift = embed . embed . build
-
-instance
- ( Embedding t (Schema u v)
- , Embedding t (Schema u (v :> w))
- , Embedding u (Schema v w)
- , Embedding v w
- ) => Liftable w (t :> u :> v :> w) where
- lift = embed . embed . embed
-
-instance (Embedding t (Schema u (v :> w :> x))
- , Embedding u (Schema v (w :> x))
- , Embedding v (Schema w x)
- , Embedding w x
- ) => Liftable x (t :> u :> v :> w :> x) where
- lift = embed . embed . embed . embed
-
-instance (Embedding t (Schema u (v :> w :> x))
- , Embedding u (Schema v (w :> x))
- , Embedding v (Schema w x)
- , Building w x
- ) => Liftable w (t :> u :> v :> w :> x) where
- lift = embed . embed . embed . build
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y))
- , Embedding u (Schema v (w :> x :> y))
- , Embedding v (Schema w (x :> y))
- , Embedding w (Schema x y)
- , Embedding x y
- ) => Liftable y (t :> u :> v :> w :> x :> y) where
- lift = embed . embed . embed . embed . embed
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y))
- , Embedding u (Schema v (w :> x :> y))
- , Embedding v (Schema w (x :> y))
- , Embedding w (Schema x y)
- , Building x y
- ) => Liftable x (t :> u :> v :> w :> x :> y) where
- lift = embed . embed . embed . embed . build
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y :> z))
- , Embedding u (Schema v (w :> x :> y :> z))
- , Embedding v (Schema w (x :> y :> z))
- , Embedding w (Schema x (y :> z))
- , Embedding x (Schema y z)
- , Embedding y z
- ) => Liftable z (t :> u :> v :> w :> x :> y :> z) where
- lift = embed . embed . embed . embed . embed . embed
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y :> z))
- , Embedding u (Schema v (w :> x :> y :> z))
- , Embedding v (Schema w (x :> y :> z))
- , Embedding w (Schema x (y :> z))
- , Embedding x (Schema y z)
- , Building y z
- ) => Liftable y (t :> u :> v :> w :> x :> y :> z) where
- lift = embed . embed . embed . embed . embed . build
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y :> z :> f))
- , Embedding u (Schema v (w :> x :> y :> z :> f))
- , Embedding v (Schema w (x :> y :> z :> f))
- , Embedding w (Schema x (y :> z :> f))
- , Embedding x (Schema y (z :> f))
- , Embedding y (Schema z f)
- , Embedding z f
- ) => Liftable f (t :> u :> v :> w :> x :> y :> z :> f) where
- lift = embed . embed . embed . embed . embed . embed . embed
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y :> z :> f))
- , Embedding u (Schema v (w :> x :> y :> z :> f))
- , Embedding v (Schema w (x :> y :> z :> f))
- , Embedding w (Schema x (y :> z :> f))
- , Embedding x (Schema y (z :> f))
- , Embedding y (Schema z f)
- , Building z f
- ) => Liftable z (t :> u :> v :> w :> x :> y :> z :> f) where
- lift = embed . embed . embed . embed . embed . embed . build
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y :> z :> f :> h))
- , Embedding u (Schema v (w :> x :> y :> z :> f :> h))
- , Embedding v (Schema w (x :> y :> z :> f :> h))
- , Embedding w (Schema x (y :> z :> f :> h))
- , Embedding x (Schema y (z :> f :> h))
- , Embedding y (Schema z (f :> h))
- , Embedding z (Schema f h)
- , Embedding f h
- ) => Liftable h (t :> u :> v :> w :> x :> y :> z :> f :> h) where
- lift = embed . embed . embed . embed . embed . embed . embed . embed
-
-instance
- ( Embedding t (Schema u (v :> w :> x :> y :> z :> f :> h))
- , Embedding u (Schema v (w :> x :> y :> z :> f :> h))
- , Embedding v (Schema w (x :> y :> z :> f :> h))
- , Embedding w (Schema x (y :> z :> f :> h))
- , Embedding x (Schema y (z :> f :> h))
- , Embedding y (Schema z (f :> h))
- , Embedding z (Schema f h)
- , Building f h
- ) => Liftable f (t :> u :> v :> w :> x :> y :> z :> f :> h) where
- lift = embed . embed . embed . embed . embed . embed . embed . build
diff --git a/Control/Joint/Abilities/Transformer.hs b/Control/Joint/Abilities/Transformer.hs
index a4ff848..8c256e2 100644
--- a/Control/Joint/Abilities/Transformer.hs
+++ b/Control/Joint/Abilities/Transformer.hs
@@ -1,14 +1,15 @@
-module Control.Joint.Abilities.Transformer (Transformer (..), (:>) (..)) where
+module Control.Joint.Abilities.Transformer where
-import Control.Applicative (Alternative (empty, (<|>)))
+import "base" Control.Applicative (Alternative (empty, (<|>)))
+import "transformers" Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Joint.Core (type (~>))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
+type family Schema (t :: * -> *) = (r :: (* -> *) -> * -> *) | r -> t
+
class Interpreted t => Transformer t where
- {-# MINIMAL embed, build, unite #-}
- type Schema (t :: * -> *) = (r :: (* -> *) -> * -> *) | r -> t
- embed :: Functor u => u ~> t :> u
+ {-# MINIMAL build, unite #-}
build :: Applicative u => t ~> t :> u
unite :: Primary (Schema t u) a -> (t :> u) a
@@ -32,3 +33,6 @@ instance (Transformer t, Monad (Schema t u)) => Monad (t :> u) where
instance (Interpreted (Schema t u), Transformer t) => Interpreted (t :> u) where
type Primary (t :> u) a = Primary (Schema t u) a
run (T x) = run x
+
+instance MonadTrans (Schema t) => MonadTrans ((:>) t) where
+ lift = T . lift
diff --git a/Control/Joint/Effects.hs b/Control/Joint/Effects.hs
index 8149696..0a9dd28 100644
--- a/Control/Joint/Effects.hs
+++ b/Control/Joint/Effects.hs
@@ -2,6 +2,7 @@ module Control.Joint.Effects (module Exports) where
import Control.Joint.Effects.Maybe as Exports
import Control.Joint.Effects.Either as Exports
+import Control.Joint.Effects.Store as Exports
import Control.Joint.Effects.State as Exports
import Control.Joint.Effects.Writer as Exports
import Control.Joint.Effects.Reader as Exports
diff --git a/Control/Joint/Effects/Either.hs b/Control/Joint/Effects/Either.hs
index 1c2d578..e3c8427 100644
--- a/Control/Joint/Effects/Either.hs
+++ b/Control/Joint/Effects/Either.hs
@@ -2,17 +2,17 @@ module Control.Joint.Effects.Either where
import Control.Joint.Operators ((<$$>), (<**>))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite), (:>) (T))
-import Control.Joint.Abilities.Liftable (Liftable (lift))
+import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T))
+import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
import Control.Joint.Schemes (UT (UT))
instance Interpreted (Either e) where
type Primary (Either e) a = Either e a
run x = x
+type instance Schema (Either e) = UT (Either e)
+
instance Transformer (Either e) where
- type Schema (Either e) = UT (Either e)
- embed x = T . UT $ Right <$> x
build x = T . UT . pure $ x
unite = T . UT
@@ -26,7 +26,7 @@ instance Applicative u => Applicative (UT (Either e) u) where
instance (Applicative u, Monad u) => Monad (UT (Either e) u) where
UT x >>= f = UT $ x >>= either (pure . Left) (run . f)
-type Failable e = Liftable (Either e)
+type Failable e = Adaptable (Either e)
failure :: Failable e t => e -> t a
-failure = lift . Left
+failure = adapt . Left
diff --git a/Control/Joint/Effects/Maybe.hs b/Control/Joint/Effects/Maybe.hs
index c731595..5de5fc2 100644
--- a/Control/Joint/Effects/Maybe.hs
+++ b/Control/Joint/Effects/Maybe.hs
@@ -1,19 +1,19 @@
module Control.Joint.Effects.Maybe where
import Control.Joint.Operators ((<$$>), (<**>))
-import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
+import Control.Joint.Abilities.Completable (Completable (complete))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite), (:>) (T))
-import Control.Joint.Abilities.Liftable (Liftable (lift))
+import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T))
+import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
import Control.Joint.Schemes (UT (UT))
instance Interpreted Maybe where
type Primary Maybe a = Maybe a
run x = x
+type instance Schema Maybe = UT Maybe
+
instance Transformer Maybe where
- type Schema Maybe = UT Maybe
- embed x = T . UT $ Just <$> x
build x = T . UT . pure $ x
unite = T . UT
@@ -27,10 +27,10 @@ instance Applicative u => Applicative (UT Maybe u) where
instance (Applicative u, Monad u) => Monad (UT Maybe u) where
UT x >>= f = UT $ x >>= maybe (pure Nothing) (run . f)
-instance Adaptable (Either e) Maybe where
- adapt = either (const Nothing) Just
+instance Completable (Either e) Maybe where
+ complete = either (const Nothing) Just
-type Optional = Liftable Maybe
+type Optional = Adaptable Maybe
nothing :: Optional t => t a
-nothing = lift Nothing
+nothing = adapt Nothing
diff --git a/Control/Joint/Effects/Reader.hs b/Control/Joint/Effects/Reader.hs
index 07a896c..a208b17 100644
--- a/Control/Joint/Effects/Reader.hs
+++ b/Control/Joint/Effects/Reader.hs
@@ -2,8 +2,8 @@ module Control.Joint.Effects.Reader where
import Control.Joint.Operators ((<$$>), (<**>))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite), (:>) (T))
-import Control.Joint.Abilities.Liftable (Liftable (lift))
+import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T))
+import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
import Control.Joint.Schemes (TU (TU))
newtype Reader e a = Reader (e -> a)
@@ -22,9 +22,9 @@ instance Interpreted (Reader e) where
type Primary (Reader e) a = (->) e a
run (Reader x) = x
+type instance Schema (Reader e) = TU ((->) e)
+
instance Transformer (Reader e) where
- type Schema (Reader e) = TU ((->) e)
- embed x = T . TU . const $ x
build x = T. TU $ pure <$> run x
unite = T . TU
@@ -38,7 +38,7 @@ instance Applicative u => Applicative (TU ((->) e) u) where
instance (Applicative u, Monad u) => Monad (TU ((->) e) u) where
TU x >>= f = TU $ \e -> x e >>= ($ e) . run . f
-type Configured e = Liftable (Reader e)
+type Configured e = Adaptable (Reader e)
get :: Configured e t => t e
-get = lift $ Reader id
+get = adapt $ Reader id
diff --git a/Control/Joint/Effects/State.hs b/Control/Joint/Effects/State.hs
index b0b7e4b..bd2a626 100644
--- a/Control/Joint/Effects/State.hs
+++ b/Control/Joint/Effects/State.hs
@@ -3,10 +3,10 @@ module Control.Joint.Effects.State where
import Control.Applicative (Alternative (empty, (<|>)))
import Control.Joint.Core (type (:.), type (:=))
-import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
+import Control.Joint.Abilities.Completable (Completable (complete))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite), (:>) (T))
-import Control.Joint.Abilities.Liftable (Liftable (lift))
+import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T))
+import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
import Control.Joint.Schemes (TUT (TUT))
import Control.Joint.Effects.Reader (Reader (Reader))
import Control.Joint.Effects.Writer (Writer (Writer))
@@ -32,9 +32,9 @@ instance Interpreted (State s) where
type Primary (State s) a = (->) s :. (,) s := a
run (State x) = x
+type instance Schema (State s) = TUT ((->) s) ((,) s)
+
instance Transformer (State s) where
- type Schema (State s) = TUT ((->) s) ((,) s)
- embed x = T . TUT $ \s -> (s,) <$> x
build x = T . TUT $ pure <$> run x
unite = T . TUT
@@ -52,19 +52,19 @@ instance (Alternative u, Monad u) => Alternative (TUT ((->) s) ((,) s) u) where
TUT x <|> TUT y = TUT $ \s -> x s <|> y s
empty = TUT $ \_ -> empty
-instance Adaptable (Reader e) (State e) where
- adapt (Reader f) = State (\e -> (e, f e))
+instance Completable (Reader e) (State e) where
+ complete (Reader f) = State (\e -> (e, f e))
-instance Adaptable (Writer e) (State e) where
- adapt (Writer (e, x)) = State (\e -> (e, x))
+instance Completable (Writer e) (State e) where
+ complete (Writer (e, x)) = State (\e -> (e, x))
-type Stateful e = Liftable (State e)
+type Stateful e = Adaptable (State e)
modify :: Stateful s t => (s -> s) -> t ()
-modify f = lift $ State $ \s -> (f s, ())
+modify f = adapt $ State $ \s -> (f s, ())
current :: Stateful s t => t s
-current = lift $ State $ \s -> (s, s)
+current = adapt $ State $ \s -> (s, s)
replace :: Stateful s t => s -> t ()
-replace new = lift $ State $ \_ -> (new, ())
+replace new = adapt $ State $ \_ -> (new, ())
diff --git a/Control/Joint/Effects/Store.hs b/Control/Joint/Effects/Store.hs
new file mode 100644
index 0000000..6548add
--- /dev/null
+++ b/Control/Joint/Effects/Store.hs
@@ -0,0 +1,20 @@
+module Control.Joint.Effects.Store where
+
+import "comonad" Control.Comonad (Comonad (extract, extend))
+
+import Control.Joint.Core (type (:.), type (:=))
+import Control.Joint.Operators ((<$$>))
+import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
+
+newtype Store s a = Store ((,) s :. (->) s := a)
+
+instance Functor (Store s) where
+ fmap f (Store x) = Store $ f <$$> x
+
+instance Comonad (Store s) where
+ extend f (Store (s, g)) = Store (s, \s' -> f (Store (s', g)))
+ extract (Store (s, g)) = g s
+
+instance Interpreted (Store s) where
+ type Primary (Store s) a = (,) s :. (->) s := a
+ run (Store x) = x
diff --git a/Control/Joint/Effects/Writer.hs b/Control/Joint/Effects/Writer.hs
index e915e24..2fc4cf9 100644
--- a/Control/Joint/Effects/Writer.hs
+++ b/Control/Joint/Effects/Writer.hs
@@ -2,8 +2,8 @@ module Control.Joint.Effects.Writer where
import Control.Joint.Operators ((<$$>), (<**>))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite), (:>) (T))
-import Control.Joint.Abilities.Liftable (Liftable (lift))
+import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T))
+import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
import Control.Joint.Schemes (UT (UT))
newtype Writer e a = Writer (e, a)
@@ -24,9 +24,9 @@ instance Interpreted (Writer e) where
type Primary (Writer e) a = (e, a)
run (Writer x) = x
+type instance Schema (Writer e) = UT ((,) e)
+
instance Monoid e => Transformer (Writer e) where
- type Schema (Writer e) = UT ((,) e)
- embed x = T . UT $ (,) mempty <$> x
build = T . UT . pure . run
unite = T . UT
@@ -40,7 +40,7 @@ instance (Monoid e, Applicative u) => Applicative (UT ((,) e) u) where
instance (Monoid e, Applicative u, Monad u) => Monad (UT ((,) e) u) where
UT x >>= f = UT $ x >>= \(acc, v) -> (\(acc', y) -> (acc <> acc', y)) <$> run (f v)
-type Accumulated e t = Liftable (Writer e) t
+type Accumulated e t = Adaptable (Writer e) t
add :: Accumulated e t => e -> t ()
-add s = lift $ Writer (s, ())
+add s = adapt $ Writer (s, ())
diff --git a/Control/Joint/Schemes/TU.hs b/Control/Joint/Schemes/TU.hs
index 5ea4469..fdb0c67 100644
--- a/Control/Joint/Schemes/TU.hs
+++ b/Control/Joint/Schemes/TU.hs
@@ -1,4 +1,8 @@
-module Control.Joint.Schemes.TU (TU (..)) where
+module Control.Joint.Schemes.TU where
+
+import "comonad" Control.Comonad (Comonad (extract))
+import "comonad" Control.Comonad.Trans.Class (ComonadTrans (lower))
+import "transformers" Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Joint.Core (type (:.), type (:=))
import Control.Joint.Abilities (Interpreted (Primary, run))
@@ -8,3 +12,9 @@ newtype TU t u a = TU (t :. u := a)
instance Interpreted (TU t u) where
type Primary (TU t u) a = t :. u := a
run (TU x) = x
+
+instance Monad t => MonadTrans (TU t) where
+ lift = TU . return
+
+instance Comonad t => ComonadTrans (TU t) where
+ lower (TU x) = extract x
diff --git a/Control/Joint/Schemes/TUT.hs b/Control/Joint/Schemes/TUT.hs
index fdf2ab0..efabab3 100644
--- a/Control/Joint/Schemes/TUT.hs
+++ b/Control/Joint/Schemes/TUT.hs
@@ -1,11 +1,17 @@
-module Control.Joint.Schemes.TUT (TUT (..)) where
+module Control.Joint.Schemes.TUT where
+
+import "adjunctions" Data.Functor.Adjunction (Adjunction (leftAdjunct))
+import "distributive" Data.Distributive (Distributive (collect))
+import "transformers" Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Joint.Core (type (:.), type (:=))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
--- TODO: think about decomposing it on UT and TU
newtype TUT t t' u a = TUT (t :. u :. t' := a)
instance Interpreted (TUT t t' u) where
type Primary (TUT t t' u) a = t :. u :. t' := a
run (TUT x) = x
+
+instance (Adjunction t' t, Distributive t) => MonadTrans (TUT t t') where
+ lift = TUT . collect (leftAdjunct id)
diff --git a/Control/Joint/Schemes/UT.hs b/Control/Joint/Schemes/UT.hs
index 39f47a3..9727dab 100644
--- a/Control/Joint/Schemes/UT.hs
+++ b/Control/Joint/Schemes/UT.hs
@@ -1,4 +1,8 @@
-module Control.Joint.Schemes.UT (UT (..)) where
+module Control.Joint.Schemes.UT where
+
+import "comonad" Control.Comonad (Comonad (extract))
+import "comonad" Control.Comonad.Trans.Class (ComonadTrans (lower))
+import "transformers" Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Joint.Core (type (:.), type (:=))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
@@ -8,3 +12,9 @@ newtype UT t u a = UT (u :. t := a)
instance Interpreted (UT t u) where
type Primary (UT t u) a = u :. t := a
run (UT x) = x
+
+instance Monad t => MonadTrans (UT t) where
+ lift x = UT $ return <$> x
+
+instance Comonad t => ComonadTrans (UT t) where
+ lower (UT x) = extract <$> x
diff --git a/joint.cabal b/joint.cabal
index 62237c9..69b34cf 100644
--- a/joint.cabal
+++ b/joint.cabal
@@ -1,5 +1,5 @@
name: joint
-version: 0.1.7
+version: 0.1.8
synopsis: Trying to compose non-composable
homepage: https://github.com/iokasimov/joint
license: BSD3
@@ -22,8 +22,8 @@ library
Control.Joint.Abilities
Control.Joint.Abilities.Interpreted
Control.Joint.Abilities.Transformer
+ Control.Joint.Abilities.Completable
Control.Joint.Abilities.Adaptable
- Control.Joint.Abilities.Liftable
Control.Joint.Schemes
Control.Joint.Schemes.TU
Control.Joint.Schemes.UT
@@ -33,9 +33,10 @@ library
Control.Joint.Effects.Reader
Control.Joint.Effects.Writer
Control.Joint.Effects.State
+ Control.Joint.Effects.Store
Control.Joint.Effects.Maybe
Control.Joint.Effects.Either
- build-depends: base == 4.*, transformers
+ build-depends: base == 4.*, transformers, comonad, adjunctions, distributive
default-language: Haskell2010
ghc-options: -fno-warn-tabs
default-extensions:
@@ -46,6 +47,7 @@ library
FunctionalDependencies
LiberalTypeSynonyms
MultiParamTypeClasses
+ PackageImports
RankNTypes
TupleSections
TypeFamilies