statechart-0.1.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

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 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
  stateName :: Id -> Name
  stateName id = fromJust $ lookup id idsNames

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 ])

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 ]

codeTransition :: (Id -> Name) -> Transition -> String
codeTransition stateName t = printf "if (%s) " predicate ++ block (transition ++ action)
  where
  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 ]

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 ])