Instances.hs

{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Control.Effect.Parallel.Instances where

import Control.Monad.Parallel
import Control.Effect.Lift
import Control.Effect.Pure
import Control.Effect.State
import Control.Effect.Trace
--import Control.Effect.NonDet

instance MonadParallel m => MonadParallel (LiftC m) where
  bindM2 f ma mb = LiftC (bindM2 f' (runLiftC ma) (runLiftC mb))
    where f' a b = runLiftC (f a b)

instance MonadParallel PureC
instance Monad m => MonadParallel (StateC s m)
deriving instance Monad m => MonadParallel (TraceByReturningC m)

-- instance MonadParallel (NonDetC m) ??

Thread.hs

{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, StandaloneDeriving, RankNTypes, TypeOperators, FlexibleInstances, TypeFamilies, UndecidableInstances, MultiParamTypeClasses, ScopedTypeVariables, GeneralizedNewtypeDeriving, LambdaCase, TypeApplications #-}

module Control.Effect.Thread
  ( module Control.Effect.Parallel.Instances
  , Thread (..)
  , yield
  , fork
  , CoroC (..)
  , runCoroC
  , schedule
  , example
  ) where

import Control.Effect
import Control.Effect.Sum
import Control.Effect.Carrier
import Control.Effect.State
import Control.Effect.Trace
import Control.Monad.IO.Class
import Control.Monad
import Control.Monad.Parallel ( MonadParallel(..) )
import Control.Effect.Parallel.Instances

data Thread m k
  = Yield k
  | forall x . Fork (m x) k

deriving instance Functor (Thread m)

instance HFunctor Thread where
  hmap _ (Yield k)    = Yield k
  hmap f (Fork act k) = Fork (f act) k

instance Effect Thread where
  handle state handler (Yield k) = Yield (handler . (<$ state) $ k)
  handle state handler (Fork act k) = Fork (handler (act <$ state)) (handler . (<$ state) $ k)

yield :: (Member Thread sig, Carrier sig m) => m ()
yield = send (Yield (pure ()))

fork :: (Member Thread sig, Carrier sig m) => m a -> m ()
fork act = send (Fork act (pure ()))

data Daemon (m :: * -> *) = forall x . Daemon (CoroC m x)

data CoroC (m :: * -> *) a
  = SYield (CoroC m a)
  | SFork (Daemon m) (CoroC m a)
  | SActive (m a)
    deriving Functor

runCoroC :: MonadParallel m => CoroC m a -> m a
runCoroC (SActive x) = x
runCoroC (SYield y) = runCoroC y
runCoroC (SFork (Daemon a) x) = bindM2 (const pure) (runCoroC a) (runCoroC x)

instance MonadParallel m => Applicative (CoroC m) where
  pure  = SActive . pure
  -- Possible optimization:
  SActive f <*> SActive a = SActive (bindM2 (\x y -> pure (x y)) f a)
  a <*> b = ap a b

instance MonadParallel m => Monad (CoroC m) where
  SActive v >>= f = SActive (v >>= runCoroC . f)
  SYield t  >>= f = SYield (t >>= f)
  SFork d t >>= f = SFork d (t >>= f)

instance (MonadParallel m, MonadIO m )=> MonadIO (CoroC m) where
  liftIO = SActive . liftIO

instance (MonadParallel m, Carrier sig m) => Carrier (Thread :+: sig) (CoroC m) where
  eff (L (Yield q))  = SYield q
  eff (L (Fork f q)) = SFork (Daemon f) q
  eff (R other)      = SActive (eff (handlePure runCoroC other))

example :: (Member Thread sig, Member Trace sig, Member (State Int) sig, Carrier sig m) => m ()
example = do
  modify @Int (+1)
  fork $ do
    trace "Forking"
    get @Int >>= trace . show
    modify @Int (+10) *> modify @Int (+100)
    get @Int >>= trace . show
  curr <- get @Int
  trace ("Main: " <> show curr)
  modify @Int (+1)