Revert "Batch merge"
[ghc.git] / compiler / utils / ListT.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# LANGUAGE Rank2Types #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6
7 -------------------------------------------------------------------------
8 -- |
9 -- Module : Control.Monad.Logic
10 -- Copyright : (c) Dan Doel
11 -- License : BSD3
12 --
13 -- Maintainer : dan.doel@gmail.com
14 -- Stability : experimental
15 -- Portability : non-portable (multi-parameter type classes)
16 --
17 -- A backtracking, logic programming monad.
18 --
19 -- Adapted from the paper
20 -- /Backtracking, Interleaving, and Terminating
21 -- Monad Transformers/, by
22 -- Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry
23 -- (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).
24 -------------------------------------------------------------------------
25
26 module ListT (
27 ListT(..),
28 runListT,
29 select,
30 fold
31 ) where
32
33 import GhcPrelude
34
35 import Control.Applicative
36
37 import Control.Monad
38 import Control.Monad.Fail as MonadFail
39
40 -------------------------------------------------------------------------
41 -- | A monad transformer for performing backtracking computations
42 -- layered over another monad 'm'
43 newtype ListT m a =
44 ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }
45
46 select :: Monad m => [a] -> ListT m a
47 select xs = foldr (<|>) mzero (map pure xs)
48
49 fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r
50 fold = runListT
51
52 -------------------------------------------------------------------------
53 -- | Runs a ListT computation with the specified initial success and
54 -- failure continuations.
55 runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r
56 runListT = unListT
57
58 instance Functor (ListT f) where
59 fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk
60
61 instance Applicative (ListT f) where
62 pure a = ListT $ \sk fk -> sk a fk
63 f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk
64
65 instance Alternative (ListT f) where
66 empty = ListT $ \_ fk -> fk
67 f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)
68
69 instance Monad (ListT m) where
70 m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk
71 #if !MIN_VERSION_base(4,13,0)
72 fail = MonadFail.fail
73 #endif
74
75 instance MonadFail.MonadFail (ListT m) where
76 fail _ = ListT $ \_ fk -> fk
77
78 instance MonadPlus (ListT m) where
79 mzero = ListT $ \_ fk -> fk
80 m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)