diff options
Diffstat (limited to 'events/src/Events/Types/NDT.hs')
-rw-r--r-- | events/src/Events/Types/NDT.hs | 59 |
1 files changed, 42 insertions, 17 deletions
diff --git a/events/src/Events/Types/NDT.hs b/events/src/Events/Types/NDT.hs index 94a84f0..8431f51 100644 --- a/events/src/Events/Types/NDT.hs +++ b/events/src/Events/Types/NDT.hs | |||
@@ -15,10 +15,13 @@ import Data.Foldable (foldr) | |||
15 | import Data.Maybe | 15 | import Data.Maybe |
16 | import Data.Either | 16 | import Data.Either |
17 | 17 | ||
18 | import Control.Applicative (Alternative) | ||
19 | import qualified Control.Applicative as Alt (Alternative(..)) | ||
18 | import Control.Monad | 20 | import Control.Monad |
19 | import Control.Monad.Identity | 21 | import Control.Monad.Identity |
20 | 22 | ||
21 | import Control.Monad.Trans | 23 | import Control.Monad.Trans |
24 | import Control.Monad.Trans.Maybe | ||
22 | 25 | ||
23 | import Debug.Trace | 26 | import Debug.Trace |
24 | 27 | ||
@@ -43,7 +46,6 @@ instance Applicative m => Applicative (NDT m) where | |||
43 | 46 | ||
44 | instance Applicative m => Monad (NDT m) where | 47 | instance Applicative m => Monad (NDT m) where |
45 | return = pure | 48 | return = pure |
46 | fail = const empty | ||
47 | (>>=) = NDTBind | 49 | (>>=) = NDTBind |
48 | 50 | ||
49 | instance Monad m => Monoid (NDT m a) where | 51 | instance Monad m => Monoid (NDT m a) where |
@@ -56,37 +58,60 @@ instance Monad m => Monoid (NDT m a) where | |||
56 | instance MonadTrans NDT where | 58 | instance MonadTrans NDT where |
57 | lift = NDTCons . fmap Just . fmap (,empty) | 59 | lift = NDTCons . fmap Just . fmap (,empty) |
58 | 60 | ||
61 | instance Monad m => Alternative (NDT m) where | ||
62 | empty = mempty | ||
63 | (<|>) = mappend | ||
64 | |||
65 | instance Monad m => MonadPlus (NDT m) where | ||
66 | mzero = mempty | ||
67 | mplus = mappend | ||
68 | |||
69 | -- instance MonadFix m => MonadFix (NDT m) where | ||
70 | -- mfix f = NDTCons . runMaybeT $ do | ||
71 | -- x <- mfix (head . f) | ||
72 | -- return (x, trace "tail" . mfix $ tail . f) | ||
73 | -- where | ||
74 | -- head :: Monad m => NDT m a -> MaybeT m a | ||
75 | -- head (NDTCons x) = MaybeT . trace "head (cons)" $ fmap fst <$> x | ||
76 | -- head (NDTBind (NDTBind x g) f) = head $ NDTBind x (f <=< g) | ||
77 | -- head (NDTBind (NDTCons x) f) = MaybeT x >>= head . f . fst . trace "head (bind cons)" | ||
78 | -- tail :: Monad m => NDT m a -> NDT m a | ||
79 | -- tail (NDTCons x) = NDTBind (lift x) $ maybe empty snd . guardNothing | ||
80 | -- tail (NDTBind (NDTBind x g) f) = tail $ NDTBind x (f <=< g) | ||
81 | -- tail (NDTBind (NDTCons x) f) = tail . NDTCons $ fmap (\(_, xs) -> (undefined, NDTBind xs f)) <$> x | ||
82 | -- guardNothing :: Maybe a -> Maybe a | ||
83 | -- guardNothing x@(Just _) = x | ||
84 | -- guardNothing x@(Nothing) = trace "Nothing" x | ||
85 | |||
86 | instance MonadIO m => MonadIO (NDT m) where | ||
87 | liftIO = lift . liftIO | ||
88 | |||
59 | empty :: Applicative m => NDT m a | 89 | empty :: Applicative m => NDT m a |
60 | empty = NDTCons $ pure Nothing | 90 | empty = NDTCons $ pure Nothing |
61 | 91 | ||
62 | cons :: Applicative m => a -> NDT m a -> NDT m a | 92 | cons :: Applicative m => a -> NDT m a -> NDT m a |
63 | cons x xs = NDTCons . pure $ Just (x, xs) | 93 | cons x xs = NDTCons . pure $ Just (x, xs) |
64 | 94 | ||
65 | foldNDT :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m a | 95 | foldNDT :: (Foldable f, Applicative f, Monoid (f a), Monad m) => (a -> m Bool) -> NDT m a -> m (f a) |
66 | foldNDT sel = fmap snd . foldNDT' sel | 96 | -- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings and children |
67 | 97 | foldNDT sel (NDTCons mx) = do | |
68 | foldNDT' :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m (Any, a) | ||
69 | -- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings | ||
70 | foldNDT' sel (NDTCons mx) = do | ||
71 | mx' <- mx | 98 | mx' <- mx |
72 | case mx' of | 99 | case mx' of |
73 | Nothing -> return mempty | 100 | Nothing -> return mempty |
74 | Just (x, mxs) -> do | 101 | Just (x, mxs) -> do |
75 | continue <- sel x | 102 | continue <- sel x |
76 | case trace ("(cons "++ show continue ++ ")") continue of | 103 | case trace ("(cons "++ show continue ++ ")") continue of |
77 | False -> return (Any True, mempty) | 104 | False -> return mempty |
78 | True -> ((Any True, x) <>) <$> foldNDT' sel mxs | 105 | True -> (pure x <>) <$> foldNDT sel mxs |
79 | foldNDT' sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do | 106 | foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do |
80 | x' <- x | 107 | x' <- x |
81 | case x' of | 108 | case x' of |
82 | Nothing -> return mempty | 109 | Nothing -> return mempty |
83 | Just (x'', xs) -> do -- foldNDT' sel . NDTCons $ Just . (, NDTBind xs f) . snd <$> foldNDT' sel (f x'') | 110 | Just (x'', xs) -> do |
84 | (productive, x3) <- foldNDT' sel $ f x'' | 111 | x3 <- foldNDT sel $ f x'' |
85 | continue <- sel x3 | 112 | xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f) |
86 | case trace ("(bind cons " ++ show (productive, continue) ++ ")") $ continue || not (getAny productive) of | 113 | return $ x3 <> xs' |
87 | False -> return mempty | 114 | foldNDT sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT sel $ NDTBind x (f <=< g) |
88 | True -> ((mempty, x3) <>) <$> foldNDT' sel (NDTBind xs f) | ||
89 | foldNDT' sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT' sel $ NDTBind x (f <=< g) | ||
90 | 115 | ||
91 | fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a | 116 | fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a |
92 | fromFoldable = foldr cons empty | 117 | fromFoldable = foldr cons empty |