Nomyx-Core 0.5.0 → 0.6.0
raw patch · 20 files changed
+1465/−121 lines, 20 filesdep +deepseqdep +old-localedep −muevaldep ~Nomyx-Language
Dependencies added: deepseq, old-locale
Dependencies removed: mueval
Dependency ranges changed: Nomyx-Language
Files
- AUTHORS +1/−1
- Nomyx-Core.cabal +12/−4
- README +0/−2
- src/Nomyx/Core/Context.hs +71/−0
- src/Nomyx/Core/Engine.hs +63/−0
- src/Nomyx/Core/Engine/Evaluation.hs +473/−0
- src/Nomyx/Core/Engine/Game.hs +116/−0
- src/Nomyx/Core/Engine/GameEvents.hs +188/−0
- src/Nomyx/Core/Engine/Test.hs +378/−0
- src/Nomyx/Core/Engine/Utils.hs +51/−0
- src/Nomyx/Core/Interpret.hs +13/−46
- src/Nomyx/Core/Mail.hs +10/−11
- src/Nomyx/Core/Multi.hs +7/−8
- src/Nomyx/Core/Profile.hs +8/−6
- src/Nomyx/Core/Quotes.hs +1/−1
- src/Nomyx/Core/Serialize.hs +8/−8
- src/Nomyx/Core/Session.hs +13/−11
- src/Nomyx/Core/Test.hs +10/−11
- src/Nomyx/Core/Types.hs +6/−5
- src/Nomyx/Core/Utils.hs +36/−7
AUTHORS view
@@ -1,1 +1,1 @@-corentin.dupont@gmail.com+Corentin Dupont <corentin.dupontDELAVEGAgmail.com> (remove DELAVEGA to obtain my email)
Nomyx-Core.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Core-version: 0.5.0+version: 0.6.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -15,7 +15,7 @@ data-dir: data library - build-depends: Nomyx-Language == 0.5.0,+ build-depends: Nomyx-Language == 0.6.0, DebugTraceHelpers == 0.12.*, MissingH == 1.2.*, acid-state == 0.12.*,@@ -38,8 +38,9 @@ ixset == 1.0.*, mime-mail == 0.4.*, mtl == 2.1.*,- mueval == 0.9.*,+ deepseq == 1.3.*, network == 2.4.*,+ old-locale == 1.0.*, safe == 0.3.*, safecopy == 0.8.*, stm == 2.4.*,@@ -63,13 +64,20 @@ Nomyx.Core.Multi Nomyx.Core.Serialize Nomyx.Core.Interpret+ Nomyx.Core.Context Nomyx.Core.Quotes Nomyx.Core.Mail Nomyx.Core.Utils Nomyx.Core.Test+ Nomyx.Core.Engine+ Nomyx.Core.Engine.Evaluation+ Nomyx.Core.Engine.Game+ Nomyx.Core.Engine.GameEvents+ Nomyx.Core.Engine.Test+ Nomyx.Core.Engine.Utils Paths_Nomyx_Core ghc-options: -W -threaded source-repository head type: git- location: git://github.com/cdupont/Nomyx-Core.git+ location: https://github.com/cdupont/Nomyx-Core.git
README view
@@ -1,5 +1,3 @@-[](https://travis-ci.org/cdupont/Nomyx-Core)-[](https://hackage.haskell.org/package/Nomyx-Core) Nomyx-Core =========
+ src/Nomyx/Core/Context.hs view
@@ -0,0 +1,71 @@+module Nomyx.Core.Context (+ unQualImports,+ qualImports,+ defaultPackages+) where+++unQualImports :: [String]+unQualImports = ["Language.Nomyx",+ "Language.Nomyx.Examples",+ "Safe",+ "Data.Typeable",+ "Data.Lens",+ "Prelude",+ "Data.Function",+ "Control.Applicative",+ "Control.Arrow",+ "Control.Monad",+ "Control.Monad.Cont",+ "Control.Monad.Error",+ "Control.Monad.Fix",+ "Control.Monad.Identity",+ "Control.Monad.Instances",+ "Control.Monad.RWS",+ "Control.Monad.Reader",+ "Control.Monad.State",+ "Control.Monad.State",+ "Control.Monad.Writer",+ "Data.Array",+ "Data.Bits",+ "Data.Bool",+ "Data.Char",+ "Data.Complex",+ "Data.Dynamic",+ "Data.Either",+ "Data.Eq",+ "Data.Fixed",+ "Data.Graph",+ "Data.Int",+ "Data.Ix",+ "Data.List",+ "Data.Maybe",+ "Data.Monoid",+ "Data.Ord",+ "Data.Ratio",+ "Data.Tree",+ "Data.Tuple",+ "Data.Typeable",+ "Data.Word",+ "System.Random"]++defaultPackages :: [String]+defaultPackages = ["Nomyx-Language",+ "array",+ "base",+ "bytestring",+ "containers"]++qualImports :: [(String, Maybe String)]+qualImports = [("Control.Category", Just "C"),+ ("Data.ByteString", Just "BS"),+ ("Data.ByteString.Char8", Just "BSC"),+ ("Data.ByteString.Lazy", Just "BSL"),+ ("Data.ByteString.Lazy.Char8", Just "BSLC"),+ ("Data.Foldable", Just "Data.Foldable"),+ ("Data.IntMap", Just "IM"),+ ("Data.IntSet", Just "IS"),+ ("Data.Map", Just "M"),+ ("Data.Sequence", Just "Data.Sequence"),+ ("Data.Set", Just "S"),+ ("Data.Traversable", Just "Data.Traversable") ]
+ src/Nomyx/Core/Engine.hs view
@@ -0,0 +1,63 @@++-- | 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(..),+ LoggedGame(..),+ GameName,+ Game(..),+ GameDesc(..),+ execGameEvent, execGameEvent',+ execWithGame, execWithGame',+ game,+ emptyGame,+ getLoggedGame,+ gameName,+ players,+ getVictorious,++ -- * Variables management+ Var(..),++ -- * Rules management+ SubmitRule(..),+ activeRules, pendingRules, rejectedRules,++ -- * Events management+ EventInfo(..),+ EventHandler,+ Status(..),+ events,+ getEventFields,+ getInput,+ getEventInfo,++ -- * Inputs management+ InputData(..),++ -- * Outputs management+ Output(..),+ Log(..),+ evalOutput,+ isOutput,++ -- * Time+ getTimes,+ currentTime,++ -- * Misc+ tracePN,+ replaceWith,+ getChoiceEvents,+ getTextEvents+ ) where++import Nomyx.Core.Engine.Evaluation+import Nomyx.Core.Engine.Game+import Nomyx.Core.Engine.GameEvents+import Nomyx.Core.Engine.Utils+import Nomyx.Core.Engine.Test+
+ src/Nomyx/Core/Engine/Evaluation.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++module Nomyx.Core.Engine.Evaluation where++import Prelude hiding ((.), log)+import Control.Monad+import Control.Monad.State+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.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)++-- | evaluate an 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+ vars <- access variables+ case find ((== name) . getL vName) vars of+ Nothing -> do+ variables %= (Var rn name def : )+ return $ Just (V name)+ Just _ -> return Nothing++evalNomex (DelVar (V name)) _ = do+ vars <- access variables+ case find ((== name) . getL vName) vars of+ Nothing -> return False+ Just _ -> do+ variables %= filter ((/= name) . getL vName)+ return True++evalNomex (WriteVar (V name) val) _ = do+ vars <- access variables+ case find (\(Var _ myName _) -> myName == name) vars of+ Nothing -> return False+ Just (Var rn myName _) -> do+ variables %= replaceWith ((== name) . getL vName) (Var rn myName val)+ return True++evalNomex (OnEvent 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 ()++evProposeRule :: RuleInfo -> Evaluate Bool+evProposeRule rule = do+ rs <- access rules+ case find ((== (rNumber ^$ rule)) . getL rNumber) rs of+ Nothing -> do+ rules %= (rule:)+ triggerEvent (RuleEv Proposed) rule+ return True+ Just _ -> return False++--Sets the rule status to Active and execute it if possible+evActivateRule :: RuleNumber -> RuleNumber -> Evaluate Bool+evActivateRule rn by = do+ rs <- access rules+ case find (\r -> _rNumber r == rn && _rStatus r /= Active) rs of+ Nothing -> return False+ Just r -> do+ let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs+ rules ~= newrules+ --execute the rule+ evalNomex (_rRule r) rn+ triggerEvent (RuleEv Activated) r+ return True++evRejectRule :: RuleNumber -> RuleNumber -> Evaluate Bool+evRejectRule rn by = do+ rs <- access rules+ case find (\r -> _rNumber r == rn && _rStatus r /= Reject) rs of+ Nothing -> return False+ Just r -> do+ let newrules = replaceWith ((== rn) . getL rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs+ rules ~= newrules+ triggerEvent (RuleEv Rejected) r+ delVarsRule rn+ delEventsRule rn+ delOutputsRule rn+ return True++evAddRule :: RuleInfo -> Evaluate Bool+evAddRule rule = do+ rs <- access rules+ case find ((== (rNumber ^$ rule)) . getL rNumber) rs of+ Nothing -> do+ rules %= (rule:)+ triggerEvent (RuleEv Added) rule+ return True+ Just _ -> return False+++--TODO: clean and execute new rule+evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool+evModifyRule mod rule = do+ rs <- access rules+ let newRules = replaceWith ((== mod) . getL rNumber) rule rs+ case find ((== mod) . getL rNumber) rs of+ Nothing -> return False+ Just r -> do+ rules ~= newRules+ 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+ case find ((== pn) . getL playerNumber) (_players g) of+ Nothing -> do+ tracePN pn "not in game!"+ return False+ Just pi -> do+ players %= filter ((/= pn) . getL playerNumber)+ triggerEvent (Player Leave) pi+ tracePN pn $ "leaving the game: " ++ _gameName g+ return True++evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool+evChangeName pn name = do+ pls <- access players+ case find ((== pn) . getL playerNumber) pls of+ Nothing -> return False+ Just pi -> do+ players ~= replaceWith ((== pn) . getL playerNumber) (pi {_playerName = name}) pls+ return True++evDelEvent :: EventNumber -> Evaluate Bool+evDelEvent en = do+ evs <- access events+ case find ((== en) . getL eventNumber) evs of+ Nothing -> return False+ Just eh -> case _evStatus eh of+ SActive -> do+ let newEvents = replaceWith ((== en) . getL eventNumber) eh{_evStatus = SDeleted} evs+ events ~= newEvents+ 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+ let on = getFreeNumber (map _outputNumber ops)+ outputs %= (Output on rn pn s SActive : )+ return on++evGetOutput :: OutputNumber -> Reader Game (Maybe String)+evGetOutput on = do+ ops <- asks _outputs+ case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of+ Nothing -> return Nothing+ Just (Output _ rn _ o _) -> do+ out <- evalNomexNE o rn+ return $ Just out++evUpdateOutput :: OutputNumber -> NomexNE String -> Evaluate Bool+evUpdateOutput on s = do+ ops <- access outputs+ case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of+ Nothing -> return False+ Just (Output _ rn pn _ _) -> do+ outputs %= replaceWith ((== on) . getL outputNumber) (Output on rn pn s SActive)+ return True++evDelOutput :: OutputNumber -> Evaluate Bool+evDelOutput on = do+ ops <- access outputs+ case find ((== on) . getL outputNumber) ops of+ Nothing -> return False+ Just o -> case _oStatus o of+ SActive -> do+ let newOutputs = replaceWith ((== on) . getL outputNumber) o{_oStatus = SDeleted} ops+ outputs ~= newOutputs+ return True+ SDeleted -> return 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 : )++--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 = fst $ indexInputs' 0 e++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++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++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++instance Functor (BEither a) where+ fmap _ (BE (Left x)) = BE (Left x)+ fmap f (BE (Right y)) = BE (Right (f y))++-- | Show instance for Game+-- showing a game involves evaluating some parts (such as victory and outputs)+instance Show Game where+ show g@(Game { _gameName, _rules, _players, _variables, _events, _victory, _currentTime}) =+ "Game Name = " ++ show _gameName +++ "\n Rules = " ++ (intercalate "\n " $ map show _rules) +++ "\n Players = " ++ show _players +++ "\n Variables = " ++ show _variables +++ "\n Events = " ++ (intercalate "\n " $ map show _events) +++ "\n Outputs = " ++ show (allOutputs g) +++ "\n Victory = " ++ show (getVictorious g) +++ "\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 view
@@ -0,0 +1,116 @@+{-# 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
@@ -0,0 +1,188 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module implements the events that can affect a game.+module Nomyx.Core.Engine.GameEvents where++import Prelude hiding (log)+import Control.Monad.State+import Data.List+import Language.Nomyx.Expression+import Nomyx.Core.Engine.Evaluation+import Nomyx.Core.Engine.Game+import Nomyx.Core.Engine.Utils+import Data.Lens+import Control.Category ((>>>))+import Data.Lens.Template+import Control.Exception as E+import Data.Time+import Data.Maybe++-- | a list of possible events affecting a game+data GameEvent = GameSettings GameName GameDesc UTCTime+ | JoinGame PlayerNumber PlayerName+ | LeaveGame PlayerNumber+ | ProposeRuleEv PlayerNumber SubmitRule+ | InputResult PlayerNumber EventNumber InputNumber InputData+ | GLog (Maybe PlayerNumber) String+ | TimeEvent UTCTime+ | SystemAddRule SubmitRule+ deriving (Show, Read, Eq, Ord)++data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord)++-- | A game being non serializable, we have to store events in parralel in order to rebuild the state latter.+data LoggedGame = LoggedGame { _game :: Game,+ _gameLog :: [TimedEvent]}+ deriving (Show)++instance Eq LoggedGame where+ (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2++instance Ord LoggedGame where+ compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2++$( makeLens ''LoggedGame)++-- | perform a game event+enactEvent :: GameEvent -> Maybe (RuleCode -> IO Rule) -> StateT Game IO ()+enactEvent (GameSettings name desc date) _ = mapStateIO $ gameSettings name desc date+enactEvent (JoinGame pn name) _ = mapStateIO $ joinGame name pn+enactEvent (LeaveGame pn) _ = mapStateIO $ leaveGame pn+enactEvent (ProposeRuleEv pn sr) (Just inter) = void $ proposeRule sr pn inter+enactEvent (InputResult pn en inn ir) _ = mapStateIO $ inputResult pn en inn ir+enactEvent (GLog mpn s) _ = mapStateIO $ logGame s mpn+enactEvent (TimeEvent t) _ = mapStateIO $ runEvalError Nothing $ evTriggerTime t+enactEvent (SystemAddRule r) (Just inter) = systemAddRule r inter+enactEvent (ProposeRuleEv _ _) Nothing = error "ProposeRuleEv: interpreter function needed"+enactEvent (SystemAddRule _) Nothing = error "SystemAddRule: interpreter function needed"++enactTimedEvent :: Maybe (RuleCode -> IO Rule) -> TimedEvent -> StateT Game IO ()+enactTimedEvent inter (TimedEvent t ge) = flip stateCatch updateError $ do+ currentTime ~= t+ enactEvent ge inter+ lg <- get+ lift $ evaluate lg+ return ()++updateError :: SomeException -> StateT Game IO ()+updateError e = do+ liftIO $ putStrLn $ "IO error: " ++ show e+ mapStateIO $ logGame ("IO error: " ++ show e) Nothing++execGameEvent :: GameEvent -> StateT LoggedGame IO ()+execGameEvent = execGameEvent' Nothing++execGameEvent' :: Maybe (RuleCode -> IO Rule) -> GameEvent -> StateT LoggedGame IO ()+execGameEvent' inter ge = do+ t <- access $ game >>> currentTime+ let te = TimedEvent t ge+ gameLog %= \gl -> gl ++ [te]+ focus game $ enactTimedEvent inter te++getLoggedGame :: Game -> (RuleCode -> IO Rule) -> [TimedEvent] -> IO LoggedGame+getLoggedGame g mInter tes = do+ let a = mapM_ (enactTimedEvent (Just mInter)) tes+ g' <- execStateT a g+ return $ LoggedGame g' tes++-- | initialize the game.+gameSettings :: GameName -> GameDesc -> UTCTime -> State Game ()+gameSettings name desc date = do+ gameName ~= name+ gameDesc ~= desc+ currentTime ~= date+ return ()++-- | join the game.+joinGame :: PlayerName -> PlayerNumber -> State Game ()+joinGame name pn = do+ g <- get+ case find ((== pn) . getL playerNumber) (_players g) of+ Just _ -> return ()+ Nothing -> do+ tracePN pn $ "Joining game: " ++ _gameName g+ let player = PlayerInfo { _playerNumber = pn, _playerName = name, _playAs = Nothing}+ players %= (player : )+ runEvalError (Just pn) $ triggerEvent (Player Arrive) player+++-- | leave the game.+leaveGame :: PlayerNumber -> State Game ()+leaveGame pn = runEvalError (Just pn) $ void $ evDelPlayer pn++-- | insert a rule in pending rules.+proposeRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO ()+proposeRule sr pn inter = do+ rule <- createRule sr pn inter+ mapStateIO $ runEvalError (Just pn) $ do+ r <- evProposeRule rule+ tracePN pn $ if r then "Your rule has been added to pending rules."+ else "Error: Rule could not be proposed"++-- | add a rule forcefully (no votes etc.)+systemAddRule :: SubmitRule -> (RuleCode -> IO Rule) -> StateT Game IO ()+systemAddRule sr inter = do+ rule <- createRule sr 0 inter+ let sysRule = (rStatus ^= Active) >>> (rAssessedBy ^= Just 0)+ rules %= (sysRule rule : )+ mapStateIO $ runEvalError (Just 0) $ void $ evalNomex (_rRule rule) (_rNumber rule)++-- | insert a log message.+logGame :: String -> Maybe PlayerNumber -> State Game ()+logGame s mpn = do+ time <- access currentTime+ void $ logs %= (Log mpn time s : )++-- | the user has provided an input result+-- TODO: this is relying on the EventNumber, which may change at all time+inputResult :: PlayerNumber -> EventNumber -> InputNumber -> InputData -> State Game ()+inputResult pn en inn ir = do+ tracePN pn $ "input result: EventNumber " ++ show en ++ ", InputNumber " ++ show inn ++ ", choice " ++ show ir+ runEvalError (Just pn) $ triggerInput en inn ir+++-- TODO repair+getTimes :: EventInfo -> Maybe UTCTime+getTimes (EventInfo _ _ (BaseEvent (Time t)) _ SActive _) = Just t+getTimes _ = Nothing++-- | A helper function to use the state transformer GameState.+-- It additionally sets the current time.+execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame+execWithGame t gs g = execState gs $ (game >>> currentTime) `setL` t $ g++execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame+execWithGame' t gs g = execStateT gs ((game >>> currentTime) `setL` t $ g)+++activeRules :: Game -> [RuleInfo]+activeRules = sort . filter ((==Active) . getL rStatus) . _rules++pendingRules :: Game -> [RuleInfo]+pendingRules = sort . filter ((==Pending) . getL rStatus) . _rules++rejectedRules :: Game -> [RuleInfo]+rejectedRules = sort . filter ((==Reject) . getL rStatus) . _rules+++createRule :: SubmitRule -> PlayerNumber -> (RuleCode -> IO Rule) -> StateT Game IO RuleInfo+createRule (SubmitRule name desc code) pn inter = do+ rs <- access rules+ let rn = getFreeNumber $ map _rNumber rs+ rf <- lift $ inter code+ tracePN pn $ "Creating rule n=" ++ show rn ++ " code=" ++ code+ return RuleInfo {_rNumber = rn,+ _rName = name,+ _rDescription = desc,+ _rProposedBy = pn,+ _rRuleCode = code,+ _rRule = rf,+ _rStatus = Pending,+ _rAssessedBy = Nothing}++stateCatch :: Exception e => StateT Game IO a -> (e -> StateT Game IO a) -> StateT Game IO a+stateCatch m h = StateT $ \s -> runStateT m s `E.catch` \e -> runStateT (h e) s++getEventInfo :: EventNumber -> LoggedGame -> EventInfo+getEventInfo en g = fromJust $ find ((== en) . getL eventNumber) (_events $ _game g)
+ src/Nomyx/Core/Engine/Test.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}++module Nomyx.Core.Engine.Test where++import Language.Nomyx.Expression+import Language.Nomyx.Variables+import Language.Nomyx.Rules+import Language.Nomyx.Events+import Language.Nomyx.Outputs+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.Utils+import Control.Monad.State+import Data.Lens+import Data.Typeable+import qualified Data.Foldable as T+import Control.Applicative++date1 = parse822Time "Tue, 02 Sep 1997 09:00:00 -0400"+date2 = parse822Time "Tue, 02 Sep 1997 10:00:00 -0400"+date3 = parse822Time "Tue, 02 Sep 1997 11:00:00 -0400"++testGame = Game { _gameName = "test",+ _gameDesc = GameDesc "test" "test",+ _rules = [],+ _players = [PlayerInfo 1 "coco" Nothing],+ _variables = [],+ _events = [],+ _outputs = [],+ _victory = Nothing,+ _logs = [],+ _currentTime = date1}++testRule = RuleInfo { _rNumber = 0,+ _rName = "test",+ _rDescription = "test",+ _rProposedBy = 0,+ _rRuleCode = "",+ _rRule = return (),+ _rStatus = Pending,+ _rAssessedBy = Nothing}++execRuleEvent :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game+execRuleEvent r f d = execState (runEvalError Nothing $ evalNomex r 0 >> triggerEvent f d) testGame++execRuleEvents :: (Show e, Typeable e) => Nomex a -> [(Field e, e)] -> Game+execRuleEvents f eds = execState (runEvalError Nothing $ evalNomex f 0 >> mapM (\(a,b) -> triggerEvent a b) eds) testGame++execRuleInput :: Nomex a -> EventNumber -> InputNumber -> InputData -> Game+execRuleInput r en inn d = execState (runEvalError Nothing $ evalNomex r 0 >> triggerInput en inn d) testGame++execRuleGame :: Nomex a -> Game -> Game+execRuleGame r g = execState (runEvalError Nothing $ void $ evalNomex r 0) g++execRuleEventGame :: (Show e, Typeable e) => Nomex a -> Field e -> e -> Game -> Game+execRuleEventGame r f d g = execState (runEvalError Nothing $ evalNomex r 0 >> (triggerEvent f d)) g++execRule :: Nomex a -> Game+execRule r = execRuleGame r testGame++addActivateRule :: Rule -> RuleNumber -> Evaluate ()+addActivateRule rf rn = do+ let rule = testRule {_rName = "testRule", _rRule = rf, _rNumber = rn, _rStatus = Pending}+ evAddRule rule+ evActivateRule (_rNumber rule) 0+ return ()++tests = [("test var 1", testVarEx1),+ ("test var 2", testVarEx2),+ ("test var 3", testVarEx3),+ ("test var 4", testVarEx4),+ ("test var 5", testVarEx5),+ ("test single input", testSingleInputEx),+ ("test multiple input", testMultipleInputsEx),+ ("test input string", testInputStringEx),+ ("test send messsage", testSendMessageEx),+ ("test send message 2", testSendMessageEx2),+ ("test user input write", testUserInputWriteEx),+ ("test activate rule", testActivateRuleEx),+ ("test auto activate", testAutoActivateEx),+ --("test meta rules vote", testApplicationMetaRuleEx),+ ("test time event", testTimeEventEx),+ ("test time event 2", testTimeEventEx2),+ ("test delete rule", testDeleteRuleEx1),+ ("test victory rule", testVictoryEx1),+ ("test assess on vote complete 1", testVoteAssessOnVoteComplete1),+ ("test assess on vote complete 2", testVoteAssessOnVoteComplete2),+ ("test assess on every vote 1", testVoteAssessOnEveryVote1),+ ("test assess on every vote 2", testVoteAssessOnEveryVote2),+ ("test assess on every vote 3", testVoteAssessOnEveryVote3),+ ("test assess on every vote 4", testVoteAssessOnEveryVote4),+ ("test majority with", testVoteMajorityWith),+ ("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),+ ("test assess on time limit 4", testVoteAssessOnTimeLimit4),+ ("test assess on time limit 5", testVoteAssessOnTimeLimit5),+ ("test composed event sum", testSumComposeEx),+ ("test composed event prod 1", testProdComposeEx1),+ ("test composed event prod 2", testProdComposeEx2),+ ("test two separate events", testTwoEventsEx)]++allTests = all snd tests++--Test variable creation+testVar1 :: Rule+testVar1 = do+ NewVar "toto" (1::Integer)+ return ()++testVarEx1 = True --(variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))]++--Test variable deleting+testVar2 :: Rule+testVar2 = do+ var <- newVar_ "toto" (1::Int)+ delVar var+ return ()++testVarEx2 = True --_variables (execRuleFunc testVar2) == []++--Test variable reading+testVar3 :: Rule+testVar3 = do+ var <- newVar_ "toto" (1::Int)+ a <- liftEffect $ readVar var+ case a of+ Just (1::Int) -> void $ newOutput (Just 1) (return "ok")+ _ -> void $ newOutput (Just 1) (return "nok")++testVarEx3 = isOutput "ok" (execRule testVar3)++--Test variable writing+testVar4 :: Rule+testVar4 = do+ var <- newVar_ "toto" (1::Int)+ writeVar var (2::Int)+ a <- liftEffect $ readVar var+ case a of+ Just (2::Int) -> void $ newOutput (Just 1) (return "ok")+ _ -> void $ newOutput (Just 1) (return "nok")++testVarEx4 = isOutput "ok" (execRule testVar4)++--Test variable writing+testVar5 :: Rule+testVar5 = do+ var <- newVar_ "toto" ([]::[Int])+ writeVar var ([1]::[Int])+ a <- liftEffect $ readVar var+ case a of+ Just (a::[Int]) -> void $ writeVar var (2:a)+ Nothing -> void $ newOutput (Just 1) (return "nok")++testVarEx5 = True --_variables (execRuleFunc testVar5) == [(Var 0 "toto" ([2,1]::[Int]))]++data Choice = Holland | Sarkozy deriving (Enum, Typeable, Show, Eq, Bounded)++-- Test input+testSingleInput :: Rule+testSingleInput = void $ onInputRadio_ "Vote for Holland or Sarkozy" [Holland, Sarkozy] h 1 where+ h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a)++testSingleInputEx = isOutput "voted for Holland" g where+ g = execRuleEvent testSingleInput (Input (Just 0) 1 "Vote for Holland or Sarkozy" (Radio [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) Holland++testMultipleInputs :: Rule+testMultipleInputs = void $ onInputCheckbox_ "Vote for Holland and Sarkozy" [(Holland, "Holland"), (Sarkozy, "Sarkozy")] h 1 where+ h a = void $ newOutput (Just 1) (return $ "voted for " ++ show a)++testMultipleInputsEx = isOutput "voted for [Holland,Sarkozy]" g where+ g = execRuleEvent testMultipleInputs (Input (Just 0) 1 "Vote for Holland and Sarkozy" (Checkbox [(Holland, "Holland"), (Sarkozy, "Sarkozy")])) [Holland, Sarkozy]++testInputString :: Rule+testInputString = void $ onInputText_ "Enter a number:" h 1 where+ h a = void $ newOutput (Just 1) (return $ "You entered: " ++ a)++testInputStringEx = isOutput "You entered: 1" g where+ g = execRuleEvent testInputString (Input (Just 0) 1 "Enter a number:" Text) "1"++-- Test message+testSendMessage :: Rule+testSendMessage = do+ let msg = Msg "msg" :: Msg String+ onEvent_ (messageEvent msg) f+ sendMessage msg "toto" where+ f (a :: String) = void $ newOutput (Just 1) (return a)++testSendMessageEx = isOutput "toto" (execRule testSendMessage)++testSendMessage2 :: Rule+testSendMessage2 = do+ onEvent_ (messageEvent (Msg "msg" :: Msg ())) $ const $ void $ newOutput (Just 1) (return "Received")+ sendMessage_ "msg"+++testSendMessageEx2 = isOutput "Received" (execRule testSendMessage2)++data Choice2 = Me | You deriving (Enum, Typeable, Show, Eq, Bounded)++-- Test user input + variable read/write+testUserInputWrite :: Rule+testUserInputWrite = do+ newVar_ "vote" (Nothing::Maybe Choice2)+ onEvent_ (messageEvent (Msg "voted" :: Msg ())) h2+ void $ onEvent_ (BaseEvent $ Input Nothing 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) h1 where+ h1 a = do+ writeVar (V "vote") (Just a)+ SendMessage (Msg "voted") ()+ h2 _ = do+ a <- liftEffect $ readVar (V "vote")+ void $ case a of+ Just (Just Me) -> newOutput (Just 1) (return "voted Me")+ _ -> newOutput (Just 1) (return "problem")+++testUserInputWriteEx = isOutput "voted Me" g where+ g = execRuleEvent testUserInputWrite (Input (Just 0) 1 "Vote for" (Radio [(Me, "Me"), (You, "You")])) Me++-- Test rule activation+testActivateRule :: Rule+testActivateRule = do+ a <- liftEffect GetRules+ when (_rStatus (head a) == Pending) $ void $ ActivateRule $ _rNumber (head a)+++testActivateRuleEx = _rStatus (head $ _rules (execRuleGame testActivateRule testGame {_rules=[testRule]})) == Active++testAutoActivateEx = _rStatus (head $ _rules (execRuleEventGame autoActivate (RuleEv Proposed) testRule (testGame {_rules=[testRule]}))) == Active++--Time tests++testTimeEvent :: Rule+testTimeEvent = void $ onEvent_ (timeEvent date1) f where+ f _ = outputAll_ $ show date1++testTimeEventEx = isOutput (show date1) g where+ g = execRuleEvent testTimeEvent (Time date1) date1++testTimeEvent2 :: Nomex ()+testTimeEvent2 = schedule' [date1, date2] (outputAll_ . show)++testTimeEventEx2 = isOutput (show date1) g && isOutput (show date2) g where+ g = execState (runEvalError Nothing $ evalNomex testTimeEvent2 0 >> void gameEvs) testGame+ gameEvs = do+ evTriggerTime date1+ evTriggerTime date2++-- Test deletes+testDeleteRule :: Rule+testDeleteRule = do+ newVar_ "toto" (1::Int)+ onMessage (Msg "msg" :: Msg ()) (const $ return ())+ void $ newOutput (Just 1) (return "toto")++testDeleteGame :: Game+testDeleteGame = flip execState testGame {_players = []} $ runEvalError Nothing $ do+ addActivateRule testDeleteRule 1+ addActivateRule (void $ suppressRule 1) 2++testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject &&+ --(_variables testDeleteGame == []) &&+ (_oStatus $ head $ _outputs testDeleteGame) == SDeleted &&+ (_evStatus $ head $ _events testDeleteGame) == SDeleted++-- Test victory+testVictoryGame :: Game+testVictoryGame = flip execState testGame $ runEvalError Nothing $ do+ addActivateRule (victoryXRules 1) 1+ addActivateRule (nothing) 2++testVictoryEx1 = (length $ getVictorious testVictoryGame) == 1++-- Test votes++voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game+voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runEvalError Nothing $ do+ mapM_ (\x -> addPlayer (PlayerInfo x ("coco " ++ show x) Nothing)) [1..total]+ actions+ evProposeRule testRule+ 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+ when timeEvent $ evTriggerTime date2++voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game+voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1++voteGame :: Int -> Int -> Int -> Rule -> Game+voteGame positives negatives notVoted = voteGame' positives negatives notVoted False++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++testVoteRule s g = (_rStatus $ head $ _rules g) == s++-- Event composition++testSumCompose :: Rule+testSumCompose = void $ onEvent_ (True <$ inputButton 1 "" <|> False <$ inputButton 1 "") f where+ f a = outputAll_ $ show a++testSumComposeEx = isOutput "True" g where+ g = execRuleEvent testSumCompose (Input (Just 0) 1 "" Button) ()++testProdCompose :: Rule+testProdCompose = void $ onEvent_ ((,) <$> inputText 1 "" <*> inputText 1 "") f where+ f a = outputAll_ $ show a++testProdComposeEx1 = null $ allOutputs g where+ g = execRuleEvent testProdCompose (Input (Just 0) 1 "" Text) "toto"++testProdComposeEx2 = isOutput "(\"toto\",\"tata\")" g where+ g = execRuleEvents testProdCompose [((Input (Just 0) 1 "" Text), "toto"), ((Input (Just 1) 1 "" Text), "tata")]++testTwoEvents :: Rule+testTwoEvents = do+ void $ onEvent_ (inputText 1 "") f+ void $ onEvent_ (inputText 1 "") f where+ f a = outputAll_ $ show a++testTwoEventsEx = (length $ allOutputs g) == 1 where+ g = execRuleInput testTwoEvents 1 0 (TextData "toto")+++--Get all event numbers of type choice (radio button)+getChoiceEvents :: State Game [EventNumber]+getChoiceEvents = do+ evs <- access events+ return $ map _eventNumber $ filter choiceEvent evs+ where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ (Radio _))) _ _ _) = True+ choiceEvent _ = False++--Get all event numbers of type text (text field)+getTextEvents :: State Game [EventNumber]+getTextEvents = do+ evs <- access events+ return $ map _eventNumber $ filter choiceEvent evs+ where choiceEvent (EventInfo _ _ (BaseEvent (Input _ _ _ Text)) _ _ _) = True+ choiceEvent _ = False++isOutput :: String -> Game -> Bool+isOutput s g = s `elem` allOutputs g+++myEvent :: NomexNE (Event String)+myEvent = do+ ps <- getAllPlayerNumbers+ let oneButton pn = inputText pn "test"+ return $ T.asum (map oneButton ps)
+ src/Nomyx/Core/Engine/Utils.hs view
@@ -0,0 +1,51 @@+ +module Nomyx.Core.Engine.Utils where +++import Data.Time+import Data.Typeable (cast, Typeable)+import Debug.Trace.Helpers (traceM)+import Data.Maybe (fromJust)+import System.Locale (rfc822DateFormat, defaultTimeLocale)+import Control.Monad.State+import Control.Monad.Identity+import Debug.Trace (trace)++-- | an equality that tests also the types. +(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool +(===) x y = cast x == Just y + +-- | Replaces all instances of a value in a list by another value. +replaceWith :: (a -> Bool) -- ^ Value to search + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replaceWith f y = map (\z -> if f z then y else z) ++tracePN :: (Monad m ) => Int -> String -> m ()+tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s++traceData :: (Show a) => String -> a -> a+traceData s a = trace (s ++ " " ++ (show a)) a+ +parse822Time :: String -> UTCTime +parse822Time = zonedTimeToUTC + . fromJust + . parseTime defaultTimeLocale rfc822DateFormat + +sndMaybe :: (a, Maybe b) -> Maybe (a,b) +sndMaybe (a, Just b) = Just (a,b) +sndMaybe (_, Nothing) = Nothing++mapStateIO :: Show s => State s a -> StateT s IO a+mapStateIO = mapStateT $ return . runIdentity++getFreeNumber :: (Eq a, Num a, Enum a) => [a] -> a+getFreeNumber l = head [a| a <- [1..], not $ a `elem` l]+++sel :: [a] -- ^ List of indices to select+ -> [Int] -- ^ List of elements+ -> [a] -- ^ List composed of elements selected from original set by indices provided+sel xs is = map (\i -> xs!!i) is+
src/Nomyx/Core/Interpret.hs view
@@ -4,38 +4,19 @@ -- | This module starts a Interpreter server that will read our strings representing rules to convert them to plain Rules. module Nomyx.Core.Interpret where -import Language.Haskell.Interpreter -import Language.Haskell.Interpreter.Server -import Language.Nomyx import System.Directory (createDirectoryIfMissing, copyFile, removeFile, doesFileExist) import System.FilePath ((</>), joinPath, dropExtension, takeFileName)-import Control.Exception as CE+import System.IO.Error import Data.Either.Unwrap-import Nomyx.Core.Utils import Data.List+import Control.Exception as CE import Control.Monad+import Language.Haskell.Interpreter import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)-import qualified Mueval.Resources as MR (limitResources)-import qualified Mueval.Context as MC-import qualified Mueval.Interpreter as MI-import System.IO.Error----unQualImports :: [String]-unQualImports = "Language.Nomyx" :- "Language.Nomyx.Examples" :- "Safe" :- "Data.Typeable" :- "Data.Lens" :- MC.defaultModules--qualImports :: [(String, Maybe String)]-qualImports = ("Control.Category", Just "C") : MC.qualifiedModules--defaultPackages :: [String]-defaultPackages = "Nomyx-Language" : MC.defaultPackages-+import Language.Haskell.Interpreter.Server+import Language.Nomyx+import Nomyx.Core.Context+import Nomyx.Core.Utils exts :: [String] exts = ["Safe", "GADTs"] ++ map show namedExts@@ -64,40 +45,22 @@ getUploadModules saveDir = do files <- getUploadedModules saveDir `catch` (\(_::SomeException) -> return []) return $ map (\f -> joinPath [saveDir, uploadDir, f]) files- -- | initializes the interpreter by loading some modules. initializeInterpreter :: FilePath -> Interpreter () initializeInterpreter saveDir = do reset -- Make sure nothing is available set [installedModulesInScope := False,- languageExtensions := map MI.readExt exts]+ languageExtensions := map readExt exts] unsafeSetGhcOption "-fpackage-trust" forM_ (defaultPackages >>= words) $ \pkg -> unsafeSetGhcOption ("-trust " ++ pkg) uploadedMods <- liftIO $ getUploadModules saveDir liftIO $ putStrLn $ "Loading modules: " ++ (intercalate ", " uploadedMods) loadModules uploadedMods setTopLevelModules $ map (dropExtension . takeFileName) uploadedMods- liftIO $ MR.limitResources False let importMods = qualImports ++ zip (unQualImports) (repeat Nothing) setImportsQ importMods ---initializeInterpreter :: FilePath -> Interpreter ()---initializeInterpreter saveDir = do--- uploadedMods <- liftIO $ getUploadModules saveDir--- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " uploadedMods)--- let o = Options { extensions = True,--- namedExtensions = exts,--- typeOnly = True,--- rLimits = True,--- loadFile = "",--- packageTrust = True,--- modules = Just unQualImports}--- MI.initializeInterpreter o--- uploadedMods <- liftIO $ getUploadModules saveDir--- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " uploadedMods)--- loadModules uploadedMods- ---- | reads maybe a Rule out of a string. interpretRule :: String -> ServerHandle -> IO (Either InterpreterError Rule) interpretRule s sh = (liftIO $ runIn sh $ interpret s (as :: Rule))@@ -130,9 +93,13 @@ when (isLeft final) $ putStrLn "Error: reinitialize interpreter failed" return $ Just e - showInterpreterError :: InterpreterError -> String showInterpreterError (UnknownError s) = "Unknown Error\n" ++ s showInterpreterError (WontCompile ers) = "Won't Compile\n" ++ concatMap (\(GhcError errMsg) -> errMsg ++ "\n") ers showInterpreterError (NotAllowed s) = "Not Allowed (Probable cause: bad module or file name)\n" ++ s showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s++readExt :: String -> Extension+readExt s = case reads s of+ [(e,[])] -> e+ _ -> UnknownExtension s
src/Nomyx/Core/Mail.hs view
@@ -5,28 +5,27 @@ module Nomyx.Core.Mail where +import Prelude hiding (div, (.))+import Language.Haskell.HsColour.Colourise hiding (string)+import qualified Language.Haskell.HsColour.HTML as HSC import Text.Blaze.Html5 hiding (map, label, br) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html.Renderer.String import Network.Mail.Mime hiding (mailTo)-import Prelude hiding (div, (.))-import Control.Monad-import Language.Nomyx-import Language.Nomyx.Engine+import Safe+import Data.List import Data.Text(Text, pack)-import Control.Concurrent import Data.Maybe import qualified Data.Text.Lazy as B-import qualified Language.Haskell.HsColour.HTML as HSC-import Language.Haskell.HsColour.Colourise hiding (string)-import Text.Blaze.Internal+import Control.Concurrent import Control.Category import Control.Applicative ((<$>))-import Safe-import Data.List+import Control.Monad+import Language.Nomyx import Nomyx.Core.Profile import Nomyx.Core.Types import Nomyx.Core.Utils+import Nomyx.Core.Engine default (Integer, Double, Data.Text.Text)@@ -50,7 +49,7 @@ (toHtml $ "a new rule has been proposed by player " ++ prop ++ ".") >> H.br (toHtml $ "Name: " ++ name) >> H.br (toHtml $ "Description: " ++ desc) >> H.br- (toHtml $ "Code: ") >> H.br >> (preEscapedString $ HSC.hscolour defaultColourPrefs False code) >> H.br >> H.br+ (toHtml $ "Code: ") >> H.br >> (preEscapedToHtml $ HSC.hscolour defaultColourPrefs False code) >> H.br >> H.br (toHtml $ "Please login into Nomyx for actions on this rule:") >> H.br (toHtml $ nomyxURL net ++ "/Nomyx") >> H.br >> H.br (toHtml $ "You received this mail because you subscribed to Nomyx. To stop receiving mails, login to Nomyx with the above address, go to Settings and uncheck the corresponding box.") >> H.br
src/Nomyx/Core/Multi.hs view
@@ -3,22 +3,21 @@ -- | This module manages multi-player games. module Nomyx.Core.Multi where -import Prelude-import Control.Monad.State-import Data.Time as T import Language.Haskell.Interpreter.Server (ServerHandle) import Data.Maybe-import Control.Exception import Data.Lens-import Language.Nomyx.Engine as G-import Control.Category hiding ((.))-import Nomyx.Core.Quotes (cr)-import Control.Applicative import Data.List+import Data.Time as T+import Control.Exception+import Control.Monad.State+import Control.Applicative+import Control.Category hiding ((.)) import Language.Nomyx+import Nomyx.Core.Engine as G import Nomyx.Core.Utils import Nomyx.Core.Types import Nomyx.Core.Interpret+import Nomyx.Core.Quotes (cr) triggerTimeEvent :: UTCTime -> StateT Multi IO () triggerTimeEvent t = do
src/Nomyx/Core/Profile.hs view
@@ -7,18 +7,19 @@ module Nomyx.Core.Profile where import Language.Nomyx-import Language.Nomyx.Engine-import Data.IxSet (toList, (@=))-import qualified Data.IxSet as IxSet++ import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Catch (bracket) import Control.Concurrent.STM+import Control.Monad+import Control.Monad.State import Safe import Data.Lens import Data.List import Data.Maybe-import Control.Monad-import Control.Monad.State+import Data.IxSet (toList, (@=))+import qualified Data.IxSet as IxSet import qualified Data.Acid.Advanced as A (update', query') import Data.Acid.Local (createCheckpointAndClose) import Data.Acid (openLocalStateFrom, makeAcidic, Update, Query)@@ -28,6 +29,7 @@ import Nomyx.Core.Quotes import Nomyx.Core.Types import Nomyx.Core.Utils+import Nomyx.Core.Engine -- | set 'ProfileData' for UserId setProfileData :: ProfileData -> Update ProfileDataState ProfileData@@ -72,7 +74,7 @@ let pd = initialProfileData uid ps put $ pds { profilesData = IxSet.updateIx uid pd profilesData } return pd- (Just profileData) -> return profileData+ Just profileData -> return profileData -- | get number of askProfileDataNumber :: Query ProfileDataState Int
src/Nomyx/Core/Quotes.hs view
@@ -19,7 +19,7 @@ import Language.Haskell.TH as TH import Language.Haskell.TH.Quote import Language.Haskell.Interpreter hiding (get)-import Nomyx.Core.Interpret+import Nomyx.Core.Context -- This quasi quoter allows to type check a string as a Nomyx rule (a RuleFunc).
src/Nomyx/Core/Serialize.hs view
@@ -4,21 +4,21 @@ module Nomyx.Core.Serialize where import Prelude hiding (log, (.))-import Language.Nomyx hiding (getCurrentTime)-import Language.Nomyx.Engine-import Language.Nomyx.Engine.GameEvents-import Control.Monad.State-import Data.Lens import Language.Haskell.Interpreter.Server+import Data.Lens import Data.Aeson.TH import Data.Aeson-import Control.Applicative-import Control.Category import Data.Time.Clock.POSIX import qualified Data.ByteString.Lazy.Char8 as BL+import Control.Monad.State+import Control.Applicative+import Control.Category+import Language.Nomyx hiding (getCurrentTime) import Nomyx.Core.Types import Nomyx.Core.Utils import Nomyx.Core.Interpret+import Nomyx.Core.Engine+import Nomyx.Core.Engine.GameEvents save :: Multi -> IO () save m = BL.writeFile (getSaveFile $ _mSettings m) (encode m)@@ -79,7 +79,7 @@ $(deriveJSON defaultOptions ''GameInfo) $(deriveJSON defaultOptions ''TimedEvent) $(deriveJSON defaultOptions ''GameEvent)-$(deriveJSON defaultOptions ''UInputData)+$(deriveJSON defaultOptions ''InputData) $(deriveJSON defaultOptions ''SubmitRule) $(deriveJSON defaultOptions ''GameDesc)
src/Nomyx/Core/Session.hs view
@@ -4,25 +4,25 @@ -- | This module manages multi-player commands. module Nomyx.Core.Session where -import Prelude-import Data.List-import Control.Monad.State-import Data.Time as T import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Haskell.Interpreter (InterpreterError)-import Nomyx.Core.Types import Debug.Trace.Helpers import Data.Lens-import Language.Nomyx-import Language.Nomyx.Engine as G-import Control.Category hiding ((.))+import Data.Time as T+import Data.List import qualified Data.Acid.Advanced as A (update', query')+import Control.Category hiding ((.))+import Control.Monad.State import Control.Concurrent.STM import System.IO.PlafCompat+import Language.Nomyx+import Nomyx.Core.Types import Nomyx.Core.Utils import Nomyx.Core.Multi import Nomyx.Core.Profile import Nomyx.Core.Interpret+import Nomyx.Core.Serialize+import Nomyx.Core.Engine as G -- | add a new player newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO ()@@ -119,8 +119,8 @@ tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -inputResult :: PlayerNumber -> EventNumber -> UInputData -> GameName -> StateT Session IO ()-inputResult pn en ir gn = inGameDo gn $ execGameEvent $ InputResult pn en ir+inputResult :: PlayerNumber -> EventNumber -> InputNumber -> InputData -> GameName -> StateT Session IO ()+inputResult pn en inn ir gn = inGameDo gn $ execGameEvent $ InputResult pn en inn ir -- | upload a rule file, given a player number, the full path of the file, the file name and the server handle inputUpload :: PlayerNumber -> FilePath -> FilePath -> ServerHandle -> StateT Session IO Bool@@ -220,7 +220,9 @@ s <- atomically $ readTVar ts ms <- evalWithWatchdog s (evalSession sm) case ms of- Just s -> atomically $ writeTVar ts s+ Just s -> do+ atomically $ writeTVar ts s+ save $ _multi s Nothing -> putStrLn "thread timed out, updateSession discarded"
src/Nomyx/Core/Test.hs view
@@ -18,13 +18,12 @@ -- | Test module module Nomyx.Core.Test where -import Prelude-import Control.Monad.State import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Nomyx hiding (getCurrentTime)-import Language.Nomyx.Engine import Control.Applicative+import Control.Monad.State import Control.Exception as E+import Control.Arrow ((>>>)) import Language.Haskell.TH import Language.Haskell.TH.Syntax as THS hiding (lift) import System.IO.Unsafe@@ -32,13 +31,11 @@ import Data.List import Data.Maybe import Data.Acid.Memory+import Data.Time hiding (getCurrentTime) import Happstack.Auth.Core.Auth (initialAuthState) import Happstack.Auth.Core.Profile (initialProfileState)-import qualified Language.Nomyx.Engine as G-import Control.Arrow ((>>>))-import Data.Time hiding (getCurrentTime)-import System.IO.Temp import Paths_Nomyx_Core as PNC+import System.IO.Temp import System.FilePath ((</>)) import System.Directory (createDirectoryIfMissing) import Nomyx.Core.Types@@ -47,6 +44,8 @@ import Nomyx.Core.Utils import Nomyx.Core.Profile import Nomyx.Core.Quotes+import Nomyx.Core.Engine+import qualified Nomyx.Core.Engine as G playTests :: FilePath -> ServerHandle -> Maybe String -> IO [(String, Bool)] playTests saveDir sh mTestName = do@@ -195,7 +194,7 @@ partialFunction2 :: String partialFunction2 = [cr|void $ do t <- liftEffect getCurrentTime- onEventOnce (Time $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|]+ onEventOnce (timeEvent $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|] gamePartialFunction1 :: StateT Session IO () gamePartialFunction1 = submitR partialFunction1@@ -216,7 +215,7 @@ partialFunction3 :: String-partialFunction3 = [cr|void $ onEvent_ (RuleEv Proposed) $ const $ readMsgVar_ (msgVar "toto3")|]+partialFunction3 = [cr|void $ onEvent_ (ruleEvent Proposed) $ const $ readMsgVar_ (msgVar "toto3")|] gamePartialFunction3 :: StateT Session IO () gamePartialFunction3 = do@@ -317,14 +316,14 @@ inputAllRadios choice pn = do s <- get let evs = evalState getChoiceEvents (firstGame $ _multi s)- mapM_ (\en -> inputResult pn en (URadioData choice) "test") evs+ mapM_ (\en -> inputResult pn en 0 (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 (UTextData a) "test") evs+ mapM_ (\en -> inputResult pn en 0 (TextData a) "test") evs firstGame :: Multi -> Game firstGame = G._game . _loggedGame . head . _gameInfos
src/Nomyx/Core/Types.hs view
@@ -2,18 +2,19 @@ {-# LANGUAGE DeriveDataTypeable #-} module Nomyx.Core.Types where-import Language.Nomyx-import Language.Nomyx.Engine-import Data.Typeable+ import Network.BSD-import Data.Lens.Template import Language.Haskell.Interpreter.Server (ServerHandle)-import Data.Acid (AcidState) import Happstack.Auth (ProfileState, AuthState)+import Data.Typeable+import Data.Lens.Template+import Data.Acid (AcidState) import Data.Data (Data) import Data.IxSet (inferIxSet, noCalcs) import Data.SafeCopy (base, deriveSafeCopy) import Data.Time+import Language.Nomyx+import Nomyx.Core.Engine type PlayerPassword = String type Port = Int
src/Nomyx/Core/Utils.hs view
@@ -16,24 +16,27 @@ module Nomyx.Core.Utils where -import Data.Maybe-import Control.Monad.State-import Nomyx.Core.Types-import System.IO.Temp++ import Codec.Archive.Tar as Tar+import System.IO.Temp import System.Directory import System.FilePath-import Control.Monad.Catch as MC #ifndef WINDOWS import qualified System.Posix.Signals as S #endif-import Control.Concurrent import System.IO import System.IO.PlafCompat import Data.Lens+import Data.Maybe+import Control.Monad.State import Control.Exception+import Control.Concurrent import Control.Category ((>>>))-import Language.Nomyx.Engine+import Control.Monad.Catch as MC+import Control.DeepSeq+import Nomyx.Core.Types+import Nomyx.Core.Engine saveFile, profilesDir, uploadDir, tarFile :: FilePath saveFile = "Nomyx.save"@@ -82,9 +85,21 @@ getRegularFiles :: FilePath -> [FilePath] -> IO [FilePath] getRegularFiles dir fps = filterM (getFileStatus . (\f -> dir </> f) >=> return . isRegularFile) fps +-- The setMode function is only used during module loading. In Windows,+-- a copied file automatically inherits permissions based on the containing+-- folder's ACLs an the user account being used.+#ifdef WINDOWS+ setMode :: FilePath -> IO()+setMode _ = return ()++#else++setMode :: FilePath -> IO() setMode file = setFileMode file (ownerModes + groupModes) +#endif+ #ifdef WINDOWS --no signals under windows@@ -133,6 +148,20 @@ --start watchdog thread forkIO $ watchDog 3 id mvar takeMVar mvar++evalWithWatchdog' :: NFData a => IO a -> IO (Maybe a)+evalWithWatchdog' s = do+ mvar <- newEmptyMVar+ hSetBuffering stdout NoBuffering+ --start evaluation thread+ id <- forkOS $ do+ s' <- s+ let s'' = force s'+ putMVar mvar (Just s'')+ --start watchdog thread+ forkIO $ watchDog 3 id mvar+ takeMVar mvar+ -- | Fork off a thread which will sleep and then kill off the specified thread. watchDog :: Int -> ThreadId -> MVar (Maybe a) -> IO ()