gistfile1.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
module Main where

----------
-- Eff

newtype Eff r a = Eff { runEff :: forall w. (a -> VE w r) -> VE w r}
instance Monad (Eff r) where
  --return :: a -> Eff a
  return x = Eff $ \k -> k x
  --(>>=) :: Eff a -> (a -> Eff b) -> Eff b
  m >>= f = Eff $ \k -> let
    -- :: a -> VE w
    f0 v = runEff (f v) k
    in runEff m f0

-- Value-Effect
data VE w r = Val w | E (r (VE w r))

send :: (forall w. (a -> VE w r) -> r (VE w r)) -> Eff r a
send f = Eff $ \k -> E (f k)

admin :: Eff r w -> VE w r
admin (Eff m ) = m Val

----------
-- Void

data Void v

run :: Eff Void w -> w
run m = case admin m of Val x -> x

testVoid :: Eff Void Int
testVoid = do
  x <- return 10
  y <- return 20
  return $ x + y

----------
-- Reader

newtype Reader e v = Reader (e -> v)

ask :: Eff (Reader e) e
ask = send Reader

runReader :: Eff (Reader e) w -> e -> Eff Void w
runReader m e = loop $ admin m
  where
    loop (Val x)        = return x
    loop (E (Reader k)) = loop $ k e

testReader :: Int -> String
testReader x = run $ runReader testReader' x

testReader' :: Eff (Reader Int) String
testReader' = do
  x <- ask
  return $ show (x * 2)

----------
-- Choose

data Choose v = forall w e. Choose [w] (w -> v)

choose :: [w] -> Eff Choose w
choose xs = send $ Choose xs

runChoose :: Eff Choose w -> Eff Void [w]
runChoose m = return . loop $ admin m
  where
    loop (Val w) = [w]
    loop (E (Choose xs f)) = concatMap (loop . f) $ xs

testChoose :: [(Int, String)]
testChoose = run $ runChoose testChoose'

testChoose' :: Eff Choose (Int, String)
testChoose' = do
  x <- choose [1,2,3]
  y <- choose ["Hoge","Piyo","Huga"]
  return (x, y)