From e1c7ed58aacb46c8204461841d29cb790cdf76e7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 30 Jul 2016 17:05:49 +0200 Subject: code cleanup --- events/src/Events/Eval.hs | 14 ++++++++++++-- events/src/Events/Types.hs | 8 +++++--- events/src/Events/Types/NDT.hs | 21 ++++++++++++++------- events/src/Main.hs | 7 +++++-- 4 files changed, 36 insertions(+), 14 deletions(-) (limited to 'events/src') 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 -- cgit v1.2.3