Switch from monoid to foldable container

1 files changed, 32 insertions, 31 deletions

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