4 files changed, 36 insertions, 14 deletions

diff --git a/events/src/Events/Eval.hs b/events/src/Events/Eval.hs
index c5bc134..280c577 100644
--- a/events/src/Events/Eval.hs
+++ b/events/src/Events/Eval.hs
@@ -1,5 +1,9 @@
+{-# LANGUAGE ViewPatterns #-}
+
 module Events.Eval
   ( evaluate
+  , ordPredicate
+  , module Data.Ord
   ) where
 
 import Control.Monad.Fix (MonadFix(mfix))
@@ -10,7 +14,13 @@ import Data.Maybe (catMaybes)
 
 import Control.Lens
 
-evaluate :: MonadFix m => (Maybe Object -> StateT EvalCtx m Bool) -> Eval m () -> m [Object]
+import Data.Ord (Ordering(..))
+
+evaluate :: MonadFix m => (Maybe Object -> ReaderT EvalCtx m Bool) -> Eval m () -> m [Object]
 evaluate predicate x = catMaybes <$> mfix x'
   where
-    x' = evalStateT (foldNDT predicate (preview objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
+    x' = runReaderT (foldNDT predicate (preview objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
+
+ordPredicate :: Applicative m => (Object -> Ordering) -> (Maybe Object -> m Bool)
+ordPredicate _  Nothing        = pure True
+ordPredicate f (Just (f -> o)) = pure $ o <= EQ
diff --git a/events/src/Events/Types.hs b/events/src/Events/Types.hs
index 711e200..5320bb3 100644
--- a/events/src/Events/Types.hs
+++ b/events/src/Events/Types.hs
@@ -11,6 +11,7 @@ module Events.Types
        , module Data.Default.Class
        , module Events.Types.NDT
        , module Control.Monad.State.Lazy
+       , module Control.Monad.Reader
        ) where
 
 import Control.Lens.TH (makeLenses)
@@ -25,6 +26,7 @@ import Data.Default.Class
 import Events.Types.NDT (NDT, foldNDT)
 
 import Control.Monad.State.Lazy
+import Control.Monad.Reader
 
 data TimeRange = TimeRange
                  { _rangeStart :: UTCTime
@@ -64,7 +66,7 @@ instance Default ObjCtx where
 
 objCtx :: Traversal' ObjCtx Object
 objCtx fObj ctx
-  | _objOccurs ctx = traverseOf (objPayload . _Just) fObj ctx
-  | otherwise      = pure ctx
+  | ctx ^. objOccurs = traverseOf (objPayload . _Just) fObj ctx
+  | otherwise        = pure ctx
 
-type Eval m a = StateT ObjCtx (NDT (StateT EvalCtx m)) a
+type Eval m a = StateT ObjCtx (NDT (ReaderT EvalCtx m)) a
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
diff --git a/events/src/Main.hs b/events/src/Main.hs
index 9e732a5..e4b255f 100644
--- a/events/src/Main.hs
+++ b/events/src/Main.hs
@@ -23,12 +23,15 @@ import qualified Events.Types.NDT as NDT
 main :: IO ()
 main = test $ do
   n <- lift $ NDT.fromFoldable ([1..] :: [Integer])
+  lower <- filter (maybe False (< fromIntegral n) <$> view (at "num" . asDouble)) <$> view ctxEvents
   -- objOccurs .= (n <= 5)
   objOccurs .= (n >= 2)
   objPayload ?= [ ("num", Yaml.Number $ fromIntegral n)
+                , ("count", Yaml.Number . fromIntegral . length $ lower)
                 ]
   where
     test = CBS.putStr . Yaml.encode <=< evaluate predicate
     predicate :: Monad m => Maybe Yaml.Object -> m Bool
-    predicate Nothing = return True
-    predicate (Just obj) = return . maybe False (<= 5) . traceShowId $ obj ^. at "num" . asDouble
+    predicate = ordPredicate $ maybe LT (`compare` 5) . view (at "num" . asDouble)
+    -- predicate Nothing = return True
+    -- predicate (Just obj) = return . maybe False (<= 5) . traceShowId $ obj ^. at "num" . asDouble