joint 0.1.1 → 0.1.2

raw patch · 12 files changed

+126/−40 lines, 12 files

Files

Control/Joint/Base/Either.hs +15/−5
Control/Joint/Base/Maybe.hs +15/−5
Control/Joint/Base/Reader.hs +18/−8
Control/Joint/Base/State.hs +52/−0
Control/Joint/Composition.hs +2/−2
Control/Joint/Schemes.hs +2/−1
Control/Joint/Schemes/TU.hs +2/−2
Control/Joint/Schemes/TUT.hs +10/−0
Control/Joint/Schemes/UT.hs +2/−2
Control/Joint/Schemes/UTU.hs +0/−10
Control/Joint/Transformer.hs +3/−3
joint.cabal +5/−2

Control/Joint/Base/Either.hs view

@@ -1,14 +1,24 @@ module Control.Joint.Base.Either where -import Control.Joint.Composition (Composition (Primary, unwrap))-import Control.Joint.Transformer (Transformer (Schema, lay, wrap))+import Control.Joint.Composition (Composition (Primary, run))+import Control.Joint.Transformer (Transformer (Schema, embed, build)) import Control.Joint.Schemes.UT (UT (UT)) +instance Functor u => Functor (UT (Either e) u) where+	fmap f (UT x) = UT $ (fmap . fmap) f x++instance Applicative u => Applicative (UT (Either e) u) where+	pure = UT . pure . pure+	UT f <*> UT x = UT $ (<*>) <$> f <*> x++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-	unwrap x = x+	run x = x  instance Transformer (Either e) where 	type Schema (Either e) u = UT (Either e) u-	lay x = UT $ Right <$> x-	wrap x = UT . pure $ x+	embed x = UT $ Right <$> x+	build x = UT . pure $ x

Control/Joint/Base/Maybe.hs view

@@ -1,14 +1,24 @@ module Control.Joint.Base.Maybe where -import Control.Joint.Composition (Composition (Primary, unwrap))-import Control.Joint.Transformer (Transformer (Schema, lay, wrap))+import Control.Joint.Composition (Composition (Primary, run))+import Control.Joint.Transformer (Transformer (Schema, embed, build)) import Control.Joint.Schemes.UT (UT (UT)) +instance Functor u => Functor (UT Maybe u) where+	fmap f (UT x) = UT $ (fmap . fmap) f x++instance Applicative u => Applicative (UT Maybe u) where+	pure = UT . pure . pure+	UT f <*> UT x = UT $ (<*>) <$> f <*> x++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-	unwrap x = x+	run x = x  instance Transformer Maybe where 	type Schema Maybe u = UT Maybe u-	lay x = UT $ Just <$> x-	wrap x = UT . pure $ x+	embed x = UT $ Just <$> x+	build x = UT . pure $ x

Control/Joint/Base/Reader.hs view

@@ -1,16 +1,26 @@ module Control.Joint.Base.Reader where -import Control.Joint.Composition (Composition (Primary, unwrap))-import Control.Joint.Transformer (Transformer (Schema, lay, wrap))+import Control.Joint.Composition (Composition (Primary, run))+import Control.Joint.Transformer (Transformer (Schema, embed, build)) import Control.Joint.Schemes.TU (TU (TU)) -newtype Reader r a = Reader (r -> a)+newtype Reader e a = Reader (e -> a) +instance Functor u => Functor (TU ((->) e) u) where+	fmap f (TU x) = TU $ \r -> f <$> x r+--+instance Applicative u => Applicative (TU ((->) e) u) where+	pure = TU . pure . pure+	TU f <*> TU x = TU $ \r -> f r <*> x r++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-	unwrap (Reader x) = x+	run (Reader x) = x -instance Transformer (Reader r) where-	type Schema (Reader r) u = TU ((->) r) u-	lay x = TU . const $ x-	wrap x = TU $ pure <$> unwrap 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

+ Control/Joint/Base/State.hs view

@@ -0,0 +1,52 @@+module Control.Joint.Base.State where++import Control.Joint.Core (type (:.), type (:=))+import Control.Joint.Composition (Composition (Primary, run))+import Control.Joint.Transformer (Transformer (Schema, embed, build))+import Control.Joint.Schemes.TUT (TUT (TUT))++newtype State s a = State ((->) s :. (,) s := a)++statefully :: s -> State s a -> (s, a)+statefully initial (State x) = x initial++instance Functor (State s) where+	fmap f (State x) = State $ \old -> f <$> x old++instance Applicative (State s) where+	pure x = State $ \s -> (s, x)+	State f <*> State x = State $ \old ->+		let latest = fst . x $ old in+			(latest, snd (f old) . snd . x $ old)++instance Monad (State s) where+	State x >>= f = State $ \old ->+		uncurry statefully $ f <$> x old++instance Composition (State s) where+	type Primary (State s) a = (->) s :. (,) s := a+	run (State x) = x++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++instance Functor u => Functor (TUT ((->) s) u ((,) s)) where+	fmap f (TUT x) = TUT $ \old -> (fmap . fmap) f $ x old++instance Monad u => Applicative (TUT ((->) s) u ((,) s)) where+	pure x = TUT $ \s -> pure (s, x)+	TUT f <*> TUT x = TUT $ \old -> f old >>= \(new, g) -> (fmap . fmap) g $ x new++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, ())

Control/Joint/Composition.hs view

@@ -1,6 +1,6 @@ module Control.Joint.Composition (Composition (..)) where  class Composition t where-	{-# MINIMAL unwrap #-}+	{-# MINIMAL run #-} 	type Primary t a :: *-	unwrap :: t a -> Primary t a+	run :: t a -> Primary t a

Control/Joint/Schemes.hs view

@@ -1,4 +1,5 @@ module Control.Joint.Schemes (module Exports) where -import Control.Joint.Schemes.UTU as Exports+import Control.Joint.Schemes.TUT as Exports+import Control.Joint.Schemes.UT as Exports import Control.Joint.Schemes.TU as Exports

Control/Joint/Schemes/TU.hs view

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

+ Control/Joint/Schemes/TUT.hs view

@@ -0,0 +1,10 @@+module Control.Joint.Schemes.TUT (TUT (..)) where++import Control.Joint.Core (type (:.), type (:=))+import Control.Joint.Composition (Composition (Primary, run))++newtype TUT t u t' a = TUT (t :. u :. t' := a)++instance Composition (TUT t u t') where+	type Primary (TUT t u t') a = t :. u :. t' := a+	run (TUT x) = x

Control/Joint/Schemes/UT.hs view

@@ -1,10 +1,10 @@ module Control.Joint.Schemes.UT (UT (..)) where  import Control.Joint.Core (type (:.), type (:=))-import Control.Joint.Composition (Composition (Primary, unwrap))+import Control.Joint.Composition (Composition (Primary, run))  newtype UT t u a = UT (u :. t := a)  instance Composition (UT t u) where 	type Primary (UT t u) a = u :. t := a-	unwrap (UT x) = x+	run (UT x) = x

− Control/Joint/Schemes/UTU.hs

@@ -1,10 +0,0 @@-module Control.Joint.Schemes.UTU (UTU (..)) where--import Control.Joint.Core (type (:.), type (:=))-import Control.Joint.Composition (Composition (Primary, unwrap))--newtype UTU t u a = UTU (u :. t u := a)--instance Composition (UTU t u) where-	type Primary (UTU t u) a = u :. t u := a-	unwrap (UTU x) = x

Control/Joint/Transformer.hs view

@@ -4,10 +4,10 @@ import Control.Joint.Composition (Composition)  class Composition t => Transformer t where-	{-# MINIMAL lay, wrap #-}+	{-# MINIMAL embed, build #-} 	type Schema (t :: * -> *) (u :: * -> *) = (r :: * -> *) | r -> t u-	lay :: Functor u => u ~> Schema t u-	wrap :: Applicative u => t ~> Schema t u+	embed :: Functor u => u ~> Schema t u+	build :: Applicative u => t ~> Schema t u  infixr 1 :> type (:>) t u a = Transformer t => Schema t u a

joint.cabal view

@@ -1,5 +1,5 @@ name:                joint-version:             0.1.1+version:             0.1.2 synopsis:            Trying to compose non-composable homepage:            https://github.com/iokasimov/joint license:             BSD3@@ -23,16 +23,19 @@     Control.Joint.Schemes     Control.Joint.Schemes.TU     Control.Joint.Schemes.UT-    Control.Joint.Schemes.UTU+    Control.Joint.Schemes.TUT     Control.Joint.Base.Maybe     Control.Joint.Base.Either     Control.Joint.Base.Reader+    Control.Joint.Base.State   build-depends: base == 4.*   default-language: Haskell2010   ghc-options: -fno-warn-tabs   default-extensions:+    FlexibleInstances     LiberalTypeSynonyms     RankNTypes+    TupleSections     TypeFamilies     TypeFamilyDependencies     TypeOperators