packages feed

Nomyx 0.2.2 → 0.2.3

raw patch · 12 files changed

+61/−54 lines, 12 filesdep ~Nomyx-Language

Dependency ranges changed: Nomyx-Language

Files

Nomyx.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-version: 0.2.2+version: 0.2.3 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -18,7 +18,7 @@   executable Nomyx     build-depends: Cabal -any, DebugTraceHelpers -any, MissingH -any,-                   MonadCatchIO-mtl -any, Nomyx-Language ==0.2.2, QuickCheck -any,+                   MonadCatchIO-mtl -any, Nomyx-Language ==0.2.3, QuickCheck -any,                    Unixutils -any, acid-state -any, base <5, binary -any,                    blaze-html ==0.5.*, blaze-markup -any, bytestring -any,                    containers -any, data-accessor-transformers -any, data-lens -any,
TODO view
@@ -27,6 +27,11 @@ - purify some IO
 - create an admin role
 - add examples with a game master, a castle..
+- add "delete game" for admin (+ del/add player, rule, event, variable?)
+- fix facebook
+- de-mangle error messages, put line number
+- add an input: button
+- vote: include new players, delete leaving players 
 
 Futur Nomic:
 - ability to analyse rules, proof system
data/static/nomyx.js view
@@ -2,14 +2,14 @@ {     var events = document.getElementById(id_events);    var show = document.getElementById(id_show);-   if (show.innerHTML == '[Show]') +   if (show.innerHTML == '[Click to show]')     {       events.style.display = 'block'; -      show.innerHTML = '[Hide]';+      show.innerHTML = '[Click to hide]';    }    else       {       events.style.display = 'none'; -      show.innerHTML ='[Show]';+      show.innerHTML ='[Click to show]';    } }
src/Mail.hs view
@@ -17,13 +17,11 @@ import Control.Concurrent import Data.Maybe import Utils-import Control.Exception 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.Category-import qualified Data.Acid.Advanced as A (query') import Control.Applicative ((<$>)) default (Integer, Double, Data.Text.Text) @@ -51,16 +49,16 @@  sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO() sendMailsNewRule s sr pn = do-   evaluate s    gn <- fromJust <$> getPlayersGame pn s+   let sendMailsTo = delete pn (map _playerNumber (_players $ _game gn))    proposer <- getPlayersName pn s-   pfd <- A.query' (acidProfileData $ _profiles s) AskProfilesData-   let pls = [ p { _pPlayerNumber = mypn} | p <- pfd, mypn <- map _playerNumber $ _players $ _game gn]-   forM_ pls $ send proposer (_net $ _mSettings $ _multi s)-   where-      send :: PlayerName -> Network -> ProfileData -> IO()-      send prop net pfd = when (_mailNewRule $ _pPlayerSettings pfd)-          $ sendMail (_mailTo $ _pPlayerSettings $ pfd) (newRuleObject prop) (renderHtml $ newRuleBody (_pPlayerName $ _pPlayerSettings $ pfd) sr prop net)+   profiles <- mapM (getProfile s) sendMailsTo+   mapM_ (send proposer (_net $ _mSettings $ _multi s) sr) (_pPlayerSettings <$> catMaybes profiles)+++send :: PlayerName -> Network -> SubmitRule -> PlayerSettings -> IO()+send prop net sr set = when (_mailNewRule set)+   $ sendMail (_mailTo set) (newRuleObject prop) (renderHtml $ newRuleBody (_pPlayerName set) sr prop net)     
 mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
src/Main.hs view
@@ -15,7 +15,7 @@     
 module Main (main) where
 -import Prelude hiding (catch, (.))
+import Prelude hiding ((.))
 import System.Console.GetOpt 
 import System.Environment 
 import Web.MainPage@@ -36,7 +36,7 @@ import System.Directory import Data.Time.Clock import Language.Nomyx hiding (getCurrentTime)-import Control.Exception hiding (bracket)+import Control.Exception as E hiding (bracket) import Test import Utils import Data.Version (showVersion)@@ -112,7 +112,7 @@    multi <- case fileExists of       True -> do          putStrLn "Loading previous game"-         Serialize.loadMulti set sh `catch`+         Serialize.loadMulti set sh `E.catch`             (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))       False -> return $ defaultMulti set    return multi@@ -124,8 +124,10 @@    s <- getLine    case s of       "d" -> do-         (Session _ m _) <- atomically $ readTVar ts-         putStrLn $ displayMulti m+         s <- atomically $ readTVar ts+         putStrLn $ displayMulti $ _multi s+         pfs <- getAllProfiles s+         putStrLn $ show pfs          serverLoop ts f       "s" -> do          putStrLn "saving state..."
src/Multi.hs view
@@ -11,7 +11,7 @@ --    getPlayersName) where  -import Prelude hiding (catch)+import Prelude import Data.List import Control.Monad.State import Utils@@ -183,7 +183,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 $ assessOnEveryVotes |]+                            [cr|onRuleProposed $ voteWith_ unanimity $ assessOnEveryVote |]  rVictory5Rules = SubmitRule "Victory 5 accepted rules"                             "Victory is achieved if you have 5 active rules"@@ -191,7 +191,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) $ assessOnEveryVotes >> assessOnTimeDelay oneMinute |]+                            [cr|onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneMinute |]   initialGame :: ServerHandle -> StateT LoggedGame IO ()
src/Test.hs view
@@ -16,14 +16,14 @@ -- | Test module module Test where -import Prelude hiding (catch)+import Prelude import Types import Control.Monad.State import Multi import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Nomyx hiding (getCurrentTime) import Control.Applicative-import Control.Exception+import Control.Exception as E import Language.Haskell.TH import Language.Haskell.TH.Syntax as THS hiding (lift) import System.IO.Unsafe@@ -62,7 +62,7 @@    tp <- testProfiles    let s = Session sh (defaultMulti (Settings "" defaultNetwork False)) tp    m' <- loadTest tes s-   (evaluate $ cond m') `catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False)+   (evaluate $ cond m') `E.catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False)   loadTest ::  StateT Session IO () -> Session -> IO Multi@@ -139,7 +139,7 @@ condHelloWorld2Players m = (head $ _outputs $ G._game $ head $ _games m) == (1, "hello, world!")  partialFunction1 :: String-partialFunction1 = [cr|voidRule $ readVar_ (V "toto1")|]+partialFunction1 = [cr|voidRule $ readVar_ (V "toto1" :: V String)|]  gamePartialFunction1 :: StateT Session IO () gamePartialFunction1 = submitR partialFunction1
src/Utils.hs view
@@ -72,8 +72,8 @@ getAllProfiles s = A.query' (acidProfileData $ _profiles s) AskProfilesData  -getPlayers :: Game -> PlayerNumber -> Maybe PlayerInfo-getPlayers g pn = find ((==pn) . getL playerNumber) (_players g)+getPlayer :: Game -> PlayerNumber -> Maybe PlayerInfo+getPlayer g pn = find ((==pn) . getL playerNumber) (_players g)  -- | finds the corresponding game in the multistate and replaces it. modifyGame :: LoggedGame -> StateT Multi IO ()@@ -99,8 +99,8 @@    A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJust pfd))    return () -getProfile :: MonadIO m => PlayerNumber -> Session -> m (Maybe ProfileData)-getProfile pn s = A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+getProfile :: MonadIO m => Session -> PlayerNumber -> m (Maybe ProfileData)+getProfile s pn = A.query' (acidProfileData $ _profiles s) (AskProfileData pn)
src/Web/Common.hs view
@@ -4,7 +4,7 @@ module Web.Common where  -import Prelude hiding (div, catch)+import Prelude hiding (div) import Text.Blaze.Html5 hiding (map, output, base) import Text.Blaze.Html5.Attributes hiding (dir, id) import qualified Text.Blaze.Html5 as H
src/Web/Game.hs view
@@ -39,7 +39,7 @@  viewGame :: Game -> PlayerNumber -> (Maybe SubmitRule) -> RoutedNomyxServer Html viewGame g pn sr = do-   let inGame = isJust $ Utils.getPlayers g pn+   let inGame = isJust $ Utils.getPlayer g pn    rf <- viewRuleForm sr inGame    vi <- viewInputs pn $ _events g    ok $ table $ do@@ -72,7 +72,7 @@  viewVictory :: Game -> Html viewVictory g = do-    let vs = _playerName <$> mapMaybe (Utils.getPlayers g) (_victory g)+    let vs = _playerName <$> mapMaybe (Utils.getPlayer g) (_victory g)     case vs of         []   -> br         a:[] -> h3 $ string $ "Player " ++ (show a) ++ " won the game!"@@ -81,28 +81,29 @@ viewAllRules :: Game -> Html viewAllRules g = do    h3 "Rules"-   viewRules "Active rules"     (activeRules g) True ! (A.title $ toValue Help.actives) >> br-   viewRules "Pending rules"    (pendingRules g) True ! (A.title $ toValue Help.pendings) >> br-   viewRules "Suppressed rules" (rejectedRules g) False >> br+   viewRules (activeRules g)   "Active rules"     True g ! (A.title $ toValue Help.actives) >> br+   viewRules (pendingRules g)  "Pending rules"    True g ! (A.title $ toValue Help.pendings) >> br+   viewRules (rejectedRules g) "Suppressed rules" False g >> br -viewRules :: String -> [Rule] -> Bool -> Html-viewRules title nrs visible = do+viewRules :: [Rule] -> String -> Bool -> Game -> Html+viewRules nrs title visible g = do    showHideTitle title visible (length nrs == 0) (h4 ! A.style "text-align:center;" $ toHtml title ) $ table ! A.class_ "table" $ do       thead $ do-         td ! A.class_ "td" $ text "Number"+         td ! A.class_ "td" $ text "#"          td ! A.class_ "td" $ text "Name"          td ! A.class_ "td" $ text "Description"          td ! A.class_ "td" $ text "Proposed by"          td ! A.class_ "td" $ text "Code of the rule"          td ! A.class_ "td" $ text "Assessed by"-      forM_ nrs viewRule+      forM_ nrs (viewRule g) -viewRule :: Rule -> Html-viewRule nr = tr $ do+viewRule :: Game -> Rule -> Html+viewRule g nr = tr $ do+   let pl = fromMaybe (show $ _rProposedBy nr) (_playerName <$> (Utils.getPlayer g $ _rProposedBy nr))    td ! A.class_ "td" $ string . show $ _rNumber nr    td ! A.class_ "td" $ string $ _rName nr    td ! A.class_ "td" $ string $ _rDescription nr-   td ! A.class_ "td" $ string $ if _rProposedBy nr == 0 then "System" else "Player " ++ (show $ _rProposedBy nr)+   td ! A.class_ "td" $ string $ if _rProposedBy nr == 0 then "System" else pl    td ! A.class_ "td" $ viewRuleFunc $ nr    td ! A.class_ "td" $ string $ case _rAssessedBy nr of       Nothing -> "Not assessed"@@ -131,17 +132,17 @@             td ! A.class_ "td" $ text "Event Number"             td ! A.class_ "td" $ text "By Rule"             td ! A.class_ "td" $ text "Event"-            --td ! A.class_ "td" $ text "Status"          mapM_ viewEvent $ sort ehs   viewEvent :: EventHandler -> Html-viewEvent (EH eventNumber ruleNumber event _ _) = tr $ do-   td ! A.class_ "td" $ string . show $ eventNumber-   td ! A.class_ "td" $ string . show $ ruleNumber-   td ! A.class_ "td" $ string . show $ event-   --td ! A.class_ "td" $ string . show $ status+viewEvent (EH eventNumber ruleNumber event _ status) = if status == EvActive then disp else disp ! A.style "background:gray;" where+   disp = tr $ do+      td ! A.class_ "td" $ string . show $ eventNumber+      td ! A.class_ "td" $ string . show $ ruleNumber+      td ! A.class_ "td" $ string . show $ event + viewInputs :: PlayerNumber -> [EventHandler] -> RoutedNomyxServer Html viewInputs pn ehs = do    mis <- mapM (viewInput pn) $ sort ehs@@ -192,7 +193,7 @@    lf  <- lift $ viewForm "user" $ newRuleForm sr    ok $ do       h3 "Propose a new rule:"-      if inGame then blazeForm lf (link) ! A.disabled ""+      if inGame then blazeForm lf (link)       else lf ! A.disabled ""  newRule :: (TVar Session) -> RoutedNomyxServer Html@@ -272,7 +273,7 @@ showHideTitle id visible empty title rest = do    div ! A.onclick (fromString $ printf "toggle_visibility('%sBody', '%sShow')" id id) $ table ! A.width "100%" $ tr $ do       td $ title ! A.width "80%"-      td ! A.style "text-align:right;" $ h5 (if visible then "[Hide]" else "[Show]") ! A.id (fromString $ printf "%sShow" id) ! A.width "20%"+      td ! A.style "text-align:right;" $ h5 (if visible then "[Click to hide]" else "[Click to show]") ! A.id (fromString $ printf "%sShow" id) ! A.width "20%"    div ! A.id (fromString $ printf "%sBody" id) ! A.style (fromString $ "display:" ++ (if visible then "block;" else "none;")) $       if (empty) then (toHtml $ "No " ++ id) else rest
src/Web/MainPage.hs view
@@ -49,7 +49,7 @@  viewMulti :: PlayerNumber -> Session -> RoutedNomyxServer Html viewMulti pn s = do-   pfd <- getProfile pn s+   pfd <- getProfile s pn    gns <- viewGamesTab (map G._game $ _games $ _multi s) (pn == 1)    mgn <- liftRouteT $ lift $ getPlayersGame pn s    g <- case mgn of@@ -82,6 +82,7 @@       H.a "Basic rules"       ! (href $ "/src/Language/Nomyx/Rule.hs") >> br       H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Definition.hs") >> br       H.a "Rules types"       ! (href $ "/src/Language/Nomyx/Expression.hs") >> br+      H.a "Voting system"     ! (href $ "/src/Language/Nomyx/Vote.hs") >> br       mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : modDir </> f)) >> br) fmods       br >> "Upload new rules file:" >> br       blazeForm up (uploadLink) ! (A.title $ toValue Help.upload)
src/Web/Settings.hs view
@@ -59,7 +59,7 @@ settings ts  = do    s <- liftIO $ atomically $ readTVar ts    pn <- getPlayerNumber ts-   pfd <- getProfile pn s+   pfd <- getProfile s pn    pfs <- liftIO $ getAllProfiles s    let pfs' = filter (\a -> (_pPlayerNumber a /= pn)) pfs    settingsPage (_pPlayerSettings $ fromJust pfd) ((_pPlayerName . _pPlayerSettings) <$> pfs')