Skip to content

Instantly share code, notes, and snippets.

@halcat0x15a
Last active May 16, 2019 11:45
Show Gist options
  • Save halcat0x15a/35322eedce4d94abd59ef99eed315bc3 to your computer and use it in GitHub Desktop.
Save halcat0x15a/35322eedce4d94abd59ef99eed315bc3 to your computer and use it in GitHub Desktop.
{-# 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
{-#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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment