diff --git a/src/Code.hs b/src/Code.hs --- a/src/Code.hs +++ b/src/Code.hs @@ -26,14 +26,6 @@ ++ "void elapseTime(int ms) { __clock += (uint64_t) ms; }\n" ++ concatMap codeClass classes -formatId :: String -> String -> String -formatId prefix id = prefix ++ map f id - where - f '-' = '_' - f a = a - -sId = formatId "s_" - indent :: String -> String indent = unlines . map (" " ++) . lines @@ -48,116 +40,33 @@ codeAttr a = printf "static %s %s%s;\n" (attrType a) (attrName a) (case attrInit a of { Nothing -> ""; Just i -> " = " ++ i}) codeStateChart :: StateChart -> String -codeStateChart (StateChart name states transitions) = seq defaultState $ "\n// Statechart " ++ name ++ ".\n" - ++ block ( - concat [ printf "static bool %s = false;\n" (sId $ stateId state) | state <- states ] - ++ concat [ printf "static uint64_t %s_entryTime = 0;\n" (sId $ stateId state) | state <- states ] - ++ intercalate "\nelse\n" (codeInit states defaultTransition rootState : mapMaybe (codeState states transitions) states) +codeStateChart (StateChart name idsNames init transitions) = "\n// Statechart " ++ name ++ ".\n" + ++ block ( "static bool __init = false;\n" + ++ "static int __trans = 0;\n" + ++ concat [ printf "static bool %s = false;\n" name | (_, name) <- idsNames ] + ++ concat [ printf "static uint64_t %s_entryTime = 0;\n" name | (_, name) <- idsNames ] + ++ codeInit stateName init + ++ codeTransitions stateName transitions ) where - rootState = head [ state | state <- states, stateParent state == Nothing ] - defaultTransition = case [ t | t <- transitions, transitionSource t == Nothing ] of - [t] -> t - [] -> error "default state not specified (1)" - _ -> error "lower level default transitions not supported" - defaultState = if Just (transitionId defaultTransition) /= stateDefaultTrans rootState - then error "default state not specified (2)" - else head [ state | state <- states, stateId state == transitionTarget defaultTransition ] - -codeInit :: [State] -> Transition -> State -> String -codeInit states transition state = "\n// Initialize\n" - ++ "if (! " ++ sId (stateId state) ++ ") " ++ block (codeTransition states transition) - -codeState :: [State] -> [Transition] -> State -> Maybe String -codeState states transitions state = if null t then Nothing else Just $ "\n// In state " ++ stateName state ++ "\n" - ++ "if (" ++ sId (stateId state) ++ ") " ++ block (intercalate "\nelse\n" t) - where - t = [ codeTransition states t | t <- transitions, transitionSource t == Just (stateId state) ] - -codeTransition :: [State] -> Transition -> String -codeTransition states t = case transitionSource t of - Nothing -> "\n// -> " ++ stateName (idState states target) ++ "\n" - ++ transAction (transitionAction t) ++ concatMap (stateEntry . idState states) b - where - b = hierarchy states target - - Just source -> "\n// " ++ stateName (idState states source) ++ " -> " ++ stateName (idState states target) ++ "\n" - ++ "if (" ++ predicate ++ ") " ++ block (concatMap (stateExit . idState states) a ++ transAction (transitionAction t) ++ concatMap (stateEntry . idState states) b) - where - (a, b) = changedStates states source target - predicate = case (predicateTimeout, predicateGuard) of - ("", "") -> "true" - ("", a) -> a - (a, "") -> a - (a, b) -> "(" ++ a ++ ") && (" ++ b ++ ")" - predicateTimeout = case transitionTimeout t of - Nothing -> "" - Just i -> "__clock >= " ++ sId source ++ "_entryTime + (" ++ i ++ ")" - predicateGuard = case transitionGuard t of - Nothing -> "" - Just g -> g - where - target = transitionTarget t - -stateExit :: State -> String -stateExit s = case stateExitAction s of - Nothing -> stateUpdate - Just a -> a ++ "\n" ++ stateUpdate - where - stateUpdate = sId (stateId s) ++ " = false;\n" - -stateEntry :: State -> String -stateEntry s = case stateEntryAction s of - Nothing -> stateUpdate - Just a -> a ++ "\n" ++ stateUpdate - where - stateUpdate = sId (stateId s) ++ " = true;\n" ++ sId (stateId s) ++ "_entryTime = __clock;\n" + stateName :: Id -> Name + stateName id = fromJust $ lookup id idsNames -transAction :: Maybe String -> String -transAction Nothing = "" -transAction (Just a) = a ++ "\n" +codeInit :: (Id -> Name) -> Init -> String +codeInit stateName (Init actions targets) = "\n// Initialize\n" + ++ "if (! __init) " ++ block ("__init = true;\n" ++ transitionStates stateName [] targets ++ concat [ block a | a <- actions ]) -idState :: [State] -> Id -> State -idState states id = head [ s | s <- states, stateId s == id ] +transitionStates :: (Id -> Name) -> [Id] -> [Id] -> String +transitionStates stateName a b = concat [ printf "%s = false;\n" (stateName s) | s <- a \\ b ] + ++ concat [ printf "%s = true;\n%s_entryTime = __clock;\n" (stateName s) (stateName s) | s <- b \\ a ] --- (statesExiting, statesEntering) with proper order. -changedStates :: [State] -> Id -> Id -> ([Id], [Id]) -changedStates states a b = (reverse a', b') +codeTransition :: (Id -> Name) -> Transition -> String +codeTransition stateName t = printf "if (%s) " predicate ++ block (transition ++ action) where - (a', b') = stripCommonPrefix (hierarchy states a) (hierarchy states b) - -hierarchy :: [State] -> Id -> [Id] -hierarchy states id = case stateParent $ idState states id of - Nothing -> [id] - Just a -> hierarchy states a ++ [id] - -stripCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) -stripCommonPrefix (a : as) (b : bs) - | a == b = stripCommonPrefix as bs - | otherwise = (a : as, b : bs) -stripCommonPrefix a b = (a, b) - -{- -data Class = Class Name [StateChart] deriving Show - -data StateChart = StateChart Name [State] [Connector] [Transition] deriving Show - -data State = State - { stateName :: Name - , stateId :: Id - , stateParent :: Maybe Id - , stateDefaultTrans :: Maybe Id - , stateEntryAction :: Maybe Code - , stateExitAction :: Maybe Code - } deriving Show + predicate = intercalate " && " $ [ stateName a | a <- transitionSource t ] ++ [ printf "__clock >= %s_entryTime + (%s)" (stateName id) time | (id, time) <- transitionTimeout t ] ++ [ printf "(%s)" a | a <- transitionGuard t ] + transition = transitionStates stateName (transitionSource t) (transitionTarget t) + action = concat [ block a | a <- transitionAction t ] -data Transition = Transition - { transitionName :: Name - , transitionTimeout :: Maybe Int - , transitionGuard :: Maybe Code - , transitionAction :: Maybe Code - , transitionSource :: Maybe Id - , transitionTarget :: Id - } deriving Show +codeTransitions :: (Id -> Name) -> [Transition] -> String +codeTransitions stateName transitions = printf "switch (__trans) " ++ block (concat [ printf "// %s -> %s\ncase %d:\n" (fst $ transitionName t) (snd $ transitionName t) n ++ (indent $ codeTransition stateName t ++ printf "__trans = %d;\nbreak;\n" (if n == length transitions - 1 then 0 else n + 1)) | (n, t) <- zip [0..] transitions ]) --} diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -2,10 +2,8 @@ ( Class (..) , Attribute (..) , StateChart (..) - , State (..) + , Init (..) , Transition (..) - -- , Connector (..) - -- , ConnectorType (..) , Name , Id , Code @@ -13,6 +11,7 @@ ) where import Data.List +import Data.Maybe import Rhapsody @@ -22,14 +21,14 @@ data Class = Class Name [Attribute] [StateChart] deriving Show -data StateChart = StateChart Name [State] [Transition] 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 @@ -39,32 +38,135 @@ , stateExitAction :: Maybe Code } deriving Show -{- -data Connector = Connector - { connectorName :: Name - , connectorId :: Id - , connectorParent :: Id - , connectorType :: ConnectorType +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 ConnectorType = Junction | Condition 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 - , transitionId :: Id - , transitionTimeout :: Maybe Code - , transitionGuard :: Maybe Code - , transitionAction :: Maybe Code - , transitionSource :: Maybe Id - , transitionTarget :: Id + { 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 parseStateChart $ containerRecords "StateCharts" a) +parseClass a = Class (head $ values "_name" a) (map parseAttribute $ containerRecords "Attrs" a) (map (formatStateChart . parseStateChart) $ containerRecords "StateCharts" a) parseAttribute :: Record -> Attribute parseAttribute a = Attribute @@ -76,15 +178,15 @@ _ -> error "too many value specifications" } -parseStateChart :: Record -> StateChart -parseStateChart a = if not $ null $ containerRecords "Connectors" a then error "connectors not supported" else StateChart +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 $ "and state not supported: " ++ value "_name" a else State - { stateName = value "_name" a +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 @@ -92,30 +194,15 @@ , stateExitAction = maybeList $ body "_exitAction" a } -{- -parseConnector :: Record -> Connector -parseConnector a = Connector - { connectorName = value "_name" a - , connectorId = ident "_id" a - , connectorParent = ident "_parent" a - , connectorType = case value "_connectorType" a of - "Junction" -> Junction - "Condition" -> Condition - --"Fork" -> Fork - --"Join" -> Join - a -> error $ "unknown connector type: " ++ a - } --} - -parseTransition :: Record -> Transition -parseTransition a = Transition - { transitionName = value "_name" a - , transitionId = ident "_id" a - , transitionTimeout = timeout - , transitionGuard = maybeList $ if guard == "else" then error "else guards not supported" else guard - , transitionAction = maybeList $ body "_itsAction" label - , transitionSource = maybeList $ ident "_itsSource" a - , transitionTarget = ident "_itsTarget" 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 @@ -124,7 +211,6 @@ | 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 diff --git a/src/Rhapsody.hs b/src/Rhapsody.hs --- a/src/Rhapsody.hs +++ b/src/Rhapsody.hs @@ -42,9 +42,14 @@ -- | A unique identifier field. ident :: String -> Record -> String ident name a = case values name a of - [_, a] -> a + [_, a] -> formatId a _ -> "" - + where + formatId :: String -> String + formatId id = "__" ++ map f id + f '-' = '_' + f a = a + -- | Extract the _body string from triggers, guards, and actions. body :: String -> Record -> String body name rec = case records name rec of diff --git a/src/Statechart.hs b/src/Statechart.hs --- a/src/Statechart.hs +++ b/src/Statechart.hs @@ -15,7 +15,7 @@ parseArgs :: [String] -> Maybe (String, [String], String) parseArgs a = case a of - [a] | head a /= '-' -> Just (takeWhile (/= '.') a ++ ".c", [], a) + [a] | head a /= '-' -> Just (takeWhile (/= '.') a, [], a) "-o" : file : rest -> do (_, inc, sbs) <- parseArgs rest Just (file, inc, sbs) diff --git a/statechart.cabal b/statechart.cabal --- a/statechart.cabal +++ b/statechart.cabal @@ -1,5 +1,5 @@ name: statechart -version: 0.0.0 +version: 0.1.0 category: Compiler