statechart-0.0.0: src/Code.hs

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

-}