Skip to content

Instantly share code, notes, and snippets.

@takanuva
Last active March 21, 2018 22:03
Show Gist options
  • Save takanuva/a2f53494dc3b6d9f2742c23e7f15b544 to your computer and use it in GitHub Desktop.
Save takanuva/a2f53494dc3b6d9f2742c23e7f15b544 to your computer and use it in GitHub Desktop.
Test with Free monads
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment