module Language.Nomyx.Expression where
import Data.Typeable
import Data.Time
import GHC.Generics
import Control.Applicative hiding (Const)
import Data.Lens.Template
import Control.Monad.Error
import Control.Shortcut
import System.Random
type PlayerNumber = Int
type PlayerName = String
type RuleNumber = Int
type RuleName = String
type RuleDesc = String
type RuleText = String
type RuleCode = String
type EventNumber = Int
type EventName = String
type VarName = String
type Code = String
type OutputNumber = Int
type InputNumber = Int
data Eff = Effect | NoEffect deriving (Typeable)
type Effect = 'Effect
type NoEffect = 'NoEffect
type Nomex = Exp Effect
type NomexNE = Exp NoEffect
data Exp :: Eff -> * -> * where
NewVar :: (Typeable a, Show a) => VarName -> a -> Nomex (Maybe (V a))
ReadVar :: (Typeable a, Show a) => V a -> NomexNE (Maybe a)
WriteVar :: (Typeable a, Show a) => V a -> a -> Nomex Bool
DelVar :: (V a) -> Nomex Bool
OnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Nomex EventNumber
DelEvent :: EventNumber -> Nomex Bool
GetEvents :: NomexNE [EventInfo]
SendMessage :: (Typeable a, Show a) => Msg a -> a -> Nomex ()
ProposeRule :: RuleInfo -> Nomex Bool
ActivateRule :: RuleNumber -> Nomex Bool
RejectRule :: RuleNumber -> Nomex Bool
AddRule :: RuleInfo -> Nomex Bool
ModifyRule :: RuleNumber -> RuleInfo -> Nomex Bool
GetRules :: NomexNE [RuleInfo]
GetPlayers :: NomexNE [PlayerInfo]
SetPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool
DelPlayer :: PlayerNumber -> Nomex Bool
--Outputs
NewOutput :: Maybe PlayerNumber -> NomexNE String -> Nomex OutputNumber
GetOutput :: OutputNumber -> NomexNE (Maybe String)
UpdateOutput :: OutputNumber -> NomexNE String -> Nomex Bool
DelOutput :: OutputNumber -> Nomex Bool
--Mileacenous
SetVictory :: NomexNE [PlayerNumber] -> Nomex ()
CurrentTime :: NomexNE UTCTime
SelfRuleNumber :: NomexNE RuleNumber
GetRandomNumber :: Random a => (a, a) -> Nomex a
Return :: a -> Exp e a
Bind :: Exp e a -> (a -> Exp e b) -> Exp e b
ThrowError :: String -> Exp Effect a
CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a
LiftEffect :: NomexNE a -> Nomex a
Simu :: Nomex a -> NomexNE Bool -> NomexNE Bool
#if __GLASGOW_HASKELL__ >= 708
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") []
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
(>>=) = Bind
instance Functor (Exp a) where
fmap f e = Bind e $ Return . f
instance Applicative (Exp a) where
pure = Return
f <*> a = do
f' <- f
a' <- a
return $ f' a'
instance MonadError String Nomex where
throwError = ThrowError
catchError = CatchError
liftEffect :: NomexNE a -> Nomex a
liftEffect = LiftEffect
data V a = V {varName :: String} deriving Typeable
data Event a where
SumEvent :: Event a -> Event a -> Event a
AppEvent :: Event (a -> b) -> Event a -> Event b
PureEvent :: a -> Event a
EmptyEvent :: Event a
BindEvent :: Event a -> (a -> Event b) -> Event b
ShortcutEvents :: [Event a] -> ([Maybe a] -> Bool) -> Event [Maybe a]
SignalEvent :: (Typeable a) => Signal a -> Event a
LiftEvent :: NomexNE a -> Event a
deriving Typeable
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
data SomeSignal = forall a. (Typeable a) => SomeSignal (Signal a)
data SomeData = forall e. (Typeable e, Show e) => SomeData e
deriving instance Show SomeData
data Player = Arrive | Leave deriving (Typeable, Show, Eq)
data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq)
data Msg m = Msg String deriving (Typeable, Show)
data InputForm a where
Text :: InputForm String
TextArea :: InputForm String
Button :: InputForm ()
Radio :: (Show a, Eq a) => [(a, String)] -> InputForm a
Checkbox :: (Show a, Eq a) => [(a, String)] -> InputForm [a]
deriving Typeable
deriving instance Show (InputForm a)
deriving instance Show (Signal a)
deriving instance Show SomeSignal
deriving instance Eq (Signal e)
deriving instance Eq (InputForm e)
deriving instance Eq (Msg e)
instance Functor Event where
fmap f a = pure f <*> a
instance Applicative Event where
pure = PureEvent
(<*>) = AppEvent
instance Alternative Event where
(<|>) = SumEvent
empty = EmptyEvent
instance Monad Event where
(>>=) = BindEvent
return = PureEvent
instance MonadPlus Event where
mplus = SumEvent
mzero = EmptyEvent
instance Shortcutable Event where
shortcut = ShortcutEvents
data EventInfo = forall e. (Typeable e, Show e) =>
EventInfo {_eventNumber :: EventNumber,
_ruleNumber :: RuleNumber,
event :: Event e,
handler :: EventHandler e,
_evStatus :: Status,
_env :: [SignalOccurence]}
data SignalAddressElem = SumR | SumL | AppR | AppL | BindR | BindL | Shortcut deriving (Show, Read, Ord, Eq, Generic)
type SignalAddress = [SignalAddressElem]
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 SignalData
deriving instance Show SignalOccurence
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
type Rule = Nomex ()
data RuleInfo = RuleInfo { _rNumber :: RuleNumber,
_rName :: RuleName,
_rDescription :: String,
_rProposedBy :: PlayerNumber,
_rRuleCode :: Code,
_rRule :: Rule,
_rStatus :: RuleStatus,
_rAssessedBy :: Maybe RuleNumber}
deriving (Typeable, Show)
instance Eq RuleInfo where
(RuleInfo {_rNumber=r1}) == (RuleInfo {_rNumber=r2}) = r1 == r2
instance Ord RuleInfo where
(RuleInfo {_rNumber=r1}) <= (RuleInfo {_rNumber=r2}) = r1 <= r2
data RuleStatus = Active
| Pending
| Reject
deriving (Eq, Show, Typeable)
data PlayerInfo = PlayerInfo { _playerNumber :: PlayerNumber,
_playerName :: String,
_playAs :: Maybe PlayerNumber}
deriving (Eq, Typeable, Show)
instance Ord PlayerInfo where
h <= g = (_playerNumber h) <= (_playerNumber g)
data VictoryInfo = VictoryInfo { _vRuleNumber :: RuleNumber,
_vCond :: NomexNE [PlayerNumber]}
deriving (Show, Typeable)
partial :: String -> Nomex (Maybe a) -> Nomex a
partial s nm = do
m <- nm
case m of
Just a -> return a
Nothing -> throwError s
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, ''SignalOccurence] )