EffAp.hs

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}

module EffAp where

import Control.Concurrent
import Control.Concurrent.Async
import OpenUnion
import Exc

data EffAp r a where
  Pure :: a -> EffAp r a
  ImpureAp :: Union r a -> EffAp r (a -> b) -> EffAp r b

instance Functor (EffAp f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (ImpureAp fa k) = ImpureAp fa (fmap (\g -> f . g) k)

instance Applicative (EffAp f) where
  pure = Pure
  Pure f <*> y = fmap f y
  ImpureAp x y <*> z = ImpureAp x (flip <$> y <*> z)

success :: a -> EffAp r a
success a = Pure a

failure :: Member (Exc e) r => e -> EffAp r a
failure e = ImpureAp (inj $ Exc e) (Pure id)

runExc :: EffAp (Exc e : r) a -> EffAp r (Either [e] a)
runExc (Pure a) = Pure $ Right a
runExc (ImpureAp u k) =
  case decomp u of
    Right (Exc e) -> fmap f (runExc k) where
      f (Right _) = Left [e]
      f (Left es) = Left (e : es)
    Left u -> ImpureAp u $ fmap f (runExc k) where
      f e a = fmap (\k -> k a) e

runAsync :: EffAp '[IO] a -> IO a
runAsync (Pure a) = pure a
runAsync (ImpureAp u k) =
  do
    let Right x = decomp u
    a <- async x
    k' <- runAsync k
    x' <- wait a
    return $ k' x'

delay1s :: Member IO r => EffAp r ()
delay1s = ImpureAp (inj x) (Pure id)
  where
    x = do
      putStrLn "start"
      threadDelay 1000000
      putStrLn "end"

e1 :: (Member (Exc String) r, Member IO r) => EffAp r Integer
e1 = (+) <$> (delay1s *> (success 1)) <*> ((success 2) <* delay1s)

e2 :: (Member (Exc String) r, Member IO r) => EffAp r Integer
e2 = (+) <$> (delay1s *> (failure "foo")) <*> ((failure "bar") <* delay1s)

r1 :: IO (Either [String] Integer)
r1 = runAsync $ runExc e1

r2 :: IO (Either [String] Integer)
r2 = runAsync $ runExc e2

exteffap.hs

{-#LANGUAGE GADTs #-}

class Functor f => Applicative f where
  pure :: a -> f a
  (<*>) :: f (a -> b) -> f a -> f b

class Applicative m => Monad m where
    return :: a -> m a
    (>>=) :: m a -> (a -> m b) -> m b

applicativeStyle = f <$> ma <*> mb

monadicStyle = do
  a <- ma
  b <- mb
  return $ f a b

import Control.Concurrent
import Control.Concurrent.Async
import Exc

data FreeAp f a where
  Pure :: a -> FreeAp f a
  ImpureAp :: f a -> FreeAp f (a -> b) -> FreeAp f b

instance Functor (FreeAp f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (ImpureAp fa k) = ImpureAp fa (fmap (\g -> f . g) k)

instance Applicative (FreeAp f) where
  pure = Pure
  Pure f <*> y = fmap f y
  ImpureAp x y <*> z = ImpureAp x (flip <$> y <*> z)

newtype Exc e a = Exc e

success :: a -> FreeAp (Exc e) a
success a = Pure a

failure :: e -> FreeAp (Exc e) a
failure e = ImpureAp (Exc e) (Pure id)

runExc :: FreeAp (Exc e) a -> Either [e] a
runExc (Pure a) = Right a
runExc (ImpureAp (Exc e) k) =
  case runExc k of
    Right _ -> Left [e]
    Left es -> Left (e : es)

runAsync :: FreeAp IO a -> IO a
runAsync (Pure a) = pure a
runAsync (ImpureAp x k) =
  do
    a <- async x
    k' <- runAsync k
    x' <- wait a
    return $ k' x'

delay1s :: FreeAp IO ()
delay1s = ImpureAp x (Pure id)
  where
    x = do
      putStrLn "start"
      threadDelay 1000000
      putStrLn "end"

e1 :: Either String Integer
e1 = (+) <$> (Right 1) <*> (Right 2)

e2 :: Either String Integer
e2 = (+) <$> (Right 1) <*> (Left "hoge")

e3 :: FreeAp (Exc String) Integer
e3 = (+) <$> (success 1) <*> (success 2)

e4 :: FreeAp (Exc String) Integer
e4 = (+) <$> (success 1) <*> (failure "hoge")

e5 :: FreeAp (Exc String) Integer
e5 = ImpureAp (Exc "foo") $ ImpureAp (Exc "bar") $ Pure (+)

data Freer f a where
  Pure :: a -> Freer f a
  Impure :: f a -> (a -> Freer f b) -> Freer f b

e6 :: Freer (Exc String) Integer
e6 = Impure (Exc "foo") $ \a -> Impure (Exc "bar") $ \b -> Pure (a + b)

e7 :: FreeAp IO ()
e7 = delay1s *> delay1s

main :: IO ()
main =
  do
    print e1
    print e2
    print $ runExc e3
    print $ runExc e4
    print $ runExc e5
    runAsync e7