summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--events/src/Events/Spec.hs4
-rw-r--r--events/src/Events/Types.hs34
-rw-r--r--events/src/Main.hs7
3 files changed, 27 insertions, 18 deletions
diff --git a/events/src/Events/Spec.hs b/events/src/Events/Spec.hs
index deabcc3..1e7e1b4 100644
--- a/events/src/Events/Spec.hs
+++ b/events/src/Events/Spec.hs
@@ -28,8 +28,8 @@ interpret :: MonadIO m => Spec -> Eval m ()
28interpret = mapM_ interpretExpr 28interpret = mapM_ interpretExpr
29 29
30interpretExpr :: MonadIO m => Expr -> Eval m () 30interpretExpr :: MonadIO m => Expr -> Eval m ()
31interpretExpr (Override obj) = ctxEvent ?= obj 31interpretExpr (Override obj) = objPayload ?= obj
32interpretExpr (Occurs expr) = ctxOccurs <~ interpretBoolExpr expr 32interpretExpr (Occurs expr) = objOccurs <~ interpretBoolExpr expr
33interpretExpr _ = return () 33interpretExpr _ = return ()
34 34
35interpretBoolExpr :: Monad m => BoolExpr -> Eval m Bool 35interpretBoolExpr :: Monad m => BoolExpr -> Eval m Bool
diff --git a/events/src/Events/Types.hs b/events/src/Events/Types.hs
index 19fccdf..3414b68 100644
--- a/events/src/Events/Types.hs
+++ b/events/src/Events/Types.hs
@@ -6,7 +6,8 @@
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, ctxEvent, ctxOccurs 9 , EvalCtx(..), ctxVars, ctxEvents
10 , ObjCtx(..), objOccurs, objPayload
10 , Eval, evaluate 11 , Eval, evaluate
11 , module Data.Aeson 12 , module Data.Aeson
12 , module Data.Time.Clock 13 , module Data.Time.Clock
@@ -29,7 +30,6 @@ import Data.Monoid
29import Control.Monad.Fix 30import Control.Monad.Fix
30import Control.Lens 31import Control.Lens
31import Data.Maybe 32import Data.Maybe
32import Data.Bool
33 33
34import Debug.Trace 34import Debug.Trace
35 35
@@ -48,8 +48,6 @@ makeLenses ''Event
48data EvalCtx = EvalCtx 48data EvalCtx = EvalCtx
49 { _ctxVars :: Object 49 { _ctxVars :: Object
50 , _ctxEvents :: [Object] 50 , _ctxEvents :: [Object]
51 , _ctxEvent :: Maybe Object
52 , _ctxOccurs :: Bool
53 } deriving (Show) 51 } deriving (Show)
54makeLenses ''EvalCtx 52makeLenses ''EvalCtx
55 53
@@ -57,20 +55,30 @@ instance Default EvalCtx where
57 def = EvalCtx 55 def = EvalCtx
58 { _ctxVars = mempty 56 { _ctxVars = mempty
59 , _ctxEvents = mempty 57 , _ctxEvents = mempty
60 , _ctxEvent = Nothing
61 , _ctxOccurs = False
62 } 58 }
63 59
64type Eval m a = ListT (StateT EvalCtx m) a 60data ObjCtx = ObjCtx
61 { _objOccurs :: Bool
62 , _objPayload :: Maybe Object
63 }
64makeLenses ''ObjCtx
65
66instance Default ObjCtx where
67 def = ObjCtx
68 { _objOccurs = False
69 , _objPayload = Nothing
70 }
71
72objCtx :: ObjCtx -> Maybe Object
73objCtx (ObjCtx False _) = Nothing
74objCtx (ObjCtx True o) = o
75
76type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a
65 77
66evaluate :: MonadFix m => Eval m () -> m [Object] 78evaluate :: MonadFix m => Eval m () -> m [Object]
67evaluate x = (^. ctxEvents) <$> mfix x' 79evaluate x = catMaybes <$> mfix x'
68 where 80 where
69 x' = execStateT (ListT.toList x) . resetState -- flip (set ctxEvents) def . catMaybes 81 x' = evalStateT (ListT.toList (objCtx <$> execStateT x def)) . 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 82
75instance MonadState s m => MonadState s (ListT m) where 83instance MonadState s m => MonadState s (ListT m) where
76 get = lift get 84 get = lift get
diff --git a/events/src/Main.hs b/events/src/Main.hs
index 7f65b19..0026a8a 100644
--- a/events/src/Main.hs
+++ b/events/src/Main.hs
@@ -18,9 +18,10 @@ import Debug.Trace
18import qualified ListT 18import qualified ListT
19 19
20main :: IO () 20main :: IO ()
21main = test $ [ -- Nop 21main = test $ [ Nop
22 -- , Override [("blub", String "Haha!")] 22 , Override [("blub", String "Haha!")]
23 --, Occurs (BoolLit True) 23 , Occurs (BoolLit True)
24 , Occurs (BoolLit False)
24 ] 25 ]
25 where 26 where
26 test = CBS.putStr . Yaml.encode <=< evaluate . interpret 27 test = CBS.putStr . Yaml.encode <=< evaluate . interpret