1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Events.Types
( TimeRange(..), rangeStart, rangeDuration
, Event(..), payload, occursWithin
, EvalCtx(..), ctxVars, ctxEvents, ctxEvent, ctxOccurs
, Eval, evaluate
, module Data.Aeson
, module Data.Time.Clock
, module Data.Default.Class
) where
import Control.Lens.TH
import Data.Aeson (Object)
import Data.Time.Clock
import Control.Monad.State.Lazy
import ListT (ListT)
import qualified ListT
import Data.Default.Class
import Data.Monoid
import Control.Monad.Fix
import Control.Lens
import Data.Maybe
import Data.Bool
import Debug.Trace
data TimeRange = TimeRange
{ _rangeStart :: UTCTime
, _rangeDuration :: NominalDiffTime
}
makeLenses ''TimeRange
data Event = Event
{ _payload :: Object
, _occursWithin :: TimeRange -> Bool
}
makeLenses ''Event
data EvalCtx = EvalCtx
{ _ctxVars :: Object
, _ctxEvents :: [Object]
, _ctxEvent :: Maybe Object
, _ctxOccurs :: Bool
} deriving (Show)
makeLenses ''EvalCtx
instance Default EvalCtx where
def = EvalCtx
{ _ctxVars = mempty
, _ctxEvents = mempty
, _ctxEvent = Nothing
, _ctxOccurs = False
}
type Eval m a = ListT (StateT EvalCtx m) a
evaluate :: MonadFix m => Eval m () -> m [Object]
evaluate x = (^. ctxEvents) <$> mfix x'
where
x' = execStateT (ListT.toList x) . resetState -- flip (set ctxEvents) def . catMaybes
resetState = execState $ do
ctxEvents <~ bool const (\x y -> x ++ maybe [] pure y) <$> use ctxOccurs <*> use ctxEvents <*> use ctxEvent
ctxEvent .= def ^. ctxEvent
ctxOccurs .= def ^. ctxOccurs
instance MonadState s m => MonadState s (ListT m) where
get = lift get
put = lift . put
|
