packages feed

statechart 0.0.0 → 0.1.0

raw patch · 5 files changed

+167/−167 lines, 5 files

Files

src/Code.hs view
@@ -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 ]) --}
src/Model.hs view
@@ -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
src/Rhapsody.hs view
@@ -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
src/Statechart.hs view
@@ -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)
statechart.cabal view
@@ -1,5 +1,5 @@ name:    statechart-version: 0.0.0+version: 0.1.0  category: Compiler