Nomyx-Core 0.7.2 → 0.7.3
raw patch · 19 files changed
+404/−372 lines, 19 filesdep ~Nomyx-Languagedep ~happstack-authenticate
Dependency ranges changed: Nomyx-Language, happstack-authenticate
Files
- Nomyx-Core.cabal +4/−3
- data/test/TestTime.hs +13/−0
- src/Nomyx/Core/Context.hs +3/−1
- src/Nomyx/Core/Engine.hs +5/−4
- src/Nomyx/Core/Engine/EvalUtils.hs +11/−35
- src/Nomyx/Core/Engine/Evaluation.hs +45/−165
- src/Nomyx/Core/Engine/EventEval.hs +173/−0
- src/Nomyx/Core/Engine/GameEvents.hs +9/−9
- src/Nomyx/Core/Engine/Test.hs +41/−23
- src/Nomyx/Core/Engine/Types.hs +17/−9
- src/Nomyx/Core/Mail.hs +4/−6
- src/Nomyx/Core/Multi.hs +1/−4
- src/Nomyx/Core/Profile.hs +1/−14
- src/Nomyx/Core/Quotes.hs +3/−15
- src/Nomyx/Core/Serialize.hs +1/−1
- src/Nomyx/Core/Session.hs +31/−42
- src/Nomyx/Core/Test.hs +13/−17
- src/Nomyx/Core/Types.hs +21/−4
- src/Nomyx/Core/Utils.hs +8/−20
Nomyx-Core.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Core-version: 0.7.2+version: 0.7.3 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.7.2,+ build-depends: Nomyx-Language == 0.7.3, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*,@@ -31,7 +31,7 @@ either-unwrap == 1.1.*, exceptions == 0.6.*, filepath == 1.3.*,- happstack-authenticate == 0.10.*,+ happstack-authenticate == 0.10.15, hint == 0.4.*, hint-server == 1.4.*, hscolour == 1.20.*,@@ -72,6 +72,7 @@ Nomyx.Core.Test Nomyx.Core.Engine Nomyx.Core.Engine.Evaluation+ Nomyx.Core.Engine.EventEval Nomyx.Core.Engine.EvalUtils Nomyx.Core.Engine.Types Nomyx.Core.Engine.GameEvents
+ data/test/TestTime.hs view
@@ -0,0 +1,13 @@++module TestTime where++import Prelude+import Language.Nomyx+import Control.Monad+import Data.Time++myRule :: Rule+myRule = void $ outputAll_ helperFunction++helperFunction :: String+helperFunction = "Hello"
src/Nomyx/Core/Context.hs view
@@ -25,6 +25,7 @@ "Control.Monad.State", "Control.Monad.State", "Control.Monad.Writer",+ "Control.Monad.Loops", "Data.Array", "Data.Bits", "Data.Bool",@@ -55,7 +56,8 @@ "base", "bytestring", "containers",- "text"]+ "text",+ "time"] qualImports :: [(String, Maybe String)] qualImports = [("Control.Category", Just "C"),
src/Nomyx/Core/Engine.hs view
@@ -2,7 +2,6 @@ -- | Warning: Nomyx internals (not required to compose rules and play the game) -- This module implements game engine. -- the module manages the effects of rules over each others.--- This module is not required module Nomyx.Core.Engine( -- * Game management GameEvent(..),@@ -15,7 +14,7 @@ game, emptyGame, getLoggedGame,- gameName,+ gameName, gameDesc, players, getVictorious, @@ -28,7 +27,7 @@ -- * Events management events,- getEventFields,+ getRemainingSignals, getEventInfo, getFormField, @@ -51,10 +50,12 @@ tracePN, replaceWith, getChoiceEvents,- getTextEvents+ getTextEvents,+ runEvaluate ) where import Nomyx.Core.Engine.Evaluation+import Nomyx.Core.Engine.EventEval import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.GameEvents import Nomyx.Core.Engine.Utils
src/Nomyx/Core/Engine/EvalUtils.hs view
@@ -18,22 +18,22 @@ import Data.Maybe import Data.List import Control.Applicative-import Control.Monad.Error import Language.Nomyx.Expression import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Safe --- find a field result in an environment-lookupField :: Typeable a => Field a -> FieldAddress -> [FieldResult] -> Maybe a-lookupField fi fa frs = headMay $ mapMaybe (maybeField fi fa) frs+-- find a signal occurence in an environment+lookupSignal :: Typeable a => Signal a -> SignalAddress -> [SignalOccurence] -> Maybe a+lookupSignal s sa env = headMay $ mapMaybe (getSignalData s sa) env ---return the field result if it matches with the input field and address-maybeField :: Typeable a => Field a -> FieldAddress -> FieldResult -> Maybe a-maybeField fi fa (FieldResult fi' res fa') = do- ((fi'', res') :: (Field a, a)) <- cast (fi', res)- if (fi'' == fi) && maybe True (== fa) fa' then (Just res') else Nothing+--get the signal data from the signal occurence+getSignalData :: Typeable a => Signal a -> SignalAddress -> SignalOccurence -> Maybe a+getSignalData s sa (SignalOccurence (SignalData s' res) sa') = do+ ((s'', res') :: (Signal a, a)) <- cast (s', res)+ if (s'' == s) && (sa' == sa) then (Just res') else Nothing + errorHandler :: EventNumber -> String -> Evaluate () errorHandler en s = do rn <- access eRuleNumber@@ -53,32 +53,8 @@ liftEval :: EvaluateNE a -> Evaluate a liftEval r = runReader r <$> get ---extract the game state from an Evaluate---knowing the rule number performing the evaluation (0 if by the system)---and the player number to whom display errors (set to Nothing for all players)---TODO: clean-runEvalError :: RuleNumber -> (Maybe PlayerNumber) -> Evaluate a -> State Game ()-runEvalError rn mpn egs = modify (\g -> _eGame $ execState (runEvalError' mpn egs) (EvalEnv rn g)) -runEvalError' :: (Maybe PlayerNumber) -> Evaluate a -> State EvalEnv ()-runEvalError' mpn egs = do- e <- runErrorT egs- case e of- Right _ -> return ()- Left e' -> do- tracePN (fromMaybe 0 mpn) $ "Error: " ++ e'- void $ runErrorT $ log mpn "Error: " --runEvaluateNE :: Game -> RuleNumber -> EvaluateNE a -> a-runEvaluateNE g rn ev = runReader ev (EvalEnv rn g)--runSystemEval :: PlayerNumber -> Evaluate a -> State Game ()-runSystemEval pn e = runEvalError 0 (Just pn) e--runSystemEval' :: Evaluate a -> State Game ()-runSystemEval' e = runEvalError 0 Nothing e- focusGame :: State Game a -> Evaluate a focusGame = lift . (focus eGame) @@ -118,8 +94,8 @@ eRuleNumber ~= oldRn return a -instance Eq SomeField where- (SomeField e1) == (SomeField e2) = e1 === e2+instance Eq SomeSignal where+ (SomeSignal e1) == (SomeSignal e2) = e1 === e2 instance Show EventInfo where show (EventInfo en rn _ _ s env) =
src/Nomyx/Core/Engine/Evaluation.hs view
@@ -1,10 +1,4 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DoAndIfThenElse #-} -- | Evaluation of a Nomyx expression module Nomyx.Core.Engine.Evaluation where@@ -19,23 +13,21 @@ import Data.Lens import Data.Maybe import Data.Todo-import Data.Either-import Data.Function (on) import Control.Category hiding (id) import Control.Applicative-import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Error import Language.Nomyx.Expression import Nomyx.Core.Engine.Types hiding (_vRuleNumber)+import Nomyx.Core.Engine.EventEval import Nomyx.Core.Engine.EvalUtils import Nomyx.Core.Engine.Utils-import Safe import System.Random + -- * Evaluation -- | evaluate an effecful expression.--- The rule number passed is the number of the rule containing the expression. evalNomex :: Nomex a -> Evaluate a evalNomex (NewVar v a) = evNewVar v a evalNomex (DelVar v) = evDelVar v@@ -75,17 +67,6 @@ evalNomexNE (Simu sim ev) = evSimu sim ev ----TODO should we also give a rule number to simulate the Nomex with?--- currently we use the simulating rule number-evSimu :: Nomex a -> NomexNE Bool -> EvaluateNE Bool-evSimu sim ev = do- rn <- asks _eRuleNumber- let s = runEvalError rn Nothing (evalNomex sim)- g <- asks _eGame- let g' = execState s g- return $ runEvaluateNE g' rn (evalNomexNE ev)- evNewVar :: (Typeable a, Show a) => VarName -> a -> Evaluate (Maybe (V a)) evNewVar name def = do (vars, rn) <- accessGame variables@@ -277,144 +258,15 @@ putGame randomGen g' return a ----- * Events------ | Get the field at a certain address-findField :: EventInfo -> FieldAddress -> FormField -> EvaluateNE (Maybe SomeField)-findField (EventInfo _ _ e _ _ er) addr ft = findField' addr e er ft--findField' :: FieldAddress -> Event e -> [FieldResult] -> FormField -> EvaluateNE (Maybe SomeField)-findField' [] (BaseEvent f) _ ft = return $ do- ft' <- getFormField (SomeField f)- guard (ft' == ft)- return $ SomeField f-findField' (SumL:as) (SumEvent e1 _) frs ft = findField' as e1 (filterPath SumL frs) ft-findField' (SumR:as) (SumEvent _ e2) frs ft = findField' as e2 (filterPath SumR frs) ft-findField' (AppL:as) (AppEvent e1 _) frs ft = findField' as e1 (filterPath AppL frs) ft-findField' (AppR:as) (AppEvent _ e2) frs ft = findField' as e2 (filterPath AppR frs) ft-findField' (BindL:as) (BindEvent e1 _) frs ft = findField' as e1 (filterPath BindL frs) ft-findField' (BindR:as) (BindEvent e1 f) frs ft = do- ter <- getEventResult e1 (filterPath BindL frs) --- case ter of- Done e2 -> findField' as (f e2) (filterPath BindR frs) ft- Todo _ -> return $ Nothing-findField' (Shortcut:as) (ShortcutEvents es _) frs ft = do- msfs <- mapM (\e-> findField' as e frs ft) es- return $ headMay $ catMaybes msfs -- returning the first field that matches--findField' fa _ _ _ = error $ "findField: wrong field address: " ++ (show fa)--filterPath :: FieldAddressElem -> [FieldResult] -> [FieldResult]-filterPath fa frs = mapMaybe f frs where- f (FieldResult fe fr (Just (fa':fas))) | fa == fa' = Just $ FieldResult fe fr (Just fas)- f fr = Just fr--getFormField :: SomeField -> Maybe FormField-getFormField (SomeField (Input pn s (Radio choices))) = Just $ RadioField pn s (zip [0..] (snd <$> choices))-getFormField (SomeField (Input pn s Text)) = Just $ TextField pn s-getFormField (SomeField (Input pn s TextArea)) = Just $ TextAreaField pn s-getFormField (SomeField (Input pn s Button)) = Just $ ButtonField pn s-getFormField (SomeField (Input pn s (Checkbox choices))) = Just $ CheckboxField pn s (zip [0..] (snd <$> choices))-getFormField _ = Nothing-----get the fields left to be completed in an event-getEventFields :: EventInfo -> Game -> [(FieldAddress, SomeField)]-getEventFields (EventInfo _ rn e _ _ env) g = case runEvaluateNE g rn $ getEventResult e env of- Done _ -> []- Todo a -> a---- compute the result of an event given an environment.--- in the case the event cannot be computed because some fields results are pending, return that list instead.-getEventResult :: Event a -> [FieldResult] -> EvaluateNE (Todo (FieldAddress, SomeField) a)-getEventResult e frs = getEventResult' e frs []--getEventResult' :: Event a -> [FieldResult] -> FieldAddress -> EvaluateNE (Todo (FieldAddress, SomeField) a)-getEventResult' (PureEvent a) _ _ = return $ Done a-getEventResult' EmptyEvent _ _ = return $ Todo []-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) _ _ = evalNomexNE a >>= return . Done-getEventResult' (BindEvent a f) ers fa = do- er <- getEventResult' a ers (fa ++ [BindL])- case er of- Done a' -> getEventResult' (f a') ers (fa ++ [BindR])- Todo bs -> return $ Todo bs--getEventResult' (BaseEvent a) ers fa = return $ case lookupField a fa ers of- Just r -> Done r- Nothing -> Todo [(fa, SomeField a)]--getEventResult' (ShortcutEvents es f) ers fa = do- (ers :: [Todo (FieldAddress, SomeField) a]) <- mapM (\e -> getEventResult' e ers (fa ++ [Shortcut])) es -- get the result for each event in the list- return $ case f (toMaybe <$> ers) of -- apply f to the event results that we already have- True -> Done $ toMaybe <$> ers -- if the result is true, we are done. Return the list of maybe results- False -> Todo $ join $ lefts $ toEither <$> ers -- otherwise, return the list of remaining fields to complete from each event----- trigger an event-triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate ()-triggerEvent e dat = access (eGame >>> events) >>= triggerEvent' (FieldResult e dat Nothing)---- trigger some specific events-triggerEvent' :: FieldResult -> [EventInfo] -> Evaluate ()-triggerEvent' res evs = do- evs' <- mapM (liftEval . (updateEventInfo res)) (sortBy (compare `on` _ruleNumber) evs) -- get all the EventInfos updated with the field- (eGame >>> events) %= union (map fst evs') -- store them- void $ mapM triggerIfComplete evs' -- trigger the handlers for completed events---- if the event is complete, trigger its handler-triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate ()-triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = case (cast val) of- Just a -> void $ withRN rn $ (evalNomex $ h (en, a)) `catchError` (errorHandler en)- Nothing -> error "Bad trigger data type"-triggerIfComplete _ = return ()---- update the EventInfo with the field result.--- get the event result if all fields are completed-updateEventInfo :: FieldResult -> EventInfo -> EvaluateNE (EventInfo, Maybe SomeData)-updateEventInfo (FieldResult field dat addr) ei@(EventInfo _ _ ev _ _ envi) = do+--TODO should we also give a rule number to simulate the Nomex with?+-- currently we use the simulating rule number+evSimu :: Nomex a -> NomexNE Bool -> EvaluateNE Bool+evSimu sim ev = do+ rn <- asks _eRuleNumber+ let s = runEvalError rn Nothing (evalNomex sim) g <- asks _eGame- let eventRes = FieldResult field dat addr- er <- getEventResult ev (eventRes : envi)- return $ case er of -- check if the event will be complete- Todo _ -> if (SomeField field) `elem` (map snd $ getEventFields ei g) -- is yes, check if our field is really a missing field of the event- then (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment- else (ei, Nothing) -- field not found: do nothing- Done a -> (env ^= [] $ ei, Just $ SomeData a) -- the event is complete: empty the environment and output the result---- * input triggers---- trigger the input event with the input data-triggerInput :: EventNumber -> FieldAddress -> FormField -> InputData -> Evaluate ()-triggerInput en fa ft ir = do- evs <- access (eGame >>> events)- let mei = find ((== en) . getL eventNumber) evs- when (isJust mei) $ execInputHandler ir fa ft (fromJust mei)---- execute the corresponding handler-execInputHandler :: InputData -> FieldAddress -> FormField -> EventInfo -> Evaluate ()-execInputHandler ir fa ft ei@(EventInfo _ _ _ _ SActive _) = do- i <- liftEval $ findField ei fa ft- case i of- Just sf -> execInputHandler' ir sf fa ei- Nothing -> logAll $ "Input not found, InputData=" ++ (show ir) ++ " FieldAddress=" ++ (show fa) ++ " FormField=" ++ (show ft)-execInputHandler _ _ _ _ = return ()---- execute the event handler using the data received from user-execInputHandler' :: InputData -> SomeField -> FieldAddress -> EventInfo -> Evaluate ()-execInputHandler' (TextData s) (SomeField e@(Input _ _ (Text))) fa ei = triggerEvent' (FieldResult e s (Just fa)) [ei]-execInputHandler' (TextAreaData s) (SomeField e@(Input _ _ (TextArea))) fa ei = triggerEvent' (FieldResult e s (Just fa)) [ei]-execInputHandler' (ButtonData) (SomeField e@(Input _ _ (Button))) fa ei = triggerEvent' (FieldResult e () (Just fa)) [ei]-execInputHandler' (RadioData i) (SomeField e@(Input _ _ (Radio cs))) fa ei = triggerEvent' (FieldResult e (fst $ cs!!i) (Just fa)) [ei]-execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ (Checkbox cs))) fa ei = triggerEvent' (FieldResult e (fst <$> cs `sel` is) (Just fa)) [ei]-execInputHandler' _ _ _ _ = return ()--+ let g' = execState s g+ return $ runEvaluateNE g' rn (evalNomexNE ev) -- * misc @@ -453,7 +305,40 @@ vic <- access (eGame >>> victory) when (isJust vic && _vRuleNumber (fromJust vic) == rn) $ void $ (eGame >>> victory) ~= Nothing +--extract the game state from an Evaluate+--knowing the rule number performing the evaluation (0 if by the system)+--and the player number to whom display errors (set to Nothing for all players)+--TODO: clean+runEvalError :: RuleNumber -> (Maybe PlayerNumber) -> Evaluate a -> State Game ()+runEvalError rn mpn egs = modify (\g -> _eGame $ execState (runEvalError' mpn egs) (EvalEnv rn g evalNomex evalNomexNE)) +runEvalError' :: (Maybe PlayerNumber) -> Evaluate a -> State EvalEnv ()+runEvalError' mpn egs = do+ e <- runErrorT egs+ case e of+ Right _ -> return ()+ Left e' -> do+ tracePN (fromMaybe 0 mpn) $ "Error: " ++ e'+ void $ runErrorT $ log mpn "Error: "++runSystemEval :: PlayerNumber -> Evaluate a -> State Game ()+runSystemEval pn e = runEvalError 0 (Just pn) e++runSystemEval' :: Evaluate a -> State Game ()+runSystemEval' e = runEvalError 0 Nothing e++--get the signals left to be completed in an event+getRemainingSignals :: EventInfo -> Game -> [(SignalAddress, SomeSignal)]+getRemainingSignals (EventInfo _ rn e _ _ env) g = case runEvaluateNE g rn (getEventResult e env) of+ Done _ -> []+ Todo a -> a++runEvaluateNE :: Game -> RuleNumber -> EvaluateNE a -> a+runEvaluateNE g rn ev = runReader ev (EvalEnv rn g evalNomex evalNomexNE)++runEvaluate :: Game -> RuleNumber -> State EvalEnv a -> a+runEvaluate g rn ev = evalState ev (EvalEnv rn g evalNomex evalNomexNE)+ -- | Show instance for Game -- showing a game involves evaluating some parts (such as victory and outputs) instance Show Game where@@ -473,7 +358,7 @@ displayEvent g ei@(EventInfo en rn _ _ s env) = "event num: " ++ (show en) ++ ", rule num: " ++ (show rn) ++- ", event fields: " ++ (show $ getEventFields ei g) ++ --TODO: display also event result?+ ", remaining signals: " ++ (show $ getRemainingSignals ei g) ++ --TODO: display also event result? ", envs: " ++ (show env) ++ ", status: " ++ (show s) @@ -484,8 +369,3 @@ ", by pn: " ++ (show mpn) ++ ", output: " ++ (show $ evalOutput g o) ++ ", status: " ++ (show s)--displayEvent' :: EventInfo -> EvaluateNE String-displayEvent' ei = do- (EvalEnv _ g) <- ask- return $ displayEvent g ei
+ src/Nomyx/Core/Engine/EventEval.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++-- | Evaluation of the events+module Nomyx.Core.Engine.EventEval where++import Prelude hiding ((.), log)+import Control.Monad+import Control.Monad.State+import Control.Monad.Reader+import Data.List+import Data.Typeable+import Data.Lens+import Data.Maybe+import Data.Todo+import Data.Either+import Data.Function (on)+import Control.Category hiding (id)+import Control.Applicative+import Control.Monad.Error.Class (MonadError(..))+import Language.Nomyx.Expression+import Nomyx.Core.Engine.Types hiding (_vRuleNumber)+import Nomyx.Core.Engine.EvalUtils+import Nomyx.Core.Engine.Utils+import Safe++-- * Event triggers++-- trigger an event+triggerEvent :: (Typeable e, Show e) => Signal e -> e -> Evaluate ()+triggerEvent s dat = do+ evs <- access (eGame >>> events)+ triggerEvent' (SignalData s dat) Nothing evs++-- trigger some specific signal+triggerEvent' :: SignalData -> Maybe SignalAddress -> [EventInfo] -> Evaluate ()+triggerEvent' sd msa evs = do+ let evs' = sortBy (compare `on` _ruleNumber) evs+ eids <- mapM (liftEval . (getUpdatedEventInfo sd msa)) evs' -- get all the EventInfos updated with the field+ (eGame >>> 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 :: (EventInfo, Maybe SomeData) -> Evaluate ()+triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = case (cast val) of+ Just a -> do+ evalNomex <- gets evalNomexFunc+ void $ withRN rn $ (evalNomex $ h (en, a)) `catchError` (errorHandler en)+ Nothing -> error "Bad trigger data type"+triggerIfComplete _ = return ()++-- get update the EventInfo updated with the signal data.+-- get the event result if all signals are completed+getUpdatedEventInfo :: SignalData -> Maybe SignalAddress -> EventInfo -> EvaluateNE (EventInfo, Maybe SomeData)+getUpdatedEventInfo sd@(SignalData signal _) addr ei@(EventInfo _ _ ev _ _ envi) = do+ trs <- getEventResult ev envi+ case trs of+ Todo rs -> case find (\(sa, ss) -> (ss == SomeSignal signal) && maybe True (==sa) addr) 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+ return $ case er of+ Todo _ -> (env ^= envi' $ ei, Nothing) -- some other signals are left to complete: add ours in the environment+ Done a -> (env ^= [] $ ei, Just $ SomeData a) -- event complete: return the final data result+ Nothing -> return (ei, Nothing) -- our signal does not belong to this event.+ Done a -> return (env ^= [] $ ei, Just $ SomeData a)++--get the signals left to be completed in an event+getRemainingSignals' :: EventInfo -> EvaluateNE [(SignalAddress, SomeSignal)]+getRemainingSignals' (EventInfo _ _ e _ _ env) = do+ tr <- getEventResult e env+ return $ case tr of+ Done _ -> []+ Todo a -> a++-- 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 :: Event a -> [SignalOccurence] -> EvaluateNE (Todo (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' :: Event a -> [SignalOccurence] -> SignalAddress -> EvaluateNE (Todo (SignalAddress, SomeSignal) a)+getEventResult' (PureEvent a) _ _ = return $ Done a+getEventResult' EmptyEvent _ _ = return $ Todo []+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+ evalNomexNE <- asks evalNomexNEFunc+ r <- evalNomexNE a+ return $ Done r+getEventResult' (BindEvent a f) ers fa = do+ er <- getEventResult' a ers (fa ++ [BindL])+ case er of+ Done a' -> getEventResult' (f a') ers (fa ++ [BindR])+ Todo bs -> return $ Todo bs++getEventResult' (SignalEvent a) ers fa = return $ case lookupSignal a fa ers of+ Just r -> Done r+ Nothing -> Todo [(fa, SomeSignal a)]++getEventResult' (ShortcutEvents es f) ers fa = do+ (ers :: [Todo (SignalAddress, SomeSignal) a]) <- mapM (\e -> getEventResult' e ers (fa ++ [Shortcut])) es -- get the result for each event in the list+ return $ case f (toMaybe <$> ers) of -- apply f to the event results that we already have+ True -> Done $ toMaybe <$> ers -- if the result is true, we are done. Return the list of maybe results+ False -> Todo $ join $ lefts $ toEither <$> ers -- otherwise, return the list of remaining fields to complete from each event+++-- * Input triggers++-- trigger the input form with the input data+triggerInput :: FormField -> InputData -> SignalAddress -> EventNumber -> Evaluate ()+triggerInput ff id sa en = do+ evs <- access (eGame >>> events)+ let mei = find ((== en) . getL eventNumber) evs+ when (isJust mei) $ triggerInputSignal id sa ff (fromJust mei)++-- trigger the input signal with the input data+triggerInputSignal :: InputData -> SignalAddress -> FormField -> EventInfo -> Evaluate ()+triggerInputSignal id sa ff ei@(EventInfo _ _ _ _ SActive _) = do+ i <- liftEval $ findField ff sa ei+ case i of+ Just sf -> triggerInputSignal' id sf sa ei+ Nothing -> logAll $ "Input not found, InputData=" ++ (show id) ++ " SignalAddress=" ++ (show sa) ++ " FormField=" ++ (show ff)+triggerInputSignal _ _ _ _ = return ()++-- trigger the input signal with the input data+triggerInputSignal' :: InputData -> SomeSignal -> SignalAddress -> EventInfo -> Evaluate ()+triggerInputSignal' (TextData s) (SomeSignal e@(Input _ _ (Text))) sa ei = triggerEvent' (SignalData e s) (Just sa) [ei]+triggerInputSignal' (TextAreaData s) (SomeSignal e@(Input _ _ (TextArea))) sa ei = triggerEvent' (SignalData e s) (Just sa) [ei]+triggerInputSignal' (ButtonData) (SomeSignal e@(Input _ _ (Button))) sa ei = triggerEvent' (SignalData e ()) (Just sa) [ei]+triggerInputSignal' (RadioData i) (SomeSignal e@(Input _ _ (Radio cs))) sa ei = triggerEvent' (SignalData e (fst $ cs!!i)) (Just sa) [ei]+triggerInputSignal' (CheckboxData is) (SomeSignal e@(Input _ _ (Checkbox cs))) sa ei = triggerEvent' (SignalData e (fst <$> cs `sel` is)) (Just sa) [ei]+triggerInputSignal' _ _ _ _ = return ()+++-- | Get the form field at a certain address+findField :: FormField -> SignalAddress -> EventInfo -> EvaluateNE (Maybe SomeSignal)+findField ff addr (EventInfo _ _ e _ _ env) = findField' addr e env ff++findField' :: SignalAddress -> Event e -> [SignalOccurence] -> FormField -> EvaluateNE (Maybe SomeSignal)+findField' [] (SignalEvent f) _ ff = return $ do+ ff' <- getFormField (SomeSignal f)+ guard (ff' == ff)+ return $ SomeSignal f+findField' (SumL:as) (SumEvent e1 _) env ff = findField' as e1 (filterPath SumL env) ff+findField' (SumR:as) (SumEvent _ e2) env ff = findField' as e2 (filterPath SumR env) ff+findField' (AppL:as) (AppEvent e1 _) env ff = findField' as e1 (filterPath AppL env) ff+findField' (AppR:as) (AppEvent _ e2) env ff = findField' as e2 (filterPath AppR env) ff+findField' (BindL:as) (BindEvent e1 _) env ff = findField' as e1 (filterPath BindL env) ff+findField' (BindR:as) (BindEvent e1 f) env ff = do+ ter <- getEventResult e1 (filterPath BindL env)+ case ter of+ Done e2 -> findField' as (f e2) (filterPath BindR env) ff+ Todo _ -> return $ Nothing+findField' (Shortcut:as) (ShortcutEvents es _) env ff = do+ msfs <- mapM (\e-> findField' as e env ff) es+ return $ headMay $ catMaybes msfs -- returning the first field that matches++findField' fa _ _ _ = error $ "findField: wrong field address: " ++ (show fa)++-- | removes one element of signal address for all signal occurences+filterPath :: SignalAddressElem -> [SignalOccurence] -> [SignalOccurence]+filterPath fa env = mapMaybe f env where+ f (SignalOccurence sd (fa':fas)) | fa == fa' = Just $ SignalOccurence sd fas+ f fr = Just fr++getFormField :: SomeSignal -> Maybe FormField+getFormField (SomeSignal (Input pn s (Radio choices))) = Just $ RadioField pn s (zip [0..] (snd <$> choices))+getFormField (SomeSignal (Input pn s Text)) = Just $ TextField pn s+getFormField (SomeSignal (Input pn s TextArea)) = Just $ TextAreaField pn s+getFormField (SomeSignal (Input pn s Button)) = Just $ ButtonField pn s+getFormField (SomeSignal (Input pn s (Checkbox choices))) = Just $ CheckboxField pn s (zip [0..] (snd <$> choices))+getFormField _ = Nothing
src/Nomyx/Core/Engine/GameEvents.hs view
@@ -9,7 +9,7 @@ import Data.List import Language.Nomyx.Expression import Nomyx.Core.Engine.Evaluation-import Nomyx.Core.Engine.EvalUtils+import Nomyx.Core.Engine.EventEval import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Data.Lens@@ -23,7 +23,7 @@ data GameEvent = JoinGame PlayerNumber PlayerName | LeaveGame PlayerNumber | ProposeRuleEv PlayerNumber SubmitRule- | InputResult PlayerNumber EventNumber FieldAddress FormField InputData+ | InputResult PlayerNumber EventNumber SignalAddress FormField InputData | GLog (Maybe PlayerNumber) String | TimeEvent UTCTime | SystemAddRule SubmitRule@@ -126,20 +126,20 @@ void $ logs %= (Log mpn time s : ) -- | the user has provided an input result-inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> FormField -> InputData -> State Game ()-inputResult pn en fa ft ir = do- tracePN pn $ "input result: EventNumber " ++ show en ++ ", FieldAddress " ++ show fa ++ ", Form " ++ show ft ++ ", choice " ++ show ir- runSystemEval pn $ triggerInput en fa ft ir+inputResult :: PlayerNumber -> EventNumber -> SignalAddress -> FormField -> InputData -> State Game ()+inputResult pn en sa ff id = do+ tracePN pn $ "input result: EventNumber " ++ show en ++ ", SignalAddress " ++ show sa ++ ", Form " ++ show ff ++ ", choice " ++ show id+ runSystemEval pn $ triggerInput ff id sa en getGameTimes :: Game -> [UTCTime] getGameTimes g = concatMap (\ei -> getTimes ei g) (_events g) getTimes :: EventInfo -> Game -> [UTCTime]-getTimes ei g = mapMaybe getTime (map snd $ getEventFields ei g)+getTimes ei g = mapMaybe getTime (map snd $ getRemainingSignals ei g) -getTime :: SomeField -> Maybe UTCTime-getTime (SomeField (Time t)) = Just t+getTime :: SomeSignal -> Maybe UTCTime+getTime (SomeSignal (Time t)) = Just t getTime _ = Nothing -- | A helper function to run the game state.
src/Nomyx/Core/Engine/Test.hs view
@@ -13,7 +13,7 @@ import Language.Nomyx.Vote import Language.Nomyx.Examples import Nomyx.Core.Engine.Evaluation-import Nomyx.Core.Engine.EvalUtils+import Nomyx.Core.Engine.EventEval import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Control.Monad.State@@ -51,22 +51,22 @@ _rStatus = Pending, _rAssessedBy = Nothing} -execRuleEvent :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game+execRuleEvent :: (Show e, Typeable e) => Nomex a -> Signal e -> e -> Game execRuleEvent r f d = execState (runSystemEval' $ evalNomex r >> triggerEvent f d) testGame -execRuleEvents :: (Show e, Typeable e) => Nomex a -> [(Field e, e)] -> Game+execRuleEvents :: (Show e, Typeable e) => Nomex a -> [(Signal e, e)] -> Game execRuleEvents f eds = execState (runSystemEval' $ evalNomex f >> mapM (\(a,b) -> triggerEvent a b) eds) testGame -execRuleInput :: Nomex a -> EventNumber -> FieldAddress -> FormField -> InputData -> Game-execRuleInput r en fa ft d = execState (runSystemEval' $ evalNomex r >> triggerInput en fa ft d) testGame+execRuleInput :: Nomex a -> EventNumber -> SignalAddress -> FormField -> InputData -> Game+execRuleInput r en sa ff id = execState (runSystemEval' $ evalNomex r >> triggerInput ff id sa en) testGame -execRuleInputs :: Nomex a -> EventNumber -> [(FieldAddress, FormField, InputData)] -> Game-execRuleInputs r en fads = execState (runSystemEval' $ evalNomex r >> mapM (\(fa, ft, d) -> triggerInput en fa ft d) fads) testGame+execRuleInputs :: Nomex a -> EventNumber -> [(SignalAddress, FormField, InputData)] -> Game+execRuleInputs r en fads = execState (runSystemEval' $ evalNomex r >> mapM (\(sa, ff, id) -> triggerInput ff id sa en) fads) testGame execRuleGame :: Nomex a -> Game -> Game execRuleGame r g = execState (runSystemEval' $ void $ evalNomex r) g -execRuleEventGame :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game -> Game+execRuleEventGame :: (Show e, Typeable e) => Nomex a -> Signal e -> e -> Game -> Game execRuleEventGame r f d g = execState (runSystemEval' $ evalNomex r >> (triggerEvent f d)) g execRule :: Nomex a -> Game@@ -118,7 +118,8 @@ ("test two separate events", testTwoEventsEx), ("test monadic event", testMonadicEventEx), ("test monadic event2", testMonadicEventEx2),- ("test shortcut event", testShorcutEventEx)+ ("test shortcut event", testShorcutEventEx),+ ("test double event", testDoubleEventEx) ] allTests = all snd tests@@ -224,7 +225,7 @@ testUserInputWrite = do newVar_ "vote" (Nothing::Maybe Choice2) onEvent_ (messageEvent (Msg "voted" :: Msg ())) h2- void $ onEvent_ (BaseEvent $ Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) h1 where+ void $ onEvent_ (SignalEvent $ Input 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) h1 where h1 a = do writeVar (V "vote") (Just a) SendMessage (Msg "voted") ()@@ -313,8 +314,8 @@ when timeEvent $ evTriggerTime date2 --Trigger a vote event (0 for positive, 1 for negative), using event details-triggerVote :: Int -> (EventNumber, FieldAddress, PlayerNumber, String) -> Evaluate ()-triggerVote res (en, fa, pn, t) = triggerInput en fa (RadioField pn t [(0,"For"),(1,"Against")]) (RadioData res)+triggerVote :: Int -> (EventNumber, SignalAddress, PlayerNumber, String) -> Evaluate ()+triggerVote res (en, sa, pn, t) = triggerInput (RadioField pn t [(0,"For"),(1,"Against")]) (RadioData res) sa en voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1@@ -423,7 +424,7 @@ testMonadicEvent2PlayerArrive = flip execState testGame {_players = []} $ runSystemEval' $ do addActivateRule testMonadicEvent2 1 addPlayer (PlayerInfo 1 "coco 1" Nothing)- triggerInput 1 [BindR] (TextField 1 "") (TextData "coco2")+ triggerInput (TextField 1 "") (TextData "coco2") [BindR] 1 testMonadicEventEx2 = isOutput "coco2" testMonadicEvent2PlayerArrive @@ -439,31 +440,48 @@ testShorcutEventEx = isOutput "coco1" g where g = execRuleInputs testShorcutEvent 1 [([Shortcut], (TextField 1 "a"), TextData "coco1")] +--This event waits for two identical signals to fire+testDoubleEvent :: Rule+testDoubleEvent = do+ let displayMsg a = void $ newOutput_ Nothing (_playerName a)+ let e :: Event PlayerInfo+ e = do+ playerEvent Arrive+ playerEvent Arrive+ void $ onEvent_ e displayMsg +testDoubleEvent2PlayerArrive :: Game+testDoubleEvent2PlayerArrive = flip execState testGame {_players = []} $ runSystemEval' $ do+ addActivateRule testDoubleEvent 1+ addPlayer (PlayerInfo 1 "coco1" Nothing)+ addPlayer (PlayerInfo 2 "coco2" Nothing)++testDoubleEventEx = isOutput "coco2" testDoubleEvent2PlayerArrive+ --Get all event numbers of type choice (radio button)-getChoiceEvents :: State EvalEnv [(EventNumber, FieldAddress, PlayerNumber, String)]+getChoiceEvents :: State EvalEnv [(EventNumber, SignalAddress, PlayerNumber, String)] getChoiceEvents = do evs <- access (eGame >>> events) g <- access eGame return $ [(_eventNumber ev, fa, pn, t) | ev <- evs, (fa, pn, t) <- getInputChoices ev g] -getInputChoices :: EventInfo -> Game -> [(FieldAddress, PlayerNumber, String)]-getInputChoices ei g = mapMaybe isInput (getEventFields ei g) where- isInput :: (FieldAddress, SomeField) -> Maybe (FieldAddress, PlayerNumber, String)- isInput (fa, (SomeField (Input pn t (Radio _)))) = Just (fa, pn, t)+getInputChoices :: EventInfo -> Game -> [(SignalAddress, PlayerNumber, String)]+getInputChoices ei g = mapMaybe isInput (getRemainingSignals ei g) where+ isInput :: (SignalAddress, SomeSignal) -> Maybe (SignalAddress, PlayerNumber, String)+ isInput (fa, (SomeSignal (Input pn t (Radio _)))) = Just (fa, pn, t) isInput _ = Nothing --Get all event numbers of type text (text field)-getTextEvents :: State Game [(EventNumber, FieldAddress)]+getTextEvents :: State Game [(EventNumber, SignalAddress)] getTextEvents = do evs <- access events g <- get return $ [(_eventNumber ev, fa) | ev <- evs, fa <- getInputTexts ev g] -getInputTexts :: EventInfo -> Game -> [FieldAddress]-getInputTexts ei g = mapMaybe isInput (getEventFields ei g) where- isInput :: (t, SomeField) -> Maybe t- isInput (fa, (SomeField (Input _ _ Text))) = Just fa+getInputTexts :: EventInfo -> Game -> [SignalAddress]+getInputTexts ei g = mapMaybe isInput (getRemainingSignals ei g) where+ isInput :: (t, SomeSignal) -> Maybe t+ isInput (fa, (SomeSignal (Input _ _ Text))) = Just fa isInput _ = Nothing addPlayer :: PlayerInfo -> Evaluate Bool
src/Nomyx/Core/Engine/Types.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-} -- | Types for the engine module Nomyx.Core.Engine.Types where@@ -21,14 +22,21 @@ import GHC.Generics import System.Random + -- * Evaluation +-- | Environment necessary for the evaluation of any nomyx expressions or events --TODO: should the first field be a "Maybe RuleNumber"? --Indeed an evaluation is not always performed by a rule but also by the system (in which case we currently use rule number 0)-data EvalEnv = EvalEnv { _eRuleNumber :: RuleNumber, -- number of the rule requesting the evaluation- _eGame :: Game} -- game to be read/modified+data EvalEnv = EvalEnv { _eRuleNumber :: RuleNumber, -- number of the rule requesting the evaluation+ _eGame :: Game, -- game to be read/modified+ evalNomexFunc :: forall a. Nomex a -> Evaluate a, -- evaluation function+ evalNomexNEFunc :: forall b. NomexNE b -> EvaluateNE b} -- evaluation function without effect -type Evaluate a = ErrorT String (State EvalEnv) a+-- | Environment necessary for the evaluation of Nomex+type Evaluate a = ErrorT String (State EvalEnv ) a++-- | Environment necessary for the evaluation of NomexNE type EvaluateNE a = Reader EvalEnv a -- * Game@@ -49,7 +57,7 @@ _randomGen :: StdGen} deriving (Typeable) -data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord)+data GameDesc = GameDesc { _desc :: String, _forumURL :: String} deriving (Eq, Show, Read, Ord) instance Eq Game where (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2@@ -85,17 +93,17 @@ -- * Events -- a form field-data FormField = RadioField PlayerNumber String [(Int, String)]- | TextField PlayerNumber String+data FormField = RadioField PlayerNumber String [(Int, String)]+ | TextField PlayerNumber String | TextAreaField PlayerNumber String- | ButtonField PlayerNumber String+ | ButtonField PlayerNumber String | CheckboxField PlayerNumber String [(Int, String)] deriving (Show, Read, Ord, Eq, Generic) -- data sent back by the form fields-data InputData = RadioData Int+data InputData = RadioData Int | CheckboxData [Int]- | TextData String+ | TextData String | TextAreaData String | ButtonData deriving (Show, Read, Eq, Ord)
src/Nomyx/Core/Mail.hs view
@@ -13,7 +13,6 @@ import Text.Blaze.Html.Renderer.String import Network.Mail.Mime hiding (mailTo) import Safe-import Data.List import Data.Text(Text, pack) import Data.Maybe import qualified Data.Text.Lazy as B@@ -69,12 +68,11 @@ newRuleObject :: PlayerName -> String newRuleObject name = "[Nomyx] New rule posted by player " ++ name ++ "!" -sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO ()-sendMailsNewRule s sr pn = when (_sendMails $ _mSettings $ _multi s) $ do- putStrLn "Sending mails"- gi <- fromJustNote "sendMailsNewRule" <$> getPlayersGame pn s+sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> GameInfo -> IO ()+sendMailsNewRule s sr pn gi = when (_sendMails $ _mSettings $ _multi s) $ do guard (_isPublic gi)- let sendMailsTo = delete pn (map _playerNumber (_players $ _game $ _loggedGame gi))+ putStrLn "Sending mails"+ let sendMailsTo = map _playerNumber (_players $ _game $ _loggedGame gi) proposer <- Nomyx.Core.Profile.getPlayerName pn s profiles <- mapM (getProfile s) sendMailsTo mapM_ (send proposer (_net $ _mSettings $ _multi s) sr) (_pPlayerSettings <$> catMaybes profiles)
src/Nomyx/Core/Multi.hs view
@@ -41,7 +41,7 @@ getTimeEvents now m = do let games = map (_game . _loggedGame) (_gameInfos m) let times = concatMap getGameTimes games- return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times+ return $ filter (\t -> t <= now && t > (-32) `addUTCTime` now) times -- | the initial rule set for a game. rVoteUnanimity = SubmitRule "Unanimity Vote"@@ -71,9 +71,6 @@ _startedAt = date} execStateT (initialGame sh) lg--getGameByName :: GameName -> StateT Multi IO (Maybe GameInfo)-getGameByName gn = find ((==gn) . getL gameNameLens) <$> access gameInfos defaultMulti :: Settings -> Multi defaultMulti = Multi []
src/Nomyx/Core/Profile.hs view
@@ -7,8 +7,6 @@ module Nomyx.Core.Profile where import Language.Nomyx-- import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Catch (bracket) import Control.Concurrent.STM@@ -28,7 +26,6 @@ import System.FilePath ((</>)) import Nomyx.Core.Quotes import Nomyx.Core.Types-import Nomyx.Core.Utils import Nomyx.Core.Engine -- | set 'ProfileData' for UserId@@ -45,10 +42,9 @@ let pfs = toList profilesData let filtered = filter (\a -> _pPlayerNumber a == uid) pfs return $ headMay filtered- --return $ getOne $ profilesData @= uid initialProfileData :: PlayerNumber -> PlayerSettings -> ProfileData-initialProfileData uid ps = ProfileData uid ps Nothing (Just (exampleRule, "")) NoUpload False+initialProfileData uid ps = ProfileData uid ps (Just (exampleRule, "")) NoUpload False exampleRule :: SubmitRule exampleRule = SubmitRule "" "" [cr|@@ -127,15 +123,6 @@ getPlayerInGameName g pn = case find ((==pn) . getL playerNumber) (_players g) of Nothing -> error "getPlayersName': No player by that number in that game" Just pm -> _playerName pm---- | returns the game the player is in-getPlayersGame :: PlayerNumber -> Session -> IO (Maybe GameInfo)-getPlayersGame pn s = do- pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)- let mgn = _pViewingGame $ fromJustNote "getPlayersGame" pfd- return $ do- gn <- mgn- find ((== gn) . getL gameNameLens) (_gameInfos $ _multi s) --checks if any game by that name exists getAllProfiles :: Session -> IO [ProfileData] getAllProfiles s = A.query' (acidProfileData $ _profiles s) AskProfilesData
src/Nomyx/Core/Quotes.hs view
@@ -1,16 +1,4 @@------------------------------------------------------------------------------------ Module : Quotes--- Copyright :--- License : BSD3------ Maintainer : corentin.dupont@gmail.com--- Stability :--- Portability :------ |---------------------------------------------------------------------------------+ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -47,9 +35,9 @@ Right "Exp Effect ()" -> [| s |] Right "Nomex ()" -> [| s |] Right "Exp 'Effect ()" -> [| s |]- Right "Rule" -> [| s |]+ Right "Rule" -> [| s |] Right a -> fail $ "Rule doesn't typecheck: " ++ show a- Left e -> fail $ show e+ Left e -> fail $ show e
src/Nomyx/Core/Serialize.hs view
@@ -79,7 +79,7 @@ $(deriveJSON defaultOptions ''LoggedGame) $(deriveJSON defaultOptions ''GameInfo) $(deriveJSON defaultOptions ''TimedEvent)-$(deriveJSON defaultOptions ''FieldAddressElem)+$(deriveJSON defaultOptions ''SignalAddressElem) $(deriveJSON defaultOptions ''FormField) $(deriveJSON defaultOptions ''GameEvent) $(deriveJSON defaultOptions ''InputData)
src/Nomyx/Core/Session.hs view
@@ -10,6 +10,7 @@ import Data.Lens import Data.Time as T import Data.List+import Data.Maybe import qualified Data.Acid.Advanced as A (update', query') import Happstack.Auth.Core.Auth import Control.Category hiding ((.))@@ -24,6 +25,7 @@ import Nomyx.Core.Interpret import Nomyx.Core.Serialize import Nomyx.Core.Engine as G+import Nomyx.Core.Mail -- | add a new player newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO ()@@ -49,17 +51,23 @@ void $ gameInfos %= (lg : ) else tracePN pn "this name is already used" --- | view a game.-viewGamePlayer :: GameName -> PlayerNumber -> StateT Session IO ()-viewGamePlayer gn pn = do- mg <- focus multi $ getGameByName gn- case mg of- Nothing -> tracePN pn "No game by that name"- Just _ -> modifyProfile pn (pViewingGame ^= Just gn)---- | unview a game.-unviewGamePlayer :: PlayerNumber -> StateT Session IO ()-unviewGamePlayer pn = modifyProfile pn (pViewingGame ^= Nothing)+forkGame :: GameName -> GameName -> GameDesc -> Bool -> PlayerNumber -> StateT Session IO ()+forkGame fromgn newgn desc isPublic pn = focus multi $ do+ gms <- access gameInfos+ case filter ((== fromgn) . getL gameNameLens) gms of+ gi:[] -> do+ tracePN pn $ "Forking game: " ++ fromgn+ time <- liftIO T.getCurrentTime+ let lg = ((game >>> gameName) `setL` (newgn)) .+ ((game >>> gameDesc) `setL` (desc)) $ _loggedGame gi+ let gi' = GameInfo {+ _loggedGame = lg,+ _ownedBy = Just pn,+ _forkedFromGame = Just fromgn,+ _isPublic = isPublic,+ _startedAt = time}+ void $ gameInfos %= (gi' : )+ _ -> tracePN pn $ "Forking game: no game by that name: " ++ fromgn -- | join a game (also view it for conveniency) joinGame :: GameName -> PlayerNumber -> StateT Session IO ()@@ -67,13 +75,11 @@ s <- get name <- lift $ Nomyx.Core.Profile.getPlayerName pn s inGameDo gn $ G.execGameEvent $ JoinGame pn name- viewGamePlayer gn pn -- | delete a game. delGame :: GameName -> StateT Session IO () delGame name = focus multi $ void $ gameInfos %= filter ((/= name) . getL gameNameLens) - -- | leave a game. leaveGame :: GameName -> PlayerNumber -> StateT Session IO () leaveGame game pn = inGameDo game $ G.execGameEvent $ LeaveGame pn@@ -83,11 +89,14 @@ submitRule sr@(SubmitRule _ _ code) pn gn sh = do tracePN pn $ "proposed " ++ show sr mrr <- liftIO $ interpretRule code sh+ s <- get+ let gi = getGameByName gn s case mrr of Right _ -> do tracePN pn "proposed rule compiled OK " inGameDo gn $ G.execGameEvent' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr) modifyProfile pn (pLastRule ^= Just (sr, "Rule submitted OK!"))+ liftIO $ sendMailsNewRule s sr pn (fromJust gi) Left e -> submitRuleError sr pn gn e adminSubmitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO ()@@ -121,7 +130,7 @@ tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -inputResult :: PlayerNumber -> EventNumber -> FieldAddress -> FormField -> InputData -> GameName -> StateT Session IO ()+inputResult :: PlayerNumber -> EventNumber -> SignalAddress -> FormField -> InputData -> GameName -> StateT Session IO () inputResult pn en fa ft ir gn = inGameDo gn $ execGameEvent $ InputResult pn en fa ft ir -- | upload a rule file, given a player number, the full path of the file, the file name and the server handle@@ -132,13 +141,13 @@ tracePN pn $ " uploaded " ++ show mod case m of Nothing -> do- inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n")+ inAllGamesDo $ execGameEvent $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n") tracePN pn "upload success" modifyProfile pn (pLastUpload ^= UploadSuccess) return True Just e -> do let errorMsg = showInterpreterError e- inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n")+ inAllGamesDo $ execGameEvent $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n") tracePN pn $ "upload failed: \n" ++ show e modifyProfile pn (pLastUpload ^= UploadFailure (temp, errorMsg)) return False@@ -175,35 +184,14 @@ pfd <- A.query' (acidProfileData $ _profiles s) AskProfileDataNumber return $ pfd + 1 -forkGame :: GameName -> PlayerNumber -> StateT Session IO ()-forkGame gn pn = focus multi $ do- gms <- access gameInfos- case filter ((== gn) . getL gameNameLens) gms of- gi:[] -> do- tracePN pn $ "Forking game: " ++ gn- time <- liftIO T.getCurrentTime- let gi' = GameInfo {- _loggedGame = (game >>> gameName) `setL` ("Forked " ++ gn) $ _loggedGame gi,- _ownedBy = Just pn,- _forkedFromGame = Just gn,- _isPublic = False,- _startedAt = time}- void $ gameInfos %= (gi' : )- _ -> tracePN pn $ "Creating a simulation game: no game by that name: " ++ gn-- -- | this function apply the given game actions to the game the player is in.-inPlayersGameDo :: PlayerNumber -> StateT LoggedGame IO a -> StateT Session IO (Maybe a)-inPlayersGameDo pn action = do- s <- get+inAllGamesDo :: StateT LoggedGame IO a -> StateT Session IO ()+inAllGamesDo action = do t <- lift T.getCurrentTime- mg <- lift $ getPlayersGame pn s- case mg of- Nothing -> tracePN pn "You must be in a game" >> return Nothing- Just gi -> do+ gis <- access (multi >>> gameInfos)+ forM_ gis $ \gi -> do (a, mylg) <- lift $ runStateT action (setL (game >>> currentTime) t (_loggedGame gi)) focus multi $ modifyGame (gi {_loggedGame = mylg})- return (Just a) inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Session IO () inGameDo gn action = focus multi $ do@@ -227,10 +215,11 @@ save $ _multi s Nothing -> putStrLn "thread timed out, session discarded" - evalSession :: StateT Session IO () -> Session -> IO Session evalSession sm s = do s' <- execStateT sm s writeFile nullFileName $ show $ _multi s' --dirty hack to force deep evaluation --deepseq (_multi s') (return ()) return s' +getGameByName :: GameName -> Session -> Maybe GameInfo+getGameByName gn s = find ((==gn) . getL (loggedGame >>> game >>> gameName)) (_gameInfos $ _multi s)
src/Nomyx/Core/Test.hs view
@@ -1,16 +1,4 @@------------------------------------------------------------------------------------ Module : Test--- Copyright :--- License : BSD3------ Maintainer : corentin.dupont@gmail.com--- Stability :--- Portability :------ |---------------------------------------------------------------------------------+ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-}@@ -45,7 +33,6 @@ import Nomyx.Core.Profile import Nomyx.Core.Quotes import Nomyx.Core.Engine-import Nomyx.Core.Engine.Types import qualified Nomyx.Core.Engine as G playTests :: FilePath -> ServerHandle -> Maybe String -> IO [(String, Bool)]@@ -73,6 +60,10 @@ ("Partial Function 3", gamePartialFunction3, condPartialFunction3), ("Test file 1", testFile1, condNRules 3), ("Test file 2", testFile2, condNRules 3),+#if __GLASGOW_HASKELL__ >= 708+ --Data.Time is Safe only in recent versions+ ("Test import Data.Time", testFileTime, condNRules 3),+#endif ("load file twice", testFileTwice, condNRules 3), ("load file twice 2", testFileTwice', condNRules 4), ("load file unsafe", testFileUnsafeIO, condNRules 2)] ++@@ -122,14 +113,12 @@ newPlayer 1 PlayerSettings {_pPlayerName = "Player 1", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False} newGame "test" (GameDesc "" "") 1 True joinGame "test" 1- viewGamePlayer "test" 1 twoPlayersOneGame :: StateT Session IO () twoPlayersOneGame = do onePlayerOneGame newPlayer 2 PlayerSettings {_pPlayerName = "Player 2", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False} joinGame "test" 2- viewGamePlayer "test" 2 submitR :: String -> StateT Session IO () submitR r = do@@ -282,6 +271,12 @@ void $ testFile "SimpleModule.hs" "SimpleModule.myRule" +--module that imports Data.Time (should be Safe in recent versions)+testFileTime :: StateT Session IO ()+testFileTime = do+ onePlayerOneGame+ void $ testFile "TestTime.hs" "TestTime.myRule"+ --loading two modules with the same name is forbidden testFileTwice :: StateT Session IO () testFileTwice = do@@ -310,11 +305,12 @@ isOutput' :: String -> Multi -> Bool isOutput' s m = any (isOutput s . _game . _loggedGame) (_gameInfos m) + -- select a choice for all radio buttons inputAllRadios :: Int -> StateT Session IO () inputAllRadios choice = do s <- get- let evs = evalState getChoiceEvents (EvalEnv 0 (firstGame $ _multi s))+ let evs = runEvaluate (firstGame $ _multi s) 0 getChoiceEvents mapM_ (\(en, fa, pn, t) -> inputResult pn en fa (RadioField pn t [(0,"For"),(1,"Against")]) (RadioData choice) "test") evs -- input text for all text fields
src/Nomyx/Core/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-} module Nomyx.Core.Types where @@ -11,7 +12,7 @@ import Data.Acid (AcidState) import Data.Data (Data) import Data.IxSet (inferIxSet, noCalcs)-import Data.SafeCopy (base, deriveSafeCopy)+import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) import Data.Time import Language.Nomyx import Nomyx.Core.Engine@@ -66,15 +67,31 @@ -- | 'ProfileData' contains application specific data ProfileData =- ProfileData { _pPlayerNumber :: PlayerNumber, -- ^ same as UserId+ ProfileData { _pPlayerNumber :: PlayerNumber, -- same as UserId _pPlayerSettings :: PlayerSettings,- _pViewingGame :: Maybe GameName, _pLastRule :: Maybe LastRule, _pLastUpload :: LastUpload, _pIsAdmin :: Bool } deriving (Eq, Ord, Read, Show, Typeable, Data)-$(deriveSafeCopy 1 'base ''ProfileData)++data ProfileDataOld =+ ProfileDataOld { _pPlayerNumberOld :: PlayerNumber, -- same as UserId+ _pPlayerSettingsOld :: PlayerSettings,+ _pViewingGameOld :: Maybe GameName,+ _pLastRuleOld :: Maybe LastRule,+ _pLastUploadOld :: LastUpload,+ _pIsAdminOld :: Bool+ }++$(deriveSafeCopy 2 'extension ''ProfileData)+$(deriveSafeCopy 1 'base ''ProfileDataOld)++instance Migrate ProfileData where+ type MigrateFrom ProfileData = ProfileDataOld+ migrate (ProfileDataOld a b c d e f) = (ProfileData a b d e f)++ $(deriveSafeCopy 1 'base ''SubmitRule) $(inferIxSet "ProfilesData" ''ProfileData 'noCalcs [''PlayerNumber]) -- , ''Text
src/Nomyx/Core/Utils.hs view
@@ -1,16 +1,3 @@------------------------------------------------------------------------------ --- --- Module : Utils --- Copyright : --- License : AllRightsReserved --- --- Maintainer : --- Stability : --- Portability : --- --- | --- ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} @@ -140,13 +127,13 @@ mvar <- newEmptyMVar hSetBuffering stdout NoBuffering --start evaluation thread- id <- forkOS $ do+ id <- forkIO $ do s' <- f s s'' <- evaluate s' writeFile nullFileName $ show s'' putMVar mvar (Just s'') --start watchdog thread- forkIO $ watchDog 3 id mvar+ forkIO $ watchDog 5 id mvar takeMVar mvar evalWithWatchdog' :: NFData a => IO a -> IO (Maybe a)@@ -154,20 +141,21 @@ mvar <- newEmptyMVar hSetBuffering stdout NoBuffering --start evaluation thread- id <- forkOS $ do+ id <- forkIO $ do s' <- s let s'' = force s' putMVar mvar (Just s'') --start watchdog thread- forkIO $ watchDog 3 id mvar+ forkIO $ watchDog 5 id mvar takeMVar mvar --- | Fork off a thread which will sleep and then kill off the specified thread.+-- | Fork off a thread which will sleep n seconds and then kill off the specified thread. watchDog :: Int -> ThreadId -> MVar (Maybe a) -> IO ()-watchDog tout tid mvar = do- threadDelay (tout * 1000000)+watchDog n tid mvar = do+ threadDelay (n * 1000000) killThread tid+ threadDelay 1000000 --give some time to kill the thread putMVar mvar Nothing gameNameLens :: Lens GameInfo GameName