summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--events/src/Events/Eval.hs14
-rw-r--r--events/src/Events/Types.hs8
-rw-r--r--events/src/Events/Types/NDT.hs21
-rw-r--r--events/src/Main.hs7
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 @@
1{-# LANGUAGE ViewPatterns #-}
2
1module Events.Eval 3module Events.Eval
2 ( evaluate 4 ( evaluate
5 , ordPredicate
6 , module Data.Ord
3 ) where 7 ) where
4 8
5import Control.Monad.Fix (MonadFix(mfix)) 9import Control.Monad.Fix (MonadFix(mfix))
@@ -10,7 +14,13 @@ import Data.Maybe (catMaybes)
10 14
11import Control.Lens 15import Control.Lens
12 16
13evaluate :: MonadFix m => (Maybe Object -> StateT EvalCtx m Bool) -> Eval m () -> m [Object] 17import Data.Ord (Ordering(..))
18
19evaluate :: MonadFix m => (Maybe Object -> ReaderT EvalCtx m Bool) -> Eval m () -> m [Object]
14evaluate predicate x = catMaybes <$> mfix x' 20evaluate predicate x = catMaybes <$> mfix x'
15 where 21 where
16 x' = evalStateT (foldNDT predicate (preview objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes 22 x' = runReaderT (foldNDT predicate (preview objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
23
24ordPredicate :: Applicative m => (Object -> Ordering) -> (Maybe Object -> m Bool)
25ordPredicate _ Nothing = pure True
26ordPredicate 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
11 , module Data.Default.Class 11 , module Data.Default.Class
12 , module Events.Types.NDT 12 , module Events.Types.NDT
13 , module Control.Monad.State.Lazy 13 , module Control.Monad.State.Lazy
14 , module Control.Monad.Reader
14 ) where 15 ) where
15 16
16import Control.Lens.TH (makeLenses) 17import Control.Lens.TH (makeLenses)
@@ -25,6 +26,7 @@ import Data.Default.Class
25import Events.Types.NDT (NDT, foldNDT) 26import Events.Types.NDT (NDT, foldNDT)
26 27
27import Control.Monad.State.Lazy 28import Control.Monad.State.Lazy
29import Control.Monad.Reader
28 30
29data TimeRange = TimeRange 31data TimeRange = TimeRange
30 { _rangeStart :: UTCTime 32 { _rangeStart :: UTCTime
@@ -64,7 +66,7 @@ instance Default ObjCtx where
64 66
65objCtx :: Traversal' ObjCtx Object 67objCtx :: Traversal' ObjCtx Object
66objCtx fObj ctx 68objCtx fObj ctx
67 | _objOccurs ctx = traverseOf (objPayload . _Just) fObj ctx 69 | ctx ^. objOccurs = traverseOf (objPayload . _Just) fObj ctx
68 | otherwise = pure ctx 70 | otherwise = pure ctx
69 71
70type Eval m a = StateT ObjCtx (NDT (StateT EvalCtx m)) a 72type 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 @@
2{-# LANGUAGE TupleSections #-} 2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} 4{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
5{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
5 6
6module Events.Types.NDT 7module Events.Types.NDT
7 ( NDT 8 ( NDT
@@ -21,6 +22,7 @@ import Control.Monad
21import Control.Monad.Identity 22import Control.Monad.Identity
22 23
23import Control.Monad.Trans 24import Control.Monad.Trans
25import Control.Monad.Reader (MonadReader(..))
24import Control.Monad.Trans.Maybe 26import Control.Monad.Trans.Maybe
25 27
26import Debug.Trace 28import Debug.Trace
@@ -50,10 +52,10 @@ instance Applicative m => Monad (NDT m) where
50 52
51instance Monad m => Monoid (NDT m a) where 53instance Monad m => Monoid (NDT m a) where
52 mempty = empty 54 mempty = empty
53 mappend (NDTCons x) y'@(NDTCons y) = trace "(cons <> cons)" . NDTCons . trace "[cons <> cons]" $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x 55 mappend (NDTCons x) y'@(NDTCons y) = NDTCons $ maybe y (\(x, xs) -> return $ Just (x, xs <> y')) =<< x
54 mappend (NDTBind x f) (NDTBind y g) = trace "(bind <> bind)" $ NDTBind (fmap Left x <> fmap Right y) (either f g) 56 mappend (NDTBind x f) (NDTBind y g) = NDTBind (fmap Left x <> fmap Right y) (either f g)
55 mappend x@(NDTBind _ _) y = trace "(bind <>)" $ x <> NDTBind y return 57 mappend x@(NDTBind _ _) y = x <> NDTBind y return
56 mappend x y@(NDTBind _ _) = trace "(<> bind)" $ NDTBind x return <> y 58 mappend x y@(NDTBind _ _) = NDTBind x return <> y
57 59
58instance MonadTrans NDT where 60instance MonadTrans NDT where
59 lift = NDTCons . fmap Just . fmap (,empty) 61 lift = NDTCons . fmap Just . fmap (,empty)
@@ -66,6 +68,11 @@ instance Monad m => MonadPlus (NDT m) where
66 mzero = mempty 68 mzero = mempty
67 mplus = mappend 69 mplus = mappend
68 70
71instance MonadReader r m => MonadReader r (NDT m) where
72 reader = lift . reader
73 local f (NDTCons x) = NDTCons (local f x)
74 local f (NDTBind x g) = NDTBind (local f x) g
75
69-- instance MonadFix m => MonadFix (NDT m) where 76-- instance MonadFix m => MonadFix (NDT m) where
70-- mfix f = NDTCons . runMaybeT $ do 77-- mfix f = NDTCons . runMaybeT $ do
71-- x <- mfix (head . f) 78-- x <- mfix (head . f)
@@ -100,10 +107,10 @@ foldNDT sel (NDTCons mx) = do
100 Nothing -> return mempty 107 Nothing -> return mempty
101 Just (x, mxs) -> do 108 Just (x, mxs) -> do
102 continue <- sel x 109 continue <- sel x
103 case trace ("(cons "++ show continue ++ ")") continue of 110 case continue of
104 False -> return mempty 111 False -> return mempty
105 True -> (pure x <>) <$> foldNDT sel mxs 112 True -> (pure x <>) <$> foldNDT sel mxs
106foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do 113foldNDT sel (NDTBind (NDTCons x) f) = do
107 x' <- x 114 x' <- x
108 case x' of 115 case x' of
109 Nothing -> return mempty 116 Nothing -> return mempty
@@ -111,7 +118,7 @@ foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
111 x3 <- foldNDT sel $ f x'' 118 x3 <- foldNDT sel $ f x''
112 xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f) 119 xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f)
113 return $ x3 <> xs' 120 return $ x3 <> xs'
114foldNDT sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT sel $ NDTBind x (f <=< g) 121foldNDT sel (NDTBind (NDTBind x g) f) = foldNDT sel $ NDTBind x (f <=< g)
115 122
116fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a 123fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
117fromFoldable = foldr cons empty 124fromFoldable = 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
23main :: IO () 23main :: IO ()
24main = test $ do 24main = test $ do
25 n <- lift $ NDT.fromFoldable ([1..] :: [Integer]) 25 n <- lift $ NDT.fromFoldable ([1..] :: [Integer])
26 lower <- filter (maybe False (< fromIntegral n) <$> view (at "num" . asDouble)) <$> view ctxEvents
26 -- objOccurs .= (n <= 5) 27 -- objOccurs .= (n <= 5)
27 objOccurs .= (n >= 2) 28 objOccurs .= (n >= 2)
28 objPayload ?= [ ("num", Yaml.Number $ fromIntegral n) 29 objPayload ?= [ ("num", Yaml.Number $ fromIntegral n)
30 , ("count", Yaml.Number . fromIntegral . length $ lower)
29 ] 31 ]
30 where 32 where
31 test = CBS.putStr . Yaml.encode <=< evaluate predicate 33 test = CBS.putStr . Yaml.encode <=< evaluate predicate
32 predicate :: Monad m => Maybe Yaml.Object -> m Bool 34 predicate :: Monad m => Maybe Yaml.Object -> m Bool
33 predicate Nothing = return True 35 predicate = ordPredicate $ maybe LT (`compare` 5) . view (at "num" . asDouble)
34 predicate (Just obj) = return . maybe False (<= 5) . traceShowId $ obj ^. at "num" . asDouble 36 -- predicate Nothing = return True
37 -- predicate (Just obj) = return . maybe False (<= 5) . traceShowId $ obj ^. at "num" . asDouble