joint 0.1.4 → 0.1.5

raw patch · 14 files changed

+252/−144 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Control/Joint/Abilities.hs +1/−1
• Control/Joint/Abilities/Adaptable.hs +6/−0
• Control/Joint/Abilities/Liftable.hs +127/−51
• Control/Joint/Abilities/Modulator.hs +0/−7
• Control/Joint/Abilities/Transformer.hs +8/−8
• Control/Joint/Effects.hs +2/−1
• Control/Joint/Effects/Either.hs +15/−15
• Control/Joint/Effects/Maybe.hs +15/−15
• Control/Joint/Effects/Reader.hs +15/−25
• Control/Joint/Effects/State.hs +11/−16
• Control/Joint/Effects/Writer.hs +44/−0
• Control/Joint/Schemes/TU.hs +1/−1
• Control/Joint/Schemes/TUT.hs +1/−0
• joint.cabal +6/−4

@@ -1,6 +1,6 @@ module Control.Joint.Abilities (module Exports) where  import Control.Joint.Abilities.Liftable as Exports-import Control.Joint.Abilities.Modulator as Exports+import Control.Joint.Abilities.Adaptable as Exports import Control.Joint.Abilities.Transformer as Exports import Control.Joint.Abilities.Composition as Exports

@@ -0,0 +1,6 @@+module Control.Joint.Abilities.Adaptable where++import Control.Joint.Core (type (~>))++class Adaptable (subeff :: * -> *) (eff :: * -> *) | subeff -> eff where+	adapt :: subeff ~> eff

@@ -1,67 +1,143 @@ module Control.Joint.Abilities.Liftable where -import Control.Joint.Abilities.Transformer (Transformer (Schema, build, embed), (:>) (T))+import Control.Joint.Core (type (~>))+import Control.Joint.Abilities.Composition (Composition (run))+import Control.Joint.Abilities.Transformer (Transformer (Schema, build, embed), (:>) (T, trans))  class Liftable (eff :: * -> *) (schema :: * -> *) where-	lift :: eff a -> schema a+	{-# MINIMAL lift #-}+	lift :: eff ~> schema -instance (Functor u, Transformer t) => Liftable u (t :> u) where-	lift = T . embed+type Embedding t u = (Transformer t, Functor u)+type Building t u = (Transformer t, Applicative u) -instance (Applicative u, Transformer t) => Liftable t (t :> u) where-	lift = T . build+instance Embedding t u => Liftable u (t :> u) where+	lift = embed -instance (Functor (Schema u v), Applicative v, Transformer u, Transformer t)-	=> Liftable u (t :> u :> v) where-	lift = T . embed . T . build+instance Building t u => Liftable t (t :> u) where+	lift = build -instance (Functor (Schema u v), Functor v, Transformer u, Transformer t)-	=> Liftable v (t :> u :> v) where-	lift = T . embed . T . embed+instance+	( Embedding t (Schema u v)+	, Building u v+	) => Liftable u (t :> u :> v) where+	lift = embed . build -instance (Functor (Schema u v), Functor (Schema v w), Functor (Schema u (v :> w))-	, Applicative v, Applicative w, Transformer u, Transformer t, Transformer v)-		=> Liftable v (t :> u :> v :> w) where-	lift = T . embed . T . embed . T . build+instance+	( Embedding t (Schema u v)+	, Embedding u v+	) => Liftable v (t :> u :> v) where+	lift = embed . embed -instance (Functor (Schema u v), Functor (Schema v w), Functor (Schema u (v :> w))-	, Applicative v, Functor w, Transformer t, Transformer u, Transformer v)-		=> Liftable w (t :> u :> v :> w) where-	lift = T . embed . T . embed . T . 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 (Functor (Schema u (v :> w :> x)), Functor (Schema v (w :> x)), Functor (Schema w x)-	, Functor x, Transformer t, Transformer u, Transformer v, Transformer w)-		=> Liftable x (t :> u :> v :> w :> x) where-	lift = T . embed . T . embed . T . embed . T . embed+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 (Functor (Schema u (v :> w :> x)), Functor (Schema v (w :> x)), Functor (Schema w x)-	, Applicative x, Transformer t, Transformer u, Transformer v, Transformer w)-		=> Liftable w (t :> u :> v :> w :> x) where-	lift = T . embed . T . embed . T . embed . T . build+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 (Functor (Schema u (v :> w :> x)), Functor (Schema v (w :> x)), Functor (Schema w x), Functor (Schema x y)-	, Functor (Schema w (x :> y)), Functor (Schema v (w :> x :> y)), Functor (Schema u (v :> w :> x :> y))-		, Functor y, Transformer t, Transformer u, Transformer v, Transformer w, Transformer x)-			=> Liftable y (t :> u :> v :> w :> x :> y) where-	lift = T . embed . T . embed . T . embed . T . embed . T . 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 (Functor (Schema u (v :> w :> x)), Functor (Schema v (w :> x)), Functor (Schema w x)-	, Functor (Schema x y), Functor (Schema w (x :> y)), Functor (Schema v (w :> x :> y))-		, Functor (Schema u (v :> w :> x :> y)), Functor y-		, Applicative y, Transformer t, Transformer u, Transformer v, Transformer w, Transformer x)-			=> Liftable x (t :> u :> v :> w :> x :> y) where-	lift = T . embed . T . embed . T . embed . T . embed . T . 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 (Functor (Schema u (v :> w :> x :> y :> z)), Functor (Schema v (w :> x :> y :> z))-	, Functor (Schema w (x :> y :> z)), Functor (Schema x (y :> z)), Functor (Schema y z)-		, Functor z, Transformer t, Transformer u, Transformer v-			, Transformer w, Transformer x, Transformer z, Transformer y)-				=> Liftable z (t :> u :> v :> w :> x :> y :> z) where-	lift = T . embed . T . embed . T . embed . T . embed . T . embed . T . 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 (Functor (Schema u (v :> w :> x :> y :> z)), Functor (Schema v (w :> x :> y :> z))-	, Functor (Schema w (x :> y :> z)), Functor (Schema x (y :> z)), Functor (Schema y z)-		, Applicative z, Transformer t, Transformer u, Transformer v-			, Transformer w, Transformer x, Transformer z, Transformer y)-				=> Liftable y (t :> u :> v :> w :> x :> y :> z) where-	lift = T . embed . T . embed . T . embed . T . embed . T . embed . T . 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

@@ -1,7 +0,0 @@-module Control.Joint.Abilities.Modulator where--import Control.Joint.Abilities.Transformer (Transformer (Schema))--class Transformer t => Modulator t where-	{-# MINIMAL (-<$>-) #-}-	(-<$>-) :: (u a -> v b) -> Schema t u a -> Schema t v b

@@ -6,16 +6,12 @@ class Composition t => Transformer t where 	{-# MINIMAL embed, build, unite #-} 	type Schema (t :: * -> *) (u :: * -> *) = (r :: * -> *) | r -> t u-	embed :: Functor u => u ~> Schema t u-	build :: Applicative u => t ~> Schema t u-	unite :: Primary (Schema t u) a -> Schema t u a+	embed :: Functor u => u ~> t :> u+	build :: Applicative u => t ~> t :> u+	unite :: Primary (Schema t u) a -> (t :> u) a  infixr 0 :>-newtype (:>) t u a = T { trans :: Transformer t => (Schema t u a) }--instance (Composition (Schema t u), Transformer t) => Composition (t :> u) where-	type Primary (t :> u) a = Primary (Schema t u) a-	run (T x) = run x+newtype (:>) t u a = T { trans :: Transformer t => Schema t u a }  instance Functor (Schema t u) => Functor (t :> u) where 	fmap f (T x) = T $ f <$> x@@ -26,3 +22,7 @@  instance (Transformer t, Monad (Schema t u)) => Monad (t :> u) where 	T x >>= f = T $ x >>= trans . f++instance (Composition (Schema t u), Transformer t) => Composition (t :> u) where+	type Primary (t :> u) a = Primary (Schema t u) a+	run (T x) = run x

@@ -1,6 +1,7 @@ module Control.Joint.Effects (module Exports) where -import Control.Joint.Effects.State as Exports import Control.Joint.Effects.Maybe as Exports import Control.Joint.Effects.Either as Exports+import Control.Joint.Effects.State as Exports+import Control.Joint.Effects.Writer as Exports import Control.Joint.Effects.Reader as Exports

@@ -1,12 +1,19 @@ module Control.Joint.Effects.Either where -import Control.Joint.Abilities.Composition (Composition (Primary, run))-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite))-import Control.Joint.Abilities.Liftable (Liftable (lift))-import Control.Joint.Schemes.TU (TU (TU))-import Control.Joint.Schemes.TUT (TUT (TUT))-import Control.Joint.Schemes.UT (UT (UT))+import Control.Joint.Abilities (Composition (Primary, run)+	, Transformer (Schema, embed, build, unite), (:>) (T), Liftable)+import Control.Joint.Schemes (UT (UT)) +instance Composition (Either e) where+	type Primary (Either e) a = Either e a+	run x = x++instance Transformer (Either e) where+	type Schema (Either e) u = UT (Either e) u+	embed x = T . UT $ Right <$> x+	build x = T . UT . pure $ x+	unite = T . UT+ instance Functor u => Functor (UT (Either e) u) where 	fmap f (UT x) = UT $ (fmap . fmap) f x @@ -17,14 +24,7 @@ instance (Applicative u, Monad u) => Monad (UT (Either e) u) where 	UT x >>= f = UT $ x >>= either (pure . Left) (run . f) -instance Composition (Either e) where-	type Primary (Either e) a = Either e a-	run x = x--instance Transformer (Either e) where-	type Schema (Either e) u = UT (Either e) u-	embed x = UT $ Right <$> x-	build x = UT . pure $ x-	unite = UT+failure :: e -> Either e a+failure = Left  type Failable e = Liftable (Either e)

@@ -1,12 +1,19 @@ module Control.Joint.Effects.Maybe where -import Control.Joint.Abilities.Composition (Composition (Primary, run))-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite))-import Control.Joint.Abilities.Liftable (Liftable (lift))-import Control.Joint.Schemes.TU (TU (TU))-import Control.Joint.Schemes.TUT (TUT (TUT))-import Control.Joint.Schemes.UT (UT (UT))+import Control.Joint.Abilities (Composition (Primary, run)+	, Transformer (Schema, embed, build, unite), (:>) (T), Adaptable (adapt), Liftable)+import Control.Joint.Schemes (UT (UT)) +instance Composition Maybe where+	type Primary Maybe a = Maybe a+	run x = x++instance Transformer Maybe where+	type Schema Maybe u = UT Maybe u+	embed x = T . UT $ Just <$> x+	build x = T . UT . pure $ x+	unite = T . UT+ instance Functor u => Functor (UT Maybe u) where 	fmap f (UT x) = UT $ (fmap . fmap) f x @@ -17,14 +24,7 @@ instance (Applicative u, Monad u) => Monad (UT Maybe u) where 	UT x >>= f = UT $ x >>= maybe (pure Nothing) (run . f) -instance Composition Maybe where-	type Primary Maybe a = Maybe a-	run x = x--instance Transformer Maybe where-	type Schema Maybe u = UT Maybe u-	embed x = UT $ Just <$> x-	build x = UT . pure $ x-	unite = UT+instance Adaptable (Either e) Maybe where+	adapt = either (const Nothing) Just  type Optional = Liftable Maybe

@@ -1,12 +1,8 @@ module Control.Joint.Effects.Reader where -import Control.Joint.Abilities.Composition (Composition (Primary, run))-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite))-import Control.Joint.Abilities.Modulator (Modulator ((-<$>-)))-import Control.Joint.Abilities.Liftable (Liftable (lift))-import Control.Joint.Schemes.TU (TU (TU))-import Control.Joint.Schemes.TUT (TUT (TUT))-import Control.Joint.Schemes.UT (UT (UT))+import Control.Joint.Abilities (Composition (Primary, run)+	, Transformer (Schema, embed, build, unite), (:>) (T), Liftable)+import Control.Joint.Schemes (TU (TU))  newtype Reader e a = Reader (e -> a) @@ -20,6 +16,16 @@ instance Monad (Reader e) where 	Reader g >>= f = Reader $ \e -> run (f (g e)) e +instance Composition (Reader e) where+	type Primary (Reader e) a = (->) e a+	run (Reader x) = x++instance Transformer (Reader e) where+	type Schema (Reader e) u = TU ((->) e) u+	embed x = T . TU . const $ x+	build x = T. TU $ pure <$> run x+	unite = T . TU+ instance Functor u => Functor (TU ((->) e) u) where 	fmap f (TU x) = TU $ \r -> f <$> x r @@ -30,23 +36,7 @@ instance (Applicative u, Monad u) => Monad (TU ((->) e) u) where 	TU x >>= f = TU $ \e -> x e >>= ($ e) . run . f -instance Composition (Reader e) where-	type Primary (Reader e) a = (->) e a-	run (Reader x) = x--instance Transformer (Reader e) where-	type Schema (Reader e) u = TU ((->) e) u-	embed x = TU . const $ x-	build x = TU $ pure <$> run x-	unite = TU--instance Modulator (Reader e) where-	f -<$>- (TU x) = TU $ f <$> x--ask :: Reader e e-ask = Reader $ \e -> e--instance Liftable (Reader e) ((->) e) where-	lift = run+get :: Reader e e+get = Reader $ \e -> e  type Configured e = Liftable (Reader e)

@@ -1,13 +1,11 @@ module Control.Joint.Effects.State where  import Control.Joint.Core (type (:.), type (:=))-import Control.Joint.Abilities.Composition (Composition (Primary, run))-import Control.Joint.Abilities.Transformer (Transformer (Schema, embed, build, unite))-import Control.Joint.Abilities.Liftable (Liftable (lift))-import Control.Joint.Schemes.TU (TU (TU))-import Control.Joint.Schemes.TUT (TUT (TUT))-import Control.Joint.Schemes.UT (UT (UT))+import Control.Joint.Abilities (Composition (Primary, run)+	, Transformer (Schema, embed, build, unite), (:>) (T), Adaptable (adapt), Liftable)+import Control.Joint.Schemes (TUT (TUT)) import Control.Joint.Effects.Reader (Reader (Reader))+import Control.Joint.Effects.Writer (Writer (Writer))  newtype State s a = State ((->) s :. (,) s := a) @@ -33,9 +31,9 @@  instance Transformer (State s) where 	type Schema (State s) u = TUT ((->) s) u ((,) s)-	embed x = TUT $ \s -> (s,) <$> x-	build x = TUT $ pure <$> run x-	unite = TUT+	embed x = T . TUT $ \s -> (s,) <$> x+	build x = T . TUT $ pure <$> run x+	unite = T . TUT  instance Functor u => Functor (TUT ((->) s) u ((,) s)) where 	fmap f (TUT x) = TUT $ \old -> (fmap . fmap) f $ x old@@ -47,16 +45,13 @@ instance Monad u => Monad (TUT ((->) s) u ((,) s)) where 	TUT x >>= f = TUT $ \old -> x old >>= \(new, y) -> ($ new) . run . f $ y -get :: State s s-get = State $ \s -> (s, s)- modify :: (s -> s) -> State s () modify f = State $ \s -> (f s, ()) -put :: s -> State s ()-put s = State $ \_ -> (s, ())+instance Adaptable (Reader e) (State e) where+	adapt (Reader f) = State (\e -> (e, f e)) -instance Liftable (Reader e) (State e) where-	lift (Reader f) = State (\e -> (e, f e))+instance Adaptable (Writer e) (State e) where+	adapt (Writer (e, x)) = State (\e -> (e, x))  type Stateful e = Liftable (State e)

@@ -0,0 +1,44 @@+module Control.Joint.Effects.Writer where++import Control.Joint.Abilities (Composition (Primary, run)+	, Transformer (Schema, embed, build, unite), (:>) (T), Liftable)+import Control.Joint.Schemes (UT (UT))++newtype Writer e a = Writer (e, a)++instance Functor (Writer e) where+	fmap f (Writer x) = Writer $ f <$> x++instance Monoid e => Applicative (Writer e) where+	pure = Writer . (,) mempty+	f <*> v = Writer $ k (run f) (run v) where+		k ~(e, a) ~(e', b) = (e <> e', a b)++instance Monoid e => Monad (Writer e) where+	Writer (e, x) >>= f = let (e', b) = run $ f x in+		Writer (e <> e', b)++instance Composition (Writer e) where+	type Primary (Writer e) a = (e, a)+	run (Writer x) = x++instance Monoid e => Transformer (Writer e) where+	type Schema (Writer e) u = UT ((,) e) u+	embed x = T . UT $ (,) mempty <$> x+	build = T . UT . pure . run+	unite = T . UT++instance Functor u => Functor (UT ((,) e) u) where+	fmap f (UT x) = UT $ (fmap . fmap) f x++instance (Monoid e, Applicative u) => Applicative (UT ((,) e) u) where+	pure = UT . pure . pure+	UT f <*> UT x = UT $ (<*>) <$> f <*> x++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)++put :: e -> Writer e ()+put s = Writer (s, ())++type Accumulated e t = Liftable (Writer e) t

@@ -1,7 +1,7 @@ module Control.Joint.Schemes.TU (TU (..)) where  import Control.Joint.Core (type (:.), type (:=))-import Control.Joint.Abilities.Composition (Composition (Primary, run))+import Control.Joint.Abilities (Composition (Primary, run))  newtype TU t u a = TU (t :. u := a) 

@@ -3,6 +3,7 @@ import Control.Joint.Core (type (:.), type (:=)) import Control.Joint.Abilities.Composition (Composition (Primary, run)) +-- TODO: think about decomposing it on UT and TU newtype TUT t u t' a = TUT (t :. u :. t' := a)  instance Composition (TUT t u t') where

@@ -1,5 +1,5 @@ name:                joint-version:             0.1.4+version:             0.1.5 synopsis:            Trying to compose non-composable homepage:            https://github.com/iokasimov/joint license:             BSD3@@ -21,17 +21,18 @@     Control.Joint.Abilities     Control.Joint.Abilities.Composition     Control.Joint.Abilities.Transformer-    Control.Joint.Abilities.Modulator+    Control.Joint.Abilities.Adaptable     Control.Joint.Abilities.Liftable     Control.Joint.Schemes     Control.Joint.Schemes.TU     Control.Joint.Schemes.UT     Control.Joint.Schemes.TUT     Control.Joint.Effects+    Control.Joint.Effects.Reader+    Control.Joint.Effects.Writer+    Control.Joint.Effects.State     Control.Joint.Effects.Maybe     Control.Joint.Effects.Either-    Control.Joint.Effects.State-    Control.Joint.Effects.Reader   build-depends: base == 4.*   default-language: Haskell2010   ghc-options: -fno-warn-tabs@@ -40,6 +41,7 @@     ExistentialQuantification     FlexibleContexts     FlexibleInstances+    FunctionalDependencies     LiberalTypeSynonyms     MultiParamTypeClasses     RankNTypes