From a4645fa4bfe346dca048c946b8a2122ddcb6bf57 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 17 Apr 2016 01:12:23 +0200
Subject: Seperated non-value rec. into own layer of state

Fixes lack of fixpoint
---
 events/src/Events/Types.hs | 34 +++++++++++++++++++++-------------
 1 file changed, 21 insertions(+), 13 deletions(-)

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

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 @@
 module Events.Types
        ( TimeRange(..), rangeStart, rangeDuration
        , Event(..), payload, occursWithin
-       , EvalCtx(..), ctxVars, ctxEvents, ctxEvent, ctxOccurs
+       , EvalCtx(..), ctxVars, ctxEvents
+       , ObjCtx(..), objOccurs, objPayload
        , Eval, evaluate
        , module Data.Aeson
        , module Data.Time.Clock
@@ -29,7 +30,6 @@ import Data.Monoid
 import Control.Monad.Fix
 import Control.Lens
 import Data.Maybe
-import Data.Bool
 
 import Debug.Trace
 
@@ -48,8 +48,6 @@ makeLenses ''Event
 data EvalCtx = EvalCtx
                { _ctxVars :: Object
                , _ctxEvents :: [Object]
-               , _ctxEvent :: Maybe Object
-               , _ctxOccurs :: Bool
                } deriving (Show)
 makeLenses ''EvalCtx
 
@@ -57,20 +55,30 @@ instance Default EvalCtx where
   def = EvalCtx
         { _ctxVars = mempty
         , _ctxEvents = mempty
-        , _ctxEvent = Nothing
-        , _ctxOccurs = False
         }
 
-type Eval m a = ListT (StateT EvalCtx m) a
+data ObjCtx = ObjCtx
+              { _objOccurs :: Bool
+              , _objPayload :: Maybe Object
+              }
+makeLenses ''ObjCtx
+
+instance Default ObjCtx where
+  def = ObjCtx
+        { _objOccurs = False
+        , _objPayload = Nothing
+        }
+
+objCtx :: ObjCtx -> Maybe Object
+objCtx (ObjCtx False _) = Nothing
+objCtx (ObjCtx True  o) = o
+
+type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a
 
 evaluate :: MonadFix m => Eval m () -> m [Object]
-evaluate x = (^. ctxEvents) <$> mfix x'
+evaluate x = catMaybes <$> 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
+    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
-- 
cgit v1.2.3