diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/imprevu.cabal b/imprevu.cabal new file mode 100644 --- /dev/null +++ b/imprevu.cabal @@ -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 diff --git a/src/Imprevu.hs b/src/Imprevu.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu.hs @@ -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 diff --git a/src/Imprevu/Evaluation.hs b/src/Imprevu/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Evaluation.hs @@ -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 diff --git a/src/Imprevu/Evaluation/EventEval.hs b/src/Imprevu/Evaluation/EventEval.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Evaluation/EventEval.hs @@ -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 + + diff --git a/src/Imprevu/Evaluation/InputEval.hs b/src/Imprevu/Evaluation/InputEval.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Evaluation/InputEval.hs @@ -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" diff --git a/src/Imprevu/Evaluation/TimeEval.hs b/src/Imprevu/Evaluation/TimeEval.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Evaluation/TimeEval.hs @@ -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 + diff --git a/src/Imprevu/Evaluation/Types.hs b/src/Imprevu/Evaluation/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Evaluation/Types.hs @@ -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) + diff --git a/src/Imprevu/Evaluation/Utils.hs b/src/Imprevu/Evaluation/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Evaluation/Utils.hs @@ -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 diff --git a/src/Imprevu/Events.hs b/src/Imprevu/Events.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Events.hs @@ -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 + + diff --git a/src/Imprevu/Inputs.hs b/src/Imprevu/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Inputs.hs @@ -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) + diff --git a/src/Imprevu/Messages.hs b/src/Imprevu/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Messages.hs @@ -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 diff --git a/src/Imprevu/SysMgt.hs b/src/Imprevu/SysMgt.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/SysMgt.hs @@ -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 + diff --git a/src/Imprevu/Test/Test.hs b/src/Imprevu/Test/Test.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Test/Test.hs @@ -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 diff --git a/src/Imprevu/Test/TestMgt.hs b/src/Imprevu/Test/TestMgt.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Test/TestMgt.hs @@ -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 diff --git a/src/Imprevu/Types.hs b/src/Imprevu/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Types.hs @@ -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 + diff --git a/src/Imprevu/Variables.hs b/src/Imprevu/Variables.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Variables.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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 + } +