1{-# LANGUAGE RankNTypes #-} 2{-# LANGUAGE MultiParamTypeClasses #-} 3{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-# LANGUAGE GADTs #-} 6module PromptExamples where 7import Control.Monad.Prompt 8import Control.Monad.Cont (MonadCont(..)) 9import Control.Monad.State (MonadState(..)) 10import Control.Monad (MonadPlus(..)) 11import Control.Monad.ST (ST) 12import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef) 13import Data.IORef (IORef, newIORef, readIORef, writeIORef) 14 15-- Some standard monads implemented with Prompt: 16 17-- State 18data SP s a where 19 Get :: SP s s 20 Put :: s -> SP s () 21 22type PState s = Prompt (SP s) 23 24instance MonadState s (Prompt (SP s)) where 25 get = prompt Get 26 put = prompt . Put 27 28runPState :: forall r s. PState s r -> s -> (r, s) 29runPState = runPromptC ret prm 30 where 31 ret :: r -> s -> (r,s) 32 ret a s = (a, s) 33 34 prm :: forall a. SP s a -> (a -> s -> (r,s)) -> s -> (r,s) 35 prm Get k st = k st st 36 prm (Put st) k __ = k () st 37 38testS :: PState Int Int 39testS = do x <- get 40 put (x+1) 41 y <- get 42 return (y*2) 43 44-- StateT using PromptT 45type PStateT s = PromptT (SP s) 46 47instance MonadState s (PromptT (SP s) m) where 48 get = prompt $ Get 49 put = prompt . Put 50 51runPStateT :: forall m r s. Monad m => PStateT s m r -> s -> m (r, s) 52runPStateT = runPromptT ret prm lft 53 where 54 ret :: r -> s -> m (r,s) 55 ret r s = return (r,s) 56 57 prm :: forall a. SP s a -> (a -> s -> m (r,s)) -> s -> m (r,s) 58 prm Get k st = k st st 59 prm (Put st) k __ = k () st 60 61 lft :: forall a. m a -> (a -> s -> m (r,s)) -> s -> m (r,s) 62 lft m k st = m >>= \a -> k a st 63 64-- MonadPlus with observation functions for "Maybe a" and "[a]" 65data PP m a where 66 PZero :: PP m a 67 PPlus :: m a -> m a -> PP m a 68type PPlus = RecPrompt PP 69 70instance MonadPlus (RecPrompt PP) where 71 mzero = prompt PZero 72 mplus x y = prompt $ PPlus x y 73 74runPPlus :: forall r m. (MonadPlus m) => PPlus r -> m r 75runPPlus = runRecPromptM prm 76 where prm :: forall a. PP PPlus a -> m a 77 prm PZero = mzero 78 prm (PPlus x y) = runPPlus x `mplus` runPPlus y 79 80runPPlusL :: forall r. PPlus r -> [r] 81runPPlusL = runRecPromptC ret prm 82 where ret x = [x] 83 prm :: forall a. PP PPlus a -> (a -> [r]) -> [r] 84 prm PZero k = [] 85 prm (PPlus x y) k = concatMap k (runPPlusL x ++ runPPlusL y) 86 87runPPlusM :: forall r. PPlus r -> Maybe r 88runPPlusM = runRecPromptC ret prm 89 where 90 ret :: r -> Maybe r 91 ret = Just 92 prm :: forall a. PP PPlus a -> (a -> Maybe r) -> Maybe r 93 prm PZero _ = Nothing 94 prm (PPlus x y) k = case (runPPlusM x, runPPlusM y) of 95 (Just a, _) -> k a 96 (_, Just a) -> k a 97 _ -> Nothing 98 99testP :: PPlus Int 100testP = do x <- mplus (mplus (return 1) (return 2)) (mplus (return 3) (return 4)) 101 if x `div` 2 == 0 then mzero else return (x+5) 102 103-- References, with observation functions in ST and IO 104data PR ref a where 105 NewRef :: a -> PR ref (ref a) 106 ReadRef :: ref a -> PR ref a 107 WriteRef :: ref a -> a -> PR ref () 108type PRef a = forall ref. Prompt (PR ref) a 109 110runPRefST :: forall s r. PRef r -> ST s r 111runPRefST m = runPromptM interp m where 112 interp :: forall a. PR (STRef s) a -> ST s a 113 interp (NewRef a) = newSTRef a 114 interp (ReadRef r) = readSTRef r 115 interp (WriteRef r a) = writeSTRef r a 116 117runPRefIO :: forall r. PRef r -> IO r 118runPRefIO m = runPromptM interp m where 119 interp :: forall a. PR IORef a -> IO a 120 interp (NewRef a) = newIORef a 121 interp (ReadRef r) = readIORef r 122 interp (WriteRef r a) = writeIORef r a 123 124-- MonadCont 125-- 126-- Implementation idea taken from the Unimo paper. 127-- Is there a simpler way to do this? It seems like there 128-- should be, since we are representing the computation as 129-- a continuation already. 130data PromptCC r m a where 131 CallCC :: ((a -> m b) -> m a) -> PromptCC r m a 132 Apply :: r -> PromptCC r m a 133type CallCC r = RecPrompt (PromptCC r) 134 135instance MonadCont (RecPrompt (PromptCC r)) where 136 callCC = prompt . CallCC 137 138runContP :: forall ans r. CallCC ans r -> (r -> ans) -> ans 139runContP = runPromptC ret prm . unRecPrompt 140 where 141 ret :: r -> (r -> ans) -> ans 142 ret r f = f r 143 144 prm :: forall a. PromptCC ans (CallCC ans) a -> (a -> (r -> ans) -> ans) 145 -> (r -> ans) -> ans 146 prm (Apply r) _ _ = r 147 prm (CallCC f) k k2 = runContP (f cont) (\a -> k a k2) 148 where cont a = prompt $ Apply (k a k2) 149