packages feed

statechart (empty) → 0.0.0

raw patch · 7 files changed

+557/−0 lines, 7 filesdep +basedep +polyparsesetup-changed

Dependencies added: base, polyparse

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Tom Hawkins 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#! /usr/bin/env runhaskell++> module Main (main) where+>+> import Distribution.Simple (defaultMain)+>+> main :: IO ()+> main = defaultMain
+ src/Code.hs view
@@ -0,0 +1,163 @@+module Code+  ( genCode+  ) where++import Data.List+import Data.Maybe+import Text.Printf++import Model++genCode :: String -> [String] -> [Class] -> IO ()+genCode name includes classes = do+  writeFile (name ++ ".h") $ "// Generated by statechart.\n\n"+    ++ "// Updates the statechart millisecond clock.  Used for tm(...) events.\n"+    ++ "void elapseTime(int ms);\n"+    ++ concat [ "\nvoid " ++ n ++ "(void);\n" | Class n _ _ <- classes ]++  writeFile (name ++ ".c") $ "// Generated by statechart.\n"+    ++ "#include <stdbool.h>\n"+    ++ "#include <stdint.h>\n\n"+    ++ concat [ "#include \"" ++ inc ++ "\"\n" | inc <- (name ++ ".h") : includes ]+    ++ "\n"+    ++ "// The reference clock used for tm(...) events.\n"+    ++ "static uint64_t __clock = 0;\n\n"+    ++ "// Updates the statechart millisecond clock.  Used for tm(...) events.\n"+    ++ "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++block :: String -> String+block a = "{\n" ++ indent a ++ "}\n"++codeClass :: Class -> String+codeClass (Class name attrs statecharts) = "\n// Class " ++ name ++ ".\n"+  ++ "void " ++ name ++ "() " ++ block (concatMap codeAttr attrs ++ concatMap codeStateChart statecharts)++codeAttr :: Attribute -> String+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)+     )+  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"++transAction :: Maybe String -> String+transAction Nothing = ""+transAction (Just a) = a ++ "\n"++idState :: [State] -> Id -> State+idState states id = head [ s | s <- states, stateId s == id ]++-- (statesExiting, statesEntering)  with proper order.+changedStates :: [State] -> Id -> Id -> ([Id], [Id])+changedStates states a b = (reverse a', b')+  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++data Transition = Transition+  { transitionName    :: Name+  , transitionTimeout :: Maybe Int+  , transitionGuard   :: Maybe Code+  , transitionAction  :: Maybe Code+  , transitionSource  :: Maybe Id+  , transitionTarget  :: Id+  } deriving Show++-}
+ src/Model.hs view
@@ -0,0 +1,131 @@+module Model+  ( Class         (..)+  , Attribute     (..)+  , StateChart    (..)+  , State         (..)+  , Transition    (..)+  -- , Connector     (..)+  -- , ConnectorType (..)+  , Name+  , Id+  , Code+  , parseModel+  ) where++import Data.List++import Rhapsody++type Name = String+type Id   = String+type Code = String++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 State = State+  { stateName         :: Name+  , stateId           :: Id+  , stateParent       :: Maybe Id+  , stateDefaultTrans :: Maybe Id+  , stateEntryAction  :: Maybe Code+  , stateExitAction   :: Maybe Code+  } deriving Show++{-+data Connector = Connector+  { connectorName   :: Name+  , connectorId     :: Id+  , connectorParent :: Id+  , connectorType   :: ConnectorType+  } deriving Show++data ConnectorType = Junction | Condition deriving Show+-}++data Transition = Transition+  { transitionName    :: Name+  , transitionId      :: Id+  , transitionTimeout :: Maybe Code+  , transitionGuard   :: Maybe Code+  , transitionAction  :: Maybe Code+  , transitionSource  :: Maybe Id+  , transitionTarget  :: Id+  } deriving Show++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)++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 $ "and state not supported: " ++ value "_name" a else State+  { stateName         = 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+  } ++{-+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+  }+  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+
+ src/Rhapsody.hs view
@@ -0,0 +1,133 @@+module Rhapsody+  ( Record (..)+  , Field  (..)+  , parseRhapsody+  , records+  , values+  , value+  , containerRecords+  , ident+  , body+  ) where++import Text.ParserCombinators.Poly.Plain++data Record = Record String [Field]  deriving (Show, Eq)+data Field+  = Value       String [String]+  | RecordNamed String [Record]+  | RecordAnon          Record+  deriving (Show, Eq)++-- | Given a record and a field name, returns a subfield of records.  Null if not found.+records :: String -> Record -> [Record]+records name (Record _ fields) = concat [ recs | RecordNamed n recs <- fields, n == name ]++-- | Given a record and a field name, returns a subfield of values.  Null if not found.+values :: String -> Record -> [String]+values name (Record _ fields) = concat [ vals | Value n vals <- fields, n == name ]++-- | Returns a field with a single value, or an empty string if the field does not exist.+value :: String -> Record -> String+value name r = case values name r of+  [] -> ""+  a : _ -> a++-- | Returns a list of records packaged in an IRPYRawContainer.+containerRecords :: String -> Record -> [Record]+containerRecords name rec = case records name rec of+  [] -> []+  a : _ -> records "value" a+ +-- | A unique identifier field.+ident :: String -> Record -> String+ident name a = case values name a of+  [_, a] -> a+  _ -> ""++-- | Extract the _body string from triggers, guards, and actions.+body :: String -> Record -> String+body name rec = case records name rec of+  [] -> ""+  a : _ -> value "_body" a++++-- Lexing.++data Token+  = Eq+  | Dash+  | SemiColon+  | BraceLeft+  | BraceRight+  | String String+  deriving (Show, Eq)++lexer :: String -> [Token]+lexer = tokens . unlines . tail . lines . decomment+  where++  tokens :: String -> [Token]+  tokens "" = []+  tokens a = case a of+    a : b | elem a " \r\n\t" -> tokens b+    '{' : b -> BraceLeft  : tokens b+    '}' : b -> BraceRight : tokens b+    '=' : b -> Eq         : tokens b+    '-' : ' ' : b -> Dash       : tokens b+    ';' : b -> SemiColon  : tokens b+    '"' : b -> String str : tokens rest where (str, rest) = string b+    '#' : b -> tokens $ dropWhile (/= '\n') b+    a -> String (takeWhile (flip notElem " \r\n\t;") a) : tokens (dropWhile (flip notElem " \r\n\t;") a)++  string :: String -> (String, String)+  string a = case a of+    [] -> error "Ending string quote not found."+    '"'  : b     -> ("", b)+    '\\' : a : b -> (a : a', b') where (a', b') = string b+    a : b        -> (a : a', b') where (a', b') = string b++decomment :: String -> String+decomment = decomment' 0+  where+  decomment' :: Int -> String -> String+  decomment' n "" | n == 0    = ""+                  | otherwise = error "reached end of file without closing comment"+  decomment' n ('(':'*':a) = "  " ++ decomment' (n + 1) a+  decomment' n ('*':')':a) | n > 0  = "  " ++ decomment' (n - 1) a+                           | otherwise = error "unexpected closing comment"+  decomment' n (a:b) = (if n > 0 && a /= '\n' then ' ' else a) : decomment' n b++++-- Parsing.++parseRhapsody :: String -> Record+parseRhapsody a = case runParser (record `discard` eof) $ lexer a of+  (Left msg, remaining) -> error $ msg ++ "\nremaining tokens: " ++ show (take 30 $ remaining) ++ " ..."+  (Right a, []) -> a+  (Right _, remaining) -> error $ "parsed, but with remaining tokens: " ++ show remaining++type Rhap a = Parser Token a++tok :: Token -> Rhap ()+tok a = satisfy (== a) >> return ()++string :: Rhap String+string = do+  a <- satisfy (\ a -> case a of { String _ -> True; _ -> False })+  case a of+    String s -> return s+    _ -> undefined++record :: Rhap Record+record = do { tok BraceLeft; name <- string; fields <- many field; tok BraceRight; return $ Record name fields }++field :: Rhap Field+field = oneOf+  [ do { tok Dash; name <- string; tok Eq; v <- many string; tok SemiColon; return $ Value name v }+  , do { tok Dash; name <- string; tok Eq; r <- many record; return $ RecordNamed name r }+  , do { r <- record; return $ RecordAnon r }+  ]+
+ src/Statechart.hs view
@@ -0,0 +1,51 @@+module Main (main) where++import System.Environment++import Code+import Model+import Rhapsody++main :: IO ()+main = do+  args <- getArgs+  case parseArgs args of+    Nothing -> help+    Just (o, inc, sbs) -> readFile sbs >>= genCode o inc . parseModel . parseRhapsody++parseArgs :: [String] -> Maybe (String, [String], String)+parseArgs a = case a of+  [a] | head a /= '-' -> Just (takeWhile (/= '.') a ++ ".c", [], a)+  "-o" : file : rest -> do+    (_, inc, sbs) <- parseArgs rest+    Just (file, inc, sbs)+  "-i" : file : rest -> do+    (o, inc, sbs) <- parseArgs rest+    Just (o, file : inc, sbs)+  _ -> Nothing++help :: IO ()+help = putStrLn $ unlines+  [ ""+  , "NAME"+  , "  statechart - statechart code generation"+  , ""+  , "SYNOPSIS"+  , "  statechart [ -o <output-name> | { -i <header-file> } ] <rhapsody-package-file>"+  , ""+  , "DESCRIPTION"+  , "  Compiles Rhapsody statecharts to C.  Each Rhapsody class will generate a function"+  , "  that computes the next transition for each of its associated statecharts."+  , ""+  , "OPTIONS"+  , "  -o <name>"+  , "    Output name.  Creates both <name>.c and <name>.h."+  , ""+  , "  -i <file>"+  , "    Header file to include in the generated code."+  , ""+  , "LIMITATIONS"+  , "  TODO, enough to say, a bunch."+  , ""+  ]+
+ statechart.cabal view
@@ -0,0 +1,44 @@+name:    statechart+version: 0.0.0++category: Compiler++synopsis: Compiles Rhapsody statecharts to C.++description:+  TODO++author:     Tom Hawkins <tomahawkins@gmail.com>+maintainer: Tom Hawkins <tomahawkins@gmail.com>++license:      BSD3+license-file: LICENSE++homepage: http://tomahawkins.org++build-type:    Simple+cabal-version: >= 1.6++extra-source-files:++executable statechart+  hs-source-dirs: src++  main-is: Statechart.hs++  other-modules:+    Code,+    Model,+    Rhapsody++  build-depends:+    base       >= 4.0 && < 5.0,+    polyparse  >= 1.4++  ghc-options:  -W+  extensions:++source-repository head+  type:     git+  location: git://github.com/tomahawkins/statechart.git+