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