[project @ 2003-06-04 14:52:09 by ralf]
[packages/old-time.git] / Control / Monad / X / NondetT.hs
1 module Control.Monad.X.NondetT
2 (NondetT,
3 runNondet,
4 runNondets,
5 mapNondetT,
6 MonadPlus(..),
7 module T
8 ) where
9
10 import Prelude
11 import Monad(liftM,MonadPlus(..))
12
13 import Control.Monad.X.Trans as T
14 import Control.Monad.X.Utils
15 import Control.Monad.X.Types(NondetT(..),T(..))
16
17
18 instance MonadTrans NondetT where
19 lift m = N (liftM single m)
20
21 instance Monad m => Functor (NondetT m) where
22 fmap = liftM
23
24 instance Monad m => Monad (NondetT m) where
25 return = return'
26 m >>= f = N (do x <- unN m
27 case x of
28 Empty -> return Empty
29 Cons a xs -> unN (mplus (f a) (xs >>= f)))
30
31 instance HasBaseMonad m n => HasBaseMonad (NondetT m) n where
32 inBase = inBase'
33
34
35 -- misc functions
36 instance Monad m => Functor (T m) where
37 fmap f Empty = Empty
38 fmap f (Cons a m) = Cons (f a) (fmap f m)
39
40
41 single x = Cons x mzero
42
43 flatten :: Monad m => T m a -> m [a]
44 flatten Empty = return []
45 flatten (Cons a m) = liftM (a :) (runNondets m)
46
47
48 runNondet m = do t <- unN m
49 case t of
50 Empty -> return Nothing
51 Cons a _ -> return (Just a)
52
53 runNondets m = flatten =<< unN m
54
55 mapNondetT f (N m) = N (f m)
56
57
58 -- other features.
59
60 instance MonadReader r m => MonadReader r (NondetT m) where
61 ask = ask'
62 local = local' mapNondetT
63
64 instance MonadWriter w m => MonadWriter w (NondetT m) where
65 tell = tell'
66 listen = listen1' N unN (\w -> fmap (\a -> (a,w)))
67
68 instance MonadState s m => MonadState s (NondetT m) where
69 get = get'
70 put = put'
71
72 instance MonadError e m => MonadError e (NondetT m) where
73 throwError = throwError'
74 catchError = catchError1' N unN
75
76 instance Monad m => MonadPlus (NondetT m) where
77 mzero = N (return Empty)
78 mplus m n = N (do x <- unN m
79 case x of
80 Empty -> unN n
81 Cons a m' -> return (Cons a (mplus m' n)))
82
83 instance Monad m => MonadNondet (NondetT m) where
84 findAll m = lift (runNondets m)
85 commit m = N (do x <- unN m
86 case x of
87 Empty -> return Empty
88 Cons a _ -> return (single a))
89
90 -- ergh, what does this do?
91 instance (MonadCont m) => MonadCont (NondetT m) where
92 callCC = callCC1' N unN single
93
94
95
96
97
98