Switch from monoid to foldable container

4 files changed, 89 insertions, 58 deletions

diff --git a/default.nix b/default.nix
index 6cb7da5..f977f6b 100644
--- a/default.nix
+++ b/default.nix
@@ -1,5 +1,5 @@
 { pkgs ? (import <nixpkgs> {})
-, compilerName ? "ghc7103"
+, compilerName ? "ghc801"
 }:
 
 rec {
diff --git a/events/src/Events/Types.hs b/events/src/Events/Types.hs
index 22faf94..0eff7aa 100644
--- a/events/src/Events/Types.hs
+++ b/events/src/Events/Types.hs
@@ -1,37 +1,34 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module Events.Types
        ( TimeRange(..), rangeStart, rangeDuration
        , Event(..), payload, occursWithin
-       , EvalCtx(..), ctxVars, ctxEvents
-       , ObjCtx(..), objOccurs, objPayload
+       , EvalCtx(..), ctxEvents
+       , ObjCtx(..), objVars, objOccurs, objPayload
        , Eval, evaluate
        , module Data.Aeson
        , module Data.Time.Clock
        , module Data.Default.Class
        ) where
 
-import Control.Lens.TH
+import Control.Lens.TH (makeLenses)
   
 import Data.Aeson (Object)
 
-import Data.Time.Clock
+import Data.Time.Clock (UTCTime, NominalDiffTime)
 
-import Control.Monad.State.Lazy
-import ListT (ListT)
-import qualified ListT
+import Control.Monad.State.Lazy (StateT, evalStateT, execStateT)
 
-import Data.Default.Class
+import Data.Default.Class (Default(def))
 
-import Data.Monoid
-import Control.Monad.Fix
-import Control.Lens
-import Data.Maybe
+-- import Data.Monoid
+import Control.Monad.Fix (MonadFix(mfix))
+import Control.Lens ((^.), set)
+import Data.Maybe (catMaybes)
 
-import Debug.Trace
+-- import Debug.Trace
+
+import Events.Types.NDT (NDT, foldNDT)
 
 data TimeRange = TimeRange
                  { _rangeStart :: UTCTime
@@ -46,40 +43,44 @@ data Event = Event
 makeLenses ''Event
 
 data EvalCtx = EvalCtx
-               { _ctxVars :: Object
-               , _ctxEvents :: [Object]
+               { _ctxEvents :: [Object]
                } deriving (Show)
 makeLenses ''EvalCtx
 
 instance Default EvalCtx where
   def = EvalCtx
-        { _ctxVars = mempty
-        , _ctxEvents = mempty
+        { _ctxEvents = mempty
         }
 
 data ObjCtx = ObjCtx
               { _objOccurs :: Bool
               , _objPayload :: Maybe Object
+              , _objVars :: Object
               }
 makeLenses ''ObjCtx
 
 instance Default ObjCtx where
   def = ObjCtx
-        { _objOccurs = False
+        { _objOccurs = True
         , _objPayload = Nothing
+        , _objVars = mempty
         }
 
 objCtx :: ObjCtx -> Maybe Object
-objCtx (ObjCtx False _) = Nothing
-objCtx (ObjCtx True  o) = o
+objCtx ctx
+  | ctx ^. objOccurs = ctx ^. objPayload
+  | otherwise        = Nothing
 
-type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a
+-- type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a
 
-evaluate :: MonadFix m => Eval m () -> m [Object]
-evaluate x = catMaybes <$> mfix x'
-  where
-    x' = evalStateT (ListT.toReverseList (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
+-- evaluate :: MonadFix m => Eval m () -> m [Object] {- TODO: Switch to `ListT m Object` – `m [Object]` will turn out to be to strict. There is no instance for `MonadFix (ListT m)` – writing one seems to be possible. -}
+-- evaluate x = catMaybes <$> mfix x'
+--   where
+--     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
-  put = lift . put
+type Eval m a = StateT ObjCtx (NDT (StateT EvalCtx m)) a
+
+evaluate :: MonadFix m => (Maybe Object -> StateT EvalCtx m Bool) -> Eval m () -> m [Object] {- TODO: Switch to `ListT m Object` – `m [Object]` will turn out to be to strict. There is no instance for `MonadFix (ListT m)` – writing one seems to be possible. -}
+evaluate predicate x = catMaybes <$> mfix x'
+  where
+    x' = evalStateT (foldNDT predicate (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
diff --git a/events/src/Events/Types/NDT.hs b/events/src/Events/Types/NDT.hs
index 94a84f0..8431f51 100644
--- a/events/src/Events/Types/NDT.hs
+++ b/events/src/Events/Types/NDT.hs
@@ -15,10 +15,13 @@ import Data.Foldable (foldr)
 import Data.Maybe
 import Data.Either
 
+import Control.Applicative (Alternative)
+import qualified Control.Applicative as Alt (Alternative(..))
 import Control.Monad
 import Control.Monad.Identity
 
 import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
 
 import Debug.Trace
 
@@ -43,7 +46,6 @@ instance Applicative m => Applicative (NDT m) where
 
 instance Applicative m => Monad (NDT m) where
   return = pure
-  fail = const empty
   (>>=) = NDTBind
 
 instance Monad m => Monoid (NDT m a) where
@@ -56,37 +58,60 @@ instance Monad m => Monoid (NDT m a) where
 instance MonadTrans NDT where
   lift = NDTCons . fmap Just . fmap (,empty)
 
+instance Monad m => Alternative (NDT m) where
+  empty = mempty
+  (<|>) = mappend
+
+instance Monad m => MonadPlus (NDT m) where
+  mzero = mempty
+  mplus = mappend
+
+-- instance MonadFix m => MonadFix (NDT m) where
+--   mfix f = NDTCons . runMaybeT $ do
+--     x <- mfix (head . f)
+--     return (x, trace "tail" . mfix $ tail . f)
+--     where
+--       head :: Monad m => NDT m a -> MaybeT m a
+--       head (NDTCons x) = MaybeT . trace "head (cons)" $ fmap fst <$> x
+--       head (NDTBind (NDTBind x g) f) = head $ NDTBind x (f <=< g)
+--       head (NDTBind (NDTCons x) f) = MaybeT x >>= head . f . fst . trace "head (bind cons)"
+--       tail :: Monad m => NDT m a -> NDT m a
+--       tail (NDTCons x) = NDTBind (lift x) $ maybe empty snd . guardNothing
+--       tail (NDTBind (NDTBind x g) f) = tail $ NDTBind x (f <=< g)
+--       tail (NDTBind (NDTCons x) f) = tail . NDTCons $ fmap (\(_, xs) -> (undefined, NDTBind xs f)) <$> x
+--       guardNothing :: Maybe a -> Maybe a
+--       guardNothing x@(Just _) = x
+--       guardNothing x@(Nothing) = trace "Nothing" x
+
+instance MonadIO m => MonadIO (NDT m) where
+  liftIO = lift . liftIO
+
 empty :: Applicative m => NDT m a
 empty = NDTCons $ pure Nothing
 
 cons :: Applicative m => a -> NDT m a -> NDT m a
 cons x xs = NDTCons . pure $ Just (x, xs)
   
-foldNDT :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m a
-foldNDT sel = fmap snd . foldNDT' sel
-
-foldNDT' :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m (Any, a)
--- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings
-foldNDT' sel (NDTCons mx) = do
+foldNDT :: (Foldable f, Applicative f, Monoid (f a), Monad m) => (a -> m Bool) -> NDT m a -> m (f a)
+-- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings and children
+foldNDT sel (NDTCons mx) = do
   mx' <- mx
   case mx' of
     Nothing -> return mempty
     Just (x, mxs) -> do
       continue <- sel x
       case trace ("(cons "++ show continue ++ ")") continue of
-        False -> return (Any True, mempty)
-        True  -> ((Any True, x) <>) <$> foldNDT' sel mxs
-foldNDT' sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
+        False -> return mempty
+        True  -> (pure x <>) <$> foldNDT sel mxs
+foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
   x' <- x
   case x' of
     Nothing -> return mempty
-    Just (x'', xs) -> do -- foldNDT' sel . NDTCons $ Just . (, NDTBind xs f) . snd <$> foldNDT' sel (f x'')
-      (productive, x3) <- foldNDT' sel $ f x''
-      continue <- sel x3
-      case trace ("(bind cons " ++ show (productive, continue) ++ ")") $ continue || not (getAny productive) of
-        False -> return mempty
-        True -> ((mempty, x3) <>) <$> foldNDT' sel (NDTBind xs f)
-foldNDT' sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT' sel $ NDTBind x (f <=< g)
+    Just (x'', xs) -> do
+      x3 <- foldNDT sel $ f x''
+      xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f)
+      return $ x3 <> xs'
+foldNDT sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT sel $ NDTBind x (f <=< g)
 
 fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
 fromFoldable = foldr cons empty
diff --git a/events/src/Main.hs b/events/src/Main.hs
index 0454f22..a4ffa5a 100644
--- a/events/src/Main.hs
+++ b/events/src/Main.hs
@@ -11,18 +11,23 @@ import Control.Lens
 import Control.Monad
 import Control.Monad.Trans
 import Data.Aeson.Lens
-import Data.Aeson
 
 import Debug.Trace
 
+import Data.Maybe (isJust)
+
 import qualified ListT
+import qualified Events.Types.NDT as NDT
 
 main :: IO ()
--- main = test $ [ Nop
---               , Override [("blub", String "Haha!")]
---               , Occurs True
---               , Occurs False
---               ]
---   where
---     test = CBS.putStr . Yaml.encode <=< evaluate . interpret
-main = undefined
+main = test $ do
+  n <- lift $ NDT.fromFoldable ([1..] :: [Integer])
+  -- objOccurs .= (n <= 5)
+  objOccurs .= (n >= 2)
+  objPayload ?= [ ("num", Yaml.Number $ fromIntegral n)
+                ]
+  where
+    test = CBS.putStr . Yaml.encode <=< evaluate predicate
+    predicate :: Monad m => Maybe Yaml.Object -> m Bool
+    predicate Nothing = return True
+    predicate (Just obj) = return . maybe False (<= 5) . traceShowId $ obj ^. at "num" . asDouble