Stateful effects

examples/ExState.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+
+import Prelude hiding (id, (.))
+import Control.Arrow
+import Control.Category
+
+import Control.Kernmantle.Rope
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.State.Strict (StateT, execStateT)
+
+--------------------------------------------------------------------------------
+-- Effect definition
+
+data Add a b where
+  Add :: Add Int ()
+
+type a ~~> b = forall m. (MonadIO m) =>
+  AnyRopeWith '[ '("add", Add) ]
+              '[ArrowState Int, HasKleisli m] a b
+
+add :: Int ~~> ()
+add = strand #add Add
+
+getCounter :: () ~~> Int
+getCounter = getA @Int
+
+--------------------------------------------------------------------------------
+-- Pipeline definition
+
+pipeline :: () ~~> ()
+pipeline = proc () -> do
+  add -< 100
+  n <- getCounter -< ()
+  liftKleisliIO id -< putStrLn ("Total: " <> show n)
+
+  add -< 100
+  n <- getCounter -< ()
+  liftKleisliIO id -< putStrLn ("Total: " <> show n)
+
+--------------------------------------------------------------------------------
+-- Effect interpretation
+
+type CoreEff = Kleisli (StateT Int IO)
+
+interpretAdd :: Add a b -> CoreEff a b
+interpretAdd Add = proc n -> do
+  k <- getA @Int -< ()
+  putA @Int -< n + k
+
+main :: IO ()
+main = do
+  let Kleisli runPipeline =
+        pipeline
+          & loosen
+          & entwine_ #add interpretAdd
+          & untwine
+  n <- execStateT (runPipeline ()) 0
+  print n

package.yaml

@@ -25,6 +25,7 @@ dependencies:
 - profunctors >= 5.5.2 # Needed to have the whole set of Cayley instances
 - comonad
 - vinyl >= 0.11
+- mtl
 - transformers
 - safe-exceptions
 - store
@@ -79,3 +80,8 @@ executables:
       - unordered-containers
       - aeson
       - lens-aeson
+  exState:
+    main: examples/ExState.hs
+    dependencies:
+      - kernmantle
+      - mtl

src/Control/Kernmantle/Rope.hs

@@ -39,6 +39,7 @@ module Control.Kernmantle.Rope
   , SieveTrans (..), HasKleisli, HasMonadIO
   , type (:->)
   , (&)
+  , ArrowState (..)
 
   , tighten, loosen
   , entwine
@@ -96,6 +97,10 @@ newtype Rope (record::RopeRec) (mantle::[Strand]) (core::BinEff) a b =
            , Bifunctor, Biapplicative
            )
 
+instance (ArrowState s c) => ArrowState s (Rope r m c) where
+  stateA (Rope rnr) = Rope $ stateA rnr
+
+-- | Just to fix the right kind for the record
 runRope :: Rope record mantle core a b -> record (Weaver core) mantle -> core a b
 runRope (Rope (RopeRunner f)) = f
 {-# INLINE runRope #-}

src/Control/Kernmantle/Rope/Internal.hs

@@ -8,14 +8,22 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Control.Kernmantle.Rope.Internal where
 
 import Control.Category
 import Control.Arrow
 import Control.Monad.Trans.Reader
+import Control.Monad.State
 import Data.Profunctor hiding (rmap)
-import Data.Bifunctor
 import Data.Biapplicative
 import Data.Bifunctor.Tannen
 import Data.Functor.Identity
@@ -73,7 +81,7 @@ mapWeaverInterp f (Weaver w) = Weaver $ f . w
 -- effect. And then all these interpreted effects will run in a @core@ effect.
 newtype RopeRunner (record::RopeRec) (mantle::[Strand]) (interp::BinEff) (core::BinEff) a b =
   RopeRunner (record (Weaver interp) mantle -> core a b)
-  
+
   deriving ( Category
            , Arrow, ArrowChoice, ArrowLoop, ArrowZero, ArrowPlus
            , Profunctor, Strong, Choice, Closed, Costrong, Cochoice
@@ -84,7 +92,7 @@ newtype RopeRunner (record::RopeRec) (mantle::[Strand]) (interp::BinEff) (core::
   deriving (ProfunctorFunctor, ProfunctorMonad)
     via Cayley ((->) (record (Weaver interp) mantle))
 
-  deriving (Bifunctor, Biapplicative)
+  deriving (Bifunctor, Biapplicative, ArrowState s)
     via Tannen ((->) (record (Weaver interp) mantle)) core
   deriving (EffFunctor, EffPointedFunctor)
     via Tannen ((->) (record (Weaver interp) mantle))
@@ -144,3 +152,35 @@ unwrapSomeStrands :: (EffFunctor f, RMap (MapStrandEffs f mantle1))
 unwrapSomeStrands f g = unwrapRopeRunner . effdimap f g . splitRopeRunner
 {-# INLINE unwrapSomeStrands #-}
 
+--------------------------------------------------------------------------------
+-- State
+
+-- | A class for effects which can pass around a mutable state.
+class Arrow eff => ArrowState s eff where
+  {-# MINIMAL stateA | getA, putA #-}
+  stateA :: eff (a,s) (b,s) -> eff a b
+  stateA eff = proc a -> do
+    s <- getA @s -< ()
+    (b,s') <- eff -< (a,s)
+    putA @s -< s'
+    returnA -< b
+
+  getA :: eff () s
+  getA = stateA @s $ arr (\((),s) -> (s,s))
+
+  putA :: eff s ()
+  putA = stateA @s $ arr (\(_,s) -> ((),s))
+
+instance (Applicative f, ArrowState s eff) => ArrowState s (Tannen f eff) where
+  stateA (Tannen f) = Tannen $ stateA <$> f
+
+instance (MonadState s m) => ArrowState s (Kleisli m) where
+  stateA (Kleisli f) = Kleisli $ \a -> do
+    s <- get
+    (b,s') <- f (a,s)
+    put s'
+    return b
+
+  getA = Kleisli (const get)
+
+  putA = Kleisli put