From 55da12b2cebfecf718bbeadbf3bdc8e8a319bde7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 16 Apr 2016 22:15:58 +0200
Subject: Now tracking event under construction in state

---
 events/src/Events/Types.hs | 29 ++++++++++++++++++++++-------
 1 file changed, 22 insertions(+), 7 deletions(-)

(limited to 'events/src/Events/Types.hs')

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 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Events.Types
        ( TimeRange(..), rangeStart, rangeDuration
        , Event(..), payload, occursWithin
-       , EvalCtx(..), ctxVars, ctxEvents
+       , EvalCtx(..), ctxVars, ctxEvents, ctxEvent, ctxOccurs
        , Eval, evaluate
        , module Data.Aeson
        , module Data.Time.Clock
@@ -29,6 +29,9 @@ import Data.Monoid
 import Control.Monad.Fix
 import Control.Lens
 import Data.Maybe
+import Data.Bool
+
+import Debug.Trace
 
 data TimeRange = TimeRange
                  { _rangeStart :: UTCTime
@@ -44,19 +47,31 @@ makeLenses ''Event
 
 data EvalCtx = EvalCtx
                { _ctxVars :: Object
-               , _ctxEvents :: [Event]
-               }
+               , _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 (Maybe Event) -> m [Event]
-evaluate x = catMaybes <$> mfix x'
+evaluate :: MonadFix m => Eval m () -> m [Object]
+evaluate x = (^. ctxEvents) <$> mfix x'
   where
-    x' = evalStateT (ListT.toList x) . flip (set ctxEvents) def . catMaybes
+    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
-- 
cgit v1.2.3