Forking Freer Monads

FreerFork.hs

class Fork q where
  type RuntimeConstraint q x :: Constraint
  fork :: RuntimeConstraint q r => Eff (q ': r) a -> q (Eff r a)
  
data MyEffect a where
  ForkMyEffect :: Member IO r => Eff (MyEffect ': r) a -> MyEffect (Eff r a)
  Say :: MyEffect ()
 
instance Fork MyEffect where
  type RuntimeConstraint MyEffect x = Member IO x
  fork = send . ForkMyEffect
 
runMyEffect :: Member IO r => IORef String -> Eff (MyEffect ': r) a -> Eff r a
runMyEffect _ (Pure x) = x
runMyEffect s (Eff u q) = case u of
  Inject (ForkMyEffect e) -> runMyEffect s (runTCQ q (runMyEffect s e))
  Inject Say -> do
    send (readIORef s >>= putStrLn)
    runTCQ q ()
  Weaken otherEffects -> Eff otherEffects (Singleton (\x -> runMyEffect s (runTCQ q x)))