module Model
( Class (..)
, Attribute (..)
, StateChart (..)
, Init (..)
, Transition (..)
, Name
, Id
, Code
, parseModel
) where
import Data.List
import Data.Maybe
import Rhapsody
type Name = String
type Id = String
type Code = String
data Class = Class Name [Attribute] [StateChart] deriving Show
data Attribute = Attribute
{ attrName :: Name
, attrType :: String
, attrInit :: Maybe String
} deriving Show
data StateChart' = StateChart' Name [State] [Transition'] deriving Show
data State = State
{ stateName :: Name
, stateId :: Id
, stateParent :: Maybe Id
, stateDefaultTrans :: Maybe Id
, stateEntryAction :: Maybe Code
, stateExitAction :: Maybe Code
} deriving Show
data Transition' = Transition'
{ transition'Name :: Name
, transition'Id :: Id
, transition'Timeout :: Maybe Code
, transition'Guard :: Maybe Code
, transition'Action :: Maybe Code
, transition'Source :: Maybe Id
, transition'Target :: Id
} deriving Show
data StateChart = StateChart Name [(Id, Name)] Init [Transition] deriving Show
data Init = Init
{ initAction :: [Code]
, initTarget :: [Id]
} deriving Show
data Transition = Transition
{ transitionName :: (Name, Name)
, transitionSource :: [Id]
, transitionTimeout :: [(Id, Code)]
, transitionGuard :: [Code]
, transitionAction :: [Code]
, transitionTarget :: [Id]
} deriving Show
formatStateChart :: StateChart' -> StateChart
formatStateChart (StateChart' name states transitions) = if not defaultTransitionsCorrect
then error "invalid transition: default transitions must only point to direct sub-states"
else if not transitionsCorrect
then error "invalid transition: transitions must not cross state boundries"
else if not allParentStatesHaveDefaultTrans
then error "invalid transition: all states containing sub-states must have a default transition"
else if not $ null redundentStateNames
then error $ "invalid states: state names are not unique: " ++ show redundentStateNames
else StateChart name idsNames init transitions'
where
defaultTransitionsCorrect = and [ elem (transition'Target t) (children (stateId s)) | s <- states, t <- transitions, Just (transition'Id t) == stateDefaultTrans s ]
transitionsCorrect = and [ parent (fromJust $ transition'Source t) == parent (transition'Target t) | t <- transitions, isJust $ transition'Source t ]
allParentStatesHaveDefaultTrans = and [ stateDefaultTrans s /= Nothing | s <- states, not $ null $ children $ stateId s ]
redundentStateNames = foldr delete names (nub names)
names = [ stateName s | s <- states ]
idsNames = [ (id, stateName $ state id) | id <- nub $ concat [ transitionSource t ++ transitionTarget t | t <- transitions' ] ++ initTarget init ]
transitions' = [ appendTransitions (appendTransitions pre $ convertTrans t) $ entryTransition $ transition'Target t | t <- transitions, isJust $ transition'Source t, pre <- exitTransitions $ fromJust $ transition'Source t ]
initTrans = entryTransition $ head [ stateId s | s <- states, stateParent s == Nothing ]
init = Init
{ initAction = transitionAction initTrans
, initTarget = transitionTarget initTrans
}
state :: Id -> State
state id = case [ s | s <- states, stateId s == id ] of
[a] -> a
_ -> error $ "state not found: " ++ id
parent :: Id -> Id
parent = fromJust . stateParent . state
children :: Id -> [Id]
children id = [ stateId s | s <- states, stateParent s == Just id ]
trans :: Id -> Transition'
trans id = case [ t | t <- transitions, transition'Id t == id ] of
[a] -> a
_ -> error $ "transition not found: " ++ id
-- Elaborated entry transition given a state id.
entryTransition :: Id -> Transition
entryTransition id = case stateDefaultTrans $ state id of
Nothing -> entry
Just tId -> appendTransitions (appendTransitions entry $ convertTrans t) $ entryTransition $ transition'Target t
where
t = trans tId
where
entry = Transition
{ transitionName = ("", "")
, transitionSource = []
, transitionTimeout = []
, transitionGuard = []
, transitionAction = maybeToList $ stateEntryAction $ state id
, transitionTarget = [id]
}
-- Elaborated exit transitions given a state id.
exitTransitions :: Id -> [Transition]
exitTransitions id = if null subExits then [exit] else [ appendTransitions a exit | a <- subExits ]
where
exit = Transition
{ transitionName = ("", "")
, transitionSource = [id]
, transitionTimeout = []
, transitionGuard = []
, transitionAction = maybeToList $ stateExitAction $ state id
, transitionTarget = []
}
subExits = concat [ exitTransitions a | a <- children id ]
convertTrans :: Transition' -> Transition
convertTrans t = Transition
{ transitionName = case transition'Source t of
Nothing -> ("", "")
Just src -> (stateName $ state $ src, stateName $ state $ transition'Target t)
, transitionSource = maybeToList $ transition'Source t
, transitionTimeout = case (transition'Source t, transition'Timeout t) of
(Just id, Just code) -> [(id, code)]
_ -> []
, transitionGuard = maybeToList $ transition'Guard t
, transitionAction = maybeToList $ transition'Action t
, transitionTarget = [transition'Target t]
}
appendTransitions :: Transition -> Transition -> Transition
appendTransitions a b = Transition
{ transitionName = (fst (transitionName a) ++ fst (transitionName b), snd (transitionName a) ++ snd (transitionName b))
, transitionSource = nub $ transitionSource a ++ transitionSource b --XXX Will b every have sources?
, transitionTimeout = transitionTimeout a ++ transitionTimeout b
, transitionGuard = transitionGuard a ++ transitionGuard b
, transitionAction = transitionAction a ++ transitionAction b
, transitionTarget = nub $ transitionTarget a ++ transitionTarget b
}
parseModel :: Record -> [Class]
parseModel file = map parseClass $ containerRecords "Classes" file
parseClass :: Record -> Class
parseClass a = Class (head $ values "_name" a) (map parseAttribute $ containerRecords "Attrs" a) (map (formatStateChart . parseStateChart) $ containerRecords "StateCharts" a)
parseAttribute :: Record -> Attribute
parseAttribute a = Attribute
{ attrName = value "_name" a
, attrType = value "_name" $ head $ records "_typeOf" a
, attrInit = case containerRecords "ValueSpecifications" a of
[] -> Nothing
[a] -> Just $ value "_value" a
_ -> error "too many value specifications"
}
parseStateChart :: Record -> StateChart'
parseStateChart a = if not $ null $ containerRecords "Connectors" a then error "connectors not supported" else StateChart'
(value "_name" a)
(map parseState $ containerRecords "States" a)
(map parseTransition $ containerRecords "Transitions" a)
parseState :: Record -> State
parseState a = if values "_stateType" a == ["And"] then error $ "invalid state: AND states not supported: " ++ value "_name" a else State
{ stateName = if null (value "_name" a) then "root" else value "_name" a
, stateId = ident "_id" a
, stateParent = maybeList $ ident "_parent" a
, stateDefaultTrans = maybeList $ ident "_defaultTrans" a
, stateEntryAction = maybeList $ body "_entryAction" a
, stateExitAction = maybeList $ body "_exitAction" a
}
parseTransition :: Record -> Transition'
parseTransition a = Transition'
{ transition'Name = value "_name" a
, transition'Id = ident "_id" a
, transition'Timeout = timeout
, transition'Guard = maybeList $ if guard == "else" then error "else guards not supported" else guard
, transition'Action = maybeList $ body "_itsAction" label
, transition'Source = maybeList $ ident "_itsSource" a
, transition'Target = ident "_itsTarget" a
}
where
label = head $ records "_itsLabel" a
timeout = case body "_itsTrigger" label of
a | isPrefixOf "tm(" a -> Just $ drop 3 $ init a
| null a -> Nothing
| otherwise -> error $ "not supported non tm() events: " ++ a
guard = body "_itsGuard" label
maybeList :: [a] -> Maybe [a]
maybeList a = if null a then Nothing else Just a