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/Spec.hs  |  4 ++--
 events/src/Events/Types.hs | 34 +++++++++++++++++++++-------------
 events/src/Main.hs         |  7 ++++---
 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 ()
 interpret = mapM_ interpretExpr
 
 interpretExpr :: MonadIO m => Expr -> Eval m ()
-interpretExpr (Override obj) = ctxEvent ?= obj
-interpretExpr (Occurs expr)  = ctxOccurs <~ interpretBoolExpr expr
+interpretExpr (Override obj) = objPayload ?= obj
+interpretExpr (Occurs expr)  = objOccurs <~ interpretBoolExpr expr
 interpretExpr _              = return ()
 
 interpretBoolExpr :: 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 @@
 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
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
 import qualified ListT
 
 main :: IO ()
-main = test $ [ -- Nop
-              -- , Override [("blub", String "Haha!")]
-              --,  Occurs (BoolLit True)
+main = test $ [ Nop
+              , Override [("blub", String "Haha!")]
+              , Occurs (BoolLit True)
+              , Occurs (BoolLit False)
               ]
   where
     test = CBS.putStr . Yaml.encode <=< evaluate . interpret
-- 
cgit v1.2.3