{-# LANGUAGE Rank2Types #-}
module Control.Monad.SearchTree ( SearchTree(..), Search, searchTree ) where
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
data SearchTree a = None | One a | Choice (SearchTree a) (SearchTree a)
deriving Int -> SearchTree a -> ShowS
[SearchTree a] -> ShowS
SearchTree a -> String
(Int -> SearchTree a -> ShowS)
-> (SearchTree a -> String)
-> ([SearchTree a] -> ShowS)
-> Show (SearchTree a)
forall a. Show a => Int -> SearchTree a -> ShowS
forall a. Show a => [SearchTree a] -> ShowS
forall a. Show a => SearchTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchTree a] -> ShowS
$cshowList :: forall a. Show a => [SearchTree a] -> ShowS
show :: SearchTree a -> String
$cshow :: forall a. Show a => SearchTree a -> String
showsPrec :: Int -> SearchTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SearchTree a -> ShowS
Show
instance Functor SearchTree where
fmap :: (a -> b) -> SearchTree a -> SearchTree b
fmap a -> b
_ SearchTree a
None = SearchTree b
forall a. SearchTree a
None
fmap a -> b
f (One a
x) = b -> SearchTree b
forall a. a -> SearchTree a
One (a -> b
f a
x)
fmap a -> b
f (Choice SearchTree a
s SearchTree a
t) = SearchTree b -> SearchTree b -> SearchTree b
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice ((a -> b) -> SearchTree a -> SearchTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f SearchTree a
s) ((a -> b) -> SearchTree a -> SearchTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f SearchTree a
t)
instance Applicative SearchTree where
pure :: a -> SearchTree a
pure = a -> SearchTree a
forall a. a -> SearchTree a
One
<*> :: SearchTree (a -> b) -> SearchTree a -> SearchTree b
(<*>) = SearchTree (a -> b) -> SearchTree a -> SearchTree b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Alternative SearchTree where
empty :: SearchTree a
empty = SearchTree a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
<|> :: SearchTree a -> SearchTree a -> SearchTree a
(<|>) = SearchTree a -> SearchTree a -> SearchTree a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Monad SearchTree where
SearchTree a
None >>= :: SearchTree a -> (a -> SearchTree b) -> SearchTree b
>>= a -> SearchTree b
_ = SearchTree b
forall a. SearchTree a
None
One a
x >>= a -> SearchTree b
f = a -> SearchTree b
f a
x
Choice SearchTree a
s SearchTree a
t >>= a -> SearchTree b
f = SearchTree b -> SearchTree b -> SearchTree b
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice (SearchTree a
s SearchTree a -> (a -> SearchTree b) -> SearchTree b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SearchTree b
f) (SearchTree a
t SearchTree a -> (a -> SearchTree b) -> SearchTree b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SearchTree b
f)
instance MonadFail SearchTree where
fail :: String -> SearchTree a
fail String
_ = SearchTree a
forall a. SearchTree a
None
instance MonadPlus SearchTree where
mzero :: SearchTree a
mzero = SearchTree a
forall a. SearchTree a
None
mplus :: SearchTree a -> SearchTree a -> SearchTree a
mplus = SearchTree a -> SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice
instance MonadFix SearchTree where
mfix :: (a -> SearchTree a) -> SearchTree a
mfix a -> SearchTree a
f = case (SearchTree a -> SearchTree a) -> SearchTree a
forall a. (a -> a) -> a
fix (a -> SearchTree a
f (a -> SearchTree a)
-> (SearchTree a -> a) -> SearchTree a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree a -> a
forall p. SearchTree p -> p
unOne) of
SearchTree a
None -> SearchTree a
forall a. SearchTree a
None
One a
x -> a -> SearchTree a
forall a. a -> SearchTree a
One a
x
Choice SearchTree a
_ SearchTree a
_ -> SearchTree a -> SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice ((a -> SearchTree a) -> SearchTree a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a
leftChoice (SearchTree a -> SearchTree a)
-> (a -> SearchTree a) -> a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SearchTree a
f)) ((a -> SearchTree a) -> SearchTree a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a
rightChoice (SearchTree a -> SearchTree a)
-> (a -> SearchTree a) -> a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SearchTree a
f))
where
unOne :: SearchTree p -> p
unOne (One p
x) = p
x
unOne SearchTree p
_ = String -> p
forall a. HasCallStack => String -> a
error String
"mfix SearchTree: not One"
leftChoice :: SearchTree a -> SearchTree a
leftChoice (Choice SearchTree a
s SearchTree a
_) = SearchTree a
s
leftChoice SearchTree a
_ = String -> SearchTree a
forall a. HasCallStack => String -> a
error String
"mfix SearchTree: not Choice"
rightChoice :: SearchTree a -> SearchTree a
rightChoice (Choice SearchTree a
_ SearchTree a
t) = SearchTree a
t
rightChoice SearchTree a
_ = String -> SearchTree a
forall a. HasCallStack => String -> a
error String
"mfix SearchTree: not Choice"
newtype Search a = Search
{
Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search :: forall r. (a -> SearchTree r) -> SearchTree r
}
searchTree :: Search a -> SearchTree a
searchTree :: Search a -> SearchTree a
searchTree Search a
a = Search a -> (a -> SearchTree a) -> SearchTree a
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a a -> SearchTree a
forall a. a -> SearchTree a
One
instance Functor Search where
fmap :: (a -> b) -> Search a -> Search b
fmap a -> b
f Search a
a = (forall r. (b -> SearchTree r) -> SearchTree r) -> Search b
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\b -> SearchTree r
k -> Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a (b -> SearchTree r
k (b -> SearchTree r) -> (a -> b) -> a -> SearchTree r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Applicative Search where
pure :: a -> Search a
pure a
x = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search ((a -> SearchTree r) -> a -> SearchTree r
forall a b. (a -> b) -> a -> b
$ a
x)
<*> :: Search (a -> b) -> Search a -> Search b
(<*>) = Search (a -> b) -> Search a -> Search b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Alternative Search where
empty :: Search a
empty = Search a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
<|> :: Search a -> Search a -> Search a
(<|>) = Search a -> Search a -> Search a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Monad Search where
Search a
a >>= :: Search a -> (a -> Search b) -> Search b
>>= a -> Search b
f = (forall r. (b -> SearchTree r) -> SearchTree r) -> Search b
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\b -> SearchTree r
k -> Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a (\a
x -> Search b -> (b -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search (a -> Search b
f a
x) b -> SearchTree r
k))
instance MonadFail Search where
fail :: String -> Search a
fail String
_ = Search a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
instance MonadPlus Search where
mzero :: Search a
mzero = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (SearchTree r -> (a -> SearchTree r) -> SearchTree r
forall a b. a -> b -> a
const SearchTree r
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
Search a
a mplus :: Search a -> Search a -> Search a
`mplus` Search a
b = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\a -> SearchTree r
k -> Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a a -> SearchTree r
k SearchTree r -> SearchTree r -> SearchTree r
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
b a -> SearchTree r
k)
instance MonadFix Search where
mfix :: (a -> Search a) -> Search a
mfix a -> Search a
f = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\a -> SearchTree r
k -> (a -> SearchTree a) -> SearchTree a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Search a -> SearchTree a
forall a. Search a -> SearchTree a
searchTree (Search a -> SearchTree a) -> (a -> Search a) -> a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Search a
f) SearchTree a -> (a -> SearchTree r) -> SearchTree r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SearchTree r
k)