packages feed

imprevu (empty) → 0.1.0

raw patch · 21 files changed

+1395/−0 lines, 21 filesdep +Booleandep +Cabaldep +DebugTraceHelperssetup-changed

Dependencies added: Boolean, Cabal, DebugTraceHelpers, Imprevu, NoTrace, aeson, base, containers, ghc, lens, monad-loops, mtl, old-locale, random, safe, semigroups, shortcut, stm, time, time-recurrence, validation

Files

+ AUTHORS view
@@ -0,0 +1,1 @@+Corentin Dupont <corentin.dupont@gmail.com>
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2016, Corentin Dupont. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,17 @@++Imprevu+=======++Complex Event Processing library embeddable in DSLs.++Installation+============++    git clone git://github.com/cdupont/Imprevu.git+    stack install++Contact+=======++Bug-reports, questions, suggestions and patches are all welcome.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ imprevu.cabal view
@@ -0,0 +1,69 @@+name: imprevu+version: 0.1.0+cabal-version: >=1.8+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2016 Corentin Dupont+maintainer: Corentin Dupont+stability: Experimental+synopsis: Reactive programming language based on a DSL+description: A DSL to express events+category: Language+Homepage: http://www.nomyx.net+author: Corentin Dupont+data-files:+data-dir: ""+extra-source-files: AUTHORS README.md++library+    build-depends: DebugTraceHelpers  == 0.12.*,+                   Boolean            == 0.2.*,+                   base               >= 4.6 && < 5,+                   containers         == 0.5.*,+                   lens               >= 4.7 && < 4.15,+                   ghc                >= 7.6 && < 8.1,+                   mtl                >= 2.1 && < 2.3,+                   old-locale         == 1.0.*,+                   random             == 1.1.*,+                   safe               == 0.3.*,+                   time               >= 1.4 && < 1.7,+                   time-recurrence    == 0.9.*,+                   monad-loops        == 0.4.*,+                   aeson,+                   stm,+                   validation,+                   semigroups,+                   shortcut,+                   NoTrace+    exposed-modules: Imprevu+                     Imprevu.Types+                     Imprevu.Events+                     Imprevu.Inputs+                     Imprevu.Messages+                     Imprevu.Variables+                     Imprevu.SysMgt+                     Imprevu.Evaluation+                     Imprevu.Evaluation.Types+                     Imprevu.Evaluation.EventEval+                     Imprevu.Evaluation.InputEval+                     Imprevu.Evaluation.TimeEval+                     Imprevu.Evaluation.Utils+                     Imprevu.Test.TestMgt+                     Imprevu.Test.Test+    exposed: True+    buildable: True+    hs-source-dirs: src+    ghc-options: -W++Test-Suite test+    type:      detailed-0.9+    test-module:    Test+    hs-source-dirs: test+    build-depends: base,+                   Imprevu            == 0.7.6,+                   Cabal              >= 0.22++source-repository head+  type:              git+  location:          https://github.com/cdupont/Nomyx.git
+ src/Imprevu.hs view
@@ -0,0 +1,15 @@++module Imprevu (+  module Imprevu.Events,+  module Imprevu.Inputs,+  module Imprevu.Messages,+  module Imprevu.SysMgt,+  module Imprevu.Types,+  module Imprevu.Variables) where++import Imprevu.Events+import Imprevu.Inputs+import Imprevu.Messages+import Imprevu.SysMgt+import Imprevu.Types+import Imprevu.Variables
+ src/Imprevu/Evaluation.hs view
@@ -0,0 +1,13 @@++module Imprevu.Evaluation (+  module Imprevu.Evaluation.Types,+  module Imprevu.Evaluation.EventEval,+  module Imprevu.Evaluation.InputEval,+  module Imprevu.Evaluation.TimeEval,+  module Imprevu.Evaluation.Utils) where++import Imprevu.Evaluation.Types+import Imprevu.Evaluation.EventEval+import Imprevu.Evaluation.InputEval+import Imprevu.Evaluation.TimeEval+import Imprevu.Evaluation.Utils
+ src/Imprevu/Evaluation/EventEval.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell           #-}+++-- | Evaluation of the events+module Imprevu.Evaluation.EventEval where++import           Control.Applicative+import           Control.Lens+import           Control.Monad+import           Control.Monad.State+import           Control.Monad.Except+import           Data.Either+import           Data.List+import           Data.Maybe+import           Data.Validation+import           Data.Typeable+import           Imprevu.Types+import           Imprevu.Evaluation.Types+import           Imprevu.Evaluation.Utils+import           Prelude                     hiding (log)+import           Safe+import           Debug.NoTrace -- .Helpers    (traceM)+++-- * Event triggers++-- trigger an event with an event result+triggerEvent :: (Show a, Typeable a, Show e, Typeable e, Eq a) => Signal a e -> e -> EvaluateN n s ()+triggerEvent e dat = do+   evs <- use events+   let evs' = evs -- sortBy (compare `on` _ruleNumber) evs+   let sd = (SignalData e dat)+   eids <- mapM (getUpdatedEventInfo sd) evs'           -- get all the EventInfoNs updated with the field+   traceM $ "triggerEvent' eids=" ++ (show eids) ++ " sd=" ++ (show sd) ++ " evs=" ++ (show evs)+   events %= union (map fst eids)                           -- store them+   void $ mapM triggerIfComplete eids                           -- trigger the handlers for completed events++-- if the event is complete, trigger its handler+triggerIfComplete :: (EventInfoN n, Maybe SomeData) -> EvaluateN n s ()+triggerIfComplete (ei@(EventInfo en _ h SActive _), Just (SomeData val)) = case cast val of+   Just a -> do+      traceM $ "triggerIfComplete: " ++ (show a)+      eval <- use (evalConf . evalFunc)+      err <- use (evalConf . errorHandler)+      withEvent <- use (evalConf . withEvent)+      void $ withEvent ei $ (eval $ h (en, a)) `catchError` (err en)+   Nothing -> error "Bad trigger data type"+triggerIfComplete _ = return ()+++-- get update the EventInfoN updated with the signal data.+-- get the event result if all signals are completed+getUpdatedEventInfo :: SignalData -> EventInfoN n -> EvaluateN n s (EventInfoN n, Maybe SomeData)+getUpdatedEventInfo sd@(SignalData sig _) ei@(EventInfo _ ev _ _ envi) = do+   trs <- getEventResult ev envi+   traceM $ "\ngetUpdatedEventInfo result of event after applying envi=" ++ (show trs) -- ++ " envi=" ++ (show envi) ++ " sig=" ++ (show sig) ++ " addr=" ++ (show addr)+   case trs of+      AccFailure rs -> case find (\(sa, (SomeSignal ss)) -> (ss === sig)) rs of -- check if our signal match one of the remaining signals+         Just (sa, _) -> do+            let envi' = SignalOccurence sd sa : envi+            er <- getEventResult ev envi'                                                           -- add our event to the environment and get the result+            case er of+               AccFailure _ -> do+                 traceM $ "getUpdatedEventInfo event to be completed"+                 return (env .~ envi' $ ei, Nothing)                                              -- some other signals are left to complete: add ours in the environment+               AccSuccess a -> do+                 traceM $ "getUpdatedEventInfo event completed"+                 return (env .~  [] $ ei, Just $ SomeData a)                                       -- event complete: return the final data result+         Nothing -> do+           traceM "getUpdatedEventInfo: no Event matches"+           return (ei, Nothing)                                                            -- our signal does not belong to this event.+      AccSuccess a -> return (env .~  [] $ ei, Just $ SomeData a)+++-- * Evaluations++--get the signals left to be completed in an event+getRemainingSignals' :: EventInfoN n -> EvaluateN n s [SomeSignal]+getRemainingSignals' (EventInfo _ e _ _ envi) = do+   tr <- getEventResult e envi+   return $ case tr of+      AccSuccess _ -> []+      AccFailure a -> map snd a++getRemainingSignals :: EventInfoN n -> EvalEnvN n s -> [SomeSignal]+getRemainingSignals ei env = join $ maybeToList $ evalState (runEvalError (getRemainingSignals' ei)) env+++-- compute the result of an event given an environment.+-- in the case the event cannot be computed because some signals results are pending, return that list instead.+getEventResult :: EventM n a -> [SignalOccurence] -> EvaluateN n s (AccValidation [(SignalAddress, SomeSignal)] a)+getEventResult e frs = getEventResult' e frs []++-- compute the result of an event given an environment. The third argument is used to know where we are in the event tree.+getEventResult' :: EventM n a -> [SignalOccurence] -> SignalAddress -> EvaluateN n s (AccValidation [(SignalAddress, SomeSignal)] a)+getEventResult' (PureEvent a)   _   _  = return $ AccSuccess a+getEventResult'  EmptyEvent     _   _  = return $ AccFailure []+getEventResult' (SumEvent a b)  ers fa = liftM2 (<|>) (getEventResult' a ers (fa ++ [SumL])) (getEventResult' b ers (fa ++ [SumR]))+getEventResult' (AppEvent f b)  ers fa = liftM2 (<*>) (getEventResult' f ers (fa ++ [AppL])) (getEventResult' b ers (fa ++ [AppR]))+getEventResult' (LiftEvent a)   _   _  = do+   eval <- use (evalConf . evalFunc)+   AccSuccess <$> eval a+   --return $ AccSuccess r+getEventResult' (BindEvent a f) ers fa = do+   er <- getEventResult' a ers (fa ++ [BindL])+   case er of+      AccSuccess a' -> getEventResult' (f a') ers (fa ++ [BindR])+      AccFailure bs -> return $ AccFailure bs++getEventResult' (SignalEvent a) ers fa = return $ case lookupSignal a fa ers of+   Just r  -> AccSuccess r+   Nothing -> AccFailure [(fa, SomeSignal a)]++getEventResult' (ShortcutEvents es f) ers fa = do+  ers' <- mapM (\e -> getEventResult' e ers (fa ++ [Shortcut])) es -- get the result for each event in the list+  traceM $ "getEventResult" ++ (show $ f (toMaybe <$> ers'))+  return $ if f (toMaybe <$> ers')                                   -- apply f to the event results that we already have+     then AccSuccess $ toMaybe <$> ers'                               -- if the result is true, we are done. Return the list of maybe results+     else AccFailure $ join $ lefts $ toEither <$> ers'                  -- otherwise, return the list of remaining fields to complete from each event+++-- find a signal occurence in an environment+lookupSignal :: (Typeable a, Typeable s, Eq s) => Signal s a -> SignalAddress -> [SignalOccurence] -> Maybe a+lookupSignal s sa envi = headMay $ mapMaybe (getSignalData s sa) envi++--get the signal data from the signal occurence+getSignalData :: (Typeable a, Typeable s, Eq s) => Signal s a -> SignalAddress -> SignalOccurence -> Maybe a+getSignalData s sa (SignalOccurence (SignalData s' res) sa') = do+  res' <- cast res+  if (sa' == sa) && (s === s') then Just res' else Nothing++runEvalError :: EvaluateN n s a -> State (EvalEnvN n s) (Maybe a)+runEvalError egs = do+   e <- runExceptT egs+   log <- use (evalConf . errorHandler)+   case e of+      Right a -> return $ Just a+      Left e' -> do+         traceM $ "Error: " ++ e'+         void $ runExceptT $ log 0 $ "Error: " ++ e'+         return Nothing++runEvaluate :: EvaluateN n s a -> EvalEnvN n s -> Maybe a+runEvaluate ev ee = evalState (runEvalError ev) ee++--TODO simplify+execSignals :: (Show a, Show e, Typeable e, Eq e, Show d, Typeable d, Eq d) => n a -> [(Signal e d, d)] -> EvalEnvN n s -> s+execSignals r sds evalEnv = _evalEnv $ runIdentity $ flip execStateT evalEnv $ do+   res <- runExceptT $ do+      let eval = _evalFunc $ _evalConf evalEnv+      eval r+      mapM_ (\(f,d) -> triggerEvent f d) sds+   case res of+      Right a -> return a+      Left s -> error $ "error occured: " ++ s++
+ src/Imprevu/Evaluation/InputEval.hs view
@@ -0,0 +1,15 @@++-- | Evaluation of the inputs+module Imprevu.Evaluation.InputEval where++import           Imprevu.Types+import           Imprevu.Evaluation.Types+import           Imprevu.Evaluation.EventEval++triggerInput :: Input -> InputData -> EvaluateN n s ()+triggerInput is@(Input (Text _) _)       (TextData a)     = triggerEvent (Signal is) a+triggerInput is@(Input (TextArea _) _)   (TextAreaData a) = triggerEvent (Signal is) a+triggerInput is@(Input (Button _) _)     (ButtonData)     = triggerEvent (Signal is) ()+triggerInput is@(Input (Radio _ _) _)    (RadioData a)    = triggerEvent (Signal is) a+triggerInput is@(Input (Checkbox _ _) _) (CheckboxData a) = triggerEvent (Signal is) a+triggerInput _ _ = error "triggerInput"
+ src/Imprevu/Evaluation/TimeEval.hs view
@@ -0,0 +1,52 @@++{-# LANGUAGE AllowAmbiguousTypes      #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE Rank2Types      #-}++module Imprevu.Evaluation.TimeEval where++import Imprevu.Types+import Imprevu.Evaluation.EventEval+import Imprevu.Evaluation.Types+import Data.Time+import Data.Maybe+import Data.Typeable+import Control.Concurrent.STM+import Control.Concurrent+import Control.Monad+import Control.Lens++type Time = Signal UTCTime UTCTime++--launchTimeEvents :: (Monad n) => TVar s -> EvalConfN n s -> IO ()+--launchTimeEvents tv ec = do+--    now <- getCurrentTime+--    --putStrLn $ "tick " ++ (show now)+--    s <- atomically $ readTVar tv+--    let timeEvents = join $ maybeToList $ runEvaluate (getTimeEvents now) (EvalEnv s ec)+--    unless (null timeEvents) $ putStrLn "found time event(s)"+--    mapM_ (triggerTimeEvent tv ec) timeEvents+--    --sleep 30 second roughly+--    threadDelay 30000000+--    launchTimeEvents tv ec++triggerTimeEvent :: (Monad n) => EvalConfN n s -> UTCTime -> s -> s+triggerTimeEvent ec t s = execSignals (return ()) [(Signal t, t)] (EvalEnv s ec)+    --save m'++-- | get all events that has not been triggered yet+getTimeEvents :: UTCTime -> EvaluateN n s [UTCTime]+getTimeEvents now = do+   eis <- use events+   times <- mapM getTimes eis+   return $ filter (\t -> t <= now && t > (-32) `addUTCTime` now) (join times)++getTimes :: EventInfoN n -> EvaluateN n s [UTCTime]+getTimes ei = do+  rss <- getRemainingSignals' ei+  return $ mapMaybe getTime rss++getTime :: SomeSignal -> Maybe UTCTime+getTime (SomeSignal (Signal t)) = cast t+getTime _                    = Nothing+
+ src/Imprevu/Evaluation/Types.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell           #-}++module Imprevu.Evaluation.Types where++import           Control.Lens+import           Control.Monad.Except+import           Control.Monad.State+import           Imprevu.Types++data EvalEnvN n s = EvalEnv { _evalEnv     :: s,+                              _evalConf    :: EvalConfN n s}++data EvalConfN n s = EvalConf { getEvents     :: s -> [EventInfoN n],+                                setEvents     :: [EventInfoN n] -> s -> s,+                                _evalFunc     :: forall a. n a -> EvaluateN n s a,           -- evaluation function+                                _errorHandler :: EventNumber -> String -> EvaluateN n s (),  -- error function+                                _withEvent    :: EventInfoN n -> EvaluateN n s () -> EvaluateN n s ()}  -- change the context of the event++-- | Environment necessary for the evaluation+type EvaluateN n s a = ExceptT String (State (EvalEnvN n s)) a++makeLenses ''EvalEnvN+makeLenses ''EvalConfN++events :: Lens' (EvalEnvN n s) [EventInfoN n]+events f ee@(EvalEnv s (EvalConf ge se _ _ _)) = fmap (\s' -> ee{_evalEnv = se s' s}) (f $ ge s)+
+ src/Imprevu/Evaluation/Utils.hs view
@@ -0,0 +1,47 @@++module Imprevu.Evaluation.Utils (+   (===),+   replaceWith,+   sel,+   toEither,+   toMaybe,+   module Debug.Trace) where++import Control.Lens           hiding (runIdentity)+import Control.Monad.Identity+import Control.Monad.State+import Control.Applicative+import Data.Typeable          (Typeable, cast)+import Debug.Trace            (trace)+import Data.Validation+import Data.Semigroup++-- | an equality that tests also the types.+(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool+(===) x y = cast x == Just y++-- | Replaces all instances of a value in a list by another value.+replaceWith :: (a -> Bool)   -- ^ Value to search+        -> a   -- ^ Value to replace it with+        -> [a] -- ^ Input list+        -> [a] -- ^ Output list+replaceWith f y = map (\z -> if f z then y else z)++sel :: [a]   -- ^ List of indices to select+    -> [Int] -- ^ List of elements+    -> [a]   -- ^ List composed of elements selected from original set by indices provided+sel xs is = map (\i -> xs!!i) is++toMaybe :: AccValidation a b -> Maybe b+toMaybe (AccFailure _) = Nothing+toMaybe (AccSuccess a) = Just a++toEither :: AccValidation a b -> Either a b+toEither (AccFailure as) = Left as+toEither (AccSuccess a)  = Right a++instance (Monoid e, Semigroup e) => Alternative (AccValidation e) where+   empty               = AccFailure mempty+   AccFailure as <|> AccFailure bs = AccFailure $ as `mappend` bs+   AccFailure _  <|> n       = n+   m       <|> _       = m
+ src/Imprevu/Events.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | All the building blocks to allow rules to build events.+module Imprevu.Events+--   onEvent, onEvent_, onEventOnce,+--   delEvent,+--   getEvents, getEvent,+--   getIntermediateResults,+--   schedule, schedule_, schedule', schedule'_,+--   getCurrentTime,+--   oneWeek, oneDay, oneHour, oneMinute,+--   timeEvent, messageEvent, victoryEvent, playerEvent, ruleEvent,+--   signalEvent, inputFormSignal,+--   liftEvent+    where++import Imprevu.Types+import Imprevu.SysMgt+import Control.Monad.Except+import Data.Typeable+import Data.Time hiding (getCurrentTime)+import Data.Time.Recurrence hiding (filter)+import Data.List+import Data.Maybe+import Safe++class (Typeable n, Applicative n, Monad n) => EvMgt n where+   --Events management+   onEvent         :: (Typeable a, Show a) => EventM n a -> ((EventNumber, a) -> n ()) -> n EventNumber+   delEvent        :: EventNumber -> n Bool+   getEvents       :: n [EventInfoN n]+   sendMessage     :: (Typeable a, Show a, Eq a) => Msg a -> a -> n ()++type Msg m = Signal String m++partial :: (MonadError String n) => String -> n (Maybe a) -> n a+partial s nm = do+   m <- nm+   case m of+      Just a -> return a+      Nothing -> throwError s++-- * Events++-- | register a callback on an event, disregard the event number+onEvent_ :: (Typeable a, Show a, EvMgt n) => EventM n a -> (a -> n ()) -> n EventNumber+onEvent_ e h = onEvent e (\(_, d) -> h d)++-- | set an handler for an event that will be triggered only once+onEventOnce :: (Typeable a, Show a, EvMgt n) => EventM n a -> (a -> n ()) -> n EventNumber+onEventOnce e h = do+    let handler (en, ed) = delEvent en >> h ed+    onEvent e handler++getEvent :: (EvMgt n) => EventNumber -> n (Maybe (EventInfoN n))+getEvent en = find (\(EventInfo en2 _ _ evst _) -> en == en2 && evst == SActive) <$> getEvents++getIntermediateResults :: (EvMgt n) => EventNumber -> n (Maybe [(ClientNumber, SomeData)])+getIntermediateResults en = do+   mev <- getEvent en+   case mev of+      Just ev -> return $ Just $ mapMaybe getInputResult (_env ev)+      Nothing -> return Nothing++getInputResult :: SignalOccurence -> Maybe (ClientNumber, SomeData)+getInputResult = undefined+--getInputResult (SignalOccurence (SignalData (InputS _ cn) r) _) = Just (cn, SomeData r)+--getInputResult _ = Nothing++-- | on the provided schedule, the supplied function will be called+schedule :: (EvMgt n, SysMgt n) => Schedule Freq -> (UTCTime -> n ()) -> n ()+schedule sched f = do+    now <- getCurrentTime+    let next = head $ starting now sched+    if next == now then executeAndScheduleNext f sched now+                   else void $ onEventOnce (timeEvent next) $ executeAndScheduleNext f sched++executeAndScheduleNext :: (EvMgt n) => (UTCTime -> n ()) -> Schedule Freq -> UTCTime -> n ()+executeAndScheduleNext f sched now = do+   f now+   let rest = drop 1 $ starting now sched+   when (rest /= []) $ void $ onEventOnce (timeEvent $ head rest) $ executeAndScheduleNext f sched++schedule_ :: (EvMgt n, SysMgt n) => Schedule Freq -> n () -> n ()+schedule_ ts f = schedule ts (const f)++--at each time provided, the supplied function will be called+schedule' :: (EvMgt n, SysMgt n) => [UTCTime] -> (UTCTime -> n ()) -> n ()+schedule' sched f = do+   let sched' = sort sched+   now <- getCurrentTime+   let nextMay = headMay $ filter (>=now) sched'+   case nextMay of+       Just next -> if next == now then executeAndScheduleNext' f sched' now+                                  else void $ onEventOnce (timeEvent next) $ executeAndScheduleNext' f sched'+       Nothing -> return ()++executeAndScheduleNext' :: (EvMgt n) => (UTCTime -> n ()) -> [UTCTime] -> UTCTime -> n ()+executeAndScheduleNext' f sched now = do+   f now+   let rest = drop 1 sched+   when (rest /= []) $ void $ onEventOnce (timeEvent $ head rest) $ executeAndScheduleNext' f sched+++--schedule'_ :: [UTCTime] -> Nomex () -> Nomex ()+--schedule'_ ts f = schedule' ts (const f)++-- * Individual events++-- | Build an event firing at a specific time+timeEvent :: UTCTime -> EventM n UTCTime+timeEvent t = SignalEvent $ Signal t++-- | Build a message event, that can be intercepted by another rule+-- this is useful for message-passing style of communication+messageEvent :: (Typeable a, Show a, Eq a) => Msg a -> EventM n a+messageEvent m = SignalEvent m++-- | Build a event firing immediatly, yelding the value of the Nomex+liftEvent :: n a -> EventM n a+liftEvent = LiftEvent++-- * internals++ -- Embed a single Signal as an EventM+signalEvent    :: (Eq s, Typeable s, Show s, Typeable e, Show e, Eq e) => s -> EventM n e+signalEvent = SignalEvent . Signal++-- Embed a single Signal as an EventM+inputEvent    :: (Typeable e, Show e, Eq e) => InputField -> ClientNumber -> EventM n e+inputEvent i cn = SignalEvent $ Signal $ Input i cn++
+ src/Imprevu/Inputs.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | All the building blocks to allow rules to get inputs.+module Imprevu.Inputs+--   InputForm(..),+--   inputRadio, inputText, inputCheckbox, inputButton, inputTextarea,+--   onInputRadio,    onInputRadio_,    onInputRadioOnce, inputRadio',+--   onInputText,     onInputText_,     onInputTextOnce,+--   onInputCheckbox, onInputCheckbox_, onInputCheckboxOnce,+--   onInputButton,   onInputButton_,   onInputButtonOnce,+--   onInputTextarea, onInputTextarea_, onInputTextareaOnce,+    where++import Imprevu.Events+import Imprevu.Types+import Data.Typeable++-- * Inputs++-- ** Radio inputs++-- | event based on a radio input choice+inputRadio :: (Enum a) => ClientNumber -> String -> [(a, String)] -> EventM n a+inputRadio cn title cs = toEnum <$> SignalEvent (inputRadioSignal title (map (\(a, s) -> (fromEnum a, s)) cs) cn)++-- | triggers a choice input to the user. The result will be sent to the callback+-- TODO: necessary Typeable?+onInputRadio :: (EvMgt n, Enum a, Show a, Typeable a) => String -> [(a, String)] -> (EventNumber -> a -> n ()) -> ClientNumber -> n EventNumber+onInputRadio title choices handler pn = onEvent (inputRadio pn title choices) (\(en, a) -> handler en a)++-- | the same, disregard the event number+onInputRadio_ :: (EvMgt n, Enum a, Show a, Typeable a) => String -> [(a, String)] -> (a -> n ()) -> ClientNumber -> n EventNumber+onInputRadio_ title choices handler pn = onEvent_ (inputRadio pn title choices) handler++-- | the same, suppress the event after first trigger+onInputRadioOnce :: (EvMgt n, Enum a, Show a, Typeable a) => String -> [(a, String)] -> (a -> n ()) -> ClientNumber -> n EventNumber+onInputRadioOnce title choices handler pn = onEventOnce (inputRadio pn title choices) handler++-- ** Text inputs++-- | event based on a text input+inputText :: ClientNumber -> String -> EventM n String+inputText cn title = SignalEvent (inputTextSignal title cn)++-- | triggers a string input to the user. The result will be sent to the callback+onInputText :: (EvMgt n) => String -> (EventNumber -> String -> n ()) -> ClientNumber -> n EventNumber+onInputText title handler pn = onEvent (inputText pn title) (\(en, a) -> handler en a)++-- | asks the player pn to answer a question, and feed the callback with this data.+onInputText_ :: (EvMgt n) => String -> (String -> n ()) -> ClientNumber -> n EventNumber+onInputText_ title handler pn = onEvent_ (inputText pn title) handler++-- | asks the player pn to answer a question, and feed the callback with this data.+onInputTextOnce :: (EvMgt n) => String -> (String -> n ()) -> ClientNumber -> n EventNumber+onInputTextOnce title handler pn = onEventOnce (inputText pn title) handler+++-- ** Checkbox inputs++-- | event based on a checkbox input+inputCheckbox :: (Enum a) => ClientNumber -> String -> [(a, String)] -> EventM n [a]+inputCheckbox cn title cs = (map toEnum) <$> SignalEvent (inputCheckboxSignal title (map (\(a, s) -> (fromEnum a, s)) cs) cn)++onInputCheckbox :: (EvMgt n, Enum a, Show a, Typeable a) => String -> [(a, String)] -> (EventNumber -> [a] -> n ()) -> ClientNumber -> n EventNumber+onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, a) -> handler en a)++onInputCheckbox_ :: (EvMgt n, Enum a, Show a, Typeable a) => String -> [(a, String)] -> ([a] -> n ()) -> ClientNumber -> n EventNumber+onInputCheckbox_ title choices handler pn = onEvent_ (inputCheckbox pn title choices) handler++onInputCheckboxOnce :: (EvMgt n, Enum a, Show a, Typeable a) => String -> [(a, String)] -> ([a] -> n ()) -> ClientNumber -> n EventNumber+onInputCheckboxOnce title choices handler pn = onEventOnce (inputCheckbox pn title choices) handler++-- ** Button inputs++-- | event based on a button+inputButton :: ClientNumber -> String -> EventM n ()+inputButton cn title = SignalEvent (inputButtonSignal title cn)++onInputButton :: (EvMgt n) => String -> (EventNumber -> () -> n ()) -> ClientNumber -> n EventNumber+onInputButton title handler pn = onEvent (inputButton pn title) (\(en, ()) -> handler en ())++onInputButton_ :: (EvMgt n) => String -> (() -> n ()) -> ClientNumber -> n EventNumber+onInputButton_ title handler pn = onEvent_ (inputButton pn title) handler++onInputButtonOnce :: (EvMgt n) => String -> (() -> n ()) -> ClientNumber -> n EventNumber+onInputButtonOnce title handler pn = onEventOnce (inputButton pn title) handler+++-- ** Textarea inputs++-- | event based on a text area+inputTextarea :: ClientNumber -> String -> EventM n String+inputTextarea cn title = SignalEvent (inputTextareaSignal title cn)++onInputTextarea :: (EvMgt n) => String -> (EventNumber -> String -> n ()) -> ClientNumber -> n EventNumber+onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en a)++onInputTextarea_ :: (EvMgt n) => String -> (String -> n ()) -> ClientNumber -> n EventNumber+onInputTextarea_ title handler pn = onEvent_ (inputTextarea pn title) handler++onInputTextareaOnce :: (EvMgt n) => String -> (String -> n ()) -> ClientNumber -> n EventNumber+onInputTextareaOnce title handler pn = onEventOnce (inputTextarea pn title) handler+++-- ** Internals++inputRadioSignal :: String -> [(Int, String)] -> ClientNumber -> Signal Input Int+inputRadioSignal title cs cn = Signal (Input (Radio title cs) cn)++inputTextSignal :: String -> ClientNumber -> Signal Input String+inputTextSignal title cn = Signal (Input (Text title) cn)++inputCheckboxSignal :: String -> [(Int, String)] -> ClientNumber -> Signal Input [Int]+inputCheckboxSignal title cs cn = Signal (Input (Checkbox title cs) cn)++inputButtonSignal :: String -> ClientNumber -> Signal Input ()+inputButtonSignal title cn = Signal (Input (Button title) cn)++inputTextareaSignal :: String -> ClientNumber -> Signal Input String+inputTextareaSignal title cn = Signal (Input (TextArea title) cn)+
+ src/Imprevu/Messages.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module Imprevu.Messages+--  sendMessage, sendMessage_,+--  onMessage, onMessageOnce,+--  APICall(..), onAPICall, callAPI, callAPIBlocking,+  where++import Control.Monad.Loops (untilJust)+import Control.Monad+import Control.Monad.Except+import Data.Typeable+import Imprevu.Events+import Imprevu.Types+import Imprevu.SysMgt+import Imprevu.Variables++-- * Messages+-- a rule can send a simple message to another rule, and subscribe to a message.++-- | send an empty message+sendMessage_ :: (EvMgt n) => String -> n ()+sendMessage_ m = sendMessage (Signal m) ()++-- | subscribe on a message+onMessage :: (Typeable m, Show m, Eq m, EvMgt n) => Msg m -> (m -> n ()) -> n EventNumber+onMessage name = onEvent_ (messageEvent name)++-- | subscribe on a message, delete it on the first call+onMessageOnce :: (Typeable m, Show m, Eq m, EvMgt n) => Msg m -> (m -> n ()) -> n EventNumber+onMessageOnce name = onEventOnce (messageEvent name)++-- * API calls+-- Nomyx Rule can register an API function with 'onAPICall' to provide services to other rules.+-- other Rules are then able to call 'callAPI' or 'callAPIBlocking' to access the services.+-- API calls between Rules are build using message passing.++-- | types of API calls+data APICall a r = APICall String++-- version with one parameters+onAPICall :: (Typeable a, Show a, Eq a, Typeable r, Show r, Eq r, EvMgt n) => APICall a r -> (a -> n r) -> n EventNumber+onAPICall (APICall name) action = onMessage (Signal name) (\(msg, a) -> action a >>= sendMessage msg)++-- | version with one parameters+callAPI :: (Typeable a, Show a, Eq a, Typeable r, Show r, Eq r, EvMgt n, SysMgt n) => APICall a r -> a -> (r -> n ()) -> n ()+callAPI (APICall name) a callback = do+   msgTemp <- createTempMsg callback+   sendMessage (Signal name) (msgTemp, a)++-- | call an API function and wait for the result.+callAPIBlocking :: (Typeable a, Show a, Eq a, Typeable r, Show r, Eq r, EvMgt n, VarMgt n, SysMgt n, MonadError String n) => APICall a r -> a -> n r+callAPIBlocking apiName param = do+  v <- getTempVar Nothing+  callAPI apiName param (\r -> void $ writeVar v (Just r))+  r <- untilJust $ readVar_ v+  delVar v+  return r++-- * Internals++-- | creates a temporary message with a random name+createTempMsg :: (Typeable m, Show m, Eq m, EvMgt n, SysMgt n) => (m -> n ()) -> n (Msg m)+createTempMsg callback = do+  r <- getRandomNumber (0, 100000::Int)+  let msg = Signal ("APIcallback" ++ (show r))+  onMessageOnce msg callback+  return msg
+ src/Imprevu/SysMgt.hs view
@@ -0,0 +1,10 @@++module Imprevu.SysMgt where++import Data.Time+import System.Random++class (Monad n) => SysMgt n where+   getCurrentTime  :: n UTCTime+   getRandomNumber :: Random a => (a, a) -> n a+
+ src/Imprevu/Test/Test.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}++module Imprevu.Test.Test where++import Control.Monad.State+import Control.Applicative+import Control.Shortcut+import Data.Typeable+import Data.List+import Data.Maybe+import Data.Time+import Imprevu.Events+import Imprevu.Inputs+import Imprevu.Variables+import Imprevu.Messages+import Imprevu.Types+import Imprevu.Test.TestMgt+import Prelude++-- * Tests++data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded)++-- Test input+testSingleInput :: TestM ()+testSingleInput = void $ onInputRadio "Vote for Holland or Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where+   h _ a = putStrLn' ("voted for " ++ show a)++testSingleInputEx :: Bool+testSingleInputEx = "voted for Holland" `elem` g where+   g = execEvent testSingleInput (inputRadioSignal "Vote for Holland or Sarkozy" [(0, "Holland"), (1, "Sarkozy")] 1) (0::Int)++testMultipleInputs :: TestM ()+testMultipleInputs = void $ onInputCheckbox "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where+   h _ a = putStrLn' ("voted for " ++ show a)++testMultipleInputsEx :: Bool+testMultipleInputsEx = "voted for [Holland,Sarkozy]" `elem` g where+   g = execEvent testMultipleInputs (inputCheckboxSignal "Vote for Holland and Sarkozy" [(0, "Holland"), (1, "Sarkozy")] 1) [0, 1 :: Int]++testInputString :: TestM ()+testInputString = void $ onInputText_ "Enter a number:" h 1 where+   h a = putStrLn' ("You entered: " ++ a)++testInputStringEx :: Bool+testInputStringEx = "You entered: 1" `elem` g where+   g = execEvent testInputString (inputTextSignal "Enter a number:" 1) "1"++-- Test message+testSendMessage :: TestM ()+testSendMessage = do+    let msg = Signal "msg" :: Msg String+    onEvent_ (messageEvent msg) f+    sendMessage msg "toto" where+        f (a :: String) = putStrLn' a++testSendMessageEx :: Bool+testSendMessageEx = "toto" `elem` (exec testSendMessage)++testSendMessage2 :: TestM ()+testSendMessage2 = do+    onEvent_ (messageEvent (Signal "msg" :: Msg ())) $ const $ putStrLn' "Received"+    sendMessage_ "msg"++testSendMessageEx2 :: Bool+testSendMessageEx2 = "Received" `elem` (exec testSendMessage2)++testAPICall :: TestM ()+testAPICall = do+    let call = APICall "test" :: APICall String String+    onAPICall call return+    callAPI call "toto" putStrLn'++testAPICallEx :: Bool+testAPICallEx = "toto" `elem` (exec testAPICall)++testAPICall2 :: TestM ()+testAPICall2 = do+    let call = APICall "test" :: APICall String String+    onAPICall call return+    a <- callAPIBlocking call "toto"+    putStrLn' a++testAPICallEx2 :: Bool+testAPICallEx2 = "toto" `elem` (exec testAPICall2)++data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded)++-- Test user input + variable read/write+testUserInputWrite :: TestM ()+testUserInputWrite = do+    newVar_ "vote" (Nothing::Maybe Choice2)+    onEvent_ (messageEvent (Signal "voted" :: Msg ())) h2+    void $ onInputRadio "Vote for" [(Me, "Me"), (You, "You")] h1 1 where+        h1 _ a = do+            writeVar (V "vote") (Just a)+            sendMessage (Signal "voted") ()+        h2 _ = do+            a <- readVar (V "vote")+            void $ case a of+                Just (Just Me) -> putStrLn' "voted Me"+                _ -> putStrLn' "problem"+++testUserInputWriteEx :: Bool+testUserInputWriteEx = "voted Me" `elem` g where+   g = execEvent testUserInputWrite (inputRadioSignal "Vote for" [(0, "Me"), (1, "You")] 1) (0::Int)++-- Event composition++testSumCompose :: TestM ()+testSumCompose = void $ onEvent_ (True <$ inputButton 1 "click here:" <|> False <$ inputButton 2 "") f where+   f a = putStrLn' $ show a++testSumComposeEx :: Bool+testSumComposeEx = "True" `elem` g where+   g = execEvent testSumCompose (inputButtonSignal "click here:" 1) () ++testProdCompose :: TestM ()+testProdCompose = void $ onEvent_ ((,) <$> inputText 1 "" <*> inputText 1 "") f where+   f a = putStrLn' $ show a++testProdComposeEx1 :: Bool+testProdComposeEx1 = null g where+   g = execEvent testProdCompose (inputTextSignal "" 1) ""++testProdComposeEx2 :: Bool+testProdComposeEx2 = "(\"toto\",\"tata\")" `elem` g where+   g = execEvents testProdCompose [(inputTextSignal "" 1, "toto"), (inputTextSignal "" 1, "tata")]++testTwoEvents :: TestM ()+testTwoEvents = do+   void $ onInputText_ "" f 1+   void $ onInputText_ "" f 1 where+   f a = putStrLn' $ show a++testTwoEventsEx :: Bool+testTwoEventsEx = (length g) == 1 where+   g = execEvent testTwoEvents (inputTextSignal "" 1) "toto"++testMonadicEvent :: TestM ()+testMonadicEvent = do+   let displayMsg a = putStrLn' a+   let e = do+       a <- inputText 1 ""+       guard (a == "coco1") >> inputText 1 ""+   void $ onEvent_ e displayMsg++testMonadicEventEx :: Bool+testMonadicEventEx = "coco2" `elem` g where+   g = execEvents testMonadicEvent [(inputTextSignal "" 1, "coco1"), (inputTextSignal "" 1, "coco2")]++testShorcutEvent :: TestM ()+testShorcutEvent = do +   let displayMsg a = putStrLn' (concat $ catMaybes a)+   let e = do+       let a = inputText 1 "a"+       let b = inputText 1 "b"+       shortcut [a,b] (\as -> length (filter isJust as) >= 1)+   void $ onEvent_ e displayMsg++testShorcutEventEx :: Bool+testShorcutEventEx = "coco1" `elem` g where+   g = execEvent testShorcutEvent (Signal (Input (Text "a") 1)) "coco1"++-- | Build a event firing when a player arrives or leaves+playerEvent :: Player -> EventM TestM PlayerInfo+playerEvent p = SignalEvent $ Signal p++data Player = Arrive | Leave deriving (Typeable, Show, Eq)++-- | informations on players+data PlayerInfo = PlayerInfo { _playerNumber :: Int}+   deriving (Eq, Typeable, Show)++--This event waits for two identical signals to fire+testDoubleEvent :: TestM ()+testDoubleEvent = do+   let displayMsg a = putStrLn' $ show $ _playerNumber a+   let e :: EventM TestM PlayerInfo+       e = do+       playerEvent Arrive+       playerEvent Arrive+   void $ onEvent_ e displayMsg++testDoubleEvent2PlayerArrive :: [String]+testDoubleEvent2PlayerArrive = execEvents testDoubleEvent [(Signal Arrive, PlayerInfo 1), (Signal Arrive, PlayerInfo 2)]++testDoubleEventEx :: Bool+testDoubleEventEx = "2" `elem` testDoubleEvent2PlayerArrive++-- * Time events++testTimeEvent :: TestM ()+testTimeEvent = void $ onEvent_ (timeEvent date1) f where+   f _ = putStrLn' $ show date1++testTimeEventEx :: Bool+testTimeEventEx = (show date1) `elem` g where+   g = execEvent testTimeEvent (Signal date1) date1++testTimeEvent2 :: TestM ()+testTimeEvent2 = schedule' [date1, date2] (putStrLn' . show)++testTimeEventEx2 :: Bool+testTimeEventEx2 = ((show date1) `elem` g) && ((show date2) `elem` g) where+  g = execEvents testTimeEvent2 [(Signal date1, date1),(Signal date2, date2)]++testTime :: TestM ()+testTime = do+  t <- liftIO Data.Time.getCurrentTime+  void $ onEvent_ (True <$ inputButton 1 "click here before 5 seconds:" <|> False <$ (timeEvent $ addUTCTime 5 t)) f where+   f a = putStrLn' $ show a
+ src/Imprevu/Test/TestMgt.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}++module Imprevu.Test.TestMgt where++import Control.Monad.State+import Control.Monad.Except+import Control.Applicative+import Control.Lens+import Data.Typeable+import Data.List+import Data.Maybe+import Data.Time+import Imprevu+import Imprevu.Evaluation+import System.IO.Unsafe+import System.Random+import Prelude+import           Debug.Trace.Helpers                 (traceM)++data TestState = TestState {eventInfos :: [EventInfoN TestM],+                            outputs    :: [String],+                            variable  :: Var}+                            deriving Show++newtype TestM a = TestM {unTestM :: StateT TestState IO a}+  deriving (Functor, Applicative, Monad, MonadIO, MonadState TestState)++-- | stores the variable's data+data Var = forall a . (Typeable a, Show a) =>+   Var { vName :: String,+         vData :: a}++deriving instance (Show Var)++instance MonadError String TestM where+  throwError = undefined+  catchError = undefined++instance EvMgt TestM where+   onEvent         = evOnEvent+   delEvent        = evDelEvent+   getEvents       = error "not implem"+   sendMessage m a = eventsEval $ triggerEvent m a++instance SysMgt TestM where+   getCurrentTime    = return date1 --liftIO Data.Time.getCurrentTime+   getRandomNumber a = liftIO $ randomRIO a++instance VarMgt TestM where+   newVar       v a = modify (\(TestState eis os _) -> (TestState eis os (Var v a))) >> (return $ Just (V v))+   readVar        _ = gets variable >>= (\(Var _ a) -> return $ cast a)+   writeVar (V v) a = modify (\(TestState eis os _) -> (TestState eis os (Var v a))) >> return True+   delVar        _  = return True++eventsEval :: EvaluateN TestM TestState () -> TestM ()+eventsEval eval = do+   s <- get+   let ee = EvalEnv s defaultEvalConf+   let (EvalEnv s' _) = runIdentity $ flip execStateT ee $ do+       res <- runExceptT eval+       case res of+         Right a -> return a+         Left _ -> error $ show "error occured"+   put s'++evalEvents :: TestM a -> EvaluateN TestM TestState a+evalEvents (TestM tio) = do+   ee@(EvalEnv s _) <- get+   let (a, s') = unsafePerformIO $ runStateT tio s+   put ee{_evalEnv = s'}+   return a++evOnEvent :: (Typeable e, Show e) => EventM TestM e -> ((EventNumber, e) -> TestM ()) -> TestM EventNumber+evOnEvent ev h = do+   (TestState evs os vs) <- get+   let en = head $ [1..] \\ (map _eventNumber evs)+   put (TestState ((EventInfo en ev h SActive []) : evs) os vs)+   return en++evDelEvent :: EventNumber -> TestM Bool+evDelEvent en = do+   (TestState evs os vs) <- get+   case find ((== en) . view eventNumber) evs of+      Nothing -> return False+      Just eh -> case _evStatus eh of+         SActive -> do+            put (TestState (replaceWith ((== en) . view eventNumber) eh{_evStatus = SDeleted} evs) os vs)+            return True+         SDeleted -> return False+++defaultEvalEnv :: EvalEnvN TestM TestState+defaultEvalEnv = EvalEnv (TestState [] [] (Var "" "")) defaultEvalConf++defaultEvalConf :: EvalConfN TestM TestState+defaultEvalConf = EvalConf getEventsTest setEventsTest evalEvents (error "EvalConf") (flip const)++getEventsTest = eventInfos+setEventsTest eis (TestState _ os vs) = (TestState eis os vs)++execEvent :: (Show s, Typeable s, Show e, Typeable e, Eq s, Eq e) => TestM () -> Signal s e -> e -> [String]+execEvent r f d = execEvents r [(f,d)]++execEvents :: (Show s, Typeable s, Show e, Typeable e, Eq s, Eq e) => TestM () -> [(Signal s e, e)] -> [String]+execEvents r sds = outputs $ execSignals r sds defaultEvalEnv++exec :: TestM () -> [String]+exec r = execEvents r ([] :: [(Signal () (), ())])++putStrLn' :: String -> TestM ()+putStrLn' s = modify (\(TestState is ss vs) -> (TestState is (s:ss) vs))++date1, date2, date3 :: UTCTime+date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"+date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400"+date3 = parse822Time "Tue, 02 Sep 1997 11:00:00 -0400"++parse822Time :: String -> UTCTime+parse822Time = zonedTimeToUTC+              . fromJust+              . parseTimeM True defaultTimeLocale rfc822DateFormat
+ src/Imprevu/Types.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE EmptyDataDecls            #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE FlexibleContexts          #-}++-- | This module contains the type definitions necessary to build a Nomic rule.+module Imprevu.Types where++import           Control.Applicative hiding (Const)+import           Control.Lens+import           Control.Shortcut+import           Control.Monad+import           Data.Typeable+import           GHC.Generics++-- * Event++-- | Composable events+data EventM n a where+   SumEvent       :: EventM n a -> EventM n a -> EventM n a                        -- The first event to fire will be returned+   AppEvent       :: EventM n (a -> b) -> EventM n a -> EventM n b                 -- Both events should fire, and then the result is returned+   PureEvent      :: a -> EventM n a                                         -- Create a fake event. The result is useable with no delay.+   EmptyEvent     :: EventM n a                                              -- An event that is never fired.+   BindEvent      :: EventM n a -> (a -> EventM n b) -> EventM n b                 -- A First event should fire, then a second event is constructed+   ShortcutEvents :: [EventM n a] -> ([Maybe a] -> Bool) -> EventM n [Maybe a]  -- Return the intermediate results as soon as the function evaluates to True, dismissing the events that hasn't fired yet+   SignalEvent    :: (Eq s, Typeable s, Show s, Typeable a, Show a) => Signal s a -> EventM n a                                  -- Embed a single Signal as an EventM+   LiftEvent      :: n a -> EventM n a                                       -- create an event containing the result of the monad evaluation+   deriving Typeable++instance Functor (EventM n) where+   fmap f a = pure f <*> a++instance Applicative (EventM n) where+   pure = PureEvent+   (<*>) = AppEvent++instance Alternative (EventM n) where+   (<|>) = SumEvent+   empty = EmptyEvent++instance Monad (EventM n) where+   (>>=) = BindEvent+   return = PureEvent++instance MonadPlus (EventM n) where+   mplus = SumEvent+   mzero = EmptyEvent++instance Shortcutable (EventM n) where+   shortcut = ShortcutEvents++type ClientNumber = Int++data Signal s a where+  Signal :: s -> Signal s a++deriving instance (Show s, Show a) => Show (Signal s a)+deriving instance (Eq s) => Eq (Signal s a)+deriving instance (Typeable s, Typeable a) => Typeable (Signal s a)++data Input = Input InputField ClientNumber+   deriving (Show, Read, Eq, Ord, Typeable, Generic)++-- | Input forms as programmed by the user+data InputField = Text     String+                | TextArea String+                | Button   String+                | Radio    String [(Int, String)]+                | Checkbox String [(Int, String)]+                deriving (Show, Read, Eq, Ord, Typeable, Generic)++-- data sent back by the form fields+data InputData = RadioData    Int+               | CheckboxData [Int]+               | TextData     String+               | TextAreaData String+               | ButtonData+               deriving (Show, Read, Eq, Ord, Typeable)++-- | Type agnostic base signal+data SomeSignal = forall a s. (Typeable a, Typeable s, Show a, Show s) => SomeSignal (Signal s a)++deriving instance Show SomeSignal++-- | Type agnostic result data+data SomeData = forall e. (Typeable e, Show e) => SomeData e++deriving instance Show SomeData++++-- * EventInfoN++type EventNumber = Int+type EventName = String++-- EventInfoN holds all infos on an active event+data EventInfoN n = forall a. (Typeable a, Show a) =>+   EventInfo {_eventNumber :: EventNumber,+              event        :: EventM n a,+              handler      :: (EventNumber, a) -> n (),+              _evStatus    :: Status,+              _env         :: [SignalOccurence]}++instance Eq (EventInfoN n) where+   (EventInfo {_eventNumber=e1}) == (EventInfo {_eventNumber=e2}) = e1 == e2++instance Ord (EventInfoN n) where+   (EventInfo {_eventNumber=e1}) <= (EventInfo {_eventNumber=e2}) = e1 <= e2++instance Show (EventInfoN n) where+   show (EventInfo en _ _ s envi) =+      "event num: " ++ (show en) +++      ", envs: " ++ (show envi) +++      ", status: " ++ (show s)++eventNumber :: Lens' (EventInfoN n) EventNumber+eventNumber f (EventInfo e ev h evs env) = fmap (\e' -> (EventInfo e' ev h evs env)) (f e)++evStatus :: Lens' (EventInfoN n) Status+evStatus f (EventInfo e ev h evs env) = fmap (\evs' -> (EventInfo e ev h evs' env)) (f evs)++env :: Lens' (EventInfoN n) [SignalOccurence]+env f (EventInfo e ev h evs env) = fmap (\env' -> (EventInfo e ev h evs env')) (f env)++-- status of an event+data Status = SActive | SDeleted deriving (Eq, Show)++-- data and addres from an occurence of a signal+data SignalOccurence = SignalOccurence {_signalOccData    :: SignalData,+                                        _signalOccAddress :: SignalAddress}++deriving instance Show SignalOccurence++-- result data from a signal+data SignalData = forall s a. (Typeable s, Typeable a, Show s, Show a, Eq s) =>+   SignalData {signal     :: Signal s a,+               signalData :: a}++instance Show SignalData where+  show (SignalData s sd) = show s ++ " " ++ (show sd)++-- SignalAddress is a representation of the address of a signal in the event tree+type SignalAddress = [SignalAddressElem]+data SignalAddressElem = SumR | SumL | AppR | AppL | BindR | BindL | Shortcut deriving (Show, Read, Ord, Eq, Generic)++makeLenses ''SignalOccurence+
+ src/Imprevu/Variables.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+++module Imprevu.Variables+ --  V(..),+ --  newVar, newVar_, newVar',+ --  readVar, readVar_,+ --  writeVar,+ --  modifyVar,+ --  delVar,+ --  getTempVar+    where++import Imprevu.SysMgt+import Imprevu.Events+import Data.Typeable+import Control.Monad.Loops+import Control.Monad.Except++type VarName = String++-- | a container for a variable name and type+data V a = V {varName :: VarName} deriving Typeable++class (Monad n) => VarMgt n where+   newVar          :: (Typeable a, Show a) => VarName -> a -> n (Maybe (V a))+   readVar         :: (Typeable a, Show a) => V a -> n (Maybe a)+   writeVar        :: (Typeable a, Show a) => V a -> a -> n Bool+   delVar          :: (V a) -> n Bool++-- * Variables+-- | variable creation+newVar_ :: (Typeable a, Show a, VarMgt n, MonadError String n) => VarName -> a -> n (V a)+newVar_ s a = partial "newVar_: Variable existing" (newVar s a)++newVar' :: (Typeable a, Show a, VarMgt n) => V a -> a -> n Bool+newVar' v a = maybe False (const True) <$> (newVar (varName v) a)++-- | variable reading+readVar_ :: (Typeable a, Show a, VarMgt n, MonadError String n) => V a -> n a+readVar_ v@(V a) = partial ("readVar_: Variable \"" ++ a ++ "\" with type \"" ++ (show $ typeOf v) ++ "\" not existing") (readVar v)++-- | modify a variable using the provided function+modifyVar :: (Typeable a, Show a, VarMgt n, MonadError String n) => V a -> (a -> a) -> n Bool+modifyVar v f = writeVar v . f =<< readVar_ v++-- | get temporary variable with random name+getTempVar :: (Typeable a, Show a, VarMgt n, SysMgt n) => a -> n (V a)+getTempVar a = untilJust $ do+    r <- getRandomNumber (0, 1000000 :: Int)+    newVar ("tempVar" ++ (show r)) a
+ test/Test.hs view
@@ -0,0 +1,38 @@+module Test where++import Imprevu.Test.Test+import Distribution.TestSuite++tests :: IO [Test]+tests = return [+   test testSingleInputEx    "single input",+   test testMultipleInputsEx "multiple inputs",+   test testInputStringEx    "input string",+   test testSendMessageEx    "send message",+   test testSendMessageEx2   "send message 2",+   test testAPICallEx        "API Call",+   test testAPICallEx2       "API Call 2",+   test testUserInputWriteEx "User input write",+   test testSumComposeEx     "sum compose",+   test testProdComposeEx1   "prod compose",+   test testProdComposeEx2   "prod compose 2",+   test testTwoEventsEx      "two events",+   test testMonadicEventEx   "monadic event",+   test testShorcutEventEx   "shortcut event",+   test testDoubleEventEx    "double event",+   test testTimeEventEx      "time event",+   test testTimeEventEx2     "time event 2"+   ]++test :: Bool -> String -> Test+test p t = Test $ test' p t++test' :: Bool -> String -> TestInstance+test' p t = TestInstance+   { run = return $ Finished $ if p then Pass else Fail ""+   , name = t+   , tags = []+   , options = []+   , setOption = \_ _ -> Right $ test' p t+   }+