From b2e4264e7849f322cbb2bb592b15d2ea7aec9149 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 28 Jul 2016 23:14:50 +0200 Subject: Switch from monoid to foldable container --- default.nix | 2 +- events/src/Events/Types.hs | 63 +++++++++++++++++++++--------------------- events/src/Events/Types/NDT.hs | 59 +++++++++++++++++++++++++++------------ events/src/Main.hs | 23 +++++++++------ 4 files changed, 89 insertions(+), 58 deletions(-) diff --git a/default.nix b/default.nix index 6cb7da5..f977f6b 100644 --- a/default.nix +++ b/default.nix @@ -1,5 +1,5 @@ { pkgs ? (import {}) -, compilerName ? "ghc7103" +, compilerName ? "ghc801" }: rec { diff --git a/events/src/Events/Types.hs b/events/src/Events/Types.hs index 22faf94..0eff7aa 100644 --- a/events/src/Events/Types.hs +++ b/events/src/Events/Types.hs @@ -1,37 +1,34 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} module Events.Types ( TimeRange(..), rangeStart, rangeDuration , Event(..), payload, occursWithin - , EvalCtx(..), ctxVars, ctxEvents - , ObjCtx(..), objOccurs, objPayload + , EvalCtx(..), ctxEvents + , ObjCtx(..), objVars, objOccurs, objPayload , Eval, evaluate , module Data.Aeson , module Data.Time.Clock , module Data.Default.Class ) where -import Control.Lens.TH +import Control.Lens.TH (makeLenses) import Data.Aeson (Object) -import Data.Time.Clock +import Data.Time.Clock (UTCTime, NominalDiffTime) -import Control.Monad.State.Lazy -import ListT (ListT) -import qualified ListT +import Control.Monad.State.Lazy (StateT, evalStateT, execStateT) -import Data.Default.Class +import Data.Default.Class (Default(def)) -import Data.Monoid -import Control.Monad.Fix -import Control.Lens -import Data.Maybe +-- import Data.Monoid +import Control.Monad.Fix (MonadFix(mfix)) +import Control.Lens ((^.), set) +import Data.Maybe (catMaybes) -import Debug.Trace +-- import Debug.Trace + +import Events.Types.NDT (NDT, foldNDT) data TimeRange = TimeRange { _rangeStart :: UTCTime @@ -46,40 +43,44 @@ data Event = Event makeLenses ''Event data EvalCtx = EvalCtx - { _ctxVars :: Object - , _ctxEvents :: [Object] + { _ctxEvents :: [Object] } deriving (Show) makeLenses ''EvalCtx instance Default EvalCtx where def = EvalCtx - { _ctxVars = mempty - , _ctxEvents = mempty + { _ctxEvents = mempty } data ObjCtx = ObjCtx { _objOccurs :: Bool , _objPayload :: Maybe Object + , _objVars :: Object } makeLenses ''ObjCtx instance Default ObjCtx where def = ObjCtx - { _objOccurs = False + { _objOccurs = True , _objPayload = Nothing + , _objVars = mempty } objCtx :: ObjCtx -> Maybe Object -objCtx (ObjCtx False _) = Nothing -objCtx (ObjCtx True o) = o +objCtx ctx + | ctx ^. objOccurs = ctx ^. objPayload + | otherwise = Nothing -type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a +-- type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a -evaluate :: MonadFix m => Eval m () -> m [Object] -evaluate x = catMaybes <$> mfix x' - where - x' = evalStateT (ListT.toReverseList (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes +-- evaluate :: MonadFix m => Eval m () -> m [Object] {- TODO: Switch to `ListT m Object` – `m [Object]` will turn out to be to strict. There is no instance for `MonadFix (ListT m)` – writing one seems to be possible. -} +-- evaluate x = catMaybes <$> mfix x' +-- where +-- x' = evalStateT (ListT.toList (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes -instance MonadState s m => MonadState s (ListT m) where - get = lift get - put = lift . put +type Eval m a = StateT ObjCtx (NDT (StateT EvalCtx m)) a + +evaluate :: MonadFix m => (Maybe Object -> StateT EvalCtx m Bool) -> Eval m () -> m [Object] {- TODO: Switch to `ListT m Object` – `m [Object]` will turn out to be to strict. There is no instance for `MonadFix (ListT m)` – writing one seems to be possible. -} +evaluate predicate x = catMaybes <$> mfix x' + where + x' = evalStateT (foldNDT predicate (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes 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 diff --git a/events/src/Main.hs b/events/src/Main.hs index 0454f22..a4ffa5a 100644 --- a/events/src/Main.hs +++ b/events/src/Main.hs @@ -11,18 +11,23 @@ import Control.Lens import Control.Monad import Control.Monad.Trans import Data.Aeson.Lens -import Data.Aeson import Debug.Trace +import Data.Maybe (isJust) + import qualified ListT +import qualified Events.Types.NDT as NDT main :: IO () --- main = test $ [ Nop --- , Override [("blub", String "Haha!")] --- , Occurs True --- , Occurs False --- ] --- where --- test = CBS.putStr . Yaml.encode <=< evaluate . interpret -main = undefined +main = test $ do + n <- lift $ NDT.fromFoldable ([1..] :: [Integer]) + -- objOccurs .= (n <= 5) + objOccurs .= (n >= 2) + objPayload ?= [ ("num", Yaml.Number $ fromIntegral n) + ] + 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 -- cgit v1.2.3