Add type argument to Function

to store CFG and other data structures

src/CFG/Graph.hs

 {-# LANGUAGE DuplicateRecordFields #-}
 module CFG.Graph
        ( graphify
+       , cfg
        ) where
 
 import Data.Graph
 import Data.Text (Text)
+import Control.Comonad
+import Data.Maybe
 
 import CFG.Types
 
-graphify :: Function -> CFG
-graphify function = CFG g ver2node key2vert
+cfg :: Function () -> Function CFG
+cfg = extend graphify
+
+-- Function must have at least one block
+graphify :: Function () -> CFG
+graphify function = CFG g ver2node key2vert entry
   where (g, ver2node, key2vert) = graphFromEdges $ graphList function
+        entry = fromJust $ key2vert (blkName $ head $ funBlocks function)
 
-graphList :: Function -> [(Block, Text, [Text])]
+graphList :: Function () -> [(Block, Text, [Text])]
 graphList = map iter . funBlocks
   where iter b = (b, blkName (b :: Block), blkSuccessors b)

src/CFG/IR.hs

@@ -7,6 +7,7 @@ module CFG.IR
        , Decision
        , Instr(..)
        , flattenCFG
+       , compileToIR
        ) where
 
 import Data.Text (Text)
@@ -15,6 +16,9 @@ import Data.Array
 
 import CFG.Types
 
+compileToIR :: Function CFG -> Function [Instr]
+compileToIR = fmap flattenCFG
+
 -- | Identifier, used for labels and function names
 type Ident = Text
 
@@ -30,11 +34,10 @@ data Instr = Goto Ident
            deriving (Show, Eq)
 
 -- | Compile a CFG to a list of instructions
-flattenCFG :: Vertex -- ^ Start node
-           -> CFG
+flattenCFG :: CFG
            -> [Instr]
-flattenCFG startNode cfg =
-  Goto (vertexToIdent cfg startNode)
+flattenCFG cfg =
+  Goto (vertexToIdent cfg (cfgEntryVertex cfg))
   : concatMap (compileBlock cfg) (vertices $ cfgGraph cfg)
   -- TODO Better (unambiguous) name for the out label
   ++ [Label "out"]

src/CFG/Parser.hs

@@ -11,19 +11,20 @@ import qualified Data.Text as T
 
 import CFG.Types
 
-parseFile :: FilePath -> Text -> Either (ParseError Char Dec) [Function]
+parseFile :: FilePath -> Text -> Either (ParseError Char Dec) [Function ()]
 parseFile = parse file
 
-file :: Parser [Function]
+file :: Parser [Function ()]
 file = many function
 
-function :: Parser Function
+function :: Parser (Function ())
 function = do
   h <- functionHeader
   let k = kind (h :: FunctionHeader)
       n = name (h :: FunctionHeader)
       s = subtask (h :: FunctionHeader)
-  Function k n s <$> entry <*> many block
+      annotation = return ()
+  Function k n s <$> entry <*> many block <*> annotation
 
 data FunctionHeader = FunctionHeader
   { kind :: FunctionKind

src/CFG/Types.hs

+{-# LANGUAGE DeriveFunctor #-}
 module CFG.Types where
 
 import Data.Text (Text)
 import Data.Graph
+import Control.Comonad
 
-data Function = Function
+data Function a = Function
   { funKind :: FunctionKind
   , funName :: Text
   , funSubtask :: Text
   , funEntryNode :: Text
   , funBlocks :: [Block]
+  , funAnnotation :: a
   }
-  deriving (Show, Eq)
+  deriving (Show, Eq, Functor)
+
+instance Comonad Function where
+  extract = funAnnotation
+  extend f x = let newAnno = f x in x { funAnnotation = newAnno }
 
 data FunctionKind = KindFunction | KindSubtask
   deriving (Show, Eq)
@@ -29,6 +36,7 @@ data CFG = CFG
   { cfgGraph :: Graph
   , cfgGetBlock :: Vertex -> (Block, Text, [Text])
   , cfgGetVertex :: Text -> Maybe Vertex
+  , cfgEntryVertex :: Vertex
   }
 
 instance Show CFG where

stub-generator.cabal

@@ -24,6 +24,7 @@ library
                      , text >= 1.2 && <1.3
                      , containers >= 0.5 && <0.6
                      , array >= 0.5 && <0.6
+                     , comonad >= 5 && <6
   default-language:    Haskell2010
 
 executable stub
@@ -34,7 +35,7 @@ executable stub
   hs-source-dirs:      src/main
   default-language:    Haskell2010
 
-test-suite stub-generator-tests
+test-suite spec
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             TestDriver.hs

test/GraphTest.hs

@@ -10,22 +10,23 @@ import           Test.Tasty
 import           Test.Tasty.HUnit
 
 import           CFG.Graph
-import qualified CFG.Parser as P
+import           CFG.Types
 
 tests :: TestTree
 tests = testGroup "Graph" [example1]
 
-example1Input :: P.Function
-example1Input = P.Function
-  { P.kind = P.KindSubtask
-  , P.name = "Foo"
-  , P.subtask = "Foo"
-  , P.entryNode = "Two"
-  , P.blocks =
+example1Input :: Function ()
+example1Input = Function
+  { funKind = KindSubtask
+  , funName = "Foo"
+  , funSubtask = "Foo"
+  , funEntryNode = "Two"
+  , funBlocks =
     [ Block "Zero" [] Nothing
     , Block "One" ["Two", "Zero"] Nothing
     , Block "Two" ["One"] Nothing
     ]
+  , funAnnotation = ()
   }
 
 example1 :: TestTree
@@ -33,16 +34,16 @@ example1 = testCase "Example graph 1" $ do
   let cfg = graphify example1Input
       hasSuccs = hasSuccessors cfg
 
-  bounds (graph cfg) @?= (0, 2)
+  bounds (cfgGraph cfg) @?= (0, 2)
   "Zero" `hasSuccs` []
   "One" `hasSuccs` ["Two", "Zero"]
   "Two" `hasSuccs` ["One"]
 
 hasSuccessors :: CFG -> Text -> [Text] -> Assertion
 hasSuccessors cfg node succs =
-  let nodeVertex = getVertex cfg node
-      succVertices = map (getVertex cfg) succs
+  let nodeVertex = cfgGetVertex cfg node
+      succVertices = map (cfgGetVertex cfg) succs
   in do
     forM_ (zip (nodeVertex : succVertices) (node:succs)) $ \(vert, name) ->
       assertBool ("Vertex " ++ T.unpack name ++ "exists") (isJust vert)
-    (graph cfg ! fromJust nodeVertex) @?= map fromJust succVertices
+    (cfgGraph cfg ! fromJust nodeVertex) @?= map fromJust succVertices

test/IRTest.hs

@@ -12,23 +12,25 @@ import           Test.Tasty.HUnit
 import           CFG.Graph
 import           CFG.IR
 import qualified CFG.Parser as P
+import           CFG.Types
 
 tests :: TestTree
 tests = testGroup "IR"
   [ example1
   ]
 
-example1Input :: P.Function
-example1Input = P.Function
-  { P.kind = P.KindSubtask
-  , P.name = "Foo"
-  , P.subtask = "Foo"
-  , P.entryNode = "Two"
-  , P.blocks =
-    [ Block "Zero" [] Nothing
+example1Input :: Function ()
+example1Input = Function
+  { funKind = KindSubtask
+  , funName = "Foo"
+  , funSubtask = "Foo"
+  , funEntryNode = "Two"
+  , funBlocks =
+    [ Block "Two" ["One"] Nothing
+    , Block "Zero" [] Nothing
     , Block "One" ["Two", "Zero"] Nothing
-    , Block "Two" ["One"] Nothing
     ]
+  , funAnnotation = ()
   }
 
 example1Output :: CFG -> [Instr]
@@ -37,7 +39,7 @@ example1Output cfg = map snd $
   -- graphify. So we bring this in the right order by sorting on the
   -- vertex-number.
   sortBy (compare `on` fst)
-    [ ((-1), Goto "Two")
+    [ (-1, Goto "Two")
     , (vert "Zero", Label "Zero")
     , (vert "Zero", Goto "out")
     , (vert "One", Label "One")
@@ -48,9 +50,9 @@ example1Output cfg = map snd $
     ]
 
   where vert :: Text -> Vertex
-        vert = fromJust . getVertex cfg
+        vert = fromJust . cfgGetVertex cfg
 
 example1 :: TestTree
 example1 = testCase "Example 1" $ do
   let cfg = graphify example1Input
-  flattenCFG (fromJust $ getVertex cfg "Two") cfg @?= example1Output cfg
+  flattenCFG cfg @?= example1Output cfg

test/ParserTest.hs

@@ -8,6 +8,7 @@ import           Test.Tasty
 import           Test.Tasty.HUnit
 
 import           CFG.Parser
+import           CFG.Types
 
 tests :: TestTree
 tests = testGroup "Parser" [example1, example2, both]
@@ -24,18 +25,20 @@ example1Input = T.pack $ unlines
   , "  ->! OSEKOS_kickoff_1"
   ]
 
-example1Output :: [Function]
+example1Output :: [Function ()]
 example1Output = [
   Function
-    { kind = KindSubtask
-    , name = "Handler12"
-    , subtask = "Handler12"
-    , entryNode = "ABB40/kickoff"
-    , blocks =
+    { funKind = KindSubtask
+    , funName = "Handler12"
+    , funSubtask = "Handler12"
+    , funEntryNode = "ABB40/kickoff"
+    , funBlocks =
       [ Block "ABB37/TerminateTask" ["ABB38"] (Just $ SystemCall "OSEKOS_TerminateTask_BB134")
       , Block "ABB38" [] Nothing
       , Block "ABB39" ["ABB37/TerminateTask"] Nothing
-      , Block "ABB40/kickoff" ["ABB39"] (Just $ SystemCall "OSEKOS_kickoff_1")]
+      , Block "ABB40/kickoff" ["ABB39"] (Just $ SystemCall "OSEKOS_kickoff_1")
+      ]
+    , funAnnotation = ()
     }]
 
 example1 :: TestTree
@@ -67,14 +70,14 @@ example2Input = T.pack $ unlines
   , "   ABB33 [ABB21/TerminateTask]"
   ]
 
-example2Output :: [Function]
+example2Output :: [Function ()]
 example2Output = [
   Function
-    { kind = KindSubtask
-    , name = "Handler11"
-    , subtask = "Handler11"
-    , entryNode = "ABB24/kickoff"
-    , blocks =
+    { funKind = KindSubtask
+    , funName = "Handler11"
+    , funSubtask = "Handler11"
+    , funEntryNode = "ABB24/kickoff"
+    , funBlocks =
       [ Block "ABB9/ActivateTask" ["ABB10"] (Just $ SystemCall "OSEKOS_ActivateTask_BB118")
       , Block "ABB10" ["ABB31", "ABB32"] (Just $ FunctionCall "_Z14print_os_statei")
       , Block "ABB15/ActivateTask" ["ABB16"] (Just $ SystemCall "OSEKOS_ActivateTask_BB124")
@@ -89,6 +92,7 @@ example2Output = [
       , Block "ABB32" ["ABB17"] Nothing
       , Block "ABB33" ["ABB21/TerminateTask"] Nothing
       ]
+    , funAnnotation = ()
     }]
 
 example2 :: TestTree