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