From b2e4264e7849f322cbb2bb592b15d2ea7aec9149 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Thu, 28 Jul 2016 23:14:50 +0200
Subject: Switch from monoid to foldable container

---
 events/src/Events/Types/NDT.hs | 59 ++++++++++++++++++++++++++++++------------
 1 file changed, 42 insertions(+), 17 deletions(-)

(limited to 'events/src/Events/Types/NDT.hs')

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)
 import Data.Maybe
 import Data.Either
 
+import Control.Applicative (Alternative)
+import qualified Control.Applicative as Alt (Alternative(..))
 import Control.Monad
 import Control.Monad.Identity
 
 import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
 
 import Debug.Trace
 
@@ -43,7 +46,6 @@ instance Applicative m => Applicative (NDT m) where
 
 instance Applicative m => Monad (NDT m) where
   return = pure
-  fail = const empty
   (>>=) = NDTBind
 
 instance Monad m => Monoid (NDT m a) where
@@ -56,37 +58,60 @@ instance Monad m => Monoid (NDT m a) where
 instance MonadTrans NDT where
   lift = NDTCons . fmap Just . fmap (,empty)
 
+instance Monad m => Alternative (NDT m) where
+  empty = mempty
+  (<|>) = mappend
+
+instance Monad m => MonadPlus (NDT m) where
+  mzero = mempty
+  mplus = mappend
+
+-- instance MonadFix m => MonadFix (NDT m) where
+--   mfix f = NDTCons . runMaybeT $ do
+--     x <- mfix (head . f)
+--     return (x, trace "tail" . mfix $ tail . f)
+--     where
+--       head :: Monad m => NDT m a -> MaybeT m a
+--       head (NDTCons x) = MaybeT . trace "head (cons)" $ fmap fst <$> x
+--       head (NDTBind (NDTBind x g) f) = head $ NDTBind x (f <=< g)
+--       head (NDTBind (NDTCons x) f) = MaybeT x >>= head . f . fst . trace "head (bind cons)"
+--       tail :: Monad m => NDT m a -> NDT m a
+--       tail (NDTCons x) = NDTBind (lift x) $ maybe empty snd . guardNothing
+--       tail (NDTBind (NDTBind x g) f) = tail $ NDTBind x (f <=< g)
+--       tail (NDTBind (NDTCons x) f) = tail . NDTCons $ fmap (\(_, xs) -> (undefined, NDTBind xs f)) <$> x
+--       guardNothing :: Maybe a -> Maybe a
+--       guardNothing x@(Just _) = x
+--       guardNothing x@(Nothing) = trace "Nothing" x
+
+instance MonadIO m => MonadIO (NDT m) where
+  liftIO = lift . liftIO
+
 empty :: Applicative m => NDT m a
 empty = NDTCons $ pure Nothing
 
 cons :: Applicative m => a -> NDT m a -> NDT m a
 cons x xs = NDTCons . pure $ Just (x, xs)
   
-foldNDT :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m a
-foldNDT sel = fmap snd . foldNDT' sel
-
-foldNDT' :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m (Any, a)
--- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings
-foldNDT' sel (NDTCons mx) = do
+foldNDT :: (Foldable f, Applicative f, Monoid (f a), Monad m) => (a -> m Bool) -> NDT m a -> m (f a)
+-- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings and children
+foldNDT sel (NDTCons mx) = do
   mx' <- mx
   case mx' of
     Nothing -> return mempty
     Just (x, mxs) -> do
       continue <- sel x
       case trace ("(cons "++ show continue ++ ")") continue of
-        False -> return (Any True, mempty)
-        True  -> ((Any True, x) <>) <$> foldNDT' sel mxs
-foldNDT' sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
+        False -> return mempty
+        True  -> (pure x <>) <$> foldNDT sel mxs
+foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
   x' <- x
   case x' of
     Nothing -> return mempty
-    Just (x'', xs) -> do -- foldNDT' sel . NDTCons $ Just . (, NDTBind xs f) . snd <$> foldNDT' sel (f x'')
-      (productive, x3) <- foldNDT' sel $ f x''
-      continue <- sel x3
-      case trace ("(bind cons " ++ show (productive, continue) ++ ")") $ continue || not (getAny productive) of
-        False -> return mempty
-        True -> ((mempty, x3) <>) <$> foldNDT' sel (NDTBind xs f)
-foldNDT' sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT' sel $ NDTBind x (f <=< g)
+    Just (x'', xs) -> do
+      x3 <- foldNDT sel $ f x''
+      xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f)
+      return $ x3 <> xs'
+foldNDT sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT sel $ NDTBind x (f <=< g)
 
 fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
 fromFoldable = foldr cons empty
-- 
cgit v1.2.3