Test with Free monads

Free.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
import Control.Monad
import Control.Monad.Trans.Free
import Control.Monad.Trans.Class

--------------------------------------------------
data StateF s a = State { unState :: s -> (s, a) }

instance Functor (StateF s) where
  fmap f (State g) =
    State $ \s -> let (x, y) = g s in
                  (x, f y)

type StateT s = FreeT (StateF s)

class Monad m => StateM s m | m -> s where
  get :: m s
  put :: s -> m ()

instance {-# OVERLAPPING #-} Monad m => StateM s (StateT s m) where
  get = liftF $ State $ \s -> (s, s)
  put s = liftF $ State $ \_ -> (s, ())

instance {-# OVERLAPPING #-} (Functor f, StateM s m) => StateM s (FreeT f m) where
  get = lift get
  put = lift . put

runStateT :: Monad m => StateT s m a -> s -> m a
runStateT x s = do
  y <- runFreeT x
  case y of
    Pure z ->
      return z
    Free (State f) ->
      let (z', s') = f s in
      runStateT s' z'
--------------------------------------------------

--------------------------------------------------
data AmbF a = Toss { unToss :: Bool -> a }

instance Functor AmbF where
  fmap f (Toss g) = Toss (f . g)

type AmbT = FreeT AmbF

class Monad m => AmbM m where
  amb :: m Bool

instance {-# OVERLAPPING #-} Monad m => AmbM (AmbT m) where
  amb = liftF $ Toss id

instance {-# OVERLAPPING #-} (Functor f, AmbM m) => AmbM (FreeT f m) where
  amb = lift amb

runAmbT :: Monad m => AmbT m a -> m [a]
runAmbT x = do
  y <- runFreeT x
  case y of
    Pure z ->
      return [z]
    Free (Toss z) ->
      liftM2 (++) (runAmbT (z False)) (runAmbT (z True))
--------------------------------------------------

{- Koka:
fun xor() : amb bool {
  val p = flip()
  val q = flip()
  (p||q) && not(p&&q)
}
-}

xor :: AmbM m => m Bool
xor = do
  p <- amb
  q <- amb
  return $ (p || q) && not (p && q)

{- Koka:
fun foo() : <amb,state<int>> bool {
  val p = flip() 
  val i = get()
  set(i+1)
  if (i>0 && p) then xor() else False
}
-}

foo :: (StateM Int m, AmbM m) => m Bool
foo = do
  p <- amb
  i <- get
  put (i + 1)
  if i > 0 && p then xor else return False

main = do
  -- I had to annotate, but... I can run those! :D
  res1 <- runAmbT (runStateT foo 0)
  res2 <- runStateT (runAmbT foo) 0
  print res1
  print res2