Nomyx-Core 0.6.1 → 0.6.2
raw patch · 12 files changed
+483/−429 lines, 12 filesdep ~Nomyx-Language
Dependency ranges changed: Nomyx-Language
Files
- Nomyx-Core.cabal +5/−3
- src/Data/Todo.hs +35/−0
- src/Nomyx/Core/Engine.hs +2/−4
- src/Nomyx/Core/Engine/EvalUtils.hs +128/−0
- src/Nomyx/Core/Engine/Evaluation.hs +148/−260
- src/Nomyx/Core/Engine/Game.hs +0/−116
- src/Nomyx/Core/Engine/GameEvents.hs +2/−1
- src/Nomyx/Core/Engine/Test.hs +47/−39
- src/Nomyx/Core/Engine/Types.hs +110/−0
- src/Nomyx/Core/Multi.hs +2/−3
- src/Nomyx/Core/Quotes.hs +2/−1
- src/Nomyx/Core/Test.hs +2/−2
Nomyx-Core.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Core-version: 0.6.1+version: 0.6.2 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.6.1,+ build-depends: Nomyx-Language == 0.6.2, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*,@@ -71,11 +71,13 @@ Nomyx.Core.Test Nomyx.Core.Engine Nomyx.Core.Engine.Evaluation- Nomyx.Core.Engine.Game+ Nomyx.Core.Engine.EvalUtils+ Nomyx.Core.Engine.Types Nomyx.Core.Engine.GameEvents Nomyx.Core.Engine.Test Nomyx.Core.Engine.Utils Paths_Nomyx_Core+ Data.Todo ghc-options: -W -threaded source-repository head
+ src/Data/Todo.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Todo where++import Control.Applicative+import Data.Typeable++data Todo a b = Todo [a] | Done b+ deriving (Eq, Ord, Read, Show, Typeable)++instance Alternative (Todo a) where+ empty = Todo []+ Todo a <|> Todo b = Todo $ a ++ b+ Todo _ <|> n = n+ m <|> _ = m++instance Applicative (Todo a) where+ pure = Done+ Todo a <*> Todo b = Todo $ a ++ b+ Todo a <*> _ = Todo a+ Done f <*> r = fmap f r++instance Functor (Todo a) where+ fmap _ (Todo x) = Todo x+ fmap f (Done y) = Done $ f y++toEither :: Todo a b -> Either [a] b+toEither (Todo as) = Left as+toEither (Done a) = Right a++fromEither :: Either [a] b -> Todo a b+fromEither (Left as) = Todo as+fromEither (Right a) = Done a++
src/Nomyx/Core/Engine.hs view
@@ -27,9 +27,6 @@ activeRules, pendingRules, rejectedRules, -- * Events management- EventInfo(..),- EventHandler,- Status(..), events, getEventFields, getInput,@@ -56,7 +53,8 @@ ) where import Nomyx.Core.Engine.Evaluation-import Nomyx.Core.Engine.Game+import Nomyx.Core.Engine.EvalUtils+import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.GameEvents import Nomyx.Core.Engine.Utils import Nomyx.Core.Engine.Test
+ src/Nomyx/Core/Engine/EvalUtils.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | additional tools for evaluation+module Nomyx.Core.Engine.EvalUtils 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.Either+import Control.Applicative+import Control.Monad.Error (ErrorT(..))+import Language.Nomyx.Expression+import Nomyx.Core.Engine.Types+import Nomyx.Core.Engine.Utils+import Data.Todo++-- update the EventInfo with the field data+updateEventInfo :: (Typeable a, Show a) => Field a -> a -> EventInfo -> (EventInfo, Maybe SomeData)+updateEventInfo field dat ei@(EventInfo _ _ ev _ _ envi) =+ if (SomeField field) `elem` (getEventFields ev envi) -- if the field if found among the remaining fields of the event+ then case getEventResult ev (eventRes : envi) of -- then check the event with that field result included+ Todo _ -> (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment+ Done a -> (env ^= [] $ ei, Just $ SomeData a) -- the event is now complete: empty the environment and set the handler to be triggered+ else (ei, Nothing) -- field not found: do nothing+ where eventRes = EventEnv field dat+++-- 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 -> [EventEnv] -> Todo SomeField a+getEventResult (PureEvent a) _ = Done a+getEventResult EmptyEvent _ = Todo []+getEventResult (SumEvent a b) ers = (getEventResult a ers) <|> (getEventResult b ers)+getEventResult (AppEvent f b) ers = (getEventResult f ers) <*> (getEventResult b ers)+getEventResult (BaseEvent a) ers = case lookupField a ers of+ Just r -> Done r+ Nothing -> Todo [SomeField a]+getEventResult (ShortcutEvents es f) ers =+ let res = partitionEithers $ toEither <$> map (flip getEventResult ers) es+ in case f (snd res) of+ Just a -> Done a+ Nothing -> Todo $ join $ fst res++-- find a field result in an environment+lookupField :: Typeable a => Field a -> [EventEnv] -> Maybe a+lookupField _ [] = Nothing+lookupField be (EventEnv a r : ers) = case (cast (a,r)) of+ Just (a',r') -> if (a' == be) then Just r' else lookupField be ers+ Nothing -> lookupField be ers++--get the fields left to be completed in an event+getEventFields :: Event a -> [EventEnv] -> [SomeField]+getEventFields e er = case (getEventResult e er) of+ Done _ -> []+ Todo a -> a++errorHandler :: RuleNumber -> EventNumber -> String -> Evaluate ()+errorHandler rn en s = logAll $ "Error in rule " ++ show rn ++ " (triggered by event " ++ show en ++ "): " ++ s++getInput :: EventInfo -> InputNumber -> Maybe SomeField+getInput (EventInfo _ _ ev _ _ env) inn = find isInput (getEventFields ev env) where+ isInput (SomeField (Input (Just n) _ _ _)) | n == inn = True+ isInput _ = False++logPlayer :: PlayerNumber -> String -> Evaluate ()+logPlayer pn = log (Just pn)++logAll :: String -> Evaluate ()+logAll = log Nothing++log :: Maybe PlayerNumber -> String -> Evaluate ()+log mpn s = do+ time <- access currentTime+ void $ logs %= (Log mpn time s : )++liftEval :: Reader Game a -> Evaluate a+liftEval r = runReader r <$> get++--remove the ErrorT layer from the Evaluate monad stack.+runEvalError :: Maybe PlayerNumber -> Evaluate a -> State Game ()+runEvalError pn egs = do+ e <- runErrorT egs+ case e of+ Right _ -> return ()+ Left e -> do+ tracePN (fromMaybe 0 pn) $ "Error: " ++ e+ void $ runErrorT $ log pn "Error: "++-- Put an index on every input fields+indexInputs :: Event a -> Event a+indexInputs e = snd $ indexInputs' 0 e++indexInputs' :: Int -> Event a -> (Int, Event a)+indexInputs' n (BaseEvent (Input _ pn s ifo)) = (n+1, BaseEvent (Input (Just n) pn s ifo))+indexInputs' n (BaseEvent a) = (n, BaseEvent a)+indexInputs' n (PureEvent a) = (n, PureEvent a)+indexInputs' n EmptyEvent = (n, EmptyEvent)+indexInputs' n (SumEvent a b) = (n2, SumEvent e1 e2) where+ (n1, e1) = indexInputs' n a+ (n2, e2) = indexInputs' n1 b+indexInputs' n (AppEvent a b) = (n2, AppEvent e1 e2) where+ (n1, e1) = indexInputs' n a+ (n2, e2) = indexInputs' n1 b+indexInputs' n (ShortcutEvents as f) = (n1, ShortcutEvents bs f) where+ (n1, bs) = mapAccumL indexInputs' n as+++instance Eq SomeField where+ (SomeField e1) == (SomeField e2) = e1 === e2+++instance Show EventInfo where+ show (EventInfo en rn e _ s env) =+ "event num: " ++ (show en) +++ ", rule num: " ++ (show rn) +++ ", event fields: " ++ (show $ getEventFields e env) +++ ", envs: " ++ (show env) +++ ", status: " ++ (show s)
src/Nomyx/Core/Engine/Evaluation.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +-- | Evaluation of a Nomyx expression module Nomyx.Core.Engine.Evaluation where import Prelude hiding ((.), log)@@ -13,33 +14,67 @@ import Control.Monad.Reader import Data.List import Data.Typeable-import Data.Function hiding ((.)) import Data.Time import Data.Lens import Data.Maybe import Control.Category hiding (id) import Control.Applicative-import Control.Monad.Error (ErrorT(..)) import Control.Monad.Error.Class (MonadError(..)) import Language.Nomyx.Expression-import Nomyx.Core.Engine.Game+import Nomyx.Core.Engine.Types+import Nomyx.Core.Engine.EvalUtils import Nomyx.Core.Engine.Utils-import Safe -type Evaluate a = ErrorT String (State Game) a---- data sent back by the forms-data InputData = RadioData Int- | CheckboxData [Int]- | TextData String- | TextAreaData String- | ButtonData- deriving (Show, Read, Eq, Ord)+-- * Evaluation --- | evaluate an expression.+-- | evaluate an effecful expression. -- The rule number passed is the number of the rule containing the expression. evalNomex :: Nomex a -> RuleNumber -> Evaluate a-evalNomex (NewVar name def) rn = do+evalNomex (NewVar v a) rn = evNewVar v a rn+evalNomex (DelVar v) _ = evDelVar v+evalNomex (WriteVar v val) _ = evWriteVar v val+evalNomex (OnEvent ev h) rn = evOnEvent ev h rn+evalNomex (DelEvent en) _ = evDelEvent en+evalNomex (SendMessage m d) _ = evSendMessage m d+evalNomex (NewOutput pn s) rn = evNewOutput pn rn s+evalNomex (UpdateOutput on s) _ = evUpdateOutput on s+evalNomex (DelOutput on) _ = evDelOutput on+evalNomex (ProposeRule rule) _ = evProposeRule rule+evalNomex (ActivateRule rule) rn = evActivateRule rule rn+evalNomex (RejectRule rule) rn = evRejectRule rule rn+evalNomex (AddRule rule) _ = evAddRule rule+evalNomex (ModifyRule mod rule) _ = evModifyRule mod rule+evalNomex (SetPlayerName pn n) _ = evChangeName pn n+evalNomex (DelPlayer pn) _ = evDelPlayer pn+evalNomex (SetVictory ps) rn = evSetVictory ps rn+evalNomex (LiftEffect e) pn = liftEval $ evalNomexNE e pn+evalNomex (ThrowError s) _ = throwError s+evalNomex (CatchError n h) rn = catchError (evalNomex n rn) (\a -> evalNomex (h a) rn)+evalNomex (Return a) _ = return a+evalNomex (Bind exp f) rn = evalNomex exp rn >>= \e -> evalNomex (f e) rn++-- | evaluate an effectless expression.+evalNomexNE :: NomexNE a -> RuleNumber -> Reader Game a+evalNomexNE (ReadVar v) _ = evReadVar v+evalNomexNE (GetOutput on) _ = evGetOutput on+evalNomexNE GetRules _ = asks _rules+evalNomexNE GetPlayers _ = asks _players+evalNomexNE GetEvents _ = asks _events+evalNomexNE SelfRuleNumber rn = return rn+evalNomexNE (CurrentTime) _ = asks _currentTime+evalNomexNE (Return a) _ = return a+evalNomexNE (Bind exp f) rn = evalNomexNE exp rn >>= \e -> evalNomexNE (f e) rn+evalNomexNE (Simu sim ev) rn = evSimu sim ev rn++evSimu :: Nomex a -> NomexNE Bool -> RuleNumber -> Reader Game Bool+evSimu sim ev rn = do+ let s = runEvalError Nothing (evalNomex sim rn)+ g <- ask+ let g' = execState s g+ return $ runReader (evalNomexNE ev rn) g'++evNewVar :: (Typeable a, Show a) => VarName -> a -> RuleNumber -> Evaluate (Maybe (V a))+evNewVar name def rn = do vars <- access variables case find ((== name) . getL vName) vars of Nothing -> do@@ -47,7 +82,8 @@ return $ Just (V name) Just _ -> return Nothing -evalNomex (DelVar (V name)) _ = do+evDelVar :: (V a) -> Evaluate Bool+evDelVar (V name) = do vars <- access variables case find ((== name) . getL vName) vars of Nothing -> return False@@ -55,7 +91,8 @@ variables %= filter ((/= name) . getL vName) return True -evalNomex (WriteVar (V name) val) _ = do+evWriteVar :: (Typeable a, Show a) => V a -> a -> Evaluate Bool+evWriteVar (V name) val = do vars <- access variables case find (\(Var _ myName _) -> myName == name) vars of Nothing -> return False@@ -63,168 +100,15 @@ variables %= replaceWith ((== name) . getL vName) (Var rn myName val) return True -evalNomex (OnEvent event handler) rn = do+evOnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> RuleNumber -> Evaluate EventNumber+evOnEvent event handler rn = do evs <- access events let en = getFreeNumber (map _eventNumber evs) events %= (EventInfo en rn (indexInputs event) handler SActive [] : ) return en -evalNomex (DelEvent en) _ = evDelEvent en--evalNomex (SendMessage (Msg id) myData) _ = triggerEvent (Message (Msg id)) myData--evalNomex (NewOutput pn s) rn = evNewOutput pn rn s-evalNomex (UpdateOutput on s) _ = evUpdateOutput on s-evalNomex (DelOutput on) _ = evDelOutput on-evalNomex (ProposeRule rule) _ = evProposeRule rule-evalNomex (ActivateRule rule) rn = evActivateRule rule rn-evalNomex (RejectRule rule) rn = evRejectRule rule rn-evalNomex (AddRule rule) _ = evAddRule rule-evalNomex (ModifyRule mod rule) _ = evModifyRule mod rule-evalNomex (SetPlayerName pn n) _ = evChangeName pn n-evalNomex (DelPlayer pn) _ = evDelPlayer pn-evalNomex (LiftEffect e) pn = liftEval $ evalNomexNE e pn---evalNomex (ThrowError s) _ = throwError s-evalNomex (CatchError n h) rn = catchError (evalNomex n rn) (\a -> evalNomex (h a) rn)-evalNomex (SetVictory ps) rn = do- void $ victory ~= (Just $ VictoryCond rn ps)- triggerEvent Victory (VictoryCond rn ps)--evalNomex (Return a) _ = return a-evalNomex (Bind exp f) rn = do- e <- evalNomex exp rn- evalNomex (f e) rn--liftEval :: Reader Game a -> Evaluate a-liftEval r = runReader r <$> get--evalNomexNE :: NomexNE a -> RuleNumber -> Reader Game a-evalNomexNE (ReadVar (V name)) _ = do- vars <- asks _variables- let var = find ((== name) . getL vName) vars- case var of- Nothing -> return Nothing- Just (Var _ _ val) -> case cast val of- Just v -> return $ Just v- Nothing -> return Nothing--evalNomexNE (GetOutput on) _ = evGetOutput on-evalNomexNE GetRules _ = asks _rules-evalNomexNE GetPlayers _ = asks _players-evalNomexNE SelfRuleNumber rn = return rn-evalNomexNE (CurrentTime) _ = asks _currentTime-evalNomexNE (Return a) _ = return a-evalNomexNE (Bind exp f) rn = do- e <- evalNomexNE exp rn- evalNomexNE (f e) rn--evalNomexNE (Simu sim ev) rn = do- let s = runEvalError Nothing (evalNomex sim rn)- g <- ask- let g' = execState s g- return $ runReader (evalNomexNE ev rn) g'--getVictorious :: Game -> [PlayerNumber]-getVictorious g = case _victory g of- Nothing -> []- Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g--evalOutput :: Game -> Output -> String-evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g--allOutputs :: Game -> [String]-allOutputs g = map (evalOutput g) (_outputs g)--triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate ()-triggerEvent e dat = do- evs <- access events- triggerEvent' e dat evs---- receive a field data-triggerEvent' :: (Typeable e, Show e) => Field e -> e -> [EventInfo] -> Evaluate ()-triggerEvent' e dat evs = do- let evs' = map (updateEventInfo e dat) evs- events %= union (map fst evs')- mapM triggerIfComplete evs'- return ()--updateEventInfo :: (Typeable a, Show a) => Field a -> a -> EventInfo -> (EventInfo, Maybe SomeData)-updateEventInfo field dat ei@(EventInfo _ _ ev _ _ envi) =- if (SomeField field) `elem` (getEventFields ev envi) -- if the field if found among the remaining fields of the event- then case getEventResult ev (eventRes : envi) of -- then check the event with that field result included- BE (Left _) -> (env ^= (eventRes : envi) $ ei, Nothing) -- some fields are left to complete: add ours in the environment- BE (Right a) -> (env ^= [] $ ei, Just $ SomeData a) -- the event is now complete: empty the environment and set the handler to be triggered- else (ei, Nothing) -- field not found: do nothing- where eventRes = EventEnv field dat--data SomeData = forall e. (Typeable e, Show e) => SomeData e-deriving instance Show SomeData---- in the case an event is complete, trigger its handler-triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate ()-triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = do- case (cast val) of- Just a -> do- let exp = h (en, a)- (evalNomex exp rn) `catchError` (errorHandler rn en)- Nothing -> error "Bad trigger data type"-triggerIfComplete _ = return ()---- 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 -> [EventEnv] -> BEither [SomeField] a-getEventResult (PureEvent a) _ = BE (Right a)-getEventResult EmptyEvent _ = BE (Left [])-getEventResult (SumEvent a b) ers = (getEventResult a ers) <|> (getEventResult b ers)-getEventResult (AppEvent f b) ers = (getEventResult f ers) <*> (getEventResult b ers)-getEventResult (BaseEvent a) ers = case lookupField a ers of- Just r -> BE (Right r)- Nothing -> BE (Left [SomeField a])---- find a field result in an environment-lookupField :: Typeable a => Field a -> [EventEnv] -> Maybe a-lookupField _ [] = Nothing-lookupField be (EventEnv a r : ers) = case (cast (a,r)) of- Just (a',r') -> if (a' == be) then Just r' else lookupField be ers- Nothing -> lookupField be ers----get the fields lefft to be completed in an event-getEventFields :: Event a -> [EventEnv] -> [SomeField]-getEventFields e er = case (getEventResult e er) of- BE (Right _) -> []- BE (Left a) -> a--errorHandler :: RuleNumber -> EventNumber -> String -> Evaluate ()-errorHandler rn en s = logAll $ "Error in rule " ++ show rn ++ " (triggered by event " ++ show en ++ "): " ++ s---- trigger the input event with the input data-triggerInput :: EventNumber -> InputNumber -> InputData -> Evaluate ()-triggerInput en inn ir = do- evs <- access events- let mei = find ((== en) . getL eventNumber) evs- when (isJust mei) $ execInputHandler ir inn (fromJust mei)--execInputHandler :: InputData -> InputNumber -> EventInfo -> Evaluate ()-execInputHandler ir inn ei = do- case (getInput ei inn) of- Just sf -> execInputHandler' ir sf ei- Nothing -> error "Input not found"--getInput :: EventInfo -> InputNumber -> Maybe SomeField-getInput (EventInfo _ _ ev _ _ env) inn = find isInput (getEventFields ev env) where- isInput (SomeField (Input (Just n) _ _ _)) | n == inn = True- isInput _ = False---- execute the event handler using the data received from user-execInputHandler' :: InputData -> SomeField -> EventInfo -> Evaluate ()-execInputHandler' (TextData s) (SomeField e@(Input _ _ _ (Text))) ei = triggerEvent' e s [ei]-execInputHandler' (TextAreaData s) (SomeField e@(Input _ _ _ (TextArea))) ei = triggerEvent' e s [ei]-execInputHandler' (ButtonData) (SomeField e@(Input _ _ _ (Button))) ei = triggerEvent' e () [ei]-execInputHandler' (RadioData i) (SomeField e@(Input _ _ _ (Radio cs))) ei = triggerEvent' e (fst $ cs!!i) [ei]-execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ _ (Checkbox cs))) ei = triggerEvent' e (fst <$> cs `sel` is) [ei]-execInputHandler' _ _ _ = return ()+evSendMessage :: (Typeable a, Show a) => Msg a -> a -> Evaluate ()+evSendMessage (Msg id) d = triggerEvent (Message (Msg id)) d evProposeRule :: RuleInfo -> Evaluate Bool evProposeRule rule = do@@ -287,15 +171,6 @@ triggerEvent (RuleEv Modified) r return True -addPlayer :: PlayerInfo -> Evaluate Bool-addPlayer pi = do- pls <- access players- let exists = any (((==) `on` _playerNumber) pi) pls- unless exists $ do- players %= (pi:)- triggerEvent (Player Arrive) pi- return $ not exists- evDelPlayer :: PlayerNumber -> Evaluate Bool evDelPlayer pn = do g <- get@@ -330,29 +205,9 @@ return True SDeleted -> return False - evTriggerTime :: UTCTime -> Evaluate () evTriggerTime t = triggerEvent (Time t) t ----delete all variables of a rule-delVarsRule :: RuleNumber -> Evaluate ()-delVarsRule rn = void $ variables %= filter ((/= rn) . getL vRuleNumber)----delete all events of a rule-delEventsRule :: RuleNumber -> Evaluate ()-delEventsRule rn = do- evs <- access events- let toDelete = filter ((== rn) . getL ruleNumber) evs- mapM_ (evDelEvent . _eventNumber) toDelete----delete all outputs of a rule-delOutputsRule :: RuleNumber -> Evaluate ()-delOutputsRule rn = do- os <- access outputs- let toDelete = filter ((== rn) . getL oRuleNumber) os- mapM_ (evDelOutput . _outputNumber) toDelete- evNewOutput :: Maybe PlayerNumber -> RuleNumber -> NomexNE String -> Evaluate OutputNumber evNewOutput pn rn s = do ops <- access outputs@@ -390,63 +245,106 @@ return True SDeleted -> return False -logPlayer :: PlayerNumber -> String -> Evaluate ()-logPlayer pn = log (Just pn)+evSetVictory :: NomexNE [PlayerNumber] -> RuleNumber -> Evaluate ()+evSetVictory ps rn = do+ void $ victory ~= (Just $ VictoryCond rn ps)+ triggerEvent Victory (VictoryCond rn ps) -logAll :: String -> Evaluate ()-logAll = log Nothing+evReadVar :: (Typeable a, Show a) => V a -> Reader Game (Maybe a)+evReadVar (V name) = do+ vars <- asks _variables+ let var = find ((== name) . getL vName) vars+ case var of+ Nothing -> return Nothing+ Just (Var _ _ val) -> case cast val of+ Just v -> return $ Just v+ Nothing -> return Nothing -log :: Maybe PlayerNumber -> String -> Evaluate ()-log mpn s = do- time <- access currentTime- void $ logs %= (Log mpn time s : )+-- * Event triggers ---remove the ErrorT layer from the Evaluate monad stack.-runEvalError :: Maybe PlayerNumber -> Evaluate a -> State Game ()-runEvalError pn egs = do- e <- runErrorT egs- case e of- Right _ -> return ()- Left e -> do- tracePN (fromMaybe 0 pn) $ "Error: " ++ e- void $ runErrorT $ log pn "Error: "+-- trigger an event+triggerEvent :: (Typeable e, Show e) => Field e -> e -> Evaluate ()+triggerEvent e dat = do+ evs <- access events+ triggerEvent' e dat evs --- Put an index on every input fields-indexInputs :: Event a -> Event a-indexInputs e = fst $ indexInputs' 0 e+-- trigger some specific events+triggerEvent' :: (Typeable e, Show e) => Field e -> e -> [EventInfo] -> Evaluate ()+triggerEvent' e dat evs = do+ let evs' = map (updateEventInfo e dat) evs+ events %= union (map fst evs')+ mapM triggerIfComplete evs'+ return () -indexInputs' :: Int -> Event a -> (Event a, Int)-indexInputs' n (BaseEvent (Input _ pn s ifo)) = (BaseEvent (Input (Just n) pn s ifo), n+1)-indexInputs' n (BaseEvent a) = (BaseEvent a, n)-indexInputs' n (PureEvent a) = (PureEvent a, n)-indexInputs' n EmptyEvent = (EmptyEvent, n)-indexInputs' n (SumEvent a b) = (SumEvent e1 e2, n2) where- (e1, n1) = indexInputs' n a- (e2, n2) = indexInputs' n1 b-indexInputs' n (AppEvent a b) = (AppEvent e1 e2, n2) where- (e1, n1) = indexInputs' n a- (e2, n2) = indexInputs' n1 b+-- if the event is complete, trigger its handler+triggerIfComplete :: (EventInfo, Maybe SomeData) -> Evaluate ()+triggerIfComplete (EventInfo en rn _ h SActive _, Just (SomeData val)) = do+ case (cast val) of+ Just a -> do+ let exp = h (en, a)+ (evalNomex exp rn) `catchError` (errorHandler rn en)+ Nothing -> error "Bad trigger data type"+triggerIfComplete _ = return () -newtype BEither a b = BE (Either a b) deriving (Show, Eq, Typeable)-bLeft = BE . Left-bRight = BE . Right -instance Alternative (BEither [a]) where- empty = bLeft []- BE (Left a) <|> BE (Left b) = bLeft $ a ++ b- BE (Left _) <|> n = n- m <|> _ = m+-- * input triggers -instance Applicative (BEither [a]) where- pure = BE . Right- BE (Left a) <*> BE (Left b) = BE (Left (a ++ b))- BE (Left a) <*> _ = BE (Left a)- BE (Right f) <*> r = fmap f r+-- trigger the input event with the input data+triggerInput :: EventNumber -> InputNumber -> InputData -> Evaluate ()+triggerInput en inn ir = do+ evs <- access events+ let mei = find ((== en) . getL eventNumber) evs+ when (isJust mei) $ execInputHandler ir inn (fromJust mei) -instance Functor (BEither a) where- fmap _ (BE (Left x)) = BE (Left x)- fmap f (BE (Right y)) = BE (Right (f y))+-- execute the corresponding handler+execInputHandler :: InputData -> InputNumber -> EventInfo -> Evaluate ()+execInputHandler ir inn ei@(EventInfo _ _ _ _ SActive _) = do+ case (getInput ei inn) of+ Just sf -> execInputHandler' ir sf ei+ Nothing -> logAll "Input not found"+execInputHandler _ _ _ = return () +-- execute the event handler using the data received from user+execInputHandler' :: InputData -> SomeField -> EventInfo -> Evaluate ()+execInputHandler' (TextData s) (SomeField e@(Input _ _ _ (Text))) ei = triggerEvent' e s [ei]+execInputHandler' (TextAreaData s) (SomeField e@(Input _ _ _ (TextArea))) ei = triggerEvent' e s [ei]+execInputHandler' (ButtonData) (SomeField e@(Input _ _ _ (Button))) ei = triggerEvent' e () [ei]+execInputHandler' (RadioData i) (SomeField e@(Input _ _ _ (Radio cs))) ei = triggerEvent' e (fst $ cs!!i) [ei]+execInputHandler' (CheckboxData is) (SomeField e@(Input _ _ _ (Checkbox cs))) ei = triggerEvent' e (fst <$> cs `sel` is) [ei]+execInputHandler' _ _ _ = return ()++-- * misc++getVictorious :: Game -> [PlayerNumber]+getVictorious g = case _victory g of+ Nothing -> []+ Just (VictoryCond rn v) -> runReader (evalNomexNE v rn) g++evalOutput :: Game -> Output -> String+evalOutput g (Output _ rn _ o _) = runReader (evalNomexNE o rn) g++allOutputs :: Game -> [String]+allOutputs g = map (evalOutput g) (_outputs g)++--delete all variables of a rule+delVarsRule :: RuleNumber -> Evaluate ()+delVarsRule rn = void $ variables %= filter ((/= rn) . getL vRuleNumber)++--delete all events of a rule+delEventsRule :: RuleNumber -> Evaluate ()+delEventsRule rn = do+ evs <- access events+ let toDelete = filter ((== rn) . getL ruleNumber) evs+ mapM_ (evDelEvent . _eventNumber) toDelete++--delete all outputs of a rule+delOutputsRule :: RuleNumber -> Evaluate ()+delOutputsRule rn = do+ os <- access outputs+ let toDelete = filter ((== rn) . getL oRuleNumber) os+ mapM_ (evDelOutput . _outputNumber) toDelete++ -- | Show instance for Game -- showing a game involves evaluating some parts (such as victory and outputs) instance Show Game where@@ -461,13 +359,3 @@ "\n currentTime = " ++ show _currentTime ++ "\n" -instance Show EventInfo where- show (EventInfo en rn e _ s env) =- "event num: " ++ (show en) ++- ", rule num: " ++ (show rn) ++- ", event fields: " ++ (show $ getEventFields e env) ++- ", envs: " ++ (show env) ++- ", status: " ++ (show s)--instance Eq SomeField where- (SomeField e1) == (SomeField e2) = e1 === e2
− src/Nomyx/Core/Engine/Game.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}---- | This module implements game engine (for the nomyx language, see Language.Nomyx)-module Nomyx.Core.Engine.Game where--import Prelude hiding (log)-import Language.Nomyx.Expression-import Data.Lens.Template-import Data.Time-import Data.Typeable-import Data.Data---- * Game--type GameName = String---- | The state of the game:-data Game = Game { _gameName :: GameName,- _gameDesc :: GameDesc,- _rules :: [RuleInfo],- _players :: [PlayerInfo],- _variables :: [Var],- _events :: [EventInfo],- _outputs :: [Output],- _victory :: Maybe VictoryCond,- _logs :: [Log],- _currentTime :: UTCTime}- deriving (Typeable)--data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord)--instance Eq Game where- (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2--instance Ord Game where- compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2--emptyGame name desc date = Game {- _gameName = name,- _gameDesc = desc,- _rules = [],- _players = [],- _variables = [],- _events = [],- _outputs = [],- _victory = Nothing,- _logs = [],- _currentTime = date}----- * Variables---- | stores the variable's data-data Var = forall a . (Typeable a, Show a) =>- Var { _vRuleNumber :: RuleNumber,- _vName :: String,- vData :: a}--instance Show Var where- show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n"---- * Events--type EventHandler e = (EventNumber, e) -> Nomex ()--data EventInfo = forall e. (Typeable e, Show e) =>- EventInfo {_eventNumber :: EventNumber,- _ruleNumber :: RuleNumber,- event :: Event e,- handler :: EventHandler e,- _evStatus :: Status,- _env :: [EventEnv]}--data EventEnv = forall e. (Typeable e, Show e) => EventEnv (Field e) e--deriving instance Show EventEnv--data Status = SActive | SDeleted deriving (Eq, Show)--instance Eq EventInfo where- (EventInfo {_eventNumber=e1}) == (EventInfo {_eventNumber=e2}) = e1 == e2--instance Ord EventInfo where- (EventInfo {_eventNumber=e1}) <= (EventInfo {_eventNumber=e2}) = e1 <= e2----- * Outputs--data Output = Output { _outputNumber :: OutputNumber, -- number of the output- _oRuleNumber :: RuleNumber, -- rule that triggered the output- _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players)- _output :: NomexNE String, -- output string- _oStatus :: Status} -- status of the output- deriving (Show)---- * Logs--data Log = Log { _lPlayerNumber :: Maybe PlayerNumber,- _lTime :: UTCTime,- _lMsg :: String}- deriving (Show)---- * Rules--data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable)---$( makeLenses [''Game, ''GameDesc, ''EventInfo, ''Var, ''Output] )---
src/Nomyx/Core/Engine/GameEvents.hs view
@@ -9,7 +9,8 @@ import Data.List import Language.Nomyx.Expression import Nomyx.Core.Engine.Evaluation-import Nomyx.Core.Engine.Game+import Nomyx.Core.Engine.EvalUtils+import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Data.Lens import Control.Category ((>>>))
src/Nomyx/Core/Engine/Test.hs view
@@ -12,14 +12,15 @@ import Language.Nomyx.Inputs import Language.Nomyx.Vote import Language.Nomyx.Examples-import Language.Nomyx.Players import Nomyx.Core.Engine.Evaluation-import Nomyx.Core.Engine.Game+import Nomyx.Core.Engine.EvalUtils+import Nomyx.Core.Engine.Types import Nomyx.Core.Engine.Utils import Control.Monad.State import Data.Lens import Data.Typeable-import qualified Data.Foldable as T+import Data.Function hiding ((.))+import Data.Maybe import Control.Applicative date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"@@ -96,9 +97,8 @@ ("test assess on every vote 3", testVoteAssessOnEveryVote3), ("test assess on every vote 4", testVoteAssessOnEveryVote4), ("test majority with", testVoteMajorityWith),- ("test number positive votes", testVoteNumberPositiveVotes),+-- ("test number positive votes", testVoteNumberPositiveVotes), ("test vote with quorum 1", testVoteWithQuorum1),- ("test vote with quorum 2", testVoteWithQuorum2), ("test assess on time limit 1", testVoteAssessOnTimeLimit1), ("test assess on time limit 2", testVoteAssessOnTimeLimit2), ("test assess on time limit 3", testVoteAssessOnTimeLimit3),@@ -107,7 +107,8 @@ ("test composed event sum", testSumComposeEx), ("test composed event prod 1", testProdComposeEx1), ("test composed event prod 2", testProdComposeEx2),- ("test two separate events", testTwoEventsEx)]+ ("test two separate events", testTwoEventsEx)+ ] allTests = all snd tests @@ -290,8 +291,8 @@ evs <- lift getChoiceEvents let pos = take positives evs let neg = take negatives $ drop positives evs- mapM_ (\x -> triggerInput x 0 (RadioData $ fromEnum For)) pos- mapM_ (\x -> triggerInput x 0 (RadioData $ fromEnum Against)) neg+ mapM_ (\(en, inum) -> triggerInput en inum (RadioData 0)) pos --issuing positive votes+ mapM_ (\(en, inum) -> triggerInput en inum (RadioData 1)) neg --issuing negative votes when timeEvent $ evTriggerTime date2 voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game@@ -303,22 +304,21 @@ voteGameTimed :: Int -> Int -> Int -> Rule -> Game voteGameTimed positives negatives notVoted = voteGame' positives negatives notVoted True --- vote rules |Expected result |pos |neg |total |description of voting system-testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ majority assessWhenEverybodyVoted-testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ voteWith_ majority assessWhenEverybodyVoted-testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ voteWith_ unanimity assessOnEveryVote-testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote-testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote-testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ voteWith_ majority assessOnEveryVote-testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majorityWith 50) assessOnEveryVote-testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ voteWith_ (numberVotes 3) assessOnEveryVote-testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) assessOnEveryVote-testVoteWithQuorum2 = testVoteRule Pending $ voteGame 6 0 10 $ onRuleProposed $ voteWith_ (majority `withQuorum` 7) assessOnEveryVote-testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 5) $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ voteWith_ (unanimity `withQuorum` 1) $ assessOnTimeLimit date2-testVoteAssessOnTimeLimit5 = testVoteRule Pending $ voteGameTimed 10 0 10 $ onRuleProposed $ voteWith_ unanimity $ assessOnTimeLimit date3+-- vote rules |Expected result |pos |neg |total |description of voting system+testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ (callVoteRule majority oneDay)+testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ (callVoteRule unanimity oneDay)+testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ (callVoteRule unanimity oneDay)+testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ (callVoteRule majority oneDay)+testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ (callVoteRule majority oneDay)+testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ (callVoteRule majority oneDay)+testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ (callVoteRule (majorityWith 50) oneDay)+testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ (callVoteRule (numberVotes 3) oneDay)+testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ (callVoteRule (majority `withQuorum` 7) oneDay)+testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ (callVoteRule' unanimity date2)+testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' unanimity date2)+testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 5) date2)+testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2)+testVoteAssessOnTimeLimit5 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2) testVoteRule s g = (_rStatus $ head $ _rules g) == s @@ -352,27 +352,35 @@ --Get all event numbers of type choice (radio button)-getChoiceEvents :: State Game [EventNumber]+getChoiceEvents :: State Game [(EventNumber, InputNumber)] getChoiceEvents = do evs <- access events- return $ map _eventNumber $ filter choiceEvent evs- where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ (Radio _))) _ _ _) = True- choiceEvent _ = False+ return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputChoices ev ] +getInputChoices :: EventInfo -> [InputNumber]+getInputChoices (EventInfo _ _ ev _ _ env) = mapMaybe isInput (getEventFields ev env) where+ isInput (SomeField (Input (Just inum) _ _ (Radio _))) = Just inum+ isInput _ = Nothing+ --Get all event numbers of type text (text field)-getTextEvents :: State Game [EventNumber]+getTextEvents :: State Game [(EventNumber, InputNumber)] getTextEvents = do evs <- access events- return $ map _eventNumber $ filter choiceEvent evs- where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ Text)) _ _ _) = True- choiceEvent _ = False+ return $ [(_eventNumber ev, inum) | ev <- evs, inum <- getInputTexts ev ] -isOutput :: String -> Game -> Bool-isOutput s g = s `elem` allOutputs g+getInputTexts :: EventInfo -> [InputNumber]+getInputTexts (EventInfo _ _ ev _ _ env) = mapMaybe isInput (getEventFields ev env) where+ isInput (SomeField (Input (Just inum) _ _ Text)) = Just inum+ isInput _ = Nothing +addPlayer :: PlayerInfo -> Evaluate Bool+addPlayer pi = do+ pls <- access players+ let exists = any (((==) `on` _playerNumber) pi) pls+ unless exists $ do+ players %= (pi:)+ triggerEvent (Player Arrive) pi+ return $ not exists -myEvent :: NomexNE (Event String)-myEvent = do- ps <- getAllPlayerNumbers- let oneButton pn = inputText pn "test"- return $ T.asum (map oneButton ps)+isOutput :: String -> Game -> Bool+isOutput s g = s `elem` allOutputs g
+ src/Nomyx/Core/Engine/Types.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Types for the engine+module Nomyx.Core.Engine.Types where++import Prelude hiding (log)+import Language.Nomyx.Expression+import Data.Lens.Template+import Data.Time+import Data.Typeable+import Data.Data+import Control.Monad.Error (ErrorT(..))+import Control.Monad.State++-- * Game++type GameName = String++-- | The state of the game:+data Game = Game { _gameName :: GameName,+ _gameDesc :: GameDesc,+ _rules :: [RuleInfo],+ _players :: [PlayerInfo],+ _variables :: [Var],+ _events :: [EventInfo],+ _outputs :: [Output],+ _victory :: Maybe VictoryCond,+ _logs :: [Log],+ _currentTime :: UTCTime}+ deriving (Typeable)++data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord)++instance Eq Game where+ (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2++instance Ord Game where+ compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2++emptyGame name desc date = Game {+ _gameName = name,+ _gameDesc = desc,+ _rules = [],+ _players = [],+ _variables = [],+ _events = [],+ _outputs = [],+ _victory = Nothing,+ _logs = [],+ _currentTime = date}+++-- * Variables++-- | stores the variable's data+data Var = forall a . (Typeable a, Show a) =>+ Var { _vRuleNumber :: RuleNumber,+ _vName :: String,+ vData :: a}++instance Show Var where+ show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n"++-- * Events++type Evaluate a = ErrorT String (State Game) a++-- data sent back by the forms+data InputData = RadioData Int+ | CheckboxData [Int]+ | TextData String+ | TextAreaData String+ | ButtonData+ deriving (Show, Read, Eq, Ord)++data SomeData = forall e. (Typeable e, Show e) => SomeData e+deriving instance Show SomeData++-- * Outputs++data Output = Output { _outputNumber :: OutputNumber, -- number of the output+ _oRuleNumber :: RuleNumber, -- rule that triggered the output+ _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players)+ _output :: NomexNE String, -- output string+ _oStatus :: Status} -- status of the output+ deriving (Show)++-- * Logs++data Log = Log { _lPlayerNumber :: Maybe PlayerNumber,+ _lTime :: UTCTime,+ _lMsg :: String}+ deriving (Show)++-- * Rules++data SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable)+++$( makeLenses [''Game, ''GameDesc, ''Var, ''Output] )+++++
src/Nomyx/Core/Multi.hs view
@@ -4,7 +4,6 @@ module Nomyx.Core.Multi where import Language.Haskell.Interpreter.Server (ServerHandle)-import Data.Maybe import Data.Lens import Data.List import Data.Time as T@@ -45,7 +44,7 @@ -- | the initial rule set for a game. rVoteUnanimity = SubmitRule "Unanimity Vote" "A proposed rule will be activated if all players vote for it"- [cr|onRuleProposed $ voteWith_ unanimity $ assessOnEveryVote |]+ [cr|onRuleProposed $ callVoteRule unanimity oneDay|] rVictory5Rules = SubmitRule "Victory 5 accepted rules" "Victory is achieved if you have 5 active rules"@@ -53,7 +52,7 @@ rVoteMajority = SubmitRule "Majority Vote" "A proposed rule will be activated if a majority of players is reached, with a minimum of 2 players, and within oone day"- [cr|onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneMinute |]+ [cr|onRuleProposed $ callVoteRule (majority `withQuorum` 2) oneDay|] initialGame :: ServerHandle -> StateT GameInfo IO ()
src/Nomyx/Core/Quotes.hs view
@@ -44,7 +44,8 @@ setImports unQualImports typeOf s case res of- Right "Exp Effect ()" -> [| s |]+ Right "Exp Effect ()" -> [| s |]+ Right "Nomex ()" -> [| s |] Right "Exp 'Effect ()" -> [| s |] Right "Rule" -> [| s |] Right a -> fail $ "Rule doesn't typecheck: " ++ show a
src/Nomyx/Core/Test.hs view
@@ -316,14 +316,14 @@ inputAllRadios choice pn = do s <- get let evs = evalState getChoiceEvents (firstGame $ _multi s)- mapM_ (\en -> inputResult pn en 0 (RadioData choice) "test") evs+ mapM_ (\(en, inum) -> inputResult pn en inum (RadioData choice) "test") evs -- input text for all text fields inputAllTexts :: String -> PlayerNumber -> StateT Session IO () inputAllTexts a pn = do s <- get let evs = evalState getTextEvents (firstGame $ _multi s)- mapM_ (\en -> inputResult pn en 0 (TextData a) "test") evs+ mapM_ (\(en, inum) -> inputResult pn en inum (TextData a) "test") evs firstGame :: Multi -> Game firstGame = G._game . _loggedGame . head . _gameInfos