From e1c7ed58aacb46c8204461841d29cb790cdf76e7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Sat, 30 Jul 2016 17:05:49 +0200
Subject: code cleanup

---
 events/src/Events/Types/NDT.hs | 21 ++++++++++++++-------
 1 file changed, 14 insertions(+), 7 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 8431f51..3f66953 100644
--- a/events/src/Events/Types/NDT.hs
+++ b/events/src/Events/Types/NDT.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
 
 module Events.Types.NDT
   ( NDT
@@ -21,6 +22,7 @@ import Control.Monad
 import Control.Monad.Identity
 
 import Control.Monad.Trans
+import Control.Monad.Reader (MonadReader(..))
 import Control.Monad.Trans.Maybe
 
 import Debug.Trace
@@ -50,10 +52,10 @@ instance Applicative m => Monad (NDT m) where
 
 instance Monad m => Monoid (NDT m a) where
   mempty = empty
-  mappend (NDTCons x) y'@(NDTCons y) = trace "(cons <> cons)" . NDTCons . trace "[cons <> cons]" $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x
-  mappend (NDTBind x f) (NDTBind y g) = trace "(bind <> bind)" $ NDTBind (fmap Left x <> fmap Right y) (either f g)
-  mappend x@(NDTBind _ _) y = trace "(bind <>)" $ x <> NDTBind y return
-  mappend x y@(NDTBind _ _) = trace "(<> bind)" $ NDTBind x return <> y
+  mappend (NDTCons x) y'@(NDTCons y) = NDTCons $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x
+  mappend (NDTBind x f) (NDTBind y g) = NDTBind (fmap Left x <> fmap Right y) (either f g)
+  mappend x@(NDTBind _ _) y = x <> NDTBind y return
+  mappend x y@(NDTBind _ _) = NDTBind x return <> y
 
 instance MonadTrans NDT where
   lift = NDTCons . fmap Just . fmap (,empty)
@@ -66,6 +68,11 @@ instance Monad m => MonadPlus (NDT m) where
   mzero = mempty
   mplus = mappend
 
+instance MonadReader r m => MonadReader r (NDT m) where
+  reader = lift . reader
+  local f (NDTCons x) = NDTCons (local f x)
+  local f (NDTBind x g) = NDTBind (local f x) g
+
 -- instance MonadFix m => MonadFix (NDT m) where
 --   mfix f = NDTCons . runMaybeT $ do
 --     x <- mfix (head . f)
@@ -100,10 +107,10 @@ foldNDT sel (NDTCons mx) = do
     Nothing -> return mempty
     Just (x, mxs) -> do
       continue <- sel x
-      case trace ("(cons "++ show continue ++ ")") continue of
+      case continue of
         False -> return mempty
         True  -> (pure x <>) <$> foldNDT sel mxs
-foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
+foldNDT sel (NDTBind (NDTCons x) f) = do
   x' <- x
   case x' of
     Nothing -> return mempty
@@ -111,7 +118,7 @@ foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ 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)
+foldNDT sel (NDTBind (NDTBind x g) f) = foldNDT sel $ NDTBind x (f <=< g)
 
 fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
 fromFoldable = foldr cons empty
-- 
cgit v1.2.3