Martin Pärtel

{-# LANGUAGE ExistentialQuantification #-}

-- This is taking a stab at mimicking the eff language in Haskell:
-- http://math.andrej.com/2010/09/27/programming-with-effects-ii-introducing-eff/

-- A definition of an "operation" takes a continuation (y -> r)
-- and gives a result a with it.
data Def y r a = Def ((y -> r) -> a)

-- We make a monadic DSL for defining operations.
instance Monad (Def y r) where
  -- An operation just returning x can ignore its continuation.
  return x = Def (\_ -> x)
  -- An operation d followed by a choice of operation b means
  -- d gets to look at the continuation k first and must return
  -- something that is used to choose the appropriate b,
  -- which gets to use the continuation next.
  (Def d) >>= b' = Def (\k ->
    let (Def b) = b' (d k)
    in b k)

-- "yield y" is an operation yielding the given value y to the continuation
-- and returning the result of the continuation directly.
yield :: y -> Def y r r
yield y = Def (\k -> k y)

-- Our "programs" can call the operations we've defined,
-- or they can just return a constant.
-- An operation invocation knows the op definition ((y -> r) -> a) and
-- knows how to build the continuation program for a yielded value y.
data Prog a = forall y r. ProgOp ((y -> r) -> a) (y -> Prog r)
             | ProgRet a

-- We evaluate a call to an operation by giving the operation
-- a continuation that, when yielded y, evaluates the continuation program
-- chosen by y.
evalProg :: Prog a -> a
evalProg (ProgOp f k) = f (\y -> (evalProg (k y)))
evalProg (ProgRet x) = x

-- Now we define the monadic DSL for defining programs that use the
-- operations defined with the above.
instance Monad Prog where
  return x = ProgRet x
  -- To sequence s and a choice of t, we do the following.
  -- We define an operation that, given a continuation k goes to evaluate the
  -- "first half" s and pass the result y to k.
  -- We arrange k to be such that it uses the y to choose t.
  s >>= t = ProgOp (\k -> k (evalProg s)) (\y -> t y)

-- A program consisting of just a call to an operation will just return the
-- result the operation yields it.
mkOp :: Def y y a -> Prog a
mkOp (Def d) = ProgOp d (\y -> ProgRet y)


-- Examples...

minChoose :: (Ord a) => a -> a -> Prog a
minChoose a b = mkOp $
  do l <- yield a
     r <- yield b
     return $ min l r

choiceExample =
  do x <- choose 3 2
     y <- choose 5 10
     return $ x + y
  where
    choose = minChoose

-- yay! ^_^

-- Problem: mkOp would force a type equation () = (String, a)
-- Well, they said they had problems coming up with a type system..
--printToLog :: String -> Prog (String, a)
printToLog msg = --mkOp $
  do (log, result) <- yield ()
     return (prepend msg log, result)
  where
    prepend msg "" = msg
    prepend msg log = msg ++ ", " ++ log

main =
  do print $ evalProg choiceExample