module Language.Nomyx.Expression where
import Data.Typeable
import Data.Time
import Control.Applicative hiding (Const)
import Data.Lens.Template
import Control.Monad.Error
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
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
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
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
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") []
liftEffect :: NomexNE a -> Nomex a
liftEffect = LiftEffect
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
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) ++ ">"
instance (Typeable a, Typeable b) => Show (a -> b) where
show e = '<' : (show . typeOf) e ++ ">"
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
BaseEvent :: (Typeable a) => Field a -> Event a
deriving Typeable
data Field a where
Input :: Maybe InputNumber -> 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 VictoryCond
deriving Typeable
data SomeField = forall a. (Typeable a) => SomeField (Field a)
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 (Field a)
deriving instance Show SomeField
deriving instance Eq (Field 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
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 VictoryCond = VictoryCond RuleNumber (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)
$( makeLenses [''RuleInfo, ''PlayerInfo] )