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
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
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
#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 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
#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 ++ ">"
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]
BaseEvent :: (Typeable a) => Field a -> Event a
LiftNomexNE :: NomexNE a -> Event a
deriving Typeable
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
deriving Typeable
data SomeField = forall a. (Typeable a) => SomeField (Field 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 (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
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 :: [FieldResult]}
data FieldAddressElem = SumR | SumL | AppR | AppL | BindR | BindL | Shortcut deriving (Show, Read, Ord, Eq, Generic)
type FieldAddress = [FieldAddressElem]
data FieldResult = forall e. (Typeable e, Show e) =>
FieldResult {field :: Field e,
fieldResult :: e,
_fieldAddress :: Maybe FieldAddress}
type EventHandler e = (EventNumber, e) -> Nomex ()
deriving instance Show FieldResult
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)
$( makeLenses [''RuleInfo, ''PlayerInfo, ''EventInfo, ''FieldResult] )