WIP arrows

src/Control/Effect.hs

@@ -1,14 +1,12 @@
 {-# LANGUAGE KindSignatures, TypeFamilies, ConstraintKinds, PolyKinds, MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
 
-module Control.Effect where 
+module Control.Effect where
 
 import Prelude hiding (Monad(..))
-import GHC.Exts ( Constraint )    
-
-{-| Specifies "parametric effect monads" which are essentially monads but
-     annotated by a type-level monoid formed by 'Plus' and 'Unit' -}
-class Effect (m :: k -> * -> *) where
+import GHC.Exts ( Constraint )
 
+class EffectKind m k | m -> k where
    {-| Effect of a trivially effectful computation |-}
    type Unit m :: k
    {-| Cominbing effects of two subcomputations |-}
@@ -18,21 +16,25 @@ class Effect (m :: k -> * -> *) where
    type Inv m (f :: k) (g :: k) :: Constraint
    type Inv m f g = ()
 
-   {-| Effect-parameterised version of 'return'. Annotated with the 'Unit m' effect, 
+{-| Specifies "parametric effect monads" which are essentially monads but
+     annotated by a type-level monoid formed by 'Plus' and 'Unit' -}
+class EffectKind m k => Effect (m :: k -> * -> *) where
+
+
+   {-| Effect-parameterised version of 'return'. Annotated with the 'Unit m' effect,
     denoting pure compuation -}
    return :: a -> m (Unit m) a
 
-   {-| Effect-parameterise version of '>>=' (bind). Combines 
+   {-| Effect-parameterise version of '>>=' (bind). Combines
     two effect annotations 'f' and 'g' on its parameter computations into 'Plus' -}
 
    (>>=) :: (Inv m f g) => m f a -> (a -> m g b) -> m (Plus m f g) b
 
    (>>) :: (Inv m f g) => m f a -> m g b -> m (Plus m f g) b
    x >> y = x >>= (\_ -> y)
-  
+
 fail = undefined
 
 {-| Specifies subeffecting behaviour -}
 class Subeffect (m :: k -> * -> *) f g where
     sub :: m f a -> m g a
-

src/Control/Effect/Arrow.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- This shouldn't be needed since I have functional dependencies
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Control.Effect.Arrow where
+
+import GHC.Exts ( Constraint )
+
+import Control.Effect
+import qualified Control.Effect as E
+
+newtype Kleisli m f a b = Kleisli { runKleisli :: a -> m f b }
+
+class E.EffectKind cat k => CategoryEffect (cat :: k -> * -> * -> *) where
+  id :: cat (Unit cat) a a
+  (>>>) :: Inv cat f g => cat f a b -> cat g b c -> cat (Plus cat f g) a c
+
+class CategoryEffect a => ArrowEffect (a :: k -> * -> * -> *) where
+  arr :: (b -> c) -> a (Unit a) b c
+  first :: a f b c -> a f (b, d) (c, d)
+
+instance EffectKind m k => EffectKind (Kleisli m) k where
+  type Unit (Kleisli m) = Unit m
+  type Plus (Kleisli m) f g = Plus m f g
+  type Inv (Kleisli m) f g = Inv m f g
+
+
+instance (EffectKind m k, Effect m) => CategoryEffect (Kleisli m) where
+  id = Kleisli E.return
+  Kleisli f >>> Kleisli g = Kleisli $ \a -> f a E.>>= g