diff --git a/Nomyx-Language.cabal b/Nomyx-Language.cabal --- a/Nomyx-Language.cabal +++ b/Nomyx-Language.cabal @@ -1,5 +1,5 @@ name: Nomyx-Language -version: 0.7.2 +version: 0.7.3 cabal-version: >=1.6 ---Warning: to use "cabal sdist", this patch is needed in cabal: https://github.com/haskell/cabal/pull/1110 ---This allows cabal to work with exported generated modules (Paths_Nomyx_Language) diff --git a/src/Language/Nomyx.hs b/src/Language/Nomyx.hs --- a/src/Language/Nomyx.hs +++ b/src/Language/Nomyx.hs @@ -2,16 +2,15 @@ -- | This module re-exports the elements necessary to compose a Nomyx rule. module Language.Nomyx ( - module Language.Nomyx.Expression, module Language.Nomyx.Outputs, module Language.Nomyx.Inputs, module Language.Nomyx.Events, module Language.Nomyx.Players, module Language.Nomyx.Variables, module Language.Nomyx.Rules, - module Language.Nomyx.Vote) where + module Language.Nomyx.Vote, + module Language.Nomyx.Expression) where -import Language.Nomyx.Expression -- Nomyx Expression DSL import Language.Nomyx.Outputs -- create outputs import Language.Nomyx.Inputs -- create inputs import Language.Nomyx.Events -- create events @@ -19,3 +18,4 @@ import Language.Nomyx.Variables -- create variables import Language.Nomyx.Rules -- manage rules import Language.Nomyx.Vote -- create votations +import Language.Nomyx.Expression -- Nomyx Expression DSL diff --git a/src/Language/Nomyx/Events.hs b/src/Language/Nomyx/Events.hs --- a/src/Language/Nomyx/Events.hs +++ b/src/Language/Nomyx/Events.hs @@ -12,7 +12,7 @@ getCurrentTime, oneWeek, oneDay, oneHour, oneMinute, timeEvent, messageEvent, victoryEvent, playerEvent, ruleEvent, - baseEvent, baseInputEvent, + signalEvent, inputFormSignal, liftEvent ) where @@ -60,8 +60,8 @@ Just ev -> return $ Just $ mapMaybe getInputResult (_env ev) Nothing -> return Nothing -getInputResult :: FieldResult -> Maybe (PlayerNumber, SomeData) -getInputResult (FieldResult (Input pn _ _) r _) = Just (pn, SomeData r) +getInputResult :: SignalOccurence -> Maybe (PlayerNumber, SomeData) +getInputResult (SignalOccurence (SignalData (Input pn _ _) r) _) = Just (pn, SomeData r) getInputResult _ = Nothing -- | broadcast a message that can be catched by another rule @@ -116,37 +116,49 @@ schedule'_ :: [UTCTime] -> Nomex () -> Nomex () schedule'_ ts f = schedule' ts (const f) - + +-- | get the current time as UTCTime getCurrentTime :: NomexNE UTCTime getCurrentTime = CurrentTime --- | duration -oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime -oneWeek = 7 * oneDay -oneDay = 24 * oneHour -oneHour = 60 * oneMinute -oneMinute = 60 - -baseEvent :: (Typeable a) => Field a -> Event a -baseEvent = BaseEvent +-- * Individual events +-- | Build an event firing at a specific time timeEvent :: UTCTime -> Event UTCTime -timeEvent = BaseEvent . Time - -messageEvent :: (Typeable a) => Msg a -> Event a -messageEvent = BaseEvent . Message +timeEvent = SignalEvent . Time +-- | Build a event firing when the victory condition is changed victoryEvent :: Event VictoryInfo -victoryEvent = BaseEvent Victory +victoryEvent = SignalEvent Victory +-- | Build a event firing when a player arrives or leaves playerEvent :: Player -> Event PlayerInfo -playerEvent = BaseEvent . Player +playerEvent = SignalEvent . Player +-- | Build a event firing when an action is made on a rule ruleEvent :: RuleEvent -> Event RuleInfo -ruleEvent re = BaseEvent $ RuleEv re +ruleEvent re = SignalEvent $ RuleEv re -baseInputEvent :: (Typeable a) => PlayerNumber -> String -> (InputForm a) -> Field a -baseInputEvent pn s iform = Input pn s iform +-- | Build a message event, that can be intercepted by another rule +-- this is useful for message-passing style of communication +messageEvent :: (Typeable a) => Msg a -> Event a +messageEvent = SignalEvent . Message +-- | Build a event firing immediatly, yelding the value of the NomexNE liftEvent :: NomexNE a -> Event a liftEvent = LiftEvent + +-- | duration +oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime +oneWeek = 7 * oneDay +oneDay = 24 * oneHour +oneHour = 60 * oneMinute +oneMinute = 60 + +-- * internals + +inputFormSignal :: (Typeable a) => PlayerNumber -> String -> (InputForm a) -> Signal a +inputFormSignal pn s iform = Input pn s iform + +signalEvent :: (Typeable a) => Signal a -> Event a +signalEvent = SignalEvent diff --git a/src/Language/Nomyx/Expression.hs b/src/Language/Nomyx/Expression.hs --- a/src/Language/Nomyx/Expression.hs +++ b/src/Language/Nomyx/Expression.hs @@ -12,7 +12,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} --- | This module containt the type definitions necessary to build a Nomic rule. +-- | This module contains the type definitions necessary to build a Nomic rule. module Language.Nomyx.Expression where import Data.Typeable @@ -46,10 +46,10 @@ type NoEffect = 'NoEffect -- | A Nomex (Nomyx Expression) allows the players to write rules. --- within the rules, you can access and modify the state of the game. +-- Within the rules, you can access and modify the state of the game. type Nomex = Exp Effect --- | A NomexNE (Nomyx Expression No Effect) is a specialisation of the type that guaranties +-- | A NomexNE (Nomyx Expression No Effect) is a specialisation of the type that guarantees -- that the instructions will have no effects. type NomexNE = Exp NoEffect @@ -98,16 +98,26 @@ deriving instance Typeable Exp deriving instance Typeable 'Effect deriving instance Typeable 'NoEffect + +instance Typeable a => Show (Exp NoEffect a) where + show _ = "<" ++ (show $ typeRep (Proxy :: Proxy a)) ++ ">" + +instance Typeable a => Show (Exp Effect a) where + show _ = "<" ++ (show $ typeRep (Proxy :: Proxy a)) ++ ">" + #else instance Typeable1 (Exp NoEffect) where typeOf1 _ = mkTyConApp (mkTyCon3 "main" "Language.Nomyx.Expression" "Exp NoEffect") [] instance Typeable1 (Exp Effect) where typeOf1 _ = mkTyConApp (mkTyCon3 "main" "Language.Nomyx.Expression" "Exp Effect") [] -#endif -liftEffect :: NomexNE a -> Nomex a -liftEffect = LiftEffect +instance Typeable a => Show (Exp NoEffect a) where + show e = "<" ++ (show $ typeOf e) ++ ">" + +instance Typeable a => Show (Exp Effect a) where + show e = "<" ++ (show $ typeOf e) ++ ">" +#endif instance Monad (Exp a) where return = Return @@ -127,22 +137,8 @@ throwError = ThrowError catchError = CatchError -instance Typeable a => Show (Exp NoEffect a) where -#if __GLASGOW_HASKELL__ < 708 - show e = "<" ++ (show $ typeOf e) ++ ">" -#else - show e = "<" ++ (show $ typeRep (Proxy :: Proxy a)) ++ ">" -#endif - -instance Typeable a => Show (Exp Effect a) where -#if __GLASGOW_HASKELL__ < 708 - show e = "<" ++ (show $ typeOf e) ++ ">" -#else - show e = "<" ++ (show $ typeRep (Proxy :: Proxy a)) ++ ">" -#endif - -instance (Typeable a, Typeable b) => Show (a -> b) where - show e = '<' : (show . typeOf) e ++ ">" +liftEffect :: NomexNE a -> Nomex a +liftEffect = LiftEffect -- * Variables @@ -159,22 +155,22 @@ EmptyEvent :: Event a -- An event that is never fired. BindEvent :: Event a -> (a -> Event b) -> Event b -- A First event should fire, then a second event is constructed ShortcutEvents :: [Event a] -> ([Maybe a] -> Bool) -> Event [Maybe a] -- Return the intermediate results as soon as the function evaluates to True, dismissing the events that hasn't fired yet - BaseEvent :: (Typeable a) => Field a -> Event a -- Embed a base event + SignalEvent :: (Typeable a) => Signal a -> Event a -- Embed a single Signal as an Event LiftEvent :: NomexNE a -> Event a -- create an event containing the result of the NomexNE. deriving Typeable --- | Base events -data Field a where - Input :: PlayerNumber -> String -> (InputForm a) -> Field a - Player :: Player -> Field PlayerInfo - RuleEv :: RuleEvent -> Field RuleInfo - Time :: UTCTime -> Field UTCTime - Message :: Msg a -> Field a - Victory :: Field VictoryInfo +-- | Signals +data Signal a where + Input :: PlayerNumber -> String -> (InputForm a) -> Signal a + Player :: Player -> Signal PlayerInfo + RuleEv :: RuleEvent -> Signal RuleInfo + Time :: UTCTime -> Signal UTCTime + Message :: Msg a -> Signal a + Victory :: Signal VictoryInfo deriving Typeable -- | Type agnostic base event -data SomeField = forall a. (Typeable a) => SomeField (Field a) +data SomeSignal = forall a. (Typeable a) => SomeSignal (Signal a) -- | Type agnostic result data data SomeData = forall e. (Typeable e, Show e) => SomeData e @@ -195,9 +191,9 @@ deriving Typeable deriving instance Show (InputForm a) -deriving instance Show (Field a) -deriving instance Show SomeField -deriving instance Eq (Field e) +deriving instance Show (Signal a) +deriving instance Show SomeSignal +deriving instance Eq (Signal e) deriving instance Eq (InputForm e) deriving instance Eq (Msg e) @@ -231,19 +227,22 @@ event :: Event e, handler :: EventHandler e, _evStatus :: Status, - _env :: [FieldResult]} + _env :: [SignalOccurence]} -data FieldAddressElem = SumR | SumL | AppR | AppL | BindR | BindL | Shortcut deriving (Show, Read, Ord, Eq, Generic) -type FieldAddress = [FieldAddressElem] +data SignalAddressElem = SumR | SumL | AppR | AppL | BindR | BindL | Shortcut deriving (Show, Read, Ord, Eq, Generic) +type SignalAddress = [SignalAddressElem] -data FieldResult = forall e. (Typeable e, Show e) => - FieldResult {field :: Field e, - fieldResult :: e, - _fieldAddress :: Maybe FieldAddress} +data SignalData = forall e. (Typeable e, Show e) => + SignalData {signal :: Signal e, + signalData :: e} +data SignalOccurence = SignalOccurence {_signalOccData :: SignalData, + _signalOccAddress :: SignalAddress} + type EventHandler e = (EventNumber, e) -> Nomex () -deriving instance Show FieldResult +deriving instance Show SignalData +deriving instance Show SignalOccurence data Status = SActive | SDeleted deriving (Eq, Show) @@ -260,7 +259,7 @@ type Rule = Nomex () -- | An informationnal structure about a rule -data RuleInfo = RuleInfo { _rNumber :: RuleNumber, -- number of the rule (must be unique) TO CHECK +data RuleInfo = RuleInfo { _rNumber :: RuleNumber, -- number of the rule (must be unique) _rName :: RuleName, -- short name of the rule _rDescription :: String, -- description of the rule _rProposedBy :: PlayerNumber, -- player proposing the rule @@ -299,6 +298,8 @@ _vCond :: NomexNE [PlayerNumber]} deriving (Show, Typeable) +-- * Miscellaneous + partial :: String -> Nomex (Maybe a) -> Nomex a partial s nm = do m <- nm @@ -308,6 +309,10 @@ concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) + +instance (Typeable a, Typeable b) => Show (a -> b) where + show e = '<' : (show . typeOf) e ++ ">" -$( makeLenses [''RuleInfo, ''PlayerInfo, ''EventInfo, ''FieldResult] ) + +$( makeLenses [''RuleInfo, ''PlayerInfo, ''EventInfo, ''SignalOccurence] ) diff --git a/src/Language/Nomyx/Inputs.hs b/src/Language/Nomyx/Inputs.hs --- a/src/Language/Nomyx/Inputs.hs +++ b/src/Language/Nomyx/Inputs.hs @@ -26,7 +26,7 @@ -- | event based on a radio input choice inputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event c -inputRadio pn title cs = baseEvent $ baseInputRadio pn title cs +inputRadio pn title cs = signalEvent $ inputRadioSignal pn title cs inputRadio' :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [c] -> Event c inputRadio' pn title cs = inputRadio pn title (zip cs (show <$> cs)) @@ -47,7 +47,7 @@ -- | event based on a text input inputText :: PlayerNumber -> String -> Event String -inputText pn title = baseEvent $ baseInputText pn title +inputText pn title = signalEvent $ inputTextSignal pn title -- | triggers a string input to the user. The result will be sent to the callback onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber @@ -66,7 +66,7 @@ -- | event based on a checkbox input inputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Event [c] -inputCheckbox pn title cs = baseEvent $ baseInputCheckbox pn title cs +inputCheckbox pn title cs = signalEvent $ inputCheckboxSignal pn title cs onInputCheckbox :: (Typeable a, Eq a, Show a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputCheckbox title choices handler pn = onEvent (inputCheckbox pn title choices) (\(en, a) -> handler en a) @@ -81,7 +81,7 @@ -- | event based on a button inputButton :: PlayerNumber -> String -> Event () -inputButton pn title = baseEvent $ baseInputButton pn title +inputButton pn title = signalEvent $ inputButtonSignal pn title onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputButton title handler pn = onEvent (inputButton pn title) (\(en, ()) -> handler en ()) @@ -97,7 +97,7 @@ -- | event based on a text area inputTextarea :: PlayerNumber -> String -> Event String -inputTextarea pn title = baseEvent $ baseInputTextarea pn title +inputTextarea pn title = signalEvent $ inputTextareaSignal pn title onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber onInputTextarea title handler pn = onEvent (inputTextarea pn title) (\(en, a) -> handler en a) @@ -112,17 +112,17 @@ -- ** Internals -baseInputRadio :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field c -baseInputRadio pn title cs = baseInputEvent pn title (Radio cs) +inputRadioSignal :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Signal c +inputRadioSignal pn title cs = inputFormSignal pn title (Radio cs) -baseInputText :: PlayerNumber -> String -> Field String -baseInputText pn title = baseInputEvent pn title Text +inputTextSignal :: PlayerNumber -> String -> Signal String +inputTextSignal pn title = inputFormSignal pn title Text -baseInputCheckbox :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Field [c] -baseInputCheckbox pn title cs = baseInputEvent pn title (Checkbox cs) +inputCheckboxSignal :: (Eq c, Show c, Typeable c) => PlayerNumber -> String -> [(c, String)] -> Signal [c] +inputCheckboxSignal pn title cs = inputFormSignal pn title (Checkbox cs) -baseInputButton :: PlayerNumber -> String -> Field () -baseInputButton pn title = baseInputEvent pn title Button +inputButtonSignal :: PlayerNumber -> String -> Signal () +inputButtonSignal pn title = inputFormSignal pn title Button -baseInputTextarea :: PlayerNumber -> String -> Field String -baseInputTextarea pn title = baseInputEvent pn title TextArea +inputTextareaSignal :: PlayerNumber -> String -> Signal String +inputTextareaSignal pn title = inputFormSignal pn title TextArea diff --git a/src/Language/Nomyx/Players.hs b/src/Language/Nomyx/Players.hs --- a/src/Language/Nomyx/Players.hs +++ b/src/Language/Nomyx/Players.hs @@ -14,7 +14,7 @@ Player(..), playerEvent, playerNumber, playerName, - getPlayers, getPlayer, getPlayerName, + getPlayers, getPlayer, getPlayerName, getPlayerName', setPlayerName, modifyPlayerName, getPlayersNumber, getAllPlayerNumbers, @@ -54,11 +54,19 @@ pls <- GetPlayers return $ find ((== pn) . getL playerNumber) pls --- | Set the name of a player +-- | Get the name of a player getPlayerName :: PlayerNumber -> NomexNE (Maybe PlayerName) getPlayerName pn = do p <- getPlayer pn return $ _playerName <$> p + +-- | Get the name of a player, his number if not found +getPlayerName' :: PlayerNumber -> NomexNE PlayerName +getPlayerName' pn = do + mp <- getPlayer pn + return $ case mp of + Just p -> _playerName p + Nothing -> "Player " ++ (show pn) -- | Set the name of a player setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool