summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--events/src/Events/Types.hs29
1 files changed, 22 insertions, 7 deletions
diff --git a/events/src/Events/Types.hs b/events/src/Events/Types.hs
index 4527fc7..19fccdf 100644
--- a/events/src/Events/Types.hs
+++ b/events/src/Events/Types.hs
@@ -1,12 +1,12 @@
1{-# LANGUAGE TemplateHaskell #-} 1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE MultiParamTypeClasses #-} 2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-} 4{-# LANGUAGE UndecidableInstances #-}
5 5
6module Events.Types 6module Events.Types
7 ( TimeRange(..), rangeStart, rangeDuration 7 ( TimeRange(..), rangeStart, rangeDuration
8 , Event(..), payload, occursWithin 8 , Event(..), payload, occursWithin
9 , EvalCtx(..), ctxVars, ctxEvents 9 , EvalCtx(..), ctxVars, ctxEvents, ctxEvent, ctxOccurs
10 , Eval, evaluate 10 , Eval, evaluate
11 , module Data.Aeson 11 , module Data.Aeson
12 , module Data.Time.Clock 12 , module Data.Time.Clock
@@ -29,6 +29,9 @@ import Data.Monoid
29import Control.Monad.Fix 29import Control.Monad.Fix
30import Control.Lens 30import Control.Lens
31import Data.Maybe 31import Data.Maybe
32import Data.Bool
33
34import Debug.Trace
32 35
33data TimeRange = TimeRange 36data TimeRange = TimeRange
34 { _rangeStart :: UTCTime 37 { _rangeStart :: UTCTime
@@ -44,19 +47,31 @@ makeLenses ''Event
44 47
45data EvalCtx = EvalCtx 48data EvalCtx = EvalCtx
46 { _ctxVars :: Object 49 { _ctxVars :: Object
47 , _ctxEvents :: [Event] 50 , _ctxEvents :: [Object]
48 } 51 , _ctxEvent :: Maybe Object
52 , _ctxOccurs :: Bool
53 } deriving (Show)
49makeLenses ''EvalCtx 54makeLenses ''EvalCtx
50 55
51instance Default EvalCtx where 56instance Default EvalCtx where
52 def = EvalCtx 57 def = EvalCtx
53 { _ctxVars = mempty 58 { _ctxVars = mempty
54 , _ctxEvents = mempty 59 , _ctxEvents = mempty
60 , _ctxEvent = Nothing
61 , _ctxOccurs = False
55 } 62 }
56 63
57type Eval m a = ListT (StateT EvalCtx m) a 64type Eval m a = ListT (StateT EvalCtx m) a
58 65
59evaluate :: MonadFix m => Eval m (Maybe Event) -> m [Event] 66evaluate :: MonadFix m => Eval m () -> m [Object]
60evaluate x = catMaybes <$> mfix x' 67evaluate x = (^. ctxEvents) <$> mfix x'
61 where 68 where
62 x' = evalStateT (ListT.toList x) . flip (set ctxEvents) def . catMaybes 69 x' = execStateT (ListT.toList x) . resetState -- flip (set ctxEvents) def . catMaybes
70 resetState = execState $ do
71 ctxEvents <~ bool const (\x y -> x ++ maybe [] pure y) <$> use ctxOccurs <*> use ctxEvents <*> use ctxEvent
72 ctxEvent .= def ^. ctxEvent
73 ctxOccurs .= def ^. ctxOccurs
74
75instance MonadState s m => MonadState s (ListT m) where
76 get = lift get
77 put = lift . put