summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--default.nix2
-rw-r--r--events/src/Events/Types.hs63
-rw-r--r--events/src/Events/Types/NDT.hs59
-rw-r--r--events/src/Main.hs23
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 @@
1{ pkgs ? (import <nixpkgs> {}) 1{ pkgs ? (import <nixpkgs> {})
2, compilerName ? "ghc7103" 2, compilerName ? "ghc801"
3}: 3}:
4 4
5rec { 5rec {
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 @@
1{-# LANGUAGE TemplateHaskell #-} 1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE UndecidableInstances #-}
5 2
6module Events.Types 3module Events.Types
7 ( TimeRange(..), rangeStart, rangeDuration 4 ( TimeRange(..), rangeStart, rangeDuration
8 , Event(..), payload, occursWithin 5 , Event(..), payload, occursWithin
9 , EvalCtx(..), ctxVars, ctxEvents 6 , EvalCtx(..), ctxEvents
10 , ObjCtx(..), objOccurs, objPayload 7 , ObjCtx(..), objVars, objOccurs, objPayload
11 , Eval, evaluate 8 , Eval, evaluate
12 , module Data.Aeson 9 , module Data.Aeson
13 , module Data.Time.Clock 10 , module Data.Time.Clock
14 , module Data.Default.Class 11 , module Data.Default.Class
15 ) where 12 ) where
16 13
17import Control.Lens.TH 14import Control.Lens.TH (makeLenses)
18 15
19import Data.Aeson (Object) 16import Data.Aeson (Object)
20 17
21import Data.Time.Clock 18import Data.Time.Clock (UTCTime, NominalDiffTime)
22 19
23import Control.Monad.State.Lazy 20import Control.Monad.State.Lazy (StateT, evalStateT, execStateT)
24import ListT (ListT)
25import qualified ListT
26 21
27import Data.Default.Class 22import Data.Default.Class (Default(def))
28 23
29import Data.Monoid 24-- import Data.Monoid
30import Control.Monad.Fix 25import Control.Monad.Fix (MonadFix(mfix))
31import Control.Lens 26import Control.Lens ((^.), set)
32import Data.Maybe 27import Data.Maybe (catMaybes)
33 28
34import Debug.Trace 29-- import Debug.Trace
30
31import Events.Types.NDT (NDT, foldNDT)
35 32
36data TimeRange = TimeRange 33data TimeRange = TimeRange
37 { _rangeStart :: UTCTime 34 { _rangeStart :: UTCTime
@@ -46,40 +43,44 @@ data Event = Event
46makeLenses ''Event 43makeLenses ''Event
47 44
48data EvalCtx = EvalCtx 45data EvalCtx = EvalCtx
49 { _ctxVars :: Object 46 { _ctxEvents :: [Object]
50 , _ctxEvents :: [Object]
51 } deriving (Show) 47 } deriving (Show)
52makeLenses ''EvalCtx 48makeLenses ''EvalCtx
53 49
54instance Default EvalCtx where 50instance Default EvalCtx where
55 def = EvalCtx 51 def = EvalCtx
56 { _ctxVars = mempty 52 { _ctxEvents = mempty
57 , _ctxEvents = mempty
58 } 53 }
59 54
60data ObjCtx = ObjCtx 55data ObjCtx = ObjCtx
61 { _objOccurs :: Bool 56 { _objOccurs :: Bool
62 , _objPayload :: Maybe Object 57 , _objPayload :: Maybe Object
58 , _objVars :: Object
63 } 59 }
64makeLenses ''ObjCtx 60makeLenses ''ObjCtx
65 61
66instance Default ObjCtx where 62instance Default ObjCtx where
67 def = ObjCtx 63 def = ObjCtx
68 { _objOccurs = False 64 { _objOccurs = True
69 , _objPayload = Nothing 65 , _objPayload = Nothing
66 , _objVars = mempty
70 } 67 }
71 68
72objCtx :: ObjCtx -> Maybe Object 69objCtx :: ObjCtx -> Maybe Object
73objCtx (ObjCtx False _) = Nothing 70objCtx ctx
74objCtx (ObjCtx True o) = o 71 | ctx ^. objOccurs = ctx ^. objPayload
72 | otherwise = Nothing
75 73
76type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a 74-- type Eval m a = StateT ObjCtx (ListT (StateT EvalCtx m)) a
77 75
78evaluate :: MonadFix m => Eval m () -> m [Object] 76-- 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. -}
79evaluate x = catMaybes <$> mfix x' 77-- evaluate x = catMaybes <$> mfix x'
80 where 78-- where
81 x' = evalStateT (ListT.toReverseList (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes 79-- x' = evalStateT (ListT.toList (objCtx <$> execStateT x def)) . flip (set ctxEvents) def . catMaybes
82 80
83instance MonadState s m => MonadState s (ListT m) where 81type Eval m a = StateT ObjCtx (NDT (StateT EvalCtx m)) a
84 get = lift get 82
85 put = lift . put 83evaluate :: 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. -}
84evaluate predicate x = catMaybes <$> mfix x'
85 where
86 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)
15import Data.Maybe 15import Data.Maybe
16import Data.Either 16import Data.Either
17 17
18import Control.Applicative (Alternative)
19import qualified Control.Applicative as Alt (Alternative(..))
18import Control.Monad 20import Control.Monad
19import Control.Monad.Identity 21import Control.Monad.Identity
20 22
21import Control.Monad.Trans 23import Control.Monad.Trans
24import Control.Monad.Trans.Maybe
22 25
23import Debug.Trace 26import Debug.Trace
24 27
@@ -43,7 +46,6 @@ instance Applicative m => Applicative (NDT m) where
43 46
44instance Applicative m => Monad (NDT m) where 47instance Applicative m => Monad (NDT m) where
45 return = pure 48 return = pure
46 fail = const empty
47 (>>=) = NDTBind 49 (>>=) = NDTBind
48 50
49instance Monad m => Monoid (NDT m a) where 51instance Monad m => Monoid (NDT m a) where
@@ -56,37 +58,60 @@ instance Monad m => Monoid (NDT m a) where
56instance MonadTrans NDT where 58instance MonadTrans NDT where
57 lift = NDTCons . fmap Just . fmap (,empty) 59 lift = NDTCons . fmap Just . fmap (,empty)
58 60
61instance Monad m => Alternative (NDT m) where
62 empty = mempty
63 (<|>) = mappend
64
65instance Monad m => MonadPlus (NDT m) where
66 mzero = mempty
67 mplus = mappend
68
69-- instance MonadFix m => MonadFix (NDT m) where
70-- mfix f = NDTCons . runMaybeT $ do
71-- x <- mfix (head . f)
72-- return (x, trace "tail" . mfix $ tail . f)
73-- where
74-- head :: Monad m => NDT m a -> MaybeT m a
75-- head (NDTCons x) = MaybeT . trace "head (cons)" $ fmap fst <$> x
76-- head (NDTBind (NDTBind x g) f) = head $ NDTBind x (f <=< g)
77-- head (NDTBind (NDTCons x) f) = MaybeT x >>= head . f . fst . trace "head (bind cons)"
78-- tail :: Monad m => NDT m a -> NDT m a
79-- tail (NDTCons x) = NDTBind (lift x) $ maybe empty snd . guardNothing
80-- tail (NDTBind (NDTBind x g) f) = tail $ NDTBind x (f <=< g)
81-- tail (NDTBind (NDTCons x) f) = tail . NDTCons $ fmap (\(_, xs) -> (undefined, NDTBind xs f)) <$> x
82-- guardNothing :: Maybe a -> Maybe a
83-- guardNothing x@(Just _) = x
84-- guardNothing x@(Nothing) = trace "Nothing" x
85
86instance MonadIO m => MonadIO (NDT m) where
87 liftIO = lift . liftIO
88
59empty :: Applicative m => NDT m a 89empty :: Applicative m => NDT m a
60empty = NDTCons $ pure Nothing 90empty = NDTCons $ pure Nothing
61 91
62cons :: Applicative m => a -> NDT m a -> NDT m a 92cons :: Applicative m => a -> NDT m a -> NDT m a
63cons x xs = NDTCons . pure $ Just (x, xs) 93cons x xs = NDTCons . pure $ Just (x, xs)
64 94
65foldNDT :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m a 95foldNDT :: (Foldable f, Applicative f, Monoid (f a), Monad m) => (a -> m Bool) -> NDT m a -> m (f a)
66foldNDT sel = fmap snd . foldNDT' sel 96-- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings and children
67 97foldNDT sel (NDTCons mx) = do
68foldNDT' :: (Monoid a, Monad m) => (a -> m Bool) -> NDT m a -> m (Any, a)
69-- ^ Evaluate depth-first, pruning leaves under the assumption that the selection predicate is monotonic on siblings
70foldNDT' sel (NDTCons mx) = do
71 mx' <- mx 98 mx' <- mx
72 case mx' of 99 case mx' of
73 Nothing -> return mempty 100 Nothing -> return mempty
74 Just (x, mxs) -> do 101 Just (x, mxs) -> do
75 continue <- sel x 102 continue <- sel x
76 case trace ("(cons "++ show continue ++ ")") continue of 103 case trace ("(cons "++ show continue ++ ")") continue of
77 False -> return (Any True, mempty) 104 False -> return mempty
78 True -> ((Any True, x) <>) <$> foldNDT' sel mxs 105 True -> (pure x <>) <$> foldNDT sel mxs
79foldNDT' sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do 106foldNDT sel (NDTBind (NDTCons x) f) = trace "(bind cons)" $ do
80 x' <- x 107 x' <- x
81 case x' of 108 case x' of
82 Nothing -> return mempty 109 Nothing -> return mempty
83 Just (x'', xs) -> do -- foldNDT' sel . NDTCons $ Just . (, NDTBind xs f) . snd <$> foldNDT' sel (f x'') 110 Just (x'', xs) -> do
84 (productive, x3) <- foldNDT' sel $ f x'' 111 x3 <- foldNDT sel $ f x''
85 continue <- sel x3 112 xs' <- if null x3 then return mempty else foldNDT sel (NDTBind xs f)
86 case trace ("(bind cons " ++ show (productive, continue) ++ ")") $ continue || not (getAny productive) of 113 return $ x3 <> xs'
87 False -> return mempty 114foldNDT sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT sel $ NDTBind x (f <=< g)
88 True -> ((mempty, x3) <>) <$> foldNDT' sel (NDTBind xs f)
89foldNDT' sel (NDTBind (NDTBind x g) f) = trace "(bind bind)" . foldNDT' sel $ NDTBind x (f <=< g)
90 115
91fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a 116fromFoldable :: (Foldable f, Monad m) => f a -> NDT m a
92fromFoldable = foldr cons empty 117fromFoldable = 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
11import Control.Monad 11import Control.Monad
12import Control.Monad.Trans 12import Control.Monad.Trans
13import Data.Aeson.Lens 13import Data.Aeson.Lens
14import Data.Aeson
15 14
16import Debug.Trace 15import Debug.Trace
17 16
17import Data.Maybe (isJust)
18
18import qualified ListT 19import qualified ListT
20import qualified Events.Types.NDT as NDT
19 21
20main :: IO () 22main :: IO ()
21-- main = test $ [ Nop 23main = test $ do
22-- , Override [("blub", String "Haha!")] 24 n <- lift $ NDT.fromFoldable ([1..] :: [Integer])
23-- , Occurs True 25 -- objOccurs .= (n <= 5)
24-- , Occurs False 26 objOccurs .= (n >= 2)
25-- ] 27 objPayload ?= [ ("num", Yaml.Number $ fromIntegral n)
26-- where 28 ]
27-- test = CBS.putStr . Yaml.encode <=< evaluate . interpret 29 where
28main = undefined 30 test = CBS.putStr . Yaml.encode <=< evaluate predicate
31 predicate :: Monad m => Maybe Yaml.Object -> m Bool
32 predicate Nothing = return True
33 predicate (Just obj) = return . maybe False (<= 5) . traceShowId $ obj ^. at "num" . asDouble