Changed the A.Structured type to be parameterised
This patch is actually an amalgam of multiple (already large) patches. Those patches conflicted (parameterised Structured vs. changes to usage checking and FlowGraph) and encountered a nasty bug in darcs 1 involving exponential time (see http://wiki.darcs.net/DarcsWiki/ConflictsFAQ for more details). Reasoning that half an hour (of 100% CPU use) was too long to apply patches, I opted to re-record the parameterised Structured changes as this new large patch. Here are the commit messages originally used for the patches (which, as mentioned, were already large patches): A gigantic patch switching all the non-test modules over to using parameterised A.Structured Changed the FlowGraph module again to handle any sort of Structured you want to pass to it (mainly for testing) A further gigantic patch changing all the tests to work with the new parameterised Structured Fixed a nasty bug involving functions being named incorrectly inside transformInputCase Added a hand-written instance of Data for Structured that allows us to use ext1M properly Fixed a few warnings in the code
This commit is contained in:
Neil Brown
parent
6c4e7ee713
commit
acd57d74de
16
GenOrdAST.hs
16
GenOrdAST.hs
|
|
@ -47,13 +47,13 @@ genHeader = [
|
|||
-- | Here's the idea for easily building a compare function. Go through in ascending order.
|
||||
-- Match A vs A in detail. For A vs _ give LT, and for _ vs A give GT. Then repeat for B, C, etc
|
||||
-- But for the last item, do not give the LT and GT matches!
|
||||
ordFor :: forall a. (Data a, Typeable a) => a -> [String]
|
||||
ordFor x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf x
|
||||
ordFor' :: forall a. (Data a, Typeable a) => String -> a -> [String]
|
||||
ordFor' typeName x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf x
|
||||
where
|
||||
process :: [(String, String, String, [String])] -> [String]
|
||||
process [] = []
|
||||
process items =
|
||||
["instance Ord " ++ (dataTypeName $ dataTypeOf x) ++ " where"]
|
||||
["instance Ord " ++ typeName ++ " where"]
|
||||
++ concat [ [ " compare (" ++ name ++ headL ++ ") (" ++ name ++ headR ++ ") = " ++
|
||||
--Shortcut:
|
||||
if null comparisons then "EQ" else
|
||||
|
|
@ -100,13 +100,21 @@ items = concat
|
|||
,ordFor (u :: A.Replicator)
|
||||
,ordFor (u :: A.Specification)
|
||||
,ordFor (u :: A.SpecType)
|
||||
,ordFor (u :: A.Structured)
|
||||
--TODO define a new function for doing a parameterised Ord
|
||||
,ordFor' "(AST.Structured AST.Process)" (u :: A.Structured A.Process)
|
||||
,ordFor' "(AST.Structured AST.Choice)" (u :: A.Structured A.Choice)
|
||||
,ordFor' "(AST.Structured AST.Option)" (u :: A.Structured A.Option)
|
||||
,ordFor' "(AST.Structured AST.Alternative)" (u :: A.Structured A.Alternative)
|
||||
,ordFor' "(AST.Structured AST.Variant)" (u :: A.Structured A.Variant)
|
||||
,ordFor' "(AST.Structured AST.ExpressionList)" (u :: A.Structured A.ExpressionList)
|
||||
,ordFor (u :: A.Subscript)
|
||||
,ordFor (u :: A.Type)
|
||||
,ordFor (u :: A.Variable)
|
||||
,ordFor (u :: A.Variant)
|
||||
]
|
||||
where
|
||||
ordFor x = ordFor' (dataTypeName $ dataTypeOf x) x
|
||||
|
||||
u = undefined
|
||||
|
||||
joinLines :: [String] -> String
|
||||
|
|
|
|||
64
GenTagAST.hs
64
GenTagAST.hs
|
|
@ -23,6 +23,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
module GenTagAST where
|
||||
|
||||
import Data.Generics
|
||||
import Data.List (intersperse)
|
||||
|
||||
import qualified AST as A
|
||||
|
||||
|
|
@ -36,7 +37,9 @@ genHeader = [
|
|||
,"module TagAST where"
|
||||
,"import Data.Generics"
|
||||
,""
|
||||
,"import qualified AST"
|
||||
,"import qualified AST as A"
|
||||
,"import qualified Metadata"
|
||||
,"import Pattern"
|
||||
,"import TreeUtils"
|
||||
-- Could probably auto-generate these, too:
|
||||
|
|
@ -47,6 +50,13 @@ genHeader = [
|
|||
,"type F4 = (Data a0, Data a1, Data a2, Data a3) => a0 -> a1 -> a2 -> a3 -> Pattern"
|
||||
,"type F5 = (Data a0, Data a1, Data a2, Data a3, Data a4) => a0 -> a1 -> a2 -> a3 -> a4 -> Pattern"
|
||||
,"type F6 = (Data a0, Data a1, Data a2, Data a3, Data a4, Data a5) => a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> Pattern"
|
||||
,"type F0' a = Pattern"
|
||||
,"type F1' a0 = a0 -> Pattern"
|
||||
,"type F2' a1 = (Data a0) => a0 -> a1 -> Pattern"
|
||||
,"type F3' a2 = (Data a0, Data a1) => a0 -> a1 -> a2 -> Pattern"
|
||||
,"type F4' a3 = (Data a0, Data a1, Data a2) => a0 -> a1 -> a2 -> a3 -> Pattern"
|
||||
,"type F5' a4 = (Data a0, Data a1, Data a2, Data a3) => a0 -> a1 -> a2 -> a3 -> a4 -> Pattern"
|
||||
,"type F6' a5 = (Data a0, Data a1, Data a2, Data a3, Data a4) => a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> Pattern"
|
||||
,""
|
||||
]
|
||||
|
||||
|
|
@ -60,6 +70,25 @@ genItem (num, name)
|
|||
n = show num
|
||||
mname = "m" ++ name
|
||||
|
||||
genItem' :: String -> String -> (Int, String, [String]) -> [String]
|
||||
genItem' suffix typeName (num, name, paramTypes)
|
||||
= [mname ++ "' :: F" ++ n ++ typeSuffix
|
||||
,mname ++ "' = tag" ++ n ++ " (A." ++ name ++ " :: " ++ params ++ ")"
|
||||
,mname ++ " :: F" ++ show (num - 1) ++ typeSuffix
|
||||
,mname ++ " = " ++ mname ++ "' DontCare"]
|
||||
where
|
||||
-- typeSuffix = "' (" ++ typeName ++ ")"
|
||||
typeSuffix = ""
|
||||
|
||||
params = concat $ intersperse " -> " $
|
||||
[case p of
|
||||
"AST.Structured" -> typeName
|
||||
"[AST.Structured]" -> "[" ++ typeName ++ "]"
|
||||
_ -> p | p <- paramTypes] ++ [typeName]
|
||||
|
||||
n = show num
|
||||
mname = "m" ++ name ++ suffix
|
||||
|
||||
consFor :: forall a. Data a => a -> [(Int, String)]
|
||||
consFor x = map consFor' (dataTypeConstrs $ dataTypeOf x)
|
||||
where
|
||||
|
|
@ -68,6 +97,26 @@ consFor x = map consFor' (dataTypeConstrs $ dataTypeOf x)
|
|||
consFor' :: Constr -> (Int, String)
|
||||
consFor' con = (length (gmapQ (const undefined) (fromConstr con :: a)), showConstr con)
|
||||
|
||||
consParamsFor :: forall a. Data a => a -> [(Int, String, [String])]
|
||||
consParamsFor x = map consParamsFor' (dataTypeConstrs $ dataTypeOf x)
|
||||
where
|
||||
-- The way I work out how many arguments a constructor takes is crazy, but
|
||||
-- I can't see a better way given the Data.Generics API
|
||||
consParamsFor' :: Constr -> (Int, String, [String])
|
||||
consParamsFor' con = (length cons, showConstr con, cons)
|
||||
where
|
||||
cons :: [String]
|
||||
cons = gmapQ showDataType (fromConstr con :: a)
|
||||
|
||||
-- Hack to handle various types:
|
||||
showDataType :: Data b => b -> String
|
||||
showDataType y = case n of
|
||||
"Prelude.[]" -> "[" ++ (dataTypeName $ dataTypeOf x) ++ "]"
|
||||
"Prelude.()" -> "()"
|
||||
_ -> n
|
||||
where
|
||||
n = dataTypeName $ dataTypeOf y
|
||||
|
||||
items :: [(Int, String)]
|
||||
items = concat
|
||||
[consFor (u :: A.Actual)
|
||||
|
|
@ -87,7 +136,6 @@ items = concat
|
|||
,consFor (u :: A.Replicator)
|
||||
,consFor (u :: A.Specification)
|
||||
,consFor (u :: A.SpecType)
|
||||
,consFor (u :: A.Structured)
|
||||
,consFor (u :: A.Subscript)
|
||||
,consFor (u :: A.Type)
|
||||
,consFor (u :: A.Variable)
|
||||
|
|
@ -96,6 +144,18 @@ items = concat
|
|||
where
|
||||
u = undefined
|
||||
|
||||
struct :: [String]
|
||||
struct = concat
|
||||
[concatMap (genItem' "P" "A.Structured A.Process") $ consParamsFor (undefined :: A.Structured A.Process)
|
||||
,concatMap (genItem' "O" "A.Structured A.Option") $ consParamsFor (undefined :: A.Structured A.Option)
|
||||
,concatMap (genItem' "C" "A.Structured A.Choice") $ consParamsFor (undefined :: A.Structured A.Choice)
|
||||
,concatMap (genItem' "V" "A.Structured A.Variant") $ consParamsFor (undefined :: A.Structured A.Variant)
|
||||
,concatMap (genItem' "A" "A.Structured A.Alternative") $ consParamsFor (undefined :: A.Structured A.Alternative)
|
||||
,concatMap (genItem' "EL" "A.Structured A.ExpressionList") $ consParamsFor (undefined :: A.Structured A.ExpressionList)
|
||||
,concatMap (genItem' "AST" "A.Structured ()") $ consParamsFor (undefined :: A.Structured ())
|
||||
]
|
||||
|
||||
|
||||
filterInvalid :: [(Int, a)] -> [(Int, a)]
|
||||
filterInvalid = filter (\(n,_) -> n > 0)
|
||||
|
||||
|
|
@ -103,4 +163,4 @@ joinLines :: [String] -> String
|
|||
joinLines xs = concat [x ++ "\n" | x <- xs]
|
||||
|
||||
main :: IO ()
|
||||
main = putStr $ joinLines $ genHeader ++ concatMap genItem (filterInvalid items)
|
||||
main = putStr $ joinLines $ genHeader ++ concatMap genItem (filterInvalid items) ++ struct
|
||||
|
|
|
|||
8
Main.hs
8
Main.hs
|
|
@ -261,10 +261,13 @@ compile mode fn outHandle
|
|||
do procs <- findAllProcesses
|
||||
let fs :: Data t => t -> PassM String
|
||||
fs = ((liftM $ (take 20) . (filter ((/=) '\"'))) . pshowCode)
|
||||
-- TODO fix this mode
|
||||
{-
|
||||
let labelFuncs = mkLabelFuncsGeneric fs
|
||||
graphs <- mapM
|
||||
((liftM $ either (const Nothing) Just) . (buildFlowGraph labelFuncs) )
|
||||
(map (A.OnlyP emptyMeta) (snd $ unzip $ procs))
|
||||
(map (A.Only emptyMeta) (snd $ unzip $ procs))
|
||||
|
||||
|
||||
-- We need this line to enforce the type of the mAlter monad (Identity)
|
||||
-- since it is never used. Then we used graphsTyped (rather than graphs)
|
||||
|
|
@ -273,7 +276,8 @@ compile mode fn outHandle
|
|||
let (graphsTyped :: [Maybe (FlowGraph Identity String)]) = map (transformMaybe fst) graphs
|
||||
--TODO output each process to a separate file, rather than just taking the first:
|
||||
return $ head $ map makeFlowGraphInstr (catMaybes graphsTyped)
|
||||
|
||||
-}
|
||||
return ""
|
||||
ModeCompile ->
|
||||
do progress "Passes:"
|
||||
|
||||
|
|
|
|||
|
|
@ -35,12 +35,12 @@ identifyParProcs = everywhereM (mkM doProcess)
|
|||
doProcess p@(A.Par _ _ s) = findProcs s >> return p
|
||||
doProcess p = return p
|
||||
|
||||
findProcs :: A.Structured -> PassM ()
|
||||
findProcs :: A.Structured A.Process -> PassM ()
|
||||
findProcs (A.Rep _ _ s) = findProcs s
|
||||
findProcs (A.Spec _ _ s) = findProcs s
|
||||
findProcs (A.ProcThen _ _ s) = findProcs s
|
||||
findProcs (A.Several _ ss) = sequence_ $ map findProcs ss
|
||||
findProcs (A.OnlyP _ (A.ProcCall _ n _))
|
||||
findProcs (A.Only _ (A.ProcCall _ n _))
|
||||
= modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
|
||||
|
||||
transformWaitFor :: Data t => t -> PassM t
|
||||
|
|
@ -51,20 +51,20 @@ transformWaitFor = everywhereM (mkM doAlt)
|
|||
= do (a',(specs,code)) <- runStateT (everywhereM (mkM doWaitFor) a) ([],[])
|
||||
if (null specs && null code)
|
||||
then return a
|
||||
else return $ A.Seq m $ foldr addSpec (A.Several m (code ++ [A.OnlyP m a'])) specs
|
||||
else return $ A.Seq m $ foldr addSpec (A.Several m (code ++ [A.Only m a'])) specs
|
||||
doAlt p = return p
|
||||
|
||||
addSpec :: (A.Structured -> A.Structured) -> A.Structured -> A.Structured
|
||||
addSpec :: Data a => (A.Structured a -> A.Structured a) -> A.Structured a -> A.Structured a
|
||||
addSpec spec inner = spec inner
|
||||
|
||||
doWaitFor :: A.Alternative -> StateT ([A.Structured -> A.Structured], [A.Structured]) PassM A.Alternative
|
||||
doWaitFor :: A.Alternative -> StateT ([A.Structured A.Process -> A.Structured A.Process], [A.Structured A.Process]) PassM A.Alternative
|
||||
doWaitFor a@(A.AlternativeWait m A.WaitFor e p)
|
||||
= do (specs, init) <- get
|
||||
id <- lift $ makeNonce "waitFor"
|
||||
let n = (A.Name m A.VariableName id)
|
||||
let var = A.Variable m n
|
||||
put (specs ++ [A.Spec m (A.Specification m n (A.Declaration m A.Time Nothing))],
|
||||
init ++ [A.OnlyP m $ A.GetTime m var, A.OnlyP m $ A.Assign m [var] $ A.ExpressionList m [A.Dyadic m A.Plus (A.ExprVariable m var) e]])
|
||||
init ++ [A.Only m $ A.GetTime m var, A.Only m $ A.Assign m [var] $ A.ExpressionList m [A.Dyadic m A.Plus (A.ExprVariable m var) e]])
|
||||
return $ A.AlternativeWait m A.WaitUntil (A.ExprVariable m var) p
|
||||
|
||||
doWaitFor a = return a
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ import Test.HUnit hiding (State)
|
|||
import qualified AST as A
|
||||
import BackendPasses
|
||||
import Pattern
|
||||
import TagAST
|
||||
import TestUtils
|
||||
import TreeUtils
|
||||
|
||||
|
|
@ -34,19 +35,19 @@ import TreeUtils
|
|||
testTransformWaitFor0 :: Test
|
||||
testTransformWaitFor0 = TestCase $ testPass "testTransformWaitFor0" orig (transformWaitFor orig) (return ())
|
||||
where
|
||||
orig = A.Alt m True $ A.OnlyA m $ A.AlternativeWait m A.WaitUntil (exprVariable "t") (A.Skip m)
|
||||
orig = A.Alt m True $ A.Only m $ A.AlternativeWait m A.WaitUntil (exprVariable "t") (A.Skip m)
|
||||
|
||||
-- | Test pulling out a single WaitFor:
|
||||
testTransformWaitFor1 :: Test
|
||||
testTransformWaitFor1 = TestCase $ testPass "testTransformWaitFor1" exp (transformWaitFor orig) (return ())
|
||||
where
|
||||
orig = A.Alt m True $ A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m)
|
||||
exp = tag2 A.Seq DontCare $ tag3 A.Spec DontCare (tag3 A.Specification DontCare varName $ A.Declaration m A.Time Nothing) $
|
||||
tag2 A.Several DontCare
|
||||
orig = A.Alt m True $ A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m)
|
||||
exp = tag2 A.Seq DontCare $ mSpecP (tag3 A.Specification DontCare varName $ A.Declaration m A.Time Nothing) $
|
||||
mSeveralP
|
||||
[
|
||||
tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar (exprVariablePattern "t")]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Alt DontCare True $ tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar (A.Skip m)
|
||||
mOnlyP $ tag2 A.GetTime DontCare var
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar (exprVariablePattern "t")]
|
||||
,mOnlyP $ tag3 A.Alt DontCare True $ mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar (A.Skip m)
|
||||
]
|
||||
varName = (tag3 A.Name DontCare A.VariableName $ Named "nowt" DontCare)
|
||||
var = tag2 A.Variable DontCare varName
|
||||
|
|
@ -56,19 +57,19 @@ testTransformWaitFor1 = TestCase $ testPass "testTransformWaitFor1" exp (transfo
|
|||
testTransformWaitFor2 :: Test
|
||||
testTransformWaitFor2 = TestCase $ testPass "testTransformWaitFor2" exp (transformWaitFor orig) (return ())
|
||||
where
|
||||
orig = A.Alt m True $ A.Several m [A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t0") (A.Skip m),
|
||||
A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t1") (A.Skip m)]
|
||||
exp = tag2 A.Seq DontCare $ tag3 A.Spec DontCare (tag3 A.Specification DontCare varName0 $ A.Declaration m A.Time Nothing) $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare varName1 $ A.Declaration m A.Time Nothing) $
|
||||
tag2 A.Several DontCare
|
||||
orig = A.Alt m True $ A.Several m [A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t0") (A.Skip m),
|
||||
A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t1") (A.Skip m)]
|
||||
exp = tag2 A.Seq DontCare $ mSpecP (tag3 A.Specification DontCare varName0 $ A.Declaration m A.Time Nothing) $
|
||||
mSpecP (tag3 A.Specification DontCare varName1 $ A.Declaration m A.Time Nothing) $
|
||||
mSeveralP
|
||||
[
|
||||
tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var0
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var0] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar0 (exprVariablePattern "t0")]
|
||||
,tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var1
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var1] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar1 (exprVariablePattern "t1")]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Alt DontCare True $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar0 (A.Skip m)
|
||||
,tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar1 (A.Skip m)]
|
||||
mOnlyP $ tag2 A.GetTime DontCare var0
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var0] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar0 (exprVariablePattern "t0")]
|
||||
,mOnlyP $ tag2 A.GetTime DontCare var1
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var1] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar1 (exprVariablePattern "t1")]
|
||||
,mOnlyP $ tag3 A.Alt DontCare True $ mSeveralA
|
||||
[mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar0 (A.Skip m)
|
||||
,mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar1 (A.Skip m)]
|
||||
]
|
||||
varName0 = (tag3 A.Name DontCare A.VariableName $ Named "nowt0" DontCare)
|
||||
var0 = tag2 A.Variable DontCare varName0
|
||||
|
|
@ -81,14 +82,14 @@ testTransformWaitFor2 = TestCase $ testPass "testTransformWaitFor2" exp (transfo
|
|||
testTransformWaitFor3 :: Test
|
||||
testTransformWaitFor3 = TestCase $ testPass "testTransformWaitFor3" exp (transformWaitFor orig) (return ())
|
||||
where
|
||||
orig = A.Alt m True $ A.OnlyA m $ A.AlternativeWait m A.WaitFor (A.Dyadic m A.Plus (exprVariable "t0") (exprVariable "t1")) (A.Skip m)
|
||||
exp = tag2 A.Seq DontCare $ tag3 A.Spec DontCare (tag3 A.Specification DontCare varName $ A.Declaration m A.Time Nothing) $
|
||||
tag2 A.Several DontCare
|
||||
orig = A.Alt m True $ A.Only m $ A.AlternativeWait m A.WaitFor (A.Dyadic m A.Plus (exprVariable "t0") (exprVariable "t1")) (A.Skip m)
|
||||
exp = tag2 A.Seq DontCare $ mSpecP (tag3 A.Specification DontCare varName $ A.Declaration m A.Time Nothing) $
|
||||
mSeveralP
|
||||
[
|
||||
tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar
|
||||
mOnlyP $ tag2 A.GetTime DontCare var
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar
|
||||
(A.Dyadic m A.Plus (exprVariable "t0") (exprVariable "t1"))]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Alt DontCare True $ tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar (A.Skip m)
|
||||
,mOnlyP $ tag3 A.Alt DontCare True $ mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar (A.Skip m)
|
||||
]
|
||||
varName = (tag3 A.Name DontCare A.VariableName $ Named "nowt" DontCare)
|
||||
var = tag2 A.Variable DontCare varName
|
||||
|
|
@ -98,14 +99,14 @@ testTransformWaitFor3 = TestCase $ testPass "testTransformWaitFor3" exp (transfo
|
|||
testTransformWaitFor4 :: Test
|
||||
testTransformWaitFor4 = TestCase $ testPass "testTransformWaitFor4" exp (transformWaitFor orig) (return ())
|
||||
where
|
||||
orig = A.Alt m True $ A.Several m [A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m)]
|
||||
exp = tag2 A.Seq DontCare $ tag3 A.Spec DontCare (tag3 A.Specification DontCare varName $ A.Declaration m A.Time Nothing) $
|
||||
tag2 A.Several DontCare
|
||||
orig = A.Alt m True $ A.Several m [A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m)]
|
||||
exp = tag2 A.Seq DontCare $ mSpecP (tag3 A.Specification DontCare varName $ A.Declaration m A.Time Nothing) $
|
||||
mSeveralP
|
||||
[
|
||||
tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar (exprVariablePattern "t")]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Alt DontCare True $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar (A.Skip m)]
|
||||
mOnlyP $ tag2 A.GetTime DontCare var
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar (exprVariablePattern "t")]
|
||||
,mOnlyP $ tag3 A.Alt DontCare True $ mSeveralA
|
||||
[mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar (A.Skip m)]
|
||||
]
|
||||
varName = (tag3 A.Name DontCare A.VariableName $ Named "nowt" DontCare)
|
||||
var = tag2 A.Variable DontCare varName
|
||||
|
|
@ -115,19 +116,19 @@ testTransformWaitFor4 = TestCase $ testPass "testTransformWaitFor4" exp (transfo
|
|||
testTransformWaitFor5 :: Test
|
||||
testTransformWaitFor5 = TestCase $ testPass "testTransformWaitFor5" exp (transformWaitFor orig) (return ())
|
||||
where
|
||||
orig = A.Alt m True $ A.Several m [A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m),
|
||||
A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m)]
|
||||
exp = tag2 A.Seq DontCare $ tag3 A.Spec DontCare (tag3 A.Specification DontCare varName0 $ A.Declaration m A.Time Nothing) $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare varName1 $ A.Declaration m A.Time Nothing) $
|
||||
tag2 A.Several DontCare
|
||||
orig = A.Alt m True $ A.Several m [A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m),
|
||||
A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t") (A.Skip m)]
|
||||
exp = tag2 A.Seq DontCare $ mSpecP (tag3 A.Specification DontCare varName0 $ A.Declaration m A.Time Nothing) $
|
||||
mSpecP (tag3 A.Specification DontCare varName1 $ A.Declaration m A.Time Nothing) $
|
||||
mSeveralP
|
||||
[
|
||||
tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var0
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var0] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar0 (exprVariablePattern "t")]
|
||||
,tag2 A.OnlyP DontCare $ tag2 A.GetTime DontCare var1
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Assign DontCare [var1] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar1 (exprVariablePattern "t")]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Alt DontCare True $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar0 (A.Skip m)
|
||||
,tag2 A.OnlyA DontCare $ tag4 A.AlternativeWait DontCare A.WaitUntil evar1 (A.Skip m)]
|
||||
mOnlyP $ tag2 A.GetTime DontCare var0
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var0] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar0 (exprVariablePattern "t")]
|
||||
,mOnlyP $ tag2 A.GetTime DontCare var1
|
||||
,mOnlyP $ tag3 A.Assign DontCare [var1] $ tag2 A.ExpressionList DontCare [tag4 A.Dyadic DontCare A.Plus evar1 (exprVariablePattern "t")]
|
||||
,mOnlyP $ tag3 A.Alt DontCare True $ mSeveralA
|
||||
[mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar0 (A.Skip m)
|
||||
,mOnlyA $ tag4 A.AlternativeWait DontCare A.WaitUntil evar1 (A.Skip m)]
|
||||
]
|
||||
varName0 = (tag3 A.Name DontCare A.VariableName $ Named "nowt0" DontCare)
|
||||
var0 = tag2 A.Variable DontCare varName0
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ data GenOps = GenOps {
|
|||
-- | Generates the list of actual parameters to a function\/proc.
|
||||
genActuals :: GenOps -> [A.Actual] -> CGen (),
|
||||
genAllocMobile :: GenOps -> Meta -> A.Type -> Maybe A.Expression -> CGen(),
|
||||
genAlt :: GenOps -> Bool -> A.Structured -> CGen (),
|
||||
genAlt :: GenOps -> Bool -> A.Structured A.Alternative -> CGen (),
|
||||
-- | Generates the given array element expressions as a flattened (one-dimensional) list of literals
|
||||
genArrayLiteralElems :: GenOps -> [A.ArrayElem] -> CGen (),
|
||||
-- | Declares a constant array for the sizes (dimensions) of a C array.
|
||||
|
|
@ -93,7 +93,7 @@ data GenOps = GenOps {
|
|||
-- wheter or not one free dimension is allowed (True <=> allowed).
|
||||
genBytesIn :: GenOps -> Meta -> A.Type -> Either Bool A.Variable -> CGen (),
|
||||
-- | Generates a case statement over the given expression with the structured as the body.
|
||||
genCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen (),
|
||||
genCase :: GenOps -> Meta -> A.Expression -> A.Structured A.Option -> CGen (),
|
||||
genCheckedConversion :: GenOps -> Meta -> A.Type -> A.Type -> CGen () -> CGen (),
|
||||
genClearMobile :: GenOps -> Meta -> A.Variable -> CGen (),
|
||||
genConversion :: GenOps -> Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen (),
|
||||
|
|
@ -115,7 +115,7 @@ data GenOps = GenOps {
|
|||
-- | Gets the current time into the given variable
|
||||
genGetTime :: GenOps -> Meta -> A.Variable -> CGen (),
|
||||
-- | Generates an IF statement (which can have replicators, specifications and such things inside it).
|
||||
genIf :: GenOps -> Meta -> A.Structured -> CGen (),
|
||||
genIf :: GenOps -> Meta -> A.Structured A.Choice -> CGen (),
|
||||
genInput :: GenOps -> A.Variable -> A.InputMode -> CGen (),
|
||||
genInputItem :: GenOps -> A.Variable -> A.InputItem -> CGen (),
|
||||
genIntrinsicFunction :: GenOps -> Meta -> String -> [A.Expression] -> CGen (),
|
||||
|
|
@ -133,7 +133,7 @@ data GenOps = GenOps {
|
|||
genOutputItem :: GenOps -> A.Variable -> A.OutputItem -> CGen (),
|
||||
-- | Generates a loop that maps over every element in a (potentially multi-dimensional) array
|
||||
genOverArray :: GenOps -> Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen (),
|
||||
genPar :: GenOps -> A.ParMode -> A.Structured -> CGen (),
|
||||
genPar :: GenOps -> A.ParMode -> A.Structured A.Process -> CGen (),
|
||||
genProcCall :: GenOps -> A.Name -> [A.Actual] -> CGen (),
|
||||
genProcess :: GenOps -> A.Process -> CGen (),
|
||||
-- | Generates a replicator loop, given the replicator and body
|
||||
|
|
@ -141,7 +141,7 @@ data GenOps = GenOps {
|
|||
-- | Generates the three bits of a for loop (e.g. "int i=0;i<10;i++" for the given replicator
|
||||
genReplicatorLoop :: GenOps -> A.Replicator -> CGen (),
|
||||
genRetypeSizes :: GenOps -> Meta -> A.Type -> A.Name -> A.Type -> A.Variable -> CGen (),
|
||||
genSeq :: GenOps -> A.Structured -> CGen (),
|
||||
genSeq :: GenOps -> A.Structured A.Process -> CGen (),
|
||||
genSimpleDyadic :: GenOps -> String -> A.Expression -> A.Expression -> CGen (),
|
||||
genSimpleMonadic :: GenOps -> String -> A.Expression -> CGen (),
|
||||
genSizeSuffix :: GenOps -> String -> CGen (),
|
||||
|
|
@ -150,11 +150,11 @@ data GenOps = GenOps {
|
|||
genSpecMode :: GenOps -> A.SpecMode -> CGen (),
|
||||
-- | Generates a STOP process that uses the given Meta tag and message as its printed message.
|
||||
genStop :: GenOps -> Meta -> String -> CGen (),
|
||||
genStructured :: GenOps -> A.Structured -> (A.Structured -> CGen ()) -> CGen (),
|
||||
genStructured :: forall a. Data a => GenOps -> A.Structured a -> (Meta -> a -> CGen ()) -> CGen (),
|
||||
genTLPChannel :: GenOps -> TLPChannel -> CGen (),
|
||||
genTimerRead :: GenOps -> A.Variable -> A.Variable -> CGen (),
|
||||
genTimerWait :: GenOps -> A.Expression -> CGen (),
|
||||
genTopLevel :: GenOps -> A.Structured -> CGen (),
|
||||
genTopLevel :: GenOps -> A.AST -> CGen (),
|
||||
-- | Generates the type as it might be used in a cast expression
|
||||
genType :: GenOps -> A.Type -> CGen (),
|
||||
genTypeSymbol :: GenOps -> String -> A.Type -> CGen (),
|
||||
|
|
@ -263,12 +263,12 @@ cgenOps = GenOps {
|
|||
--}}}
|
||||
|
||||
--{{{ top-level
|
||||
generate :: GenOps -> A.Structured -> PassM String
|
||||
generate :: GenOps -> A.AST -> PassM String
|
||||
generate ops ast
|
||||
= do (a, out) <- runWriterT (call genTopLevel ops ast)
|
||||
return $ concat out
|
||||
|
||||
generateC :: A.Structured -> PassM String
|
||||
generateC :: A.AST -> PassM String
|
||||
generateC = generate cgenOps
|
||||
|
||||
cgenTLPChannel :: GenOps -> TLPChannel -> CGen ()
|
||||
|
|
@ -276,14 +276,14 @@ cgenTLPChannel _ TLPIn = tell ["in"]
|
|||
cgenTLPChannel _ TLPOut = tell ["out"]
|
||||
cgenTLPChannel _ TLPError = tell ["err"]
|
||||
|
||||
cgenTopLevel :: GenOps -> A.Structured -> CGen ()
|
||||
cgenTopLevel :: GenOps -> A.AST -> CGen ()
|
||||
cgenTopLevel ops s
|
||||
= do tell ["#include <tock_support.h>\n"]
|
||||
cs <- get
|
||||
tell ["extern int " ++ nameString n ++ "_stack_size;\n"
|
||||
| n <- Set.toList $ csParProcs cs]
|
||||
sequence_ $ map (call genForwardDeclaration ops) (listify (const True :: A.Specification -> Bool) s)
|
||||
call genStructured ops s (\s -> tell ["\n#error Invalid top-level item: ",show s])
|
||||
call genStructured ops s (\m _ -> tell ["\n#error Invalid top-level item: ", show m])
|
||||
(name, chans) <- tlpInterface
|
||||
tell ["void tock_main (Process *me, Channel *in, Channel *out, Channel *err) {\n"]
|
||||
genName name
|
||||
|
|
@ -347,12 +347,12 @@ cgenOverArray ops m var func
|
|||
Nothing -> return ()
|
||||
|
||||
-- | Generate code for one of the Structured types.
|
||||
cgenStructured :: GenOps -> A.Structured -> (A.Structured -> CGen ()) -> CGen ()
|
||||
cgenStructured :: Data a => GenOps -> A.Structured a -> (Meta -> a -> CGen ()) -> CGen ()
|
||||
cgenStructured ops (A.Rep _ rep s) def = call genReplicator ops rep (call genStructured ops s def)
|
||||
cgenStructured ops (A.Spec _ spec s) def = call genSpec ops spec (call genStructured ops s def)
|
||||
cgenStructured ops (A.ProcThen _ p s) def = call genProcess ops p >> call genStructured ops s def
|
||||
cgenStructured ops (A.Several _ ss) def = sequence_ [call genStructured ops s def | s <- ss]
|
||||
cgenStructured _ s def = def s
|
||||
cgenStructured ops (A.Only m s) def = def m s
|
||||
|
||||
--}}}
|
||||
|
||||
|
|
@ -1618,13 +1618,13 @@ cgenStop ops m s
|
|||
tell [",\"", s, "\");"]
|
||||
--}}}
|
||||
--{{{ seq
|
||||
cgenSeq :: GenOps -> A.Structured -> CGen ()
|
||||
cgenSeq :: GenOps -> A.Structured A.Process -> CGen ()
|
||||
cgenSeq ops s = call genStructured ops s doP
|
||||
where
|
||||
doP (A.OnlyP _ p) = call genProcess ops p
|
||||
doP _ p = call genProcess ops p
|
||||
--}}}
|
||||
--{{{ if
|
||||
cgenIf :: GenOps -> Meta -> A.Structured -> CGen ()
|
||||
cgenIf :: GenOps -> Meta -> A.Structured A.Choice -> CGen ()
|
||||
cgenIf ops m s
|
||||
= do label <- makeNonce "if_end"
|
||||
tell ["/*",label,"*/"]
|
||||
|
|
@ -1632,10 +1632,10 @@ cgenIf ops m s
|
|||
call genStop ops m "no choice matched in IF process"
|
||||
tell [label, ":;"]
|
||||
where
|
||||
genIfBody :: String -> A.Structured -> CGen ()
|
||||
genIfBody :: String -> A.Structured A.Choice -> CGen ()
|
||||
genIfBody label s = call genStructured ops s doC
|
||||
where
|
||||
doC (A.OnlyC m (A.Choice m' e p))
|
||||
doC m (A.Choice m' e p)
|
||||
= do tell ["if("]
|
||||
call genExpression ops e
|
||||
tell ["){"]
|
||||
|
|
@ -1644,7 +1644,7 @@ cgenIf ops m s
|
|||
tell ["}"]
|
||||
--}}}
|
||||
--{{{ case
|
||||
cgenCase :: GenOps -> Meta -> A.Expression -> A.Structured -> CGen ()
|
||||
cgenCase :: GenOps -> Meta -> A.Expression -> A.Structured A.Option -> CGen ()
|
||||
cgenCase ops m e s
|
||||
= do tell ["switch("]
|
||||
call genExpression ops e
|
||||
|
|
@ -1655,17 +1655,17 @@ cgenCase ops m e s
|
|||
call genStop ops m "no option matched in CASE process"
|
||||
tell ["}"]
|
||||
where
|
||||
genCaseBody :: CGen () -> A.Structured -> CGen Bool
|
||||
genCaseBody :: CGen () -> A.Structured A.Option -> CGen Bool
|
||||
genCaseBody coll (A.Spec _ spec s)
|
||||
= genCaseBody (call genSpec ops spec coll) s
|
||||
genCaseBody coll (A.OnlyO _ (A.Option _ es p))
|
||||
genCaseBody coll (A.Only _ (A.Option _ es p))
|
||||
= do sequence_ [tell ["case "] >> call genExpression ops e >> tell [":"] | e <- es]
|
||||
tell ["{"]
|
||||
coll
|
||||
call genProcess ops p
|
||||
tell ["}break;"]
|
||||
return False
|
||||
genCaseBody coll (A.OnlyO _ (A.Else _ p))
|
||||
genCaseBody coll (A.Only _ (A.Else _ p))
|
||||
= do tell ["default:"]
|
||||
tell ["{"]
|
||||
coll
|
||||
|
|
@ -1686,7 +1686,7 @@ cgenWhile ops e p
|
|||
tell ["}"]
|
||||
--}}}
|
||||
--{{{ par
|
||||
cgenPar :: GenOps -> A.ParMode -> A.Structured -> CGen ()
|
||||
cgenPar :: GenOps -> A.ParMode -> A.Structured A.Process -> CGen ()
|
||||
cgenPar ops pm s
|
||||
= do (size, _, _) <- constantFold $ addOne (sizeOfStructured s)
|
||||
pids <- makeNonce "pids"
|
||||
|
|
@ -1711,13 +1711,13 @@ cgenPar ops pm s
|
|||
tell [index, " = 0;\n"]
|
||||
call genStructured ops s (freeP pids index)
|
||||
where
|
||||
createP pids pris index (A.OnlyP _ p)
|
||||
createP pids pris index _ p
|
||||
= do when (pm == A.PriPar) $
|
||||
tell [pris, "[", index, "] = ", index, ";\n"]
|
||||
tell [pids, "[", index, "++] = "]
|
||||
genProcAlloc p
|
||||
tell [";\n"]
|
||||
freeP pids index (A.OnlyP _ _)
|
||||
freeP pids index _ _
|
||||
= do tell ["ProcAllocClean (", pids, "[", index, "++]);\n"]
|
||||
|
||||
genProcAlloc :: A.Process -> CGen ()
|
||||
|
|
@ -1731,7 +1731,7 @@ cgenPar ops pm s
|
|||
genProcAlloc p = call genMissing ops $ "genProcAlloc " ++ show p
|
||||
--}}}
|
||||
--{{{ alt
|
||||
cgenAlt :: GenOps -> Bool -> A.Structured -> CGen ()
|
||||
cgenAlt :: GenOps -> Bool -> A.Structured A.Alternative -> CGen ()
|
||||
cgenAlt ops isPri s
|
||||
= do tell ["AltStart ();\n"]
|
||||
tell ["{\n"]
|
||||
|
|
@ -1753,10 +1753,10 @@ cgenAlt ops isPri s
|
|||
tell ["}\n"]
|
||||
tell [label, ":\n;\n"]
|
||||
where
|
||||
genAltEnable :: A.Structured -> CGen ()
|
||||
genAltEnable :: A.Structured A.Alternative -> CGen ()
|
||||
genAltEnable s = call genStructured ops s doA
|
||||
where
|
||||
doA (A.OnlyA _ alt)
|
||||
doA _ alt
|
||||
= case alt of
|
||||
A.Alternative _ c im _ -> doIn c im
|
||||
A.AlternativeCond _ e c im _ -> withIf ops e $ doIn c im
|
||||
|
|
@ -1779,10 +1779,10 @@ cgenAlt ops isPri s
|
|||
call genVariable ops c
|
||||
tell [");\n"]
|
||||
|
||||
genAltDisable :: String -> A.Structured -> CGen ()
|
||||
genAltDisable :: String -> A.Structured A.Alternative -> CGen ()
|
||||
genAltDisable id s = call genStructured ops s doA
|
||||
where
|
||||
doA (A.OnlyA _ alt)
|
||||
doA _ alt
|
||||
= case alt of
|
||||
A.Alternative _ c im _ -> doIn c im
|
||||
A.AlternativeCond _ e c im _ -> withIf ops e $ doIn c im
|
||||
|
|
@ -1803,10 +1803,10 @@ cgenAlt ops isPri s
|
|||
call genVariable ops c
|
||||
tell [");\n"]
|
||||
|
||||
genAltProcesses :: String -> String -> String -> A.Structured -> CGen ()
|
||||
genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen ()
|
||||
genAltProcesses id fired label s = call genStructured ops s doA
|
||||
where
|
||||
doA (A.OnlyA _ alt)
|
||||
doA _ alt
|
||||
= case alt of
|
||||
A.Alternative _ c im p -> doIn c im p
|
||||
A.AlternativeCond _ e c im p -> withIf ops e $ doIn c im p
|
||||
|
|
|
|||
|
|
@ -158,16 +158,16 @@ chansToAny x = do st <- get
|
|||
|
||||
--{{{ top-level
|
||||
-- | Transforms the given AST into a pass that generates C++ code.
|
||||
generateCPPCSP :: A.Structured -> PassM String
|
||||
generateCPPCSP :: A.AST -> PassM String
|
||||
generateCPPCSP = generate cppgenOps
|
||||
|
||||
-- | Generates the top-level code for an AST.
|
||||
cppgenTopLevel :: GenOps -> A.Structured -> CGen ()
|
||||
cppgenTopLevel :: GenOps -> A.AST -> CGen ()
|
||||
cppgenTopLevel ops s
|
||||
= do tell ["#include <tock_support_cppcsp.h>\n"]
|
||||
--In future, these declarations could be moved to a header file:
|
||||
sequence_ $ map (call genForwardDeclaration ops) (listify (const True :: A.Specification -> Bool) s)
|
||||
call genStructured ops s (\s -> tell ["\n#error Invalid top-level item: ",show s])
|
||||
call genStructured ops s (\m _ -> tell ["\n#error Invalid top-level item: ",show m])
|
||||
(name, chans) <- tlpInterface
|
||||
tell ["int main (int argc, char** argv) { csp::Start_CPPCSP();"]
|
||||
(chanType,writer) <-
|
||||
|
|
@ -409,16 +409,16 @@ cppgenOutputCase ops c tag ois
|
|||
|
||||
-- | We use the process wrappers here, in order to execute the functions in parallel.
|
||||
--We use forking instead of Run\/InParallelOneThread, because it is easier to use forking with replication.
|
||||
cppgenPar :: GenOps -> A.ParMode -> A.Structured -> CGen ()
|
||||
cppgenPar :: GenOps -> A.ParMode -> A.Structured A.Process -> CGen ()
|
||||
cppgenPar ops _ s
|
||||
= do forking <- makeNonce "forking"
|
||||
tell ["{ csp::ScopedForking ",forking," ; "]
|
||||
call genStructured ops s (genPar' forking)
|
||||
tell [" }"]
|
||||
where
|
||||
genPar' :: String -> A.Structured -> CGen ()
|
||||
genPar' forking (A.OnlyP _ p)
|
||||
= case p of
|
||||
genPar' :: String -> Meta -> A.Process -> CGen ()
|
||||
genPar' forking _ p
|
||||
= case p of
|
||||
A.ProcCall _ n as ->
|
||||
do tell [forking," .forkInThisThread(new proc_"]
|
||||
genName n
|
||||
|
|
@ -430,7 +430,7 @@ cppgenPar ops _ s
|
|||
|
||||
|
||||
-- | Changed to use C++CSP's Alternative class:
|
||||
cppgenAlt :: GenOps -> Bool -> A.Structured -> CGen ()
|
||||
cppgenAlt :: GenOps -> Bool -> A.Structured A.Alternative -> CGen ()
|
||||
cppgenAlt ops _ s
|
||||
= do guards <- makeNonce "alt_guards"
|
||||
tell ["std::list< csp::Guard* > ", guards, " ; "]
|
||||
|
|
@ -449,10 +449,10 @@ cppgenAlt ops _ s
|
|||
tell [label, ":\n;\n"]
|
||||
where
|
||||
--This function is like the enable function in GenerateC, but this one merely builds a list of guards. It does not do anything other than add to the guard list
|
||||
initAltGuards :: String -> A.Structured -> CGen ()
|
||||
initAltGuards :: String -> A.Structured A.Alternative -> CGen ()
|
||||
initAltGuards guardList s = call genStructured ops s doA
|
||||
where
|
||||
doA (A.OnlyA _ alt)
|
||||
doA _ alt
|
||||
= case alt of
|
||||
A.Alternative _ c im _ -> doIn c im
|
||||
A.AlternativeCond _ e c im _ -> withIf ops e $ doIn c im
|
||||
|
|
@ -475,10 +475,10 @@ cppgenAlt ops _ s
|
|||
|
||||
-- This is the same as GenerateC for now -- but it's not really reusable
|
||||
-- because it's so closely tied to how ALT is implemented in the backend.
|
||||
genAltProcesses :: String -> String -> String -> A.Structured -> CGen ()
|
||||
genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen ()
|
||||
genAltProcesses id fired label s = call genStructured ops s doA
|
||||
where
|
||||
doA (A.OnlyA _ alt)
|
||||
doA _ alt
|
||||
= case alt of
|
||||
A.Alternative _ c im p -> doIn c im p
|
||||
A.AlternativeCond _ e c im p -> withIf ops e $ doIn c im p
|
||||
|
|
@ -1047,7 +1047,7 @@ cppgenUnfoldedVariable ops m var
|
|||
--{{{ if
|
||||
-- | Changed to throw a nonce-exception class instead of the goto, because C++ doesn't allow gotos to cross class initialisations (such as arrays)
|
||||
|
||||
cppgenIf :: GenOps -> Meta -> A.Structured -> CGen ()
|
||||
cppgenIf :: GenOps -> Meta -> A.Structured A.Choice -> CGen ()
|
||||
cppgenIf ops m s
|
||||
= do ifExc <- makeNonce "if_exc"
|
||||
tell ["class ",ifExc, "{};try{"]
|
||||
|
|
@ -1055,10 +1055,10 @@ cppgenIf ops m s
|
|||
call genStop ops m "no choice matched in IF process"
|
||||
tell ["}catch(",ifExc,"){}"]
|
||||
where
|
||||
genIfBody :: String -> A.Structured -> CGen ()
|
||||
genIfBody :: String -> A.Structured A.Choice -> CGen ()
|
||||
genIfBody ifExc s = call genStructured ops s doC
|
||||
where
|
||||
doC (A.OnlyC m (A.Choice m' e p))
|
||||
doC m (A.Choice m' e p)
|
||||
= do tell ["if("]
|
||||
call genExpression ops e
|
||||
tell ["){"]
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ module GenerateCTest (tests) where
|
|||
import Control.Monad.Error
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import Data.Generics
|
||||
import Data.List (isInfixOf, intersperse)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Test.HUnit hiding (State)
|
||||
|
|
@ -833,21 +834,22 @@ testCase :: Test
|
|||
testCase = TestList
|
||||
[
|
||||
testBothSame "testCase 0" "switch($){default:^}" ((tcall3 genCase emptyMeta e (A.Several emptyMeta [])) . over)
|
||||
,testBothSame "testCase 1" "switch($){default:{@}break;}" ((tcall3 genCase emptyMeta e (A.OnlyO emptyMeta $ A.Else emptyMeta p)) . over)
|
||||
,testBothSame "testCase 2" "switch($){default:{#@}break;}" ((tcall3 genCase emptyMeta e (spec $ A.OnlyO emptyMeta $ A.Else emptyMeta p)) . over)
|
||||
,testBothSame "testCase 1" "switch($){default:{@}break;}" ((tcall3 genCase emptyMeta e (A.Only emptyMeta $ A.Else emptyMeta p)) . over)
|
||||
,testBothSame "testCase 2" "switch($){default:{#@}break;}" ((tcall3 genCase emptyMeta e (spec $ A.Only emptyMeta $ A.Else emptyMeta p)) . over)
|
||||
|
||||
,testBothSame "testCase 10" "switch($){case $:{@}break;default:^}" ((tcall3 genCase emptyMeta e (A.OnlyO emptyMeta $ A.Option emptyMeta [intLiteral 0] p)) . over)
|
||||
,testBothSame "testCase 10" "switch($){case $:{@}break;default:^}" ((tcall3 genCase emptyMeta e (A.Only emptyMeta $ A.Option emptyMeta [intLiteral 0] p)) . over)
|
||||
|
||||
,testBothSame "testCase 20" "switch($){case $:case $:{#@}break;default:{@}break;case $:{@}break;}" ((tcall3 genCase emptyMeta e $ A.Several emptyMeta
|
||||
[spec $ A.OnlyO emptyMeta $ A.Option emptyMeta [e, e] p
|
||||
,A.OnlyO emptyMeta $ A.Else emptyMeta p
|
||||
,A.OnlyO emptyMeta $ A.Option emptyMeta [e] p]
|
||||
[spec $ A.Only emptyMeta $ A.Option emptyMeta [e, e] p
|
||||
,A.Only emptyMeta $ A.Else emptyMeta p
|
||||
,A.Only emptyMeta $ A.Option emptyMeta [e] p]
|
||||
) . over)
|
||||
]
|
||||
where
|
||||
--The expression and process won't be used so we can use what we like:
|
||||
e = A.True emptyMeta
|
||||
p = A.Skip emptyMeta
|
||||
spec :: Data a => A.Structured a -> A.Structured a
|
||||
spec = A.Spec emptyMeta undefined
|
||||
over ops = ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash}
|
||||
|
||||
|
|
@ -872,7 +874,7 @@ testIf = TestList
|
|||
((tcall2 genIf emptyMeta (A.Several emptyMeta [])) . over)
|
||||
,testBothR "testIf 1" "/\\*([[:alnum:]_]+)\\*/if\\(\\$\\)\\{@goto \\1;\\}\\^\\1:;"
|
||||
"class ([[:alnum:]_]+)\\{\\};try\\{if\\(\\$\\)\\{@throw \\1\\(\\);\\}\\^\\}catch\\(\\1\\)\\{\\}"
|
||||
((tcall2 genIf emptyMeta (A.OnlyC emptyMeta $ A.Choice emptyMeta e p)) . over)
|
||||
((tcall2 genIf emptyMeta (A.Only emptyMeta $ A.Choice emptyMeta e p)) . over)
|
||||
]
|
||||
where
|
||||
e :: A.Expression
|
||||
|
|
|
|||
|
|
@ -31,7 +31,6 @@ import CompState
|
|||
import Errors
|
||||
import Metadata
|
||||
import Omega
|
||||
import Pass
|
||||
import ShowCode
|
||||
import Types
|
||||
import UsageCheckUtils
|
||||
|
|
@ -98,7 +97,11 @@ checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $
|
|||
cx <- showCode lx
|
||||
cy <- showCode ly
|
||||
prob <- formatProblem varMapping problem
|
||||
debug $ "Found solution for problem: " ++ prob
|
||||
-- debug $ "Found solution for problem: " ++ prob
|
||||
-- liftIO $ putStrLn $ "Succeeded on problem: " ++ prob
|
||||
-- allProbs <- concatMapM (\(_,_,p) -> formatProblem varMapping p >>* (++ "\n#\n")) problems
|
||||
-- svm <- mapM showFlattenedExp $ Map.keys varMapping
|
||||
-- liftIO $ putStrLn $ "All problems: " ++ allProbs ++ "\n" ++ (concat $ intersperse " ; " $ svm)
|
||||
dieP m $ "Indexes of array \"" ++ userArrName ++ "\" "
|
||||
++ "(\"" ++ cx ++ "\" and \"" ++ cy ++ "\") could overlap"
|
||||
++ if sol /= "" then " when: " ++ sol else ""
|
||||
|
|
@ -149,7 +152,7 @@ checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $
|
|||
showFlattenedExp :: FlattenedExp -> m String
|
||||
showFlattenedExp (Const n) = return $ show n
|
||||
showFlattenedExp (Scale n ((A.Variable _ vn),vi))
|
||||
= do vn' <- getRealName vn >>* (++ replicate vi '\'')
|
||||
= do vn' <- getRealName vn >>* (++ replicate vi '@')
|
||||
case n of
|
||||
1 -> return vn'
|
||||
-1 -> return $ "-" ++ vn'
|
||||
|
|
@ -175,8 +178,6 @@ data FlattenedExp
|
|||
| Modulo (Set.Set FlattenedExp) (Set.Set FlattenedExp)
|
||||
| Divide (Set.Set FlattenedExp) (Set.Set FlattenedExp)
|
||||
|
||||
--TODO change the A.Variable to Var, and automatically derive Eq and Ord
|
||||
|
||||
instance Eq FlattenedExp where
|
||||
a == b = EQ == compare a b
|
||||
|
||||
|
|
|
|||
|
|
@ -162,11 +162,11 @@ checkInitVar m graph startNode
|
|||
|
||||
-- Gets all variables read-from in a particular node, and the node identifier
|
||||
readNode :: (Node, FNode m UsageLabel) -> (Node, ExSet Var)
|
||||
readNode (n, Node (_,ul,_)) = (n,NormalSet $ readVars $ nodeVars ul)
|
||||
readNode (n, nd) = (n,NormalSet $ readVars $ nodeVars $ getNodeData nd)
|
||||
|
||||
-- Gets all variables written-to in a particular node
|
||||
writeNode :: FNode m UsageLabel -> ExSet Var
|
||||
writeNode (Node (_,ul,_)) = NormalSet $ writtenVars $ nodeVars ul
|
||||
writeNode nd = NormalSet $ writtenVars $ nodeVars $ getNodeData nd
|
||||
|
||||
-- Nothing is treated as if were the set of all possible variables:
|
||||
nodeFunction :: (Node, EdgeLabel) -> ExSet Var -> Maybe (ExSet Var) -> ExSet Var
|
||||
|
|
@ -185,7 +185,7 @@ checkInitVar m graph startNode
|
|||
|
||||
getMeta :: Node -> Meta
|
||||
getMeta n = case lab graph n of
|
||||
Just (Node (m,_,_)) -> m
|
||||
Just nd -> getNodeMeta nd
|
||||
_ -> emptyMeta
|
||||
|
||||
checkInitVar' :: Map.Map Node (ExSet Var) -> (Node, ExSet Var) -> m ()
|
||||
|
|
|
|||
|
|
@ -143,11 +143,11 @@ testParUsageCheck = TestList (map doTest tests)
|
|||
buildTestFlowGraph :: [(Int, [Var], [Var])] -> [(Int, Int, EdgeLabel)] -> Int -> Int -> String -> FlowGraph Identity UsageLabel
|
||||
buildTestFlowGraph ns es start end v
|
||||
= mkGraph
|
||||
([(-1,Node (emptyMeta,Usage Nothing (Just $ ScopeIn False v) emptyVars, undefined)),(-2,Node (emptyMeta,Usage Nothing (Just $ ScopeOut v) emptyVars, undefined))] ++ (map transNode ns))
|
||||
([(-1,makeTestNode emptyMeta $ Usage Nothing (Just $ ScopeIn False v) emptyVars),(-2,makeTestNode emptyMeta $ Usage Nothing (Just $ ScopeOut v) emptyVars)] ++ (map transNode ns))
|
||||
([(-1,start,ESeq),(end,-2,ESeq)] ++ es)
|
||||
where
|
||||
transNode :: (Int, [Var], [Var]) -> (Int, FNode Identity UsageLabel)
|
||||
transNode (n,r,w) = (n,Node (emptyMeta, (Usage Nothing Nothing $ vars r w []), undefined))
|
||||
transNode (n,r,w) = (n,makeTestNode emptyMeta (Usage Nothing Nothing $ vars r w []))
|
||||
|
||||
|
||||
testInitVar :: Test
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ checkPar getRep f g = mapM f =<< allParItems
|
|||
prevR :: Maybe (Maybe A.Replicator)
|
||||
prevR = liftM fst $ Map.lookup n mp
|
||||
r :: Maybe (Maybe A.Replicator)
|
||||
r = lab g s >>* (getRep . (\(Node (_,l,_)) -> l))
|
||||
r = lab g s >>* (getRep . getNodeData)
|
||||
|
||||
tagStartParEdge :: (Node,Node,EdgeLabel) -> Maybe (Node,Node,Int)
|
||||
tagStartParEdge (s,e,EStartPar n) = Just (s,e,n)
|
||||
|
|
@ -71,7 +71,7 @@ checkPar getRep f g = mapM f =<< allParItems
|
|||
[] -> fail "No edges in list of PAR edges"
|
||||
[n] -> case lab g n of
|
||||
Nothing -> fail "Label not found for node at start of PAR"
|
||||
Just (Node (m,_,_)) -> return m
|
||||
Just nd -> return $ getNodeMeta nd
|
||||
_ -> fail "PAR edges did not all start at the same node"
|
||||
where
|
||||
distinctItems = nub $ map fst ns
|
||||
|
|
@ -118,7 +118,7 @@ checkPar getRep f g = mapM f =<< allParItems
|
|||
(Nothing, g') -> customDFS vs g'
|
||||
|
||||
labelItem :: Context (FNode m a) EdgeLabel -> a
|
||||
labelItem c = let (Node (_,x,_)) = lab' c in x
|
||||
labelItem = getNodeData . lab'
|
||||
|
||||
customSucc :: Context (FNode m a) EdgeLabel -> [Node]
|
||||
customSucc c = [n | (n,e) <- lsuc' c, e /= endEdge]
|
||||
|
|
@ -144,10 +144,10 @@ findReachDef graph startNode
|
|||
readInNode' n v _ = readInNode v (lab graph n)
|
||||
|
||||
readInNode :: Var -> Maybe (FNode m UsageLabel) -> Bool
|
||||
readInNode v (Just (Node (_,ul,_))) = (Set.member v . readVars . nodeVars) ul
|
||||
readInNode v (Just nd) = (Set.member v . readVars . nodeVars) (getNodeData nd)
|
||||
|
||||
writeNode :: FNode m UsageLabel -> Set.Set Var
|
||||
writeNode (Node (_,ul,_)) = writtenVars $ nodeVars ul
|
||||
writeNode nd = writtenVars $ nodeVars $ getNodeData nd
|
||||
|
||||
-- | A confusiing function used by processNode. It takes a node and node label, and uses
|
||||
-- these to form a multi-map modifier function that replaces all node-sources for variables
|
||||
|
|
|
|||
|
|
@ -368,25 +368,60 @@ data Variant = Variant Meta Name [InputItem] Process
|
|||
-- | This represents something that can contain local replicators and specifications.
|
||||
-- (This ought to be a parametric type, @Structured Variant@ etc., but doing so
|
||||
-- makes using generic functions across it hard.)
|
||||
data Structured =
|
||||
Rep Meta Replicator Structured
|
||||
| Spec Meta Specification Structured
|
||||
| ProcThen Meta Process Structured
|
||||
| OnlyV Meta Variant -- ^ Variant (@CASE@) input process
|
||||
| OnlyC Meta Choice -- ^ @IF@ process
|
||||
| OnlyO Meta Option -- ^ @CASE@ process
|
||||
| OnlyA Meta Alternative -- ^ @ALT@ process
|
||||
| OnlyP Meta Process -- ^ @SEQ@, @PAR@
|
||||
| OnlyEL Meta ExpressionList -- ^ @VALOF@
|
||||
| Several Meta [Structured]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
data Data a => Structured a =
|
||||
Rep Meta Replicator (Structured a)
|
||||
| Spec Meta Specification (Structured a)
|
||||
| ProcThen Meta Process (Structured a)
|
||||
| Only Meta a
|
||||
| Several Meta [Structured a]
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
-- The Data instance for Structured is tricky. Because it is a parameterised class we
|
||||
-- need to change the dataCast1 function from the default declaration; something
|
||||
-- that leaving GHC to handle deriving (Data) will not achieve. Therefore we have no
|
||||
-- choice but to provide our own instance long-hand here:
|
||||
|
||||
_struct_RepConstr = mkConstr _struct_DataType "Rep" [] Prefix
|
||||
_struct_SpecConstr = mkConstr _struct_DataType "Spec" [] Prefix
|
||||
_struct_ProcThenConstr= mkConstr _struct_DataType "ProcThen" [] Prefix
|
||||
_struct_OnlyConstr = mkConstr _struct_DataType "Only" [] Prefix
|
||||
_struct_SeveralConstr = mkConstr _struct_DataType "Several" [] Prefix
|
||||
_struct_DataType = mkDataType "AST.Structured"
|
||||
[_struct_RepConstr
|
||||
,_struct_SpecConstr
|
||||
,_struct_ProcThenConstr
|
||||
,_struct_OnlyConstr
|
||||
,_struct_SeveralConstr
|
||||
]
|
||||
|
||||
instance Data a => Data (Structured a) where
|
||||
gfoldl f z (Rep m r s) = z Rep `f` m `f` r `f` s
|
||||
gfoldl f z (Spec m sp str) = z Spec `f` m `f` sp `f` str
|
||||
gfoldl f z (ProcThen m p s) = z ProcThen `f` m `f` p `f` s
|
||||
gfoldl f z (Only m x) = z Only `f` m `f` x
|
||||
gfoldl f z (Several m ss) = z Several `f` m `f` ss
|
||||
toConstr (Rep {}) = _struct_RepConstr
|
||||
toConstr (Spec {}) = _struct_SpecConstr
|
||||
toConstr (ProcThen {}) = _struct_ProcThenConstr
|
||||
toConstr (Only {}) = _struct_OnlyConstr
|
||||
toConstr (Several {}) = _struct_SeveralConstr
|
||||
gunfold k z c = case constrIndex c of
|
||||
1 -> (k . k . k) (z Rep)
|
||||
2 -> (k . k . k) (z Spec)
|
||||
3 -> (k . k . k) (z ProcThen)
|
||||
4 -> (k . k) (z Only)
|
||||
5 -> (k . k) (z Several)
|
||||
_ -> error "gunfold"
|
||||
dataTypeOf _ = _struct_DataType
|
||||
dataCast1 f = gcast1 f
|
||||
|
||||
|
||||
-- | The mode in which an input operates.
|
||||
data InputMode =
|
||||
-- | A plain input from a channel.
|
||||
InputSimple Meta [InputItem]
|
||||
-- | A variant input from a channel.
|
||||
| InputCase Meta Structured
|
||||
| InputCase Meta (Structured Variant)
|
||||
-- | Read the value of a timer.
|
||||
| InputTimerRead Meta InputItem
|
||||
-- | Wait for a particular time to go past on a timer.
|
||||
|
|
@ -437,7 +472,7 @@ data SpecType =
|
|||
-- | Declare a @PROC@.
|
||||
| Proc Meta SpecMode [Formal] Process
|
||||
-- | Declare a @FUNCTION@.
|
||||
| Function Meta SpecMode [Type] [Formal] Structured
|
||||
| Function Meta SpecMode [Type] [Formal] (Structured ExpressionList)
|
||||
-- | Declare a retyping abbreviation of a variable.
|
||||
| Retypes Meta AbbrevMode Type Variable
|
||||
-- | Declare a retyping abbreviation of an expression.
|
||||
|
|
@ -491,16 +526,16 @@ data Process =
|
|||
| ClearMobile Meta Variable
|
||||
| Skip Meta
|
||||
| Stop Meta
|
||||
| Seq Meta Structured
|
||||
| If Meta Structured
|
||||
| Case Meta Expression Structured
|
||||
| Seq Meta (Structured Process)
|
||||
| If Meta (Structured Choice)
|
||||
| Case Meta Expression (Structured Option)
|
||||
| While Meta Expression Process
|
||||
| Par Meta ParMode Structured
|
||||
| Par Meta ParMode (Structured Process)
|
||||
-- | A @PROCESSOR@ process.
|
||||
-- The occam2.1 syntax says this is just a process, although it shouldn't be
|
||||
-- legal outside a @PLACED PAR@.
|
||||
| Processor Meta Expression Process
|
||||
| Alt Meta Bool Structured
|
||||
| Alt Meta Bool (Structured Alternative)
|
||||
| ProcCall Meta Name [Actual]
|
||||
-- | A call of a built-in @PROC@.
|
||||
-- This may go away in the future, since which @PROC@s are intrinsics depends
|
||||
|
|
@ -508,3 +543,4 @@ data Process =
|
|||
| IntrinsicProcCall Meta String [Actual]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
type AST = Structured ()
|
||||
|
|
|
|||
|
|
@ -99,11 +99,13 @@ testCheckTreeForConstr = TestList
|
|||
,doTest (1,A.Int,[con0 A.Int],[ADI A.Int])
|
||||
,doTest (100, A.True emptyMeta, [con1 A.True],[ADI $ A.True emptyMeta])
|
||||
|
||||
,doTest (200, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [con1 A.Skip], [ADI $ A.Skip emptyMeta])
|
||||
,doTest (201, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [con2 A.Several], [ADI $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta]])
|
||||
,doTest (202, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [con0 A.Int], [])
|
||||
,doTest (203, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [con2 A.OnlyP, con1 A.Skip],
|
||||
[ADI $ A.OnlyP emptyMeta $ A.Skip emptyMeta, ADI $ A.Skip emptyMeta])
|
||||
,doTest (200, A.Seq emptyMeta $ A.Several emptyMeta [A.Only emptyMeta $ A.Skip emptyMeta], [con1 A.Skip], [ADI $ A.Skip emptyMeta])
|
||||
,doTest (201, A.Seq emptyMeta $ A.Several emptyMeta [A.Only emptyMeta $ A.Skip emptyMeta],
|
||||
[con2 (A.Several :: Meta -> [A.Structured A.Process] -> A.Structured A.Process)],
|
||||
[ADI $ A.Several emptyMeta [A.Only emptyMeta $ A.Skip emptyMeta]])
|
||||
,doTest (202, A.Seq emptyMeta $ A.Several emptyMeta [A.Only emptyMeta $ A.Skip emptyMeta], [con0 A.Int], [])
|
||||
,doTest (203, A.Seq emptyMeta $ A.Several emptyMeta [A.Only emptyMeta $ A.Skip emptyMeta], [con2 (A.Only :: Meta -> A.Process -> A.Structured A.Process), con1 A.Skip],
|
||||
[ADI $ A.Only emptyMeta $ A.Skip emptyMeta, ADI $ A.Skip emptyMeta])
|
||||
]
|
||||
where
|
||||
doTest :: Data a => (Int, a, [Constr], [AnyDataItem]) -> Test
|
||||
|
|
|
|||
|
|
@ -75,14 +75,13 @@ data CompState = CompState {
|
|||
-- Set by passes
|
||||
csNonceCounter :: Int,
|
||||
csFunctionReturns :: Map String [A.Type],
|
||||
csPulledItems :: [[A.Structured -> A.Structured]],
|
||||
csPulledItems :: [[PulledItem]],
|
||||
csAdditionalArgs :: Map String [A.Actual],
|
||||
csParProcs :: Set A.Name
|
||||
}
|
||||
deriving (Data, Typeable)
|
||||
|
||||
instance Show (A.Structured -> A.Structured) where
|
||||
show p = "(function on Structured)"
|
||||
type PulledItem = (Meta, Either A.Specification A.Process) -- Either Spec or ProcThen
|
||||
|
||||
emptyState :: CompState
|
||||
emptyState = CompState {
|
||||
|
|
@ -155,7 +154,7 @@ popPullContext :: CSM m => m ()
|
|||
popPullContext = modify (\ps -> ps { csPulledItems = tail $ csPulledItems ps })
|
||||
|
||||
-- | Add a pulled item to the collection.
|
||||
addPulled :: CSM m => (A.Structured -> A.Structured) -> m ()
|
||||
addPulled :: CSM m => PulledItem -> m ()
|
||||
addPulled item
|
||||
= modify (\ps -> case csPulledItems ps of
|
||||
(l:ls) -> ps { csPulledItems = (item:l):ls })
|
||||
|
|
@ -169,12 +168,17 @@ havePulled
|
|||
_ -> return True
|
||||
|
||||
-- | Apply pulled items to a Structured.
|
||||
applyPulled :: CSM m => A.Structured -> m A.Structured
|
||||
applyPulled :: (CSM m, Data a) => A.Structured a -> m (A.Structured a)
|
||||
applyPulled ast
|
||||
= do ps <- get
|
||||
case csPulledItems ps of
|
||||
(l:ls) -> do put $ ps { csPulledItems = [] : ls }
|
||||
return $ foldl (\p f -> f p) ast l
|
||||
return $ foldl (\p f -> apply f p) ast l
|
||||
where
|
||||
apply :: Data a => PulledItem -> A.Structured a -> A.Structured a
|
||||
apply (m, Left spec) = A.Spec m spec
|
||||
apply (m, Right proc) = A.ProcThen m proc
|
||||
|
||||
--}}}
|
||||
|
||||
--{{{ type contexts
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
-- * If statements, on the other hand, have to be chained together. Each expression is connected
|
||||
-- to its body, but also to the next expression. There is no link between the last expression
|
||||
-- and the end of the if; if statements behave like STOP if nothing is matched.
|
||||
module FlowGraph (AlterAST(..), EdgeLabel(..), FNode(..), FlowGraph, GraphLabelFuncs(..), buildFlowGraph, joinLabelFuncs, makeFlowGraphInstr, mkLabelFuncsConst, mkLabelFuncsGeneric) where
|
||||
module FlowGraph (AlterAST(..), EdgeLabel(..), FNode, FlowGraph, FlowGraph', GraphLabelFuncs(..), buildFlowGraph, getNodeData, getNodeFunc, getNodeMeta, joinLabelFuncs, makeFlowGraphInstr, makeTestNode, mkLabelFuncsConst, mkLabelFuncsGeneric) where
|
||||
|
||||
import Control.Monad.Error
|
||||
import Control.Monad.State
|
||||
|
|
@ -70,47 +70,51 @@ data OuterType = ONone | OSeq | OPar Int (Node, Node) | OCase (Node,Node) | OIf
|
|||
-- | A type used to build up tree-modifying functions. When given an inner modification function,
|
||||
-- it returns a modification function for the whole tree. The functions are monadic, to
|
||||
-- provide flexibility; you can always use the Identity monad.
|
||||
type ASTModifier m inner = (inner -> m inner) -> (A.Structured -> m A.Structured)
|
||||
type ASTModifier m inner structType = (inner -> m inner) -> (A.Structured structType -> m (A.Structured structType))
|
||||
|
||||
-- | An operator for combining ASTModifier functions as you walk the tree.
|
||||
-- While its implementation is simple, it adds clarity to the code.
|
||||
(@->) :: ASTModifier m outer -> ((inner -> m inner) -> (outer -> m outer)) -> ASTModifier m inner
|
||||
(@->) :: ASTModifier m outer b -> ((inner -> m inner) -> (outer -> m outer)) -> ASTModifier m inner b
|
||||
(@->) = (.)
|
||||
|
||||
-- | A choice of AST altering functions built on ASTModifier.
|
||||
data AlterAST m =
|
||||
AlterProcess (ASTModifier m A.Process)
|
||||
|AlterArguments (ASTModifier m [A.Formal])
|
||||
|AlterExpression (ASTModifier m A.Expression)
|
||||
|AlterExpressionList (ASTModifier m A.ExpressionList)
|
||||
|AlterReplicator (ASTModifier m A.Replicator)
|
||||
|AlterSpec (ASTModifier m A.Specification)
|
||||
data AlterAST m structType =
|
||||
AlterProcess (ASTModifier m A.Process structType)
|
||||
|AlterArguments (ASTModifier m [A.Formal] structType)
|
||||
|AlterExpression (ASTModifier m A.Expression structType)
|
||||
|AlterExpressionList (ASTModifier m A.ExpressionList structType)
|
||||
|AlterReplicator (ASTModifier m A.Replicator structType)
|
||||
|AlterSpec (ASTModifier m A.Specification structType)
|
||||
|AlterNothing
|
||||
|
||||
data Monad m => FNode' m a b = Node (Meta, a, AlterAST m b)
|
||||
|
||||
-- | The label for a node. A Meta tag, a custom label, and a function
|
||||
-- for altering the part of the AST that this node came from
|
||||
data Monad m => FNode m a = Node (Meta, a, AlterAST m)
|
||||
type FNode m a = FNode' m a ()
|
||||
--type FEdge = (Node, EdgeLabel, Node)
|
||||
|
||||
instance (Monad m, Show a) => Show (FNode m a) where
|
||||
instance (Monad m, Show a) => Show (FNode' m a b) where
|
||||
show (Node (m,x,_)) = (filter ((/=) '\"')) $ show m ++ ":" ++ show x
|
||||
|
||||
type FlowGraph' m a b = Gr (FNode' m a b) EdgeLabel
|
||||
|
||||
-- | The main FlowGraph type. The m parameter is the monad
|
||||
-- in which alterations to the AST (based on the FlowGraph)
|
||||
-- must occur. The a parameter is the type of the node labels.
|
||||
type FlowGraph m a = Gr (FNode m a) EdgeLabel
|
||||
type FlowGraph m a = FlowGraph' m a ()
|
||||
|
||||
-- | A list of nodes and edges. Used for building up the graph.
|
||||
type NodesEdges m a = ([LNode (FNode m a)],[LEdge EdgeLabel])
|
||||
type NodesEdges m a b = ([LNode (FNode' m a b)],[LEdge EdgeLabel])
|
||||
|
||||
-- | The state carried around when building up the graph. In order they are:
|
||||
-- * The next node identifier
|
||||
-- * The next identifier for a PAR item (for the EStartPar/EEndPar edges)
|
||||
-- * The list of nodes and edges to put into the graph
|
||||
-- * The list of root nodes thus far (those with no links to them)
|
||||
type GraphMakerState mAlter a = (Node, Int, NodesEdges mAlter a, [Node])
|
||||
type GraphMakerState mAlter a b = (Node, Int, NodesEdges mAlter a b, [Node])
|
||||
|
||||
type GraphMaker mLabel mAlter a b = ErrorT String (StateT (GraphMakerState mAlter a) mLabel) b
|
||||
type GraphMaker mLabel mAlter a b c = ErrorT String (StateT (GraphMakerState mAlter a b) mLabel) c
|
||||
|
||||
-- | The GraphLabelFuncs type. These are a group of functions
|
||||
-- used to provide labels for different elements of AST.
|
||||
|
|
@ -130,6 +134,18 @@ data Monad m => GraphLabelFuncs m label = GLF {
|
|||
,labelScopeOut :: A.Specification -> m label
|
||||
}
|
||||
|
||||
getNodeMeta :: Monad m => FNode' m a b -> Meta
|
||||
getNodeMeta (Node (m,_,_)) = m
|
||||
|
||||
getNodeData :: Monad m => FNode' m a b -> a
|
||||
getNodeData (Node (_,d,_)) = d
|
||||
|
||||
getNodeFunc :: Monad m => FNode' m a b -> AlterAST m b
|
||||
getNodeFunc (Node (_,_,f)) = f
|
||||
|
||||
makeTestNode :: Monad m => Meta -> a -> FNode m a
|
||||
makeTestNode m d = Node (m,d,undefined)
|
||||
|
||||
-- | Builds the instructions to send to GraphViz
|
||||
makeFlowGraphInstr :: (Monad m, Show a) => FlowGraph m a -> String
|
||||
makeFlowGraphInstr = graphviz'
|
||||
|
|
@ -167,12 +183,12 @@ mkLabelFuncsGeneric f = GLF f f f f f f f f
|
|||
-- the parameters, only in the result. The mLabel monad is the monad in
|
||||
-- which the labelling must be done; hence the flow-graph is returned inside
|
||||
-- the label monad.
|
||||
buildFlowGraph :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
|
||||
buildFlowGraph :: forall mLabel mAlter label structType. (Monad mLabel, Monad mAlter, Data structType) =>
|
||||
GraphLabelFuncs mLabel label ->
|
||||
A.Structured ->
|
||||
mLabel (Either String (FlowGraph mAlter label, [Node]))
|
||||
A.Structured structType ->
|
||||
mLabel (Either String (FlowGraph' mAlter label structType, [Node]))
|
||||
buildFlowGraph funcs s
|
||||
= do res <- runStateT (runErrorT $ buildStructured ONone s id) (0, 0, ([],[]), [])
|
||||
= do res <- runStateT (runErrorT $ buildStructured (\_ _ _ -> throwError "Did not expect outer-most node to exist in AST") ONone s id) (0, 0, ([],[]), [])
|
||||
return $ case res of
|
||||
(Left err,_) -> Left err
|
||||
(Right (Left {}),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, roots)
|
||||
|
|
@ -183,16 +199,16 @@ buildFlowGraph funcs s
|
|||
run :: (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> mLabel label
|
||||
run func = func funcs
|
||||
|
||||
addNode :: (Meta, label, AlterAST mAlter) -> GraphMaker mLabel mAlter label Node
|
||||
addNode :: (Meta, label, AlterAST mAlter structType) -> GraphMaker mLabel mAlter label structType Node
|
||||
addNode x = do (n,pi,(nodes, edges), rs) <- get
|
||||
put (n+1, pi,((n, Node x):nodes, edges), rs)
|
||||
return n
|
||||
|
||||
denoteRootNode :: Node -> GraphMaker mLabel mAlter label ()
|
||||
denoteRootNode :: Node -> GraphMaker mLabel mAlter label structType ()
|
||||
denoteRootNode root = do (n, pi, nes, roots) <- get
|
||||
put (n, pi, nes, root : roots)
|
||||
|
||||
addEdge :: EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label ()
|
||||
addEdge :: EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label structType ()
|
||||
addEdge label start end = do (n, pi, (nodes, edges), rs) <- get
|
||||
-- Edges should only be added after the nodes, so
|
||||
-- for safety here we can check that the nodes exist:
|
||||
|
|
@ -202,25 +218,25 @@ buildFlowGraph funcs s
|
|||
|
||||
-- It is important for the flow-graph tests that the Meta tag passed in is the same as the
|
||||
-- result of calling findMeta on the third parameter
|
||||
addNode' :: Meta -> (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> AlterAST mAlter -> GraphMaker mLabel mAlter label Node
|
||||
addNode' :: Meta -> (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> AlterAST mAlter structType -> GraphMaker mLabel mAlter label structType Node
|
||||
addNode' m f t r = do val <- (lift . lift) (run f t)
|
||||
addNode (m, val, r)
|
||||
|
||||
addNodeExpression :: Meta -> A.Expression -> (ASTModifier mAlter A.Expression) -> GraphMaker mLabel mAlter label Node
|
||||
addNodeExpression :: Meta -> A.Expression -> (ASTModifier mAlter A.Expression structType) -> GraphMaker mLabel mAlter label structType Node
|
||||
addNodeExpression m e r = addNode' m labelExpression e (AlterExpression r)
|
||||
|
||||
addNodeExpressionList :: Meta -> A.ExpressionList -> (ASTModifier mAlter A.ExpressionList) -> GraphMaker mLabel mAlter label Node
|
||||
addNodeExpressionList :: Meta -> A.ExpressionList -> (ASTModifier mAlter A.ExpressionList structType) -> GraphMaker mLabel mAlter label structType Node
|
||||
addNodeExpressionList m e r = addNode' m labelExpressionList e (AlterExpressionList r)
|
||||
|
||||
addDummyNode :: Meta -> GraphMaker mLabel mAlter label Node
|
||||
addDummyNode :: Meta -> GraphMaker mLabel mAlter label structType Node
|
||||
addDummyNode m = addNode' m labelDummy m AlterNothing
|
||||
|
||||
getNextParEdgeId :: GraphMaker mLabel mAlter label Int
|
||||
getNextParEdgeId :: GraphMaker mLabel mAlter label structType Int
|
||||
getNextParEdgeId = do (a, pi, b, c) <- get
|
||||
put (a, pi + 1, b, c)
|
||||
return pi
|
||||
|
||||
addParEdges :: Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label ()
|
||||
addParEdges :: Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
|
||||
addParEdges usePI (s,e) pairs
|
||||
= do (n,pi,(nodes,edges),rs) <- get
|
||||
put (n,pi,(nodes,edges ++ (concatMap (parEdge usePI) pairs)),rs)
|
||||
|
|
@ -240,14 +256,14 @@ buildFlowGraph funcs s
|
|||
x' <- f x
|
||||
return (pre ++ [x'] ++ suf)
|
||||
|
||||
mapMR :: forall inner. ASTModifier mAlter [inner] -> (inner -> ASTModifier mAlter inner -> GraphMaker mLabel mAlter label (Node,Node)) -> [inner] -> GraphMaker mLabel mAlter label [(Node,Node)]
|
||||
mapMR :: forall inner. ASTModifier mAlter [inner] structType -> (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType (Node,Node)) -> [inner] -> GraphMaker mLabel mAlter label structType [(Node,Node)]
|
||||
mapMR outerRoute func xs = mapM funcAndRoute (zip [0..] xs)
|
||||
where
|
||||
funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label (Node,Node)
|
||||
funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType (Node,Node)
|
||||
funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind)
|
||||
|
||||
|
||||
mapMRE :: forall inner. ASTModifier mAlter [inner] -> (inner -> ASTModifier mAlter inner -> GraphMaker mLabel mAlter label (Either Bool (Node,Node))) -> [inner] -> GraphMaker mLabel mAlter label (Either Bool [(Node,Node)])
|
||||
mapMRE :: forall inner. ASTModifier mAlter [inner] structType -> (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node,Node))) -> [inner] -> GraphMaker mLabel mAlter label structType (Either Bool [(Node,Node)])
|
||||
mapMRE outerRoute func xs = mapM funcAndRoute (zip [0..] xs) >>* foldl foldEither (Left False)
|
||||
where
|
||||
foldEither :: Either Bool [(Node,Node)] -> Either Bool (Node,Node) -> Either Bool [(Node,Node)]
|
||||
|
|
@ -256,7 +272,7 @@ buildFlowGraph funcs s
|
|||
foldEither (Left hadNode) (Left hadNode') = Left $ hadNode || hadNode'
|
||||
foldEither (Right ns) (Right n) = Right (ns ++ [n])
|
||||
|
||||
funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label (Either Bool (Node,Node))
|
||||
funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType (Either Bool (Node,Node))
|
||||
funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind)
|
||||
|
||||
|
||||
|
|
@ -264,67 +280,49 @@ buildFlowGraph funcs s
|
|||
nonEmpty (Left hadNodes) = hadNodes
|
||||
nonEmpty (Right nodes) = not (null nodes)
|
||||
|
||||
joinPairs :: Meta -> [(Node, Node)] -> GraphMaker mLabel mAlter label (Node, Node)
|
||||
joinPairs :: Meta -> [(Node, Node)] -> GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
joinPairs m [] = addDummyNode m >>* mkPair
|
||||
joinPairs m nodes = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge ESeq s e) nodes
|
||||
return (fst (head nodes), snd (last nodes))
|
||||
|
||||
|
||||
buildStructuredP = buildStructured (\_ r p -> buildProcess p r)
|
||||
buildStructuredC = buildStructured buildOnlyChoice
|
||||
buildStructuredO = buildStructured buildOnlyOption
|
||||
|
||||
-- Returns a pair of beginning-node, end-node
|
||||
-- Bool indicates emptiness (False = empty, True = there was something)
|
||||
buildStructured :: OuterType -> A.Structured -> ASTModifier mAlter A.Structured -> GraphMaker mLabel mAlter label (Either Bool (Node, Node))
|
||||
buildStructured outer (A.Several m ss) route
|
||||
buildStructured :: forall a. Data a => (OuterType -> ASTModifier mAlter a structType -> a -> GraphMaker mLabel mAlter label structType (Node, Node)) ->
|
||||
OuterType -> A.Structured a -> ASTModifier mAlter (A.Structured a) structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node, Node))
|
||||
buildStructured f outer (A.Several m ss) route
|
||||
= do case outer of
|
||||
ONone -> -- If there is no context, they should be left as disconnected graphs.
|
||||
do nodes <- mapMRE decompSeveral (buildStructured outer) ss
|
||||
do nodes <- mapMRE decompSeveral (buildStructured f outer) ss
|
||||
return $ Left $ nonEmpty nodes
|
||||
OSeq -> do nodes <- mapMRE decompSeveral (buildStructured outer) ss
|
||||
OSeq -> do nodes <- mapMRE decompSeveral (buildStructured f outer) ss
|
||||
case nodes of
|
||||
Left hadNodes -> return $ Left hadNodes
|
||||
Right nodes' -> joinPairs m nodes' >>* Right
|
||||
OPar pId (nStart, nEnd) ->
|
||||
do nodes <- mapMRE decompSeveral (buildStructured outer) ss
|
||||
do nodes <- mapMRE decompSeveral (buildStructured f outer) ss
|
||||
addParEdges pId (nStart, nEnd) $ either (const []) id nodes
|
||||
return $ Left $ nonEmpty nodes
|
||||
--Because the conditions in If statements are chained together, we
|
||||
--must fold the specs, not map them independently
|
||||
OIf prev end -> foldM foldIf (prev,end) (zip [0..] ss) >>* Right
|
||||
where
|
||||
foldIf :: (Node,Node) -> (Int,A.Structured) -> GraphMaker mLabel mAlter label (Node, Node)
|
||||
foldIf (prev,end) (ind,s) = do nodes <- buildStructured (OIf prev end) s $ decompSeveral @-> (routeList ind)
|
||||
foldIf :: (Node,Node) -> (Int,A.Structured a) -> GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
foldIf (prev,end) (ind,s) = do nodes <- buildStructured f (OIf prev end) s $ decompSeveral @-> (routeList ind)
|
||||
case nodes of
|
||||
Left {} -> return (prev,end)
|
||||
Right (prev',_) -> return (prev', end)
|
||||
_ -> do nodes <- mapMRE decompSeveral (buildStructured outer) ss
|
||||
_ -> do nodes <- mapMRE decompSeveral (buildStructured f outer) ss
|
||||
return $ Left $ nonEmpty nodes
|
||||
where
|
||||
decompSeveral :: ASTModifier mAlter [A.Structured]
|
||||
decompSeveral :: ASTModifier mAlter [A.Structured a] structType
|
||||
decompSeveral = route22 route A.Several
|
||||
|
||||
buildStructured _ (A.OnlyP _ p) route = buildProcess p (route22 route A.OnlyP) >>* Right
|
||||
buildStructured outer (A.OnlyC _ (A.Choice m exp p)) route
|
||||
= do nexp <- addNodeExpression (findMeta exp) exp $ route @-> (\f (A.OnlyC m (A.Choice m' exp p)) -> do {exp' <- f exp; return (A.OnlyC m (A.Choice m' exp' p))})
|
||||
(nbodys, nbodye) <- buildProcess p $ route @-> (\f (A.OnlyC m (A.Choice m' exp p)) -> f p >>* ((A.OnlyC m) . (A.Choice m' exp)))
|
||||
addEdge ESeq nexp nbodys
|
||||
case outer of
|
||||
OIf cPrev cEnd ->
|
||||
do addEdge ESeq cPrev nexp
|
||||
addEdge ESeq nbodye cEnd
|
||||
_ -> throwError "Choice found outside IF statement"
|
||||
return $ Right (nexp,nbodye)
|
||||
buildStructured outer (A.OnlyO _ opt) route
|
||||
= do (s,e) <-
|
||||
case opt of
|
||||
(A.Option m es p) -> do
|
||||
buildProcess p $ route @-> (\f (A.OnlyO m (A.Option m2 es p)) -> f p >>* ((A.OnlyO m) . (A.Option m2 es)))
|
||||
(A.Else _ p) -> buildProcess p $ route @-> (\f (A.OnlyO m (A.Else m2 p)) -> f p >>* ((A.OnlyO m) . (A.Else m2)))
|
||||
case outer of
|
||||
OCase (cStart, cEnd) ->
|
||||
do addEdge ESeq cStart s
|
||||
addEdge ESeq e cEnd
|
||||
_ -> throwError "Option found outside CASE statement"
|
||||
return $ Right (s,e)
|
||||
buildStructured outer (A.Spec m spec str) route
|
||||
|
||||
buildStructured f outer (A.Spec m spec str) route
|
||||
= do n <- addNode' (findMeta spec) labelScopeIn spec (AlterSpec $ route23 route A.Spec)
|
||||
n' <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec)
|
||||
|
||||
|
|
@ -342,18 +340,18 @@ buildFlowGraph funcs s
|
|||
outer' <- case outer of
|
||||
OPar {} -> getNextParEdgeId >>* flip OPar (n,n')
|
||||
_ -> return outer
|
||||
nodes <- buildStructured outer' str (route33 route A.Spec)
|
||||
nodes <- buildStructured f outer' str (route33 route A.Spec)
|
||||
case nodes of
|
||||
Left False -> do addEdge ESeq n n'
|
||||
Left True -> return ()
|
||||
Right (s,e) -> do addEdge ESeq n s
|
||||
addEdge ESeq e n'
|
||||
return $ Right (n,n')
|
||||
buildStructured outer (A.Rep m rep str) route
|
||||
buildStructured f outer (A.Rep m rep str) route
|
||||
= do let alter = AlterReplicator $ route23 route A.Rep
|
||||
case outer of
|
||||
OSeq -> do n <- addNode' (findMeta rep) labelReplicator rep alter
|
||||
nodes <- buildStructured outer str (route33 route A.Rep)
|
||||
nodes <- buildStructured f outer str (route33 route A.Rep)
|
||||
case nodes of
|
||||
Right (s,e) ->
|
||||
do addEdge ESeq n s
|
||||
|
|
@ -365,7 +363,7 @@ buildFlowGraph funcs s
|
|||
do s <- addNode' (findMeta rep) labelReplicator rep alter
|
||||
e <- addDummyNode m
|
||||
pId <- getNextParEdgeId
|
||||
nodes <- buildStructured (OPar pId (s,e)) str (route33 route A.Rep)
|
||||
nodes <- buildStructured f (OPar pId (s,e)) str (route33 route A.Rep)
|
||||
case nodes of
|
||||
Left False -> addEdge ESeq s e
|
||||
Left True -> return ()
|
||||
|
|
@ -374,25 +372,55 @@ buildFlowGraph funcs s
|
|||
return $ Right (s,e)
|
||||
_ -> throwError $ "Cannot have replicators inside context: " ++ show outer
|
||||
|
||||
buildStructured _ s _ = return $ Left False
|
||||
buildStructured f outer (A.Only _ o) route = f outer (route22 route A.Only) o >>* Right
|
||||
buildStructured _ _ s _ = return $ Left False
|
||||
|
||||
addNewSubProcFunc :: Meta -> [A.Formal] -> Either (A.Process, ASTModifier mAlter A.Process) (A.Structured, ASTModifier mAlter A.Structured) ->
|
||||
ASTModifier mAlter [A.Formal] -> GraphMaker mLabel mAlter label ()
|
||||
buildOnlyChoice outer route (A.Choice m exp p)
|
||||
= do nexp <- addNodeExpression (findMeta exp) exp $ route23 route A.Choice
|
||||
(nbodys, nbodye) <- buildProcess p $ route33 route A.Choice
|
||||
addEdge ESeq nexp nbodys
|
||||
case outer of
|
||||
OIf cPrev cEnd ->
|
||||
do addEdge ESeq cPrev nexp
|
||||
addEdge ESeq nbodye cEnd
|
||||
_ -> throwError "Choice found outside IF statement"
|
||||
return (nexp,nbodye)
|
||||
buildOnlyOption outer route opt
|
||||
= do (s,e) <-
|
||||
case opt of
|
||||
(A.Option m es p) -> do
|
||||
nexpNodes <- mapMR (route23 route A.Option) (\e r -> addNodeExpression (findMeta e) e r >>* mkPair) es
|
||||
(nexps, nexpe) <- joinPairs m nexpNodes
|
||||
(nbodys, nbodye) <- buildProcess p $ route33 route A.Option
|
||||
addEdge ESeq nexpe nbodys
|
||||
return (nexps,nbodye)
|
||||
(A.Else _ p) -> buildProcess p $ route22 route A.Else
|
||||
case outer of
|
||||
OCase (cStart, cEnd) ->
|
||||
do addEdge ESeq cStart s
|
||||
addEdge ESeq e cEnd
|
||||
_ -> throwError "Option found outside CASE statement"
|
||||
return (s,e)
|
||||
|
||||
addNewSubProcFunc :: Meta -> [A.Formal] -> Either (A.Process, ASTModifier mAlter A.Process structType) (A.Structured A.ExpressionList, ASTModifier mAlter (A.Structured A.ExpressionList) structType) ->
|
||||
ASTModifier mAlter [A.Formal] structType -> GraphMaker mLabel mAlter label structType ()
|
||||
addNewSubProcFunc m args body argsRoute
|
||||
= do root <- addNode' m labelStartNode (m, args) (AlterArguments argsRoute)
|
||||
denoteRootNode root
|
||||
bodyNode <- case body of
|
||||
Left (p,route) -> buildProcess p route >>* fst
|
||||
Right (s,route) ->
|
||||
do s <- buildStructured ONone s route
|
||||
do s <- buildStructured (buildEL m) ONone s route
|
||||
case s of
|
||||
Left {} -> throwError $ show m ++ " Expected VALOF or specification at top-level of function when building flow-graph"
|
||||
Right (n,_) -> return n
|
||||
addEdge ESeq root bodyNode
|
||||
where
|
||||
buildEL m _ r el = addNodeExpressionList m el r >>* mkPair
|
||||
|
||||
buildProcess :: A.Process -> ASTModifier mAlter A.Process -> GraphMaker mLabel mAlter label (Node, Node)
|
||||
buildProcess :: A.Process -> ASTModifier mAlter A.Process structType -> GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
buildProcess (A.Seq m s) route
|
||||
= do s <- buildStructured OSeq s (route22 route A.Seq)
|
||||
= do s <- buildStructuredP OSeq s (route22 route A.Seq)
|
||||
case s of
|
||||
Left True -> throwError $ show m ++ " SEQ had non-joined up body when building flow-graph"
|
||||
Left False -> do n <- addDummyNode m
|
||||
|
|
@ -402,7 +430,7 @@ buildFlowGraph funcs s
|
|||
= do nStart <- addDummyNode m
|
||||
nEnd <- addDummyNode m
|
||||
pId <- getNextParEdgeId
|
||||
nodes <- buildStructured (OPar pId (nStart, nEnd)) s (route33 route A.Par)
|
||||
nodes <- buildStructuredP (OPar pId (nStart, nEnd)) s (route33 route A.Par)
|
||||
case nodes of
|
||||
Left False -> do addEdge ESeq nStart nEnd -- no processes in PAR, join start and end with simple ESeq link
|
||||
Left True -> return () -- already wired up
|
||||
|
|
@ -419,12 +447,12 @@ buildFlowGraph funcs s
|
|||
buildProcess (A.Case m e s) route
|
||||
= do nStart <- addNodeExpression (findMeta e) e (route23 route A.Case)
|
||||
nEnd <- addDummyNode m
|
||||
buildStructured (OCase (nStart,nEnd)) s (route33 route A.Case)
|
||||
buildStructuredO (OCase (nStart,nEnd)) s (route33 route A.Case)
|
||||
return (nStart, nEnd)
|
||||
buildProcess (A.If m s) route
|
||||
= do nStart <- addDummyNode m
|
||||
nEnd <- addDummyNode m
|
||||
buildStructured (OIf nStart nEnd) s (route22 route A.If)
|
||||
buildStructuredC (OIf nStart nEnd) s (route22 route A.If)
|
||||
return (nStart, nEnd)
|
||||
buildProcess p route = addNode' (findMeta p) labelProcess p (AlterProcess route) >>* mkPair
|
||||
|
||||
|
|
@ -453,27 +481,27 @@ decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3
|
|||
(a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a)
|
||||
decomp55 con f4 = decomp5 con return return return return f4
|
||||
|
||||
route22 :: (Monad m, Data a, Typeable a0, Typeable a1) => ASTModifier m a -> (a0 -> a1 -> a) -> ASTModifier m a1
|
||||
route22 :: (Monad m, Data a, Typeable a0, Typeable a1) => ASTModifier m a b -> (a0 -> a1 -> a) -> ASTModifier m a1 b
|
||||
route22 route con = route @-> (decomp22 con)
|
||||
|
||||
route23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a1
|
||||
route23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a b -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a1 b
|
||||
route23 route con = route @-> (decomp23 con)
|
||||
|
||||
route33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a2
|
||||
route33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a b -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a2 b
|
||||
route33 route con = route @-> (decomp33 con)
|
||||
|
||||
route34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
|
||||
ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a2
|
||||
ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a2 b
|
||||
route34 route con = route @-> (decomp34 con)
|
||||
|
||||
route44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
|
||||
ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a3
|
||||
ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a3 b
|
||||
route44 route con = route @-> (decomp44 con)
|
||||
|
||||
route45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
|
||||
ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a3
|
||||
ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a3 b
|
||||
route45 route con = route @-> (decomp45 con)
|
||||
|
||||
route55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
|
||||
ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a4
|
||||
ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a4 b
|
||||
route55 route con = route @-> (decomp55 con)
|
||||
|
|
|
|||
|
|
@ -105,27 +105,27 @@ nextId' inc t
|
|||
-- for being isomorphic, based on the meta-tag node labels (node E in the expected list is
|
||||
-- isomorphic to node A in the actual list if their meta tags are the same).
|
||||
testGraph :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test
|
||||
testGraph testName nodes roots edges proc = testGraph' testName nodes roots edges (A.OnlyP emptyMeta proc)
|
||||
testGraph testName nodes roots edges proc = testGraph' testName nodes roots edges (A.Only emptyMeta proc)
|
||||
|
||||
--TODO test root nodes too
|
||||
|
||||
testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test
|
||||
testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
|
||||
testGraph' testName nodes roots edges code
|
||||
= TestCase $
|
||||
case evalState (buildFlowGraph testOps code) Map.empty of
|
||||
Left err -> assertFailure (testName ++ " graph building failed: " ++ err)
|
||||
Right gr -> checkGraphEquality (nodes, roots, edges) (gr :: (FlowGraph Identity Int, [Node]))
|
||||
Right gr -> checkGraphEquality (nodes, roots, edges) (gr :: (FlowGraph' Identity Int A.Process, [Node]))
|
||||
where
|
||||
-- Checks two graphs are equal by creating a node mapping from the expected graph to the real map (checkNodeEquality),
|
||||
-- then mapping the edges across (transformEdge) and checking everything is right (in checkGraphEquality)
|
||||
|
||||
deNode :: Monad m => FNode m a -> (Meta, a)
|
||||
deNode (Node (x,y,_)) = (x,y)
|
||||
-- deNode :: Monad m => FNode' m a b -> (Meta, a)
|
||||
deNode nd = (getNodeMeta nd, getNodeData nd)
|
||||
|
||||
testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int
|
||||
testOps = GLF nextId nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100)
|
||||
|
||||
checkGraphEquality :: (Graph g, Show b, Ord b, Monad m) => ([(Int, Meta)], [Int], [(Int, Int, b)]) -> (g (FNode m Int) b, [Int]) -> Assertion
|
||||
checkGraphEquality :: (Data a, Monad m) => ([(Int, Meta)], [Int], [(Int, Int, EdgeLabel)]) -> (FlowGraph' m Int a, [Int]) -> Assertion
|
||||
checkGraphEquality (nodes, roots, edges) (g, actRoots)
|
||||
= do let (remainingNodes, nodeLookup, ass) = foldl checkNodeEquality (Map.fromList (map revPair nodes),Map.empty, return ()) (map (transformPair id deNode) $ labNodes g)
|
||||
ass
|
||||
|
|
@ -162,74 +162,74 @@ testSeq :: Test
|
|||
testSeq = TestLabel "testSeq" $ TestList
|
||||
[
|
||||
testSeq' 0 [(0,m0)] [] (A.Several m1 [])
|
||||
,testSeq' 1 [(0,m2)] [] (A.OnlyP m1 sm2)
|
||||
,testSeq' 2 [(0,m3)] [] (A.Several m1 [A.OnlyP m2 sm3])
|
||||
,testSeq' 3 [(0,m3),(1,m5)] [(0,1,ESeq)] (A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
|
||||
,testSeq' 4 [(0,m3),(1,m5),(2,m7)] [(0,1,ESeq),(1,2,ESeq)] (A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7])
|
||||
,testSeq' 5 [(0,m3),(1,m5)] [(0,1,ESeq)] (A.Several m1 [A.Several m1 [A.OnlyP m2 sm3],A.Several m1 [A.OnlyP m4 sm5]])
|
||||
,testSeq' 1 [(0,m2)] [] (A.Only m1 sm2)
|
||||
,testSeq' 2 [(0,m3)] [] (A.Several m1 [A.Only m2 sm3])
|
||||
,testSeq' 3 [(0,m3),(1,m5)] [(0,1,ESeq)] (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
,testSeq' 4 [(0,m3),(1,m5),(2,m7)] [(0,1,ESeq),(1,2,ESeq)] (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7])
|
||||
,testSeq' 5 [(0,m3),(1,m5)] [(0,1,ESeq)] (A.Several m1 [A.Several m1 [A.Only m2 sm3],A.Several m1 [A.Only m4 sm5]])
|
||||
,testSeq' 6 [(0,m3),(1,m5),(2,m7),(3,m9)] [(0,1,ESeq),(1,2,ESeq),(2,3,ESeq)]
|
||||
(A.Several m1 [A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7], A.OnlyP m8 sm9])
|
||||
(A.Several m1 [A.Several m1 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7], A.Only m8 sm9])
|
||||
|
||||
,testSeq' 10 [(0,m1),(1,m4),(100,sub m1 100)] [(0,1,ESeq),(1,100,ESeq)] (A.Spec mU (someSpec m1) $ A.OnlyP m3 sm4)
|
||||
,testSeq' 10 [(0,m1),(1,m4),(100,sub m1 100)] [(0,1,ESeq),(1,100,ESeq)] (A.Spec mU (someSpec m1) $ A.Only m3 sm4)
|
||||
,testSeq'' 11
|
||||
[(1,m1),(3,m4),(5,m5),(7,m7),(9,m10),(101,sub m1 100),(105,sub m5 100),(107,sub m7 100)] [1]
|
||||
[(1,3,ESeq),(3,101,ESeq),(101,5,ESeq),(5,7,ESeq),(7,9,ESeq),(9,107,ESeq),(107,105,ESeq)]
|
||||
(A.Several m11 [A.Spec mU (someSpec m1) $ A.OnlyP m3 sm4,A.Spec mU (someSpec m5) $ A.Spec mU (someSpec m7) $ A.OnlyP m9 sm10])
|
||||
(A.Several m11 [A.Spec mU (someSpec m1) $ A.Only m3 sm4,A.Spec mU (someSpec m5) $ A.Spec mU (someSpec m7) $ A.Only m9 sm10])
|
||||
|
||||
,testSeq' 12 [(0,m1),(100,sub m1 100)] [(0,100,ESeq)] (A.Spec mU (someSpec m1) $ A.Several m4 [])
|
||||
|
||||
-- Replicated SEQ:
|
||||
|
||||
,testSeq' 100 [(0,m10), (1,m3), (2,m5)] [(0,1,ESeq), (1,2,ESeq), (2,0,ESeq)]
|
||||
(A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
|
||||
(A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
|
||||
,testSeq'' 101 [(0,m8), (1,m3), (2,m5),(3,m9),(4,m11)] [3] [(3,0,ESeq),(0,1,ESeq), (1,2,ESeq), (2,0,ESeq),(0,4,ESeq)]
|
||||
(A.OnlyP mU $ A.Seq m6 $ A.Several m7
|
||||
[A.OnlyP mU sm9
|
||||
,(A.Rep m8 (A.For m8 undefined undefined undefined) $ A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
|
||||
,A.OnlyP mU sm11])
|
||||
(A.Only mU $ A.Seq m6 $ A.Several m7
|
||||
[A.Only mU sm9
|
||||
,(A.Rep m8 (A.For m8 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
,A.Only mU sm11])
|
||||
|
||||
,testSeq' 102 [(0,m10)] [(0,0,ESeq)]
|
||||
(A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several mU [])
|
||||
|
||||
,testSeq' 103 [(1,m10), (0,m1), (2,m2)] [(0,1,ESeq),(1,1,ESeq),(1,2,ESeq)]
|
||||
(A.Several mU [A.OnlyP mU sm1, (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several mU []), A.OnlyP mU sm2])
|
||||
(A.Several mU [A.Only mU sm1, (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several mU []), A.Only mU sm2])
|
||||
|
||||
]
|
||||
where
|
||||
testSeq' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test
|
||||
testSeq' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
|
||||
testSeq' n a b s = testSeq'' n a [0] b s
|
||||
|
||||
testSeq'' :: Int -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test
|
||||
testSeq'' :: Int -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
|
||||
testSeq'' n a r b s = testGraph ("testSeq " ++ show n) a r b (A.Seq m0 s)
|
||||
|
||||
testPar :: Test
|
||||
testPar = TestLabel "testPar" $ TestList
|
||||
[
|
||||
testPar' 0 [] [(0,99,ESeq)] (A.Several m1 [])
|
||||
,testPar' 1 [(1,m2)] [(0,1,EStartPar 0), (1,99,EEndPar 0)] (A.OnlyP m1 sm2)
|
||||
,testPar' 2 [(1,m3)] [(0,1,EStartPar 0), (1,99,EEndPar 0)] (A.Several m1 [A.OnlyP m2 sm3])
|
||||
,testPar' 1 [(1,m2)] [(0,1,EStartPar 0), (1,99,EEndPar 0)] (A.Only m1 sm2)
|
||||
,testPar' 2 [(1,m3)] [(0,1,EStartPar 0), (1,99,EEndPar 0)] (A.Several m1 [A.Only m2 sm3])
|
||||
,testPar' 3 [(1, m3), (2, m5)]
|
||||
[(0,1,EStartPar 0),(1,99,EEndPar 0), (0,2,EStartPar 0), (2,99,EEndPar 0)]
|
||||
(A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
|
||||
(A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
,testPar' 4 [(3,m3),(5,m5),(7,m7)]
|
||||
[(0,3,EStartPar 0),(3,99,EEndPar 0),(0,5,EStartPar 0),(5,99,EEndPar 0),(0,7,EStartPar 0),(7,99,EEndPar 0)]
|
||||
(A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7])
|
||||
(A.Several m1 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7])
|
||||
,testPar' 5 [(1, m3), (2, m5)]
|
||||
[(0,1,EStartPar 0),(1,99,EEndPar 0), (0,2,EStartPar 0), (2,99,EEndPar 0)]
|
||||
(A.Several mU [A.Several mU [A.OnlyP m2 sm3],A.Several mU [A.OnlyP m4 sm5]])
|
||||
(A.Several mU [A.Several mU [A.Only m2 sm3],A.Several mU [A.Only m4 sm5]])
|
||||
,testPar' 6 [(3,m3),(5,m5),(7,m7),(9,m9)]
|
||||
[(0,3,EStartPar 0), (0,5,EStartPar 0), (0,7,EStartPar 0), (0,9,EStartPar 0)
|
||||
,(3,99,EEndPar 0), (5,99,EEndPar 0), (7,99,EEndPar 0), (9,99,EEndPar 0)]
|
||||
(A.Several m1 [A.Several m10 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7], A.OnlyP m8 sm9])
|
||||
(A.Several m1 [A.Several m10 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7], A.Only m8 sm9])
|
||||
|
||||
,testPar' 10 [(1, m3), (2, m5), (6, m6),(106,sub m6 100)]
|
||||
[(0,6,EStartPar 0),(6,1,ESeq),(1,106,ESeq),(106,99,EEndPar 0), (0,2,EStartPar 0), (2,99,EEndPar 0)]
|
||||
(A.Several m1 [A.Spec mU (someSpec m6) $ A.OnlyP m2 sm3,A.OnlyP m4 sm5])
|
||||
(A.Several m1 [A.Spec mU (someSpec m6) $ A.Only m2 sm3,A.Only m4 sm5])
|
||||
,testPar' 11 [(1, m3), (2, m5), (3,m7), (6, m6),(106,sub m6 100)]
|
||||
[(0,6,EStartPar 0),(6,1,EStartPar 1),(6,2,EStartPar 1),(1,106,EEndPar 1),(2,106,EEndPar 1)
|
||||
,(106,99,EEndPar 0), (0,3,EStartPar 0), (3,99,EEndPar 0)]
|
||||
(A.Several m1 [A.Spec mU (someSpec m6) $ A.Several mU [A.OnlyP mU sm3, A.OnlyP mU sm5], A.OnlyP mU sm7])
|
||||
(A.Several m1 [A.Spec mU (someSpec m6) $ A.Several mU [A.Only mU sm3, A.Only mU sm5], A.Only mU sm7])
|
||||
|
||||
,testPar' 20 [(1,m1),(100,sub m1 100)] [(0,1,EStartPar 0),(1,100,ESeq),(100,99,EEndPar 0)] (A.Spec mU (someSpec m1) $ A.Several m4 [])
|
||||
|
||||
|
|
@ -240,7 +240,7 @@ testPar = TestLabel "testPar" $ TestList
|
|||
|
||||
,testPar' 100 [(1,m6), (2,m3), (3,m5), (4, sub m6 1)]
|
||||
[(0,1,EStartPar 0), (1,2,EStartPar 1), (2,4,EEndPar 1), (1,3,EStartPar 1), (3,4,EEndPar 1), (4,99,EEndPar 0)]
|
||||
(A.Rep m6 (A.For m6 undefined undefined undefined) $ A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
|
||||
(A.Rep m6 (A.For m6 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
|
||||
,testPar' 101 [(1,m1), (2,m2), (3,m3), (11,sub m1 1), (4,m4), (5,m5), (6,m6), (7,m7), (15, sub m5 1)]
|
||||
-- The links in the main PAR:
|
||||
|
|
@ -251,16 +251,16 @@ testPar = TestLabel "testPar" $ TestList
|
|||
,(5,6,EStartPar 2), (6,15,EEndPar 2), (5,7,EStartPar 2), (7,15,EEndPar 2)]
|
||||
|
||||
(A.Several mU
|
||||
[(A.Rep m1 (A.For m1 undefined undefined undefined) $ A.Several mU [A.OnlyP mU sm2,A.OnlyP mU sm3])
|
||||
,A.OnlyP mU sm4
|
||||
,(A.Rep m5 (A.For m5 undefined undefined undefined) $ A.Several mU [A.OnlyP mU sm6,A.OnlyP mU sm7])])
|
||||
[(A.Rep m1 (A.For m1 undefined undefined undefined) $ A.Several mU [A.Only mU sm2,A.Only mU sm3])
|
||||
,A.Only mU sm4
|
||||
,(A.Rep m5 (A.For m5 undefined undefined undefined) $ A.Several mU [A.Only mU sm6,A.Only mU sm7])])
|
||||
|
||||
,testPar' 102 [(1,m6), (4, sub m6 1)]
|
||||
[(0,1,EStartPar 0), (1,4,ESeq), (4,99,EEndPar 0)]
|
||||
(A.Rep m6 (A.For m6 undefined undefined undefined) $ A.Several mU [])
|
||||
]
|
||||
where
|
||||
testPar' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test
|
||||
testPar' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
|
||||
testPar' n a b s = testGraph ("testPar " ++ show n) (a ++ [(0,m0), (99,sub m0 1)]) [0] b (A.Par m0 A.PlainPar s)
|
||||
|
||||
testWhile :: Test
|
||||
|
|
@ -268,11 +268,11 @@ testWhile = TestLabel "testWhile" $ TestList
|
|||
[
|
||||
testGraph "testWhile 0" [(0,m0), (1,m1)] [0] [(0,1,ESeq), (1,0,ESeq)] (A.While mU (A.True m0) sm1)
|
||||
,testGraph "testWhile 1" [(2,m2), (3, m3), (5, m5)] [2] [(2,3,ESeq), (3,2,ESeq), (2,5,ESeq)]
|
||||
(A.Seq m0 $ A.Several m1 [A.OnlyP m9 $ A.While mU (A.True m2) sm3,A.OnlyP m4 sm5])
|
||||
(A.Seq m0 $ A.Several m1 [A.Only m9 $ A.While mU (A.True m2) sm3,A.Only m4 sm5])
|
||||
,testGraph "testWhile 2" [(2,m2), (3, m3), (5, m5), (7, m7)] [7] [(7,2,ESeq), (2,3,ESeq), (3,2,ESeq), (2,5,ESeq)]
|
||||
(A.Seq m0 $ A.Several m1 [A.OnlyP m6 sm7,A.OnlyP m9 $ A.While mU (A.True m2) sm3,A.OnlyP m4 sm5])
|
||||
(A.Seq m0 $ A.Several m1 [A.Only m6 sm7,A.Only m9 $ A.While mU (A.True m2) sm3,A.Only m4 sm5])
|
||||
,testGraph "testWhile 3" [(2,m2), (3, m3), (5, m5), (7, m7), (9, m9)] [7] [(7,2,ESeq), (2,3,ESeq), (3,9,ESeq), (9,2,ESeq), (2,5,ESeq)]
|
||||
(A.Seq m0 $ A.Several m1 [A.OnlyP m6 sm7,A.OnlyP mU $ A.While mU (A.True m2) $ A.Seq mU $ A.Several mU [A.OnlyP mU sm3,A.OnlyP mU sm9],A.OnlyP m4 sm5])
|
||||
(A.Seq m0 $ A.Several m1 [A.Only m6 sm7,A.Only mU $ A.While mU (A.True m2) $ A.Seq mU $ A.Several mU [A.Only mU sm3,A.Only mU sm9],A.Only m4 sm5])
|
||||
]
|
||||
|
||||
testCase :: Test
|
||||
|
|
@ -290,8 +290,8 @@ testCase = TestLabel "testCase" $ TestList
|
|||
--TODO test case statements that have specs
|
||||
]
|
||||
where
|
||||
cases :: Meta -> [A.Option] -> A.Structured
|
||||
cases m = (A.Several m) . (map (A.OnlyO mU))
|
||||
cases :: Meta -> [A.Option] -> A.Structured A.Option
|
||||
cases m = (A.Several m) . (map (A.Only mU))
|
||||
|
||||
testIf :: Test
|
||||
testIf = TestLabel "testIf" $ TestList
|
||||
|
|
@ -306,8 +306,8 @@ testIf = TestLabel "testIf" $ TestList
|
|||
(A.If m0 $ ifs mU [(A.True m2, sm3), (A.True m4, sm5), (A.True m6, sm7)])
|
||||
]
|
||||
where
|
||||
ifs :: Meta -> [(A.Expression, A.Process)] -> A.Structured
|
||||
ifs m = (A.Several m) . (map (\(e,p) -> A.OnlyC mU $ A.Choice (findMeta e) e p))
|
||||
ifs :: Meta -> [(A.Expression, A.Process)] -> A.Structured A.Choice
|
||||
ifs m = (A.Several m) . (map (\(e,p) -> A.Only mU $ A.Choice (findMeta e) e p))
|
||||
|
||||
testProcFuncSpec :: Test
|
||||
testProcFuncSpec = TestLabel "testProcFuncSpec" $ TestList
|
||||
|
|
@ -318,16 +318,16 @@ testProcFuncSpec = TestLabel "testProcFuncSpec" $ TestList
|
|||
-- Single spec of process (with body with SEQ SKIP SKIP):
|
||||
,testGraph' "testProcFuncSpec 1" [(0, m3),(1,m6),(2,sub m6 100),(4,m5), (9,m9)] [1,9] ([(1,2,ESeq)] ++ [(9,0,ESeq), (0,4,ESeq)])
|
||||
(A.Spec mU (A.Specification m6 undefined $ A.Proc m9 undefined undefined $
|
||||
A.Seq m0 $ A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5]
|
||||
A.Seq m0 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5]
|
||||
) $ A.Several mU [])
|
||||
-- Nested spec of process (with bodies with SEQ SKIP SKIP):
|
||||
,testGraph' "testProcFuncSpec 2" [(0,m6),(1,sub m6 100),(3,m2),(4,m3),(5,m4),(6,m5),(7,m7),(8,sub m7 100), (10,m10), (11, m11)] [0,10,11]
|
||||
([(0,7,ESeq), (7,8,ESeq), (8,1,ESeq)] ++ [(10,3,ESeq), (3,4,ESeq)] ++ [(11,5,ESeq), (5,6,ESeq)])
|
||||
(A.Spec mU (A.Specification m6 undefined $ A.Proc m10 undefined undefined $
|
||||
A.Seq mU $ A.Several mU [A.OnlyP mU sm2,A.OnlyP mU sm3]
|
||||
A.Seq mU $ A.Several mU [A.Only mU sm2,A.Only mU sm3]
|
||||
) $
|
||||
A.Spec mU (A.Specification m7 undefined $ A.Proc m11 undefined undefined $
|
||||
A.Seq mU $ A.Several mU [A.OnlyP mU sm4,A.OnlyP mU sm5]
|
||||
A.Seq mU $ A.Several mU [A.Only mU sm4,A.Only mU sm5]
|
||||
)
|
||||
$ A.Several mU [])
|
||||
]
|
||||
|
|
@ -528,27 +528,6 @@ sub3 x = x-3
|
|||
-- (such as for A.Alternative) you need to take account of this in its parent items, and bump
|
||||
-- up the required size for them accordingly.
|
||||
|
||||
-- | A type that indicates which of the OnlyX items are allowed in a given A.Structured.
|
||||
-- This is to avoid generating, for example, A.If with A.OnlyA things inside them.
|
||||
data OnlyAllowed = OA {
|
||||
onlyP :: Bool
|
||||
,onlyO :: Bool
|
||||
,onlyC :: Bool
|
||||
,onlyA :: Bool
|
||||
}
|
||||
|
||||
nothing = OA False False False False
|
||||
|
||||
justP = nothing {onlyP = True}
|
||||
justO = nothing {onlyO = True}
|
||||
justC = nothing {onlyC = True}
|
||||
justA = nothing {onlyA = True}
|
||||
|
||||
-- | Slightly cheaty way of easily masking out items:
|
||||
cond :: Bool -> (Int, a) -> (Int, a)
|
||||
cond True = id
|
||||
cond False = const (1000000, undefined)
|
||||
|
||||
-- | Generates a simple expression (A.True m).
|
||||
genExpression :: GenL A.Expression
|
||||
genExpression = nextIdT >>* makeMeta' >>= genElem1 A.True
|
||||
|
|
@ -564,6 +543,9 @@ genAlternative n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
|
|||
(3, genElem3 A.AlternativeSkip m genExpression . genProcess . sub2)
|
||||
]
|
||||
|
||||
genAlternative' :: (Int, Int -> GenL A.Alternative)
|
||||
genAlternative' = (3, genAlternative)
|
||||
|
||||
-- | Generates a A.Specification.
|
||||
genSpecification :: GenL A.Specification
|
||||
genSpecification = nextIdT >>* makeMeta' >>= \m -> genElem3 A.Specification m (comb0 $ simpleName "x") genSpecType
|
||||
|
|
@ -577,27 +559,48 @@ genSpecification = nextIdT >>* makeMeta' >>= \m -> genElem3 A.Specification m (c
|
|||
--TODO proc and function declaration
|
||||
]
|
||||
|
||||
genChoice :: Int -> GenL A.Choice
|
||||
genChoice n = nextIdT >>* makeMeta' >>= \m -> (comb2 (\e p -> A.Choice emptyMeta e p) genExpression . genProcess . sub2) n
|
||||
|
||||
genChoice' :: (Int, Int -> GenL A.Choice)
|
||||
genChoice' = (3, genChoice)
|
||||
|
||||
genOption :: Int -> GenL A.Option
|
||||
genOption = comb1 (A.Else emptyMeta) . genProcess . sub1
|
||||
|
||||
genOption' :: (Int, Int -> GenL A.Option)
|
||||
genOption' = (1, genOption)
|
||||
|
||||
genReplicator :: GenL A.Replicator
|
||||
genReplicator = nextIdT >>* makeMeta' >>= \m -> genElem4 A.For m (comb0 $ simpleName "i") genExpression genExpression
|
||||
|
||||
-- | Generates a A.Structured, obeying the given OnlyAllowed structure.
|
||||
genStructured :: OnlyAllowed -> Int -> GenL A.Structured
|
||||
genStructured allowed n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
|
||||
[
|
||||
cond (onlyP allowed) (2,genElem2 A.OnlyP m . genProcess . sub1 )
|
||||
,cond (onlyO allowed) (2,comb1 (A.OnlyO emptyMeta . A.Else emptyMeta) . genProcess . sub1 )
|
||||
,cond (onlyC allowed) (3,comb2 (\e p -> A.OnlyC emptyMeta $ A.Choice emptyMeta e p) genExpression . genProcess . sub2)
|
||||
,cond (onlyA allowed) (4,genElem2 A.OnlyA m . genAlternative . sub1 )
|
||||
|
||||
class ReplicatorAnnotation a where
|
||||
replicatorItem :: (Int, Int -> GenL a) -> Maybe (Int, Int -> GenL (A.Structured a))
|
||||
|
||||
replicatorItem' x = (4, genElem3 A.Rep m genReplicator . genStructured x . sub3)
|
||||
|
||||
--Replicators are allowed in ALTs, IFs, SEQs and PARs:
|
||||
|
||||
,cond (onlyP allowed || onlyC allowed || onlyA allowed)
|
||||
(4, genElem3 A.Rep m genReplicator . genStructured allowed . sub3)
|
||||
instance ReplicatorAnnotation A.Process where replicatorItem = Just . replicatorItem'
|
||||
instance ReplicatorAnnotation A.Alternative where replicatorItem = Just . replicatorItem'
|
||||
instance ReplicatorAnnotation A.Choice where replicatorItem = Just . replicatorItem'
|
||||
|
||||
instance ReplicatorAnnotation A.Option where replicatorItem = const Nothing
|
||||
|
||||
-- | Generates a A.Structured, obeying the given OnlyAllowed structure.
|
||||
genStructured :: (Data a, ReplicatorAnnotation a) => (Int, Int -> GenL a) -> Int -> GenL (A.Structured a)
|
||||
genStructured (no,genOnly) n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
|
||||
([{-
|
||||
cond (onlyP allowed) (2,genElem2 A.Only m . genProcess . sub1 )
|
||||
,cond (onlyO allowed) (2,comb1 (A.Only emptyMeta . A.Else emptyMeta) . genProcess . sub1 )
|
||||
,cond (onlyC allowed) (3,comb2 (\e p -> A.Only emptyMeta $ A.Choice emptyMeta e p) genExpression . genProcess . sub2)
|
||||
,cond (onlyA allowed) (4,genElem2 A.Only m . genAlternative . sub1 )
|
||||
-}
|
||||
(no - 1, genElem2 A.Only m . genOnly . sub1)
|
||||
|
||||
-- Specs currently don't work with Case statements TODO
|
||||
,cond (not $ onlyO allowed) (3,genElem3 A.Spec m genSpecification . genStructured allowed . sub2 )
|
||||
,(1,genElem2 A.Several m . genList (genStructured allowed) . sub1)
|
||||
]
|
||||
,(3,genElem3 A.Spec m genSpecification . genStructured (no, genOnly) . sub2 )
|
||||
,(1,genElem2 A.Several m . genList (genStructured (no, genOnly)) . sub1)
|
||||
] ++ maybeToList (replicatorItem (no,genOnly)) )
|
||||
|
||||
-- | Generates a A.Process.
|
||||
genProcess :: Int -> GenL A.Process
|
||||
|
|
@ -605,32 +608,35 @@ genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
|
|||
[
|
||||
(1,const $ genElem1 A.Skip m)
|
||||
,(1,const $ genElem1 A.Stop m)
|
||||
,(2,genElem2 A.Seq m . genStructured justP . sub1)
|
||||
,(2,genElem3 A.Par m (comb0 A.PlainPar) . genStructured justP . sub1)
|
||||
,(2,genElem2 A.Seq m . genStructured genProcess' . sub1)
|
||||
,(2,genElem3 A.Par m (comb0 A.PlainPar) . genStructured genProcess' . sub1)
|
||||
,(3,genElem3 A.While m genExpression . genProcess . sub2)
|
||||
,(2,genElem2 A.If m . genStructured justC . sub1)
|
||||
,(3,genElem3 A.Case m genExpression . genStructured justO . sub2)
|
||||
,(2,genElem2 A.If m . genStructured genChoice' . sub1)
|
||||
,(3,genElem3 A.Case m genExpression . genStructured genOption' . sub2)
|
||||
,(2,const $ genElem3 A.Assign m (comb0 [variable "x"]) genExpressionList)
|
||||
,(1,const $ genElem2 A.GetTime m (comb0 $ variable "x"))
|
||||
,(1,const $ genElem3 A.Wait m (comb0 A.WaitFor) genExpression)
|
||||
,(2,genElem3 A.Alt m (comb0 True) . genStructured justA . sub1)
|
||||
,(2,genElem3 A.Alt m (comb0 True) . genStructured genAlternative' . sub1)
|
||||
]
|
||||
|
||||
genProcess' :: (Int, Int -> GenL A.Process)
|
||||
genProcess' = (1, genProcess)
|
||||
|
||||
-- | Generates a flow-graph from the given AST.
|
||||
-- TODO put this in proper error monad
|
||||
genGraph :: A.Structured -> FlowGraph Identity ()
|
||||
genGraph :: Data a => A.Structured a -> FlowGraph' Identity () a
|
||||
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) fst $ runIdentity $ buildFlowGraph funcs s
|
||||
where
|
||||
funcs = mkLabelFuncsConst (return ())
|
||||
funcs :: GraphLabelFuncs Identity ()
|
||||
funcs = mkLabelFuncsConst (return ())
|
||||
|
||||
-- | Given a flow-graph, it returns a list of all the identity alteration functions,
|
||||
-- for each node. Applying any, many or all of these functions to the source AST
|
||||
-- should leave it unchanged.
|
||||
pickFuncId :: Monad m => FlowGraph m () -> [A.Structured -> m A.Structured]
|
||||
pickFuncId :: (Data a, Monad m) => FlowGraph' m () a -> [A.Structured a -> m (A.Structured a)]
|
||||
pickFuncId g = map (applyFunc . getFunc) (labNodes g)
|
||||
where
|
||||
getFunc (_,Node (_,_,f)) = f
|
||||
getFunc (_,n) = getNodeFunc n
|
||||
|
||||
applyFunc (AlterProcess f) = f return
|
||||
applyFunc (AlterExpression f) = f return
|
||||
|
|
@ -641,10 +647,10 @@ pickFuncId g = map (applyFunc . getFunc) (labNodes g)
|
|||
|
||||
-- | Given a flow-graph, it returns a list of the meta-tag replacement alteration functions,
|
||||
-- for each meta-tag (i.e. each node).
|
||||
pickFuncRep :: Monad m => FlowGraph m () -> Map.Map Meta (A.Structured -> m A.Structured)
|
||||
pickFuncRep :: (Data a, Monad m) => FlowGraph' m () a -> Map.Map Meta (A.Structured a -> m (A.Structured a))
|
||||
pickFuncRep gr = Map.fromList $ map (helpApplyFunc . getMetaFunc) (labNodes gr)
|
||||
where
|
||||
getMetaFunc (_,Node (m,_,f)) = (m,f)
|
||||
getMetaFunc (_,n) = (getNodeMeta n,getNodeFunc n)
|
||||
|
||||
helpApplyFunc (m,f) = (m, applyFunc (m,f))
|
||||
|
||||
|
|
@ -687,26 +693,26 @@ testModify =
|
|||
prop_Id :: QC (A.Process, Map.Map [Meta] A.Process) -> Result
|
||||
prop_Id (QC (g,_)) = collectAll $ (flip map) (map (foldFuncsM) $ powerset $ pickFuncId $ genGraph g') $ \f -> runIdentity (f g') *==* g'
|
||||
where
|
||||
g' = A.OnlyP emptyMeta g
|
||||
g' = A.Only emptyMeta g
|
||||
|
||||
-- | Checks that applying any set (from the powerset of replacement functions) of replacement functions
|
||||
-- produces the expected result.
|
||||
prop_Rep :: QC (A.Process, Map.Map [Meta] A.Process) -> Result
|
||||
prop_Rep (QC (g,rest)) = collectAll $ (flip map) (helper $ pickFuncRep $ genGraph g') $
|
||||
\(funcs,ms) -> Just (runIdentity (applyMetas ms funcs g')) *==* (Map.lookup ms rest >>* A.OnlyP emptyMeta)
|
||||
\(funcs,ms) -> Just (runIdentity (applyMetas ms funcs g')) *==* (Map.lookup ms rest >>* A.Only emptyMeta)
|
||||
where
|
||||
g' = A.OnlyP emptyMeta g
|
||||
g' = A.Only emptyMeta g
|
||||
|
||||
-- | This tests our genNumsToTotal function, which is itself a test generator; nasty!
|
||||
prop_gennums :: Int -> Result
|
||||
prop_gennums n = generate 0 (mkStdGen 0) (genNumsToTotal n >>* sum) *==* n
|
||||
|
||||
-- | Repeatedly pairs the map with each element of the powerset of its keys
|
||||
helper :: Monad m => Map.Map Meta (A.Structured -> m A.Structured) -> [(Map.Map Meta (A.Structured -> m A.Structured), [Meta])]
|
||||
helper :: Monad m => Map.Map Meta (A.Structured a -> m (A.Structured a)) -> [(Map.Map Meta (A.Structured a -> m (A.Structured a)), [Meta])]
|
||||
helper fs = zip (repeat fs) (powerset $ Map.keys fs)
|
||||
|
||||
-- | Applies the functions associated with the given meta tags
|
||||
applyMetas :: Monad m => [Meta] -> Map.Map Meta (A.Structured -> m A.Structured) -> (A.Structured -> m A.Structured)
|
||||
applyMetas :: Monad m => [Meta] -> Map.Map Meta (A.Structured a -> m (A.Structured a)) -> (A.Structured a -> m (A.Structured a))
|
||||
applyMetas ms funcs = foldFuncsM $ concatMap (\m -> Map.lookup m funcs) ms
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ instance Die PassM where
|
|||
dieReport = throwError
|
||||
|
||||
-- | The type of an AST-mangling pass.
|
||||
type Pass = A.Structured -> PassM A.Structured
|
||||
type Pass = A.AST -> PassM A.AST
|
||||
|
||||
-- | Compose a list of passes into a single pass.
|
||||
runPasses :: [(String, Pass)] -> Pass
|
||||
|
|
@ -105,3 +105,6 @@ excludeConstr cons x
|
|||
= if null items then return x else dieInternal (Nothing, "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x)
|
||||
where
|
||||
items = checkTreeForConstr cons x
|
||||
|
||||
mk1M :: (Monad m, Data a, Typeable1 t) => (forall d . Data d => t d -> m (t d)) -> a -> m a
|
||||
mk1M = ext1M return
|
||||
|
|
|
|||
|
|
@ -134,15 +134,16 @@ doPattern p@(Match c ps) =
|
|||
items = map doPattern ps
|
||||
folded = foldPatternList p
|
||||
|
||||
doAny :: (forall a. Typeable a => (a -> Doc) -> (a -> Doc)) -> GenericQ Doc
|
||||
doAny :: (forall a. Data a => (a -> Doc) -> (a -> Doc)) -> GenericQ Doc
|
||||
doAny extFunc = extFunc (
|
||||
(doGeneral anyFunc) `ext1Q` (doList anyFunc) `extQ` doString `extQ` doMeta `extQ` doPattern
|
||||
`extQ` (doMap anyFunc :: Map.Map String String -> Doc)
|
||||
`extQ` (doMap anyFunc :: Map.Map String A.NameDef -> Doc)
|
||||
`extQ` (doMap anyFunc :: Map.Map String [A.Type] -> Doc)
|
||||
`extQ` (doMap anyFunc :: Map.Map String [A.Actual] -> Doc)
|
||||
`extQ` (doSet anyFunc :: Set.Set String -> Doc)
|
||||
`extQ` (doSet anyFunc :: Set.Set A.Name -> Doc)
|
||||
-- `extQ` (doSet anyFunc :: Set.Set String -> Doc)
|
||||
-- `extQ` (doSet anyFunc :: Set.Set A.Name -> Doc)
|
||||
`ext1Q` (doSet anyFunc)
|
||||
)
|
||||
where
|
||||
anyFunc :: GenericQ Doc
|
||||
|
|
@ -159,7 +160,7 @@ pshowCode c = do st <- get
|
|||
FrontendOccam -> return $ render $ (extOccam $ doAny extOccam) c
|
||||
FrontendRain -> return $ render $ (extRain $ doAny extRain) c
|
||||
where
|
||||
extOccam :: forall a. Typeable a => (a -> Doc) -> (a -> Doc)
|
||||
extOccam :: forall a. (Data a, Typeable a) => (a -> Doc) -> (a -> Doc)
|
||||
extOccam f = extCode f showOccam
|
||||
extRain :: forall a. Typeable a => (a -> Doc) -> (a -> Doc)
|
||||
extRain :: forall a. (Data a, Typeable a) => (a -> Doc) -> (a -> Doc)
|
||||
extRain f = extCode f showRain
|
||||
|
|
|
|||
|
|
@ -390,7 +390,7 @@ instance ShowOccam A.Specification where
|
|||
+>> occamOutdent
|
||||
+>> (showOccamLine colon)
|
||||
--TODO use the specmode
|
||||
showOccamM (A.Specification _ n (A.Function _ sm retTypes params el@(A.OnlyEL {})))
|
||||
showOccamM (A.Specification _ n (A.Function _ sm retTypes params el@(A.Only {})))
|
||||
= showOccamLine $
|
||||
showWithCommas retTypes +>> (return " FUNCTION ") +>> showName n +>> return "(" +>> showWithCommas params +>> return ")"
|
||||
+>> return " IS " +>> showOccamM el +>> colon
|
||||
|
|
@ -461,17 +461,12 @@ instance ShowOccam A.Option where
|
|||
showOccamM (A.Option _ es p) = showOccamLine (showAll $ intersperse (return " , ") $ map showOccamM es) +>> occamBlock (showOccamM p)
|
||||
showOccamM (A.Else _ p) = showOccamLine (return "ELSE") +>> occamBlock (showOccamM p)
|
||||
|
||||
instance ShowOccam A.Structured where
|
||||
instance (Data a, ShowOccam a) => ShowOccam (A.Structured a) where
|
||||
showOccamM (A.Spec _ spec str) = showOccamM spec +>> showOccamM str
|
||||
showOccamM (A.Rep _ rep str)
|
||||
= do item <- currentContext
|
||||
(showOccamLine (return (item ++ " ") +>> showOccamM rep)) +>> occamIndent +>> showOccamM str +>> occamOutdent
|
||||
showOccamM (A.OnlyP _ p) = showOccamM p
|
||||
showOccamM (A.OnlyEL _ el) = showOccamM el
|
||||
showOccamM (A.OnlyA _ a) = showOccamM a
|
||||
showOccamM (A.OnlyV _ v) = showOccamM v
|
||||
showOccamM (A.OnlyC _ c) = showOccamM c
|
||||
showOccamM (A.OnlyO _ o) = showOccamM o
|
||||
showOccamM (A.Only _ p) = showOccamM p
|
||||
showOccamM (A.Several _ ss) = showAll $ map showOccamM ss
|
||||
showOccamM (A.ProcThen _ p str) = showOccamLine (return "VALOF") +>> occamBlock (showOccamM p +>> showOccamLine (return "RESULT " +>> showOccamM str))
|
||||
|
||||
|
|
@ -485,7 +480,7 @@ instance ShowOccam A.ExpressionList where
|
|||
showOccamM (A.ExpressionList _ es) = showWithCommas es
|
||||
--TODO functioncalllist
|
||||
|
||||
outer :: String -> A.Structured -> OccamWriter String
|
||||
outer :: (Data a, ShowOccam a) => String -> A.Structured a -> OccamWriter String
|
||||
outer keyword (A.Rep _ rep str) = showOccamLine (return keyword +>> showOccamM rep) +>> beginStr keyword +>> showOccamM str +>> endStr
|
||||
outer keyword str = doStr keyword (showOccamM str)
|
||||
|
||||
|
|
@ -523,7 +518,7 @@ instance ShowRain a where
|
|||
-- ShowOccam\/ShowRain implementation. But since to add a type to the ShowOccam\/ShowRain
|
||||
-- classes you have to provide a specific instance above anyway, I don't think that adding
|
||||
-- one more line while you're at it is too bad.
|
||||
extCode :: Typeable b => (b -> Doc) -> (forall a. (ShowOccam a, ShowRain a) => a -> String) -> (b -> Doc)
|
||||
extCode :: (Data b, Typeable b) => (b -> Doc) -> (forall a. (ShowOccam a, ShowRain a) => a -> String) -> (b -> Doc)
|
||||
extCode q f = q
|
||||
`extQ` (text . (f :: A.DyadicOp -> String))
|
||||
`extQ` (text . (f :: A.Expression -> String))
|
||||
|
|
@ -533,9 +528,10 @@ extCode q f = q
|
|||
`extQ` (text . (f :: A.Process -> String))
|
||||
`extQ` (text . (f :: A.Replicator -> String))
|
||||
`extQ` (text . (f :: A.Specification -> String))
|
||||
`extQ` (text . (f :: A.Structured -> String))
|
||||
`extQ` (text . (f :: A.Type -> String))
|
||||
`extQ` (text . (f :: A.Variable -> String))
|
||||
--TODO
|
||||
-- `ext1Q` (text . (f :: (Data c, ShowOccam c) => A.Structured c -> String))
|
||||
|
||||
(+>>) :: State s [a] -> State s [a] -> State s [a]
|
||||
(+>>) x y = do x' <- x
|
||||
|
|
|
|||
|
|
@ -223,15 +223,15 @@ makeSimpleAssignPattern lhs rhs = stopCaringPattern emptyMeta $ mkPattern $ make
|
|||
|
||||
-- | Turns a list of 'A.Process' into a 'A.Seq' with those processes in order, with empty meta tags.
|
||||
makeSeq :: [A.Process] -> A.Process
|
||||
makeSeq procList = A.Seq emptyMeta $ A.Several emptyMeta (map (\x -> A.OnlyP emptyMeta x) procList)
|
||||
makeSeq procList = A.Seq emptyMeta $ A.Several emptyMeta (map (A.Only emptyMeta) procList)
|
||||
|
||||
-- | Turns a list of 'A.Process' into a 'A.Par' with those processes in order (with type 'A.PlainPar'), with empty meta tags.
|
||||
makePar :: [A.Process] -> A.Process
|
||||
makePar procList = A.Par emptyMeta A.PlainPar $ A.Several emptyMeta (map (\x -> A.OnlyP emptyMeta x) procList)
|
||||
makePar procList = A.Par emptyMeta A.PlainPar $ A.Several emptyMeta (map (A.Only emptyMeta) procList)
|
||||
|
||||
-- | Wraps the given process in a replicated 'A.Par' of the form PAR i = 0 FOR 3.
|
||||
makeRepPar :: A.Process -> A.Process
|
||||
makeRepPar proc = A.Par emptyMeta A.PlainPar $ A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (intLiteral 3)) (A.OnlyP emptyMeta proc)
|
||||
makeRepPar proc = A.Par emptyMeta A.PlainPar $ A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (intLiteral 3)) (A.Only emptyMeta proc)
|
||||
|
||||
-- | Creates an assignment to the given 'A.Variable' from the given 'A.Expression.'
|
||||
makeAssign :: A.Variable -> A.Expression -> A.Process
|
||||
|
|
|
|||
|
|
@ -572,7 +572,7 @@ sizeOfReplicator :: A.Replicator -> A.Expression
|
|||
sizeOfReplicator (A.For _ _ _ count) = count
|
||||
|
||||
-- | Get the number of items in a Structured as an expression.
|
||||
sizeOfStructured :: A.Structured -> A.Expression
|
||||
sizeOfStructured :: Data a => A.Structured a -> A.Expression
|
||||
sizeOfStructured (A.Rep m rep s)
|
||||
= A.Dyadic m A.Times (sizeOfReplicator rep) (sizeOfStructured s)
|
||||
sizeOfStructured (A.Spec _ _ s) = sizeOfStructured s
|
||||
|
|
|
|||
|
|
@ -1339,7 +1339,7 @@ definition
|
|||
(rs, sm) <- tryVV (sepBy1 dataType sComma) (specMode sFUNCTION)
|
||||
n <- newFunctionName
|
||||
fs <- formalList
|
||||
do { sIS; fs' <- scopeInFormals fs; el <- expressionList rs; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (A.OnlyEL m el) }
|
||||
do { sIS; fs' <- scopeInFormals fs; el <- expressionList rs; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (A.Only m el) }
|
||||
<|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess rs; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' vp }
|
||||
<|> retypesAbbrev
|
||||
<?> "definition"
|
||||
|
|
@ -1476,7 +1476,7 @@ formalVariableType
|
|||
return (A.Abbrev, s)
|
||||
<?> "formal variable type"
|
||||
|
||||
valueProcess :: [A.Type] -> OccParser A.Structured
|
||||
valueProcess :: [A.Type] -> OccParser (A.Structured A.ExpressionList)
|
||||
valueProcess rs
|
||||
= do m <- md
|
||||
sVALOF
|
||||
|
|
@ -1487,7 +1487,7 @@ valueProcess rs
|
|||
el <- expressionList rs
|
||||
eol
|
||||
outdent
|
||||
return $ A.ProcThen m p (A.OnlyEL m el)
|
||||
return $ A.ProcThen m p (A.Only m el)
|
||||
<|> handleSpecs specification (valueProcess rs) A.Spec
|
||||
<?> "value process"
|
||||
--}}}
|
||||
|
|
@ -1536,7 +1536,7 @@ process
|
|||
<|> procInstance
|
||||
<|> intrinsicProc
|
||||
<|> handleSpecs (allocation <|> specification) process
|
||||
(\m s p -> A.Seq m (A.Spec m s (A.OnlyP m p)))
|
||||
(\m s p -> A.Seq m (A.Spec m s (A.Only m p)))
|
||||
<?> "process"
|
||||
|
||||
--{{{ assignment (:=)
|
||||
|
|
@ -1585,7 +1585,7 @@ channelInput
|
|||
do sCASE
|
||||
tl <- taggedList nts
|
||||
eol
|
||||
return (c, A.InputCase m (A.OnlyV m (tl (A.Skip m))))
|
||||
return (c, A.InputCase m (A.Only m (tl (A.Skip m))))
|
||||
<?> "channel input"
|
||||
|
||||
timerInput :: OccParser (A.Variable, A.InputMode)
|
||||
|
|
@ -1641,7 +1641,7 @@ caseInput
|
|||
return $ A.Input m c (A.InputCase m (A.Several m vs))
|
||||
<?> "case input"
|
||||
|
||||
variant :: [(A.Name, [A.Type])] -> OccParser A.Structured
|
||||
variant :: [(A.Name, [A.Type])] -> OccParser (A.Structured A.Variant)
|
||||
variant nts
|
||||
= do m <- md
|
||||
tl <- taggedList nts
|
||||
|
|
@ -1649,7 +1649,7 @@ variant nts
|
|||
indent
|
||||
p <- process
|
||||
outdent
|
||||
return $ A.OnlyV m (tl p)
|
||||
return $ A.Only m (tl p)
|
||||
<|> handleSpecs specification (variant nts) A.Spec
|
||||
<?> "variant"
|
||||
--}}}
|
||||
|
|
@ -1710,8 +1710,8 @@ seqProcess :: OccParser A.Process
|
|||
seqProcess
|
||||
= do m <- md
|
||||
sSEQ
|
||||
do { eol; ps <- maybeIndentedList m "empty SEQ" process; return $ A.Seq m (A.Several m (map (A.OnlyP m) ps)) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.Seq m (A.Rep m r' (A.OnlyP m p)) }
|
||||
do { eol; ps <- maybeIndentedList m "empty SEQ" process; return $ A.Seq m (A.Several m (map (A.Only m) ps)) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.Seq m (A.Rep m r' (A.Only m p)) }
|
||||
<?> "SEQ process"
|
||||
--}}}
|
||||
--{{{ IF
|
||||
|
|
@ -1722,7 +1722,7 @@ ifProcess
|
|||
return $ A.If m c
|
||||
<?> "IF process"
|
||||
|
||||
conditional :: OccParser A.Structured
|
||||
conditional :: OccParser (A.Structured A.Choice)
|
||||
conditional
|
||||
= do m <- md
|
||||
sIF
|
||||
|
|
@ -1730,14 +1730,14 @@ conditional
|
|||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; c <- ifChoice; scopeOutRep r'; outdent; return $ A.Rep m r' c }
|
||||
<?> "conditional"
|
||||
|
||||
ifChoice :: OccParser A.Structured
|
||||
ifChoice :: OccParser (A.Structured A.Choice)
|
||||
ifChoice
|
||||
= guardedChoice
|
||||
<|> conditional
|
||||
<|> handleSpecs specification ifChoice A.Spec
|
||||
<?> "choice"
|
||||
|
||||
guardedChoice :: OccParser A.Structured
|
||||
guardedChoice :: OccParser (A.Structured A.Choice)
|
||||
guardedChoice
|
||||
= do m <- md
|
||||
b <- booleanExpr
|
||||
|
|
@ -1745,7 +1745,7 @@ guardedChoice
|
|||
indent
|
||||
p <- process
|
||||
outdent
|
||||
return $ A.OnlyC m (A.Choice m b p)
|
||||
return $ A.Only m (A.Choice m b p)
|
||||
<?> "guarded choice"
|
||||
--}}}
|
||||
--{{{ CASE
|
||||
|
|
@ -1762,21 +1762,21 @@ caseProcess
|
|||
return $ A.Case m sel (A.Several m os)
|
||||
<?> "CASE process"
|
||||
|
||||
caseOption :: A.Type -> OccParser A.Structured
|
||||
caseOption :: A.Type -> OccParser (A.Structured A.Option)
|
||||
caseOption t
|
||||
= do m <- md
|
||||
ces <- tryVX (sepBy (constExprOfType t) sComma) eol
|
||||
indent
|
||||
p <- process
|
||||
outdent
|
||||
return $ A.OnlyO m (A.Option m ces p)
|
||||
return $ A.Only m (A.Option m ces p)
|
||||
<|> do m <- md
|
||||
sELSE
|
||||
eol
|
||||
indent
|
||||
p <- process
|
||||
outdent
|
||||
return $ A.OnlyO m (A.Else m p)
|
||||
return $ A.Only m (A.Else m p)
|
||||
<|> handleSpecs specification (caseOption t) A.Spec
|
||||
<?> "option"
|
||||
--}}}
|
||||
|
|
@ -1798,8 +1798,8 @@ parallel :: OccParser A.Process
|
|||
parallel
|
||||
= do m <- md
|
||||
isPri <- parKeyword
|
||||
do { eol; ps <- maybeIndentedList m "empty PAR" process; return $ A.Par m isPri (A.Several m (map (A.OnlyP m) ps)) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.Par m isPri (A.Rep m r' (A.OnlyP m p)) }
|
||||
do { eol; ps <- maybeIndentedList m "empty PAR" process; return $ A.Par m isPri (A.Several m (map (A.Only m) ps)) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.Par m isPri (A.Rep m r' (A.Only m p)) }
|
||||
<|> processor
|
||||
<?> "PAR process"
|
||||
|
||||
|
|
@ -1830,7 +1830,7 @@ altProcess
|
|||
return $ A.Alt m isPri a
|
||||
<?> "ALT process"
|
||||
|
||||
alternation :: OccParser (Bool, A.Structured)
|
||||
alternation :: OccParser (Bool, A.Structured A.Alternative)
|
||||
alternation
|
||||
= do m <- md
|
||||
isPri <- altKeyword
|
||||
|
|
@ -1846,7 +1846,7 @@ altKeyword
|
|||
-- The reason the CASE guards end up here is because they have to be handled
|
||||
-- specially: you can't tell until parsing the guts of the CASE what the processes
|
||||
-- are.
|
||||
alternative :: OccParser A.Structured
|
||||
alternative :: OccParser (A.Structured A.Alternative)
|
||||
alternative
|
||||
-- FIXME: Check we don't have PRI ALT inside ALT.
|
||||
= do (isPri, a) <- alternation
|
||||
|
|
@ -1857,24 +1857,24 @@ alternative
|
|||
(b, c) <- tryVXVXX booleanExpr sAmp channel sQuest (sCASE >> eol)
|
||||
nts <- caseInputItems c
|
||||
vs <- maybeIndentedList m "empty ? CASE" (variant nts)
|
||||
return $ A.OnlyA m (A.AlternativeCond m b c (A.InputCase m $ A.Several m vs) (A.Skip m))
|
||||
return $ A.Only m (A.AlternativeCond m b c (A.InputCase m $ A.Several m vs) (A.Skip m))
|
||||
<|> do m <- md
|
||||
c <- tryVXX channel sQuest (sCASE >> eol)
|
||||
nts <- caseInputItems c
|
||||
vs <- maybeIndentedList m "empty ? CASE" (variant nts)
|
||||
return $ A.OnlyA m (A.Alternative m c (A.InputCase m $ A.Several m vs) (A.Skip m))
|
||||
return $ A.Only m (A.Alternative m c (A.InputCase m $ A.Several m vs) (A.Skip m))
|
||||
<|> guardedAlternative
|
||||
<|> handleSpecs specification alternative A.Spec
|
||||
<?> "alternative"
|
||||
|
||||
guardedAlternative :: OccParser A.Structured
|
||||
guardedAlternative :: OccParser (A.Structured A.Alternative)
|
||||
guardedAlternative
|
||||
= do m <- md
|
||||
makeAlt <- guard
|
||||
indent
|
||||
p <- process
|
||||
outdent
|
||||
return $ A.OnlyA m (makeAlt p)
|
||||
return $ A.Only m (makeAlt p)
|
||||
<?> "guarded alternative"
|
||||
|
||||
guard :: OccParser (A.Process -> A.Alternative)
|
||||
|
|
@ -1943,7 +1943,7 @@ intrinsicProc
|
|||
--}}}
|
||||
--{{{ top-level forms
|
||||
|
||||
topLevelItem :: OccParser A.Structured
|
||||
topLevelItem :: OccParser A.AST
|
||||
topLevelItem = handleSpecs (allocation <|> specification) topLevelItem
|
||||
(\m s inner -> A.Spec m s inner)
|
||||
<|> do m <- md
|
||||
|
|
@ -1959,7 +1959,7 @@ topLevelItem = handleSpecs (allocation <|> specification) topLevelItem
|
|||
-- A source file is really a series of specifications, but the later ones need to
|
||||
-- have the earlier ones in scope, so we can't parse them separately.
|
||||
-- Instead, we nest the specifications
|
||||
sourceFile :: OccParser (A.Structured, CompState)
|
||||
sourceFile :: OccParser (A.AST, CompState)
|
||||
sourceFile
|
||||
= do p <- topLevelItem
|
||||
s <- getState
|
||||
|
|
@ -1976,7 +1976,7 @@ runTockParser toks prod cs
|
|||
Right r -> return r
|
||||
|
||||
-- | Parse an occam program.
|
||||
parseOccamProgram :: [Token] -> PassM A.Structured
|
||||
parseOccamProgram :: [Token] -> PassM A.AST
|
||||
parseOccamProgram toks
|
||||
= do cs <- get
|
||||
(p, cs') <- runTockParser toks sourceFile cs
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ module ParseRain where
|
|||
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.State (MonadState, liftIO, get, put)
|
||||
import Data.Generics
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified IO
|
||||
|
|
@ -243,22 +244,22 @@ expression
|
|||
data InnerBlockLineState = Decls | NoMoreDecls | Mixed deriving (Eq)
|
||||
|
||||
|
||||
innerBlock :: Bool -> RainParser A.Structured
|
||||
innerBlock :: Bool -> RainParser (A.Structured A.Process)
|
||||
innerBlock declsMustBeFirst = do m <- sLeftC
|
||||
lines <- linesToEnd (if declsMustBeFirst then Decls else Mixed)
|
||||
case lines of
|
||||
Left single -> return single
|
||||
Right lines -> return $ A.Several m lines
|
||||
where
|
||||
wrapProc :: A.Process -> A.Structured
|
||||
wrapProc x = A.OnlyP (findMeta x) x
|
||||
wrapProc :: A.Process -> A.Structured A.Process
|
||||
wrapProc x = A.Only (findMeta x) x
|
||||
|
||||
makeList :: Either A.Structured [A.Structured] -> [A.Structured]
|
||||
makeList :: Either (A.Structured A.Process) [A.Structured A.Process] -> [A.Structured A.Process]
|
||||
makeList (Left s) = [s]
|
||||
makeList (Right ss) = ss
|
||||
|
||||
--Returns either a single line (which means the immediate next line is a declaration) or a list of remaining lines
|
||||
linesToEnd :: InnerBlockLineState -> RainParser (Either A.Structured [A.Structured])
|
||||
linesToEnd :: InnerBlockLineState -> RainParser (Either (A.Structured A.Process) [A.Structured A.Process])
|
||||
linesToEnd state
|
||||
= (if state /= NoMoreDecls then
|
||||
do (m,decl) <- declaration
|
||||
|
|
@ -270,8 +271,10 @@ innerBlock declsMustBeFirst = do m <- sLeftC
|
|||
<|> do {st <- statement ; rest <- linesToEnd nextState ; return $ Right $ (wrapProc st) : (makeList rest)}
|
||||
--Although return is technically a statement, we parse it here because it can only occur inside a block,
|
||||
--and we don't want to wrap it in an A.OnlyP:
|
||||
{- TODO parse return again
|
||||
<|> do {m <- sReturn ; exp <- expression ; sSemiColon ; rest <- linesToEnd nextState ;
|
||||
return $ Right $ (A.OnlyEL m $ A.ExpressionList (findMeta exp) [exp]) : (makeList rest)}
|
||||
-}
|
||||
<|> do {sRightC ; return $ Right []}
|
||||
<?> "statement, declaration, or end of block"
|
||||
where
|
||||
|
|
@ -298,9 +301,9 @@ assignOp
|
|||
|
||||
each :: RainParser A.Process
|
||||
each = do { m <- sPareach ; sLeftR ; n <- name ; sColon ; exp <- expression ; sRightR ; st <- block ;
|
||||
return $ A.Par m A.PlainPar $ A.Rep m (A.ForEach m n exp) $ A.OnlyP m st }
|
||||
return $ A.Par m A.PlainPar $ A.Rep m (A.ForEach m n exp) $ A.Only m st }
|
||||
<|> do { m <- sSeqeach ; sLeftR ; n <- name ; sColon ; exp <- expression ; sRightR ; st <- block ;
|
||||
return $ A.Seq m $ A.Rep m (A.ForEach m n exp) $ A.OnlyP m st }
|
||||
return $ A.Seq m $ A.Rep m (A.ForEach m n exp) $ A.Only m st }
|
||||
|
||||
comm :: Bool -> RainParser A.Process
|
||||
comm isAlt
|
||||
|
|
@ -321,18 +324,18 @@ alt = do {m <- sPri ; sAlt ; m' <- sLeftC ; cases <- many altCase ; optElseCase
|
|||
singleton :: RainParser a -> RainParser [a]
|
||||
singleton p = do {a <- p ; return [a]}
|
||||
|
||||
altCase :: RainParser A.Structured
|
||||
altCase :: RainParser (A.Structured A.Alternative)
|
||||
altCase = do input <- comm True
|
||||
case input of
|
||||
A.Input m lv im -> do { body <- block ; return $ A.OnlyA m $ A.Alternative m lv im body }
|
||||
A.Input m lv im -> do { body <- block ; return $ A.Only m $ A.Alternative m lv im body }
|
||||
_ -> dieP (findMeta input) $ "communication type not supported in an alt: \"" ++ show input ++ "\""
|
||||
<|> do (m, wm, e) <- waitStatement True
|
||||
body <- block
|
||||
return $ A.OnlyA m $ A.AlternativeWait m wm e body
|
||||
elseCase :: RainParser A.Structured
|
||||
return $ A.Only m $ A.AlternativeWait m wm e body
|
||||
elseCase :: RainParser (A.Structured A.Alternative)
|
||||
elseCase = do m <- sElse
|
||||
body <- block
|
||||
return $ A.OnlyA m $ A.AlternativeSkip m (A.True m) body
|
||||
return $ A.Only m $ A.AlternativeSkip m (A.True m) body
|
||||
|
||||
tuple :: RainParser [A.Expression]
|
||||
tuple = do { sLeftR ; items <- expression `sepBy` sComma ; sRightR ; return items }
|
||||
|
|
@ -363,8 +366,8 @@ statement :: RainParser A.Process
|
|||
statement
|
||||
= do { m <- sWhile ; sLeftR ; exp <- expression ; sRightR ; st <- block ; return $ A.While m exp st}
|
||||
<|> do { m <- sIf ; sLeftR ; exp <- expression ; sRightR ; st <- block ;
|
||||
option (A.If m $ A.Several m [A.OnlyC m (A.Choice m exp st), A.OnlyC m (A.Choice m (A.True m) (A.Skip m))])
|
||||
(do {sElse ; elSt <- block ; return (A.If m $ A.Several m [A.OnlyC m (A.Choice m exp st), A.OnlyC m (A.Choice m (A.True m) elSt)])})
|
||||
option (A.If m $ A.Several m [A.Only m (A.Choice m exp st), A.Only m (A.Choice m (A.True m) (A.Skip m))])
|
||||
(do {sElse ; elSt <- block ; return (A.If m $ A.Several m [A.Only m (A.Choice m exp st), A.Only m (A.Choice m (A.True m) elSt)])})
|
||||
}
|
||||
<|> block
|
||||
<|> each
|
||||
|
|
@ -389,41 +392,41 @@ tupleDef = do {sLeftR ; tm <- sepBy tupleDefMember sComma ; sRightR ; return tm}
|
|||
tupleDefMember :: RainParser (A.Name,A.Type)
|
||||
tupleDefMember = do {t <- dataType ; sColon ; n <- name ; return (n,t)}
|
||||
|
||||
declaration :: RainParser (Meta,A.Structured -> A.Structured)
|
||||
declaration :: Data a => RainParser (Meta, A.Structured a -> A.Structured a)
|
||||
declaration = try $ do {t <- dataType; sColon ; ns <- name `sepBy1` sComma ; sSemiColon ;
|
||||
return (findMeta t, \x -> foldr (foldSpec t) x ns) }
|
||||
where
|
||||
foldSpec :: A.Type -> A.Name -> (A.Structured -> A.Structured)
|
||||
foldSpec :: Data a => A.Type -> A.Name -> (A.Structured a -> A.Structured a)
|
||||
foldSpec t n = A.Spec (findMeta t) $ A.Specification (findMeta t) n $ A.Declaration (findMeta t) t Nothing
|
||||
|
||||
terminator :: A.Structured
|
||||
terminator :: Data a => A.Structured a
|
||||
terminator = A.Several emptyMeta []
|
||||
|
||||
processDecl :: RainParser A.Structured
|
||||
processDecl :: RainParser A.AST
|
||||
processDecl = do {m <- sProcess ; procName <- name ; params <- tupleDef ; body <- block ;
|
||||
return $ A.Spec m
|
||||
(A.Specification m procName (A.Proc m A.PlainSpec (formaliseTuple params) body))
|
||||
terminator}
|
||||
|
||||
functionDecl :: RainParser A.Structured
|
||||
functionDecl :: RainParser A.AST
|
||||
functionDecl = do {m <- sFunction ; retType <- dataType ; sColon ; funcName <- name ; params <- tupleDef ; body <- block ;
|
||||
return $ A.Spec m
|
||||
(A.Specification m funcName (A.Function m A.PlainSpec [retType] (formaliseTuple params) (A.OnlyP (findMeta body) body)))
|
||||
return {- $ A.Spec m TODO handle functions again
|
||||
(A.Specification m funcName (A.Function m A.PlainSpec [retType] (formaliseTuple params) (A.Only (findMeta body) body))) -}
|
||||
terminator}
|
||||
|
||||
topLevelDecl :: RainParser A.Structured
|
||||
topLevelDecl :: RainParser A.AST
|
||||
topLevelDecl = do decls <- many (processDecl <|> functionDecl <?> "process or function declaration")
|
||||
eof
|
||||
return $ A.Several emptyMeta decls
|
||||
|
||||
rainSourceFile :: RainParser (A.Structured, CompState)
|
||||
rainSourceFile :: RainParser (A.AST, CompState)
|
||||
rainSourceFile
|
||||
= do p <- topLevelDecl
|
||||
s <- getState
|
||||
return (p, s)
|
||||
|
||||
-- | Load and parse a Rain source file.
|
||||
parseRainProgram :: String -> PassM A.Structured
|
||||
parseRainProgram :: String -> PassM A.AST
|
||||
parseRainProgram filename
|
||||
= do source <- liftIO $ readFile filename
|
||||
lexOut <- liftIO $ L.runLexer filename source
|
||||
|
|
|
|||
|
|
@ -90,9 +90,12 @@ testParseFail (text,prod)
|
|||
Right result -> assertFailure ("Test was expected to fail:\n***BEGIN CODE***\n" ++ text ++ "\n*** END CODE ***\n")
|
||||
where parser = do { p <- prod ; eof ; return p}
|
||||
|
||||
emptySeveral :: A.Structured
|
||||
emptySeveral :: Data a => A.Structured a
|
||||
emptySeveral = A.Several m []
|
||||
|
||||
emptySeveralAST :: A.AST
|
||||
emptySeveralAST = emptySeveral
|
||||
|
||||
-- | A handy synonym for the empty block
|
||||
emptyBlock :: A.Process
|
||||
emptyBlock = A.Seq m emptySeveral
|
||||
|
|
@ -266,8 +269,8 @@ testRange =
|
|||
makeIf :: [(A.Expression,A.Process)] -> A.Process
|
||||
makeIf list = A.If m $ A.Several m (map makeChoice list)
|
||||
where
|
||||
makeChoice :: (A.Expression,A.Process) -> A.Structured
|
||||
makeChoice (exp,proc) = A.OnlyC m $ A.Choice m exp proc
|
||||
makeChoice :: (A.Expression,A.Process) -> A.Structured A.Choice
|
||||
makeChoice (exp,proc) = A.Only m $ A.Choice m exp proc
|
||||
|
||||
dyExp :: A.DyadicOp -> A.Variable -> A.Variable -> A.Expression
|
||||
dyExp op v0 v1 = A.Dyadic m op (A.ExprVariable m v0) (A.ExprVariable m v1)
|
||||
|
|
@ -355,19 +358,19 @@ testPar =
|
|||
[
|
||||
passPar (0, "par { }", A.Par m A.PlainPar $ A.Several m [] )
|
||||
|
||||
,passPar (1, "par { {} {} }", A.Par m A.PlainPar $ A.Several m [A.OnlyP m emptyBlock, A.OnlyP m emptyBlock] )
|
||||
,passPar (1, "par { {} {} }", A.Par m A.PlainPar $ A.Several m [A.Only m emptyBlock, A.Only m emptyBlock] )
|
||||
|
||||
--Rain only allows declarations at the beginning of a par block:
|
||||
|
||||
,passPar (2, "par {int:x; {} }", A.Par m A.PlainPar $
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Int Nothing) $
|
||||
A.Several m [A.OnlyP m $ A.Seq m $ A.Several m []] )
|
||||
A.Several m [A.Only m $ A.Seq m $ A.Several m []] )
|
||||
|
||||
|
||||
,passPar (3, "par {uint16:x; uint32:y; {} }", A.Par m A.PlainPar $
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.UInt16 Nothing) $
|
||||
A.Spec m (A.Specification m (simpleName "y") $ A.Declaration m A.UInt32 Nothing) $
|
||||
A.Several m [A.OnlyP m $ A.Seq m $ A.Several m []] )
|
||||
A.Several m [A.Only m $ A.Seq m $ A.Several m []] )
|
||||
|
||||
,fail ("par { {} int: x; }",RP.statement)
|
||||
]
|
||||
|
|
@ -376,26 +379,26 @@ testPar =
|
|||
passPar (ind, input, exp) = pass (input,RP.statement, assertPatternMatch ("testPar " ++ show ind) (pat exp))
|
||||
|
||||
-- | Test innerBlock, particularly with declarations mixed with statements:
|
||||
testBlock :: [ParseTest A.Structured]
|
||||
testBlock :: [ParseTest (A.Structured A.Process)]
|
||||
testBlock =
|
||||
[
|
||||
passBlock (0, "{ a = b; }", False, A.Several m [A.OnlyP m $ makeSimpleAssign "a" "b"])
|
||||
passBlock (0, "{ a = b; }", False, A.Several m [A.Only m $ makeSimpleAssign "a" "b"])
|
||||
|
||||
,passBlock (1, "{ a = b; b = c; }", False,
|
||||
A.Several m [A.OnlyP m $ makeSimpleAssign "a" "b",A.OnlyP m $ makeSimpleAssign "b" "c"])
|
||||
A.Several m [A.Only m $ makeSimpleAssign "a" "b",A.Only m $ makeSimpleAssign "b" "c"])
|
||||
|
||||
,passBlock (2, "{ uint8: x; a = b; }", False,
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Byte noInit) $
|
||||
A.Several m [A.OnlyP m $ makeSimpleAssign "a" "b"])
|
||||
A.Several m [A.Only m $ makeSimpleAssign "a" "b"])
|
||||
|
||||
,passBlock (3, "{ uint8: x; a = b; b = c; }", False,
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Byte noInit) $
|
||||
A.Several m [A.OnlyP m $ makeSimpleAssign "a" "b",A.OnlyP m $ makeSimpleAssign "b" "c"])
|
||||
A.Several m [A.Only m $ makeSimpleAssign "a" "b",A.Only m $ makeSimpleAssign "b" "c"])
|
||||
|
||||
,passBlock (4, "{ b = c; uint8: x; a = b; }", False,
|
||||
A.Several m [A.OnlyP m $ makeSimpleAssign "b" "c",
|
||||
A.Several m [A.Only m $ makeSimpleAssign "b" "c",
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Byte noInit) $
|
||||
A.Several m [A.OnlyP m $ makeSimpleAssign "a" "b"]
|
||||
A.Several m [A.Only m $ makeSimpleAssign "a" "b"]
|
||||
])
|
||||
|
||||
,passBlock (5, "{ uint8: x; }", False,
|
||||
|
|
@ -404,7 +407,7 @@ testBlock =
|
|||
,fail("{b}",RP.innerBlock False)
|
||||
]
|
||||
where
|
||||
passBlock :: (Int, String, Bool, A.Structured) -> ParseTest A.Structured
|
||||
passBlock :: (Int, String, Bool, A.Structured A.Process) -> ParseTest (A.Structured A.Process)
|
||||
passBlock (ind, input, b, exp) = pass (input, RP.innerBlock b, assertPatternMatch ("testBlock " ++ show ind) (pat exp))
|
||||
|
||||
testEach :: [ParseTest A.Process]
|
||||
|
|
@ -412,13 +415,13 @@ testEach =
|
|||
[
|
||||
pass ("seqeach (c : \"1\") par {c = 7;}", RP.statement,
|
||||
assertPatternMatch "Each Test 0" (pat $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "1")) $
|
||||
A.OnlyP m $ makePar [(makeAssign (variable "c") (A.Literal m A.Int (A.IntLiteral m "7")))] ))
|
||||
A.Only m $ makePar [(makeAssign (variable "c") (A.Literal m A.Int (A.IntLiteral m "7")))] ))
|
||||
,pass ("pareach (c : \"345\") {c = 1; c = 2;}", RP.statement,
|
||||
assertPatternMatch "Each Test 1" $ pat $ A.Par m A.PlainPar $ A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "345")) $
|
||||
A.OnlyP m $ makeSeq[(makeAssign (variable "c") (A.Literal m A.Int (A.IntLiteral m "1"))),(makeAssign (variable "c") (A.Literal m A.Int (A.IntLiteral m "2")))] )
|
||||
A.Only m $ makeSeq[(makeAssign (variable "c") (A.Literal m A.Int (A.IntLiteral m "1"))),(makeAssign (variable "c") (A.Literal m A.Int (A.IntLiteral m "2")))] )
|
||||
]
|
||||
|
||||
testTopLevelDecl :: [ParseTest A.Structured]
|
||||
testTopLevelDecl :: [ParseTest A.AST]
|
||||
testTopLevelDecl =
|
||||
[
|
||||
passTop (0, "process noargs() {}",
|
||||
|
|
@ -447,22 +450,24 @@ testTopLevelDecl =
|
|||
, fail ("process foo (int: x)", RP.topLevelDecl)
|
||||
, fail ("process foo (int x) {}", RP.topLevelDecl)
|
||||
|
||||
{- TODO get functions going again
|
||||
,passTop (100, "function uint8: cons() {}",
|
||||
[A.Spec m (A.Specification m (simpleName "cons") $ A.Function m A.PlainSpec [A.Byte] [] $ A.OnlyP m emptyBlock) emptySeveral])
|
||||
[A.Spec m (A.Specification m (simpleName "cons") $ A.Function m A.PlainSpec [A.Byte] [] $ A.Only m emptyBlock) emptySeveral])
|
||||
|
||||
,passTop (101, "function uint8: f(uint8: x) {}",
|
||||
[A.Spec m (A.Specification m (simpleName "f") $
|
||||
A.Function m A.PlainSpec [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $ A.OnlyP m emptyBlock)
|
||||
A.Function m A.PlainSpec [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $ A.Only m emptyBlock)
|
||||
emptySeveral])
|
||||
|
||||
,passTop (102, "function uint8: id(uint8: x) {return x;}",
|
||||
[A.Spec m (A.Specification m (simpleName "id") $
|
||||
A.Function m A.PlainSpec [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $
|
||||
A.OnlyP m $ A.Seq m $ A.Several m [A.OnlyEL m $ A.ExpressionList m [exprVariable "x"]])
|
||||
A.Only m $ A.Seq m $ A.Several m [A.Only m $ A.ExpressionList m [exprVariable "x"]])
|
||||
emptySeveral])
|
||||
-}
|
||||
]
|
||||
where
|
||||
passTop :: (Int, String, [A.Structured]) -> ParseTest A.Structured
|
||||
passTop :: (Int, String, [A.AST]) -> ParseTest A.AST
|
||||
passTop (ind, input, exp) = pass (input, RP.topLevelDecl, assertPatternMatch ("testTopLevelDecl " ++ show ind) $ pat $ A.Several m exp)
|
||||
|
||||
nonShared :: A.ChanAttributes
|
||||
|
|
@ -507,7 +512,10 @@ testDataType =
|
|||
,pass ("timer",RP.dataType,assertEqual "testDataType 301" $ A.UserDataType $ typeName "timer")
|
||||
]
|
||||
|
||||
testDecl :: [ParseTest (Meta, A.Structured -> A.Structured)]
|
||||
instance Data a => Show (A.Structured a -> A.Structured a) where
|
||||
show _ = "<function over Structured"
|
||||
|
||||
testDecl :: [ParseTest (Meta, A.AST -> A.AST)]
|
||||
testDecl =
|
||||
[
|
||||
passd ("bool: b;",0,pat $ A.Specification m (simpleName "b") $ A.Declaration m A.Bool noInit)
|
||||
|
|
@ -530,15 +538,17 @@ testDecl =
|
|||
,fail ("bool: b0 b1;",RP.declaration)
|
||||
]
|
||||
where
|
||||
passd :: (String,Int,Pattern) -> ParseTest (Meta, A.Structured -> A.Structured)
|
||||
specAST = (A.Spec :: Meta -> A.Specification -> A.AST -> A.AST)
|
||||
|
||||
passd :: (String,Int,Pattern) -> ParseTest (Meta, A.AST -> A.AST)
|
||||
passd (code,index,exp) = pass(code,RP.declaration,check ("testDecl " ++ (show index)) exp)
|
||||
check :: String -> Pattern -> (Meta, A.Structured -> A.Structured) -> Assertion
|
||||
check msg spec (_,act) = assertPatternMatch msg (tag3 A.Spec DontCare spec $ emptySeveral) (act $ emptySeveral)
|
||||
check :: String -> Pattern -> (Meta, A.AST -> A.AST) -> Assertion
|
||||
check msg spec (_,act) = assertPatternMatch msg (tag3 specAST DontCare spec $ emptySeveralAST) (act $ emptySeveralAST)
|
||||
|
||||
passd2 :: (String,Int,Pattern,Pattern) -> ParseTest (Meta, A.Structured -> A.Structured)
|
||||
passd2 :: (String,Int,Pattern,Pattern) -> ParseTest (Meta, A.AST -> A.AST)
|
||||
passd2 (code,index,expOuter,expInner) = pass(code,RP.declaration,check2 ("testDecl " ++ (show index)) expOuter expInner)
|
||||
check2 :: String -> Pattern -> Pattern -> (Meta, A.Structured -> A.Structured) -> Assertion
|
||||
check2 msg specOuter specInner (_,act) = assertPatternMatch msg (tag3 A.Spec DontCare specOuter $ tag3 A.Spec DontCare specInner $ A.Several m []) (act $ A.Several m [])
|
||||
check2 :: String -> Pattern -> Pattern -> (Meta, A.AST -> A.AST) -> Assertion
|
||||
check2 msg specOuter specInner (_,act) = assertPatternMatch msg (tag3 specAST DontCare specOuter $ tag3 specAST DontCare specInner $ emptySeveralAST) (act $ emptySeveralAST)
|
||||
|
||||
testComm :: [ParseTest A.Process]
|
||||
testComm =
|
||||
|
|
@ -571,26 +581,26 @@ testAlt :: [ParseTest A.Process]
|
|||
testAlt =
|
||||
[
|
||||
passAlt (0, "pri alt {}", A.Alt m True $ A.Several m [])
|
||||
,passAlt (1, "pri alt { c ? x {} }", A.Alt m True $ A.Several m [A.OnlyA m $ A.Alternative m
|
||||
,passAlt (1, "pri alt { c ? x {} }", A.Alt m True $ A.Several m [A.Only m $ A.Alternative m
|
||||
(variable "c") (A.InputSimple m [A.InVariable m (variable "x")]) emptyBlock])
|
||||
,passAlt (2, "pri alt { c ? x {} d ? y {} }", A.Alt m True $ A.Several m [
|
||||
A.OnlyA m $ A.Alternative m (variable "c") (A.InputSimple m [A.InVariable m (variable "x")]) emptyBlock
|
||||
,A.OnlyA m $ A.Alternative m (variable "d") (A.InputSimple m [A.InVariable m (variable "y")]) emptyBlock])
|
||||
A.Only m $ A.Alternative m (variable "c") (A.InputSimple m [A.InVariable m (variable "x")]) emptyBlock
|
||||
,A.Only m $ A.Alternative m (variable "d") (A.InputSimple m [A.InVariable m (variable "y")]) emptyBlock])
|
||||
--Fairly nonsensical, but valid:
|
||||
,passAlt (3, "pri alt { else {} }", A.Alt m True $ A.Several m [
|
||||
A.OnlyA m $ A.AlternativeSkip m (A.True m) emptyBlock])
|
||||
A.Only m $ A.AlternativeSkip m (A.True m) emptyBlock])
|
||||
,passAlt (4, "pri alt { c ? x {} else {} }", A.Alt m True $ A.Several m [
|
||||
A.OnlyA m $ A.Alternative m (variable "c") (A.InputSimple m [A.InVariable m (variable "x")]) emptyBlock
|
||||
,A.OnlyA m $ A.AlternativeSkip m (A.True m) emptyBlock])
|
||||
A.Only m $ A.Alternative m (variable "c") (A.InputSimple m [A.InVariable m (variable "x")]) emptyBlock
|
||||
,A.Only m $ A.AlternativeSkip m (A.True m) emptyBlock])
|
||||
|
||||
,passAlt (100, "pri alt { wait for t {} }", A.Alt m True $ A.Several m [
|
||||
A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t") emptyBlock])
|
||||
A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t") emptyBlock])
|
||||
,passAlt (101, "pri alt { wait for t {} wait until t {} }", A.Alt m True $ A.Several m [
|
||||
A.OnlyA m $ A.AlternativeWait m A.WaitFor (exprVariable "t") emptyBlock
|
||||
,A.OnlyA m $ A.AlternativeWait m A.WaitUntil (exprVariable "t") emptyBlock])
|
||||
A.Only m $ A.AlternativeWait m A.WaitFor (exprVariable "t") emptyBlock
|
||||
,A.Only m $ A.AlternativeWait m A.WaitUntil (exprVariable "t") emptyBlock])
|
||||
,passAlt (102, "pri alt { wait until t + t {} else {} }", A.Alt m True $ A.Several m [
|
||||
A.OnlyA m $ A.AlternativeWait m A.WaitUntil (buildExpr $ Dy (Var "t") A.Plus (Var "t")) emptyBlock
|
||||
,A.OnlyA m $ A.AlternativeSkip m (A.True m) emptyBlock])
|
||||
A.Only m $ A.AlternativeWait m A.WaitUntil (buildExpr $ Dy (Var "t") A.Plus (Var "t")) emptyBlock
|
||||
,A.Only m $ A.AlternativeSkip m (A.True m) emptyBlock])
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -86,9 +86,9 @@ transformInt = everywhereM (mkM transformInt')
|
|||
-- This may seem like three passes in one, but if you try to separate them out, it just ends up
|
||||
-- with more confusion and more code.
|
||||
uniquifyAndResolveVars :: Data t => t -> PassM t
|
||||
uniquifyAndResolveVars = everywhereM (mkM uniquifyAndResolveVars')
|
||||
uniquifyAndResolveVars = everywhereM (mk1M uniquifyAndResolveVars')
|
||||
where
|
||||
uniquifyAndResolveVars' :: A.Structured -> PassM A.Structured
|
||||
uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
|
||||
--Variable declarations:
|
||||
uniquifyAndResolveVars' (A.Spec m (A.Specification m' n decl@(A.Declaration {})) scope)
|
||||
|
|
@ -164,9 +164,9 @@ checkIntegral _ = Nothing
|
|||
|
||||
-- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops
|
||||
transformEachRange :: Data t => t -> PassM t
|
||||
transformEachRange = everywhereM (mkM transformEachRange')
|
||||
transformEachRange = everywhereM (mk1M transformEachRange')
|
||||
where
|
||||
transformEachRange' :: A.Structured -> PassM A.Structured
|
||||
transformEachRange' :: forall a. Data a => A.Structured a -> PassM (A.Structured a)
|
||||
transformEachRange' s@(A.Rep m _ _)
|
||||
= case getMatchedItems patt s of
|
||||
Left _ -> return s --Doesn't match, return the original
|
||||
|
|
@ -183,7 +183,8 @@ transformEachRange = everywhereM (mkM transformEachRange')
|
|||
) body
|
||||
else dieP eachMeta "Items in range constructor (x..y) are not integer literals"
|
||||
where
|
||||
patt = tag3 A.Rep (Named "repMeta" DontCare) (
|
||||
patt :: Pattern
|
||||
patt = tag3 (A.Rep :: Meta -> A.Replicator -> A.Structured a -> A.Structured a) (Named "repMeta" DontCare) (
|
||||
tag3 A.ForEach (Named "eachMeta" DontCare) (Named "loopVar" DontCare) $
|
||||
tag2 A.ExprConstr DontCare $
|
||||
tag3 A.RangeConstr DontCare (tag3 A.Literal DontCare DontCare $ Named "begin" DontCare)
|
||||
|
|
@ -197,9 +198,9 @@ transformEachRange = everywhereM (mkM transformEachRange')
|
|||
|
||||
-- | A pass that changes all the 'A.ForEach' replicators in the AST into 'A.For' replicators.
|
||||
transformEach :: Data t => t -> PassM t
|
||||
transformEach = everywhereM (mkM transformEach')
|
||||
transformEach = everywhereM (mk1M transformEach')
|
||||
where
|
||||
transformEach' :: A.Structured -> PassM A.Structured
|
||||
transformEach' :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
transformEach' (A.Rep m (A.ForEach m' loopVar loopExp) s)
|
||||
= do (spec,var,am) <- case loopExp of
|
||||
(A.ExprVariable _ v) -> return (id,v,A.Abbrev)
|
||||
|
|
@ -246,12 +247,12 @@ transformRangeRep = everywhereM (mkM transformRangeRep')
|
|||
transformRangeRep' s = return s
|
||||
|
||||
transformFunction :: Data t => t -> PassM t
|
||||
transformFunction = everywhereM (mkM transformFunction')
|
||||
transformFunction = return {- TODO handle functions again everywhereM (mkM transformFunction')
|
||||
where
|
||||
transformFunction' :: A.SpecType -> PassM A.SpecType
|
||||
transformFunction' (A.Function m specMode types params body)
|
||||
= case body of
|
||||
(A.OnlyP _ (A.Seq m' (A.Several m'' statements))) ->
|
||||
(A.Only _ (A.Seq m' (A.Several m'' statements))) ->
|
||||
if (null statements)
|
||||
then dieP m "Functions must not have empty bodies"
|
||||
else case (last statements) of
|
||||
|
|
@ -262,6 +263,7 @@ transformFunction = everywhereM (mkM transformFunction')
|
|||
_ -> dieP m "Functions must have a return statement as their last statement"
|
||||
_ -> dieP m "Functions must have seq[uential] bodies"
|
||||
transformFunction' s = return s
|
||||
-}
|
||||
|
||||
pullUpParDeclarations :: Data t => t -> PassM t
|
||||
pullUpParDeclarations = everywhereM (mkM pullUpParDeclarations')
|
||||
|
|
@ -269,11 +271,11 @@ pullUpParDeclarations = everywhereM (mkM pullUpParDeclarations')
|
|||
pullUpParDeclarations' :: A.Process -> PassM A.Process
|
||||
pullUpParDeclarations' p@(A.Par m mode inside)
|
||||
= case chaseSpecs inside of
|
||||
Just (specs, innerCode) -> return $ A.Seq m $ specs $ A.OnlyP m $ A.Par m mode innerCode
|
||||
Just (specs, innerCode) -> return $ A.Seq m $ specs $ A.Only m $ A.Par m mode innerCode
|
||||
Nothing -> return p
|
||||
pullUpParDeclarations' p = return p
|
||||
|
||||
chaseSpecs :: A.Structured -> Maybe (A.Structured -> A.Structured, A.Structured)
|
||||
chaseSpecs :: A.Structured A.Process -> Maybe (A.Structured A.Process -> A.Structured A.Process, A.Structured A.Process)
|
||||
chaseSpecs (A.Spec m spec inner)
|
||||
= case chaseSpecs inner of
|
||||
Nothing -> Just (A.Spec m spec,inner)
|
||||
|
|
|
|||
|
|
@ -45,9 +45,9 @@ import TagAST
|
|||
import TestUtils
|
||||
import TreeUtils
|
||||
|
||||
-- | A helper function that returns a simple A.Structured item (A.OnlyP m $ A.Skip m).
|
||||
skipP :: A.Structured
|
||||
skipP = A.OnlyP m (A.Skip m)
|
||||
-- | A helper function that returns a simple A.Structured A.Process item (A.Only m $ A.Skip m).
|
||||
skipP :: A.Structured A.Process
|
||||
skipP = A.Only m (A.Skip m)
|
||||
|
||||
-- | A function that tries to cast a given value into the return type, and dies (using "dieInternal")
|
||||
-- if the cast isn't valid.
|
||||
|
|
@ -65,16 +65,16 @@ testEachPass0 = TestCase $ testPassWithItemsStateCheck "testEachPass0" exp (tran
|
|||
orig = A.Seq m
|
||||
(A.Rep m
|
||||
(A.ForEach m (simpleName "c") (makeLiteralStringRain "1"))
|
||||
(A.OnlyP m (makeAssign (variable "c") (intLiteral 7)))
|
||||
(A.Only m (makeAssign (variable "c") (intLiteral 7)))
|
||||
)
|
||||
exp = mSeq
|
||||
(mSpec
|
||||
(mSpecP
|
||||
(mSpecification listVarName
|
||||
(mIsExpr A.ValAbbrev (A.List A.Byte) (makeLiteralStringRain "1"))
|
||||
)
|
||||
(mRep
|
||||
(mRepP
|
||||
(mFor indexVar (intLiteral 0) (tag2 A.SizeVariable DontCare listVar))
|
||||
(mSpec
|
||||
(mSpecP
|
||||
(mSpecification (simpleName "c")
|
||||
--ValAbbrev because we are abbreviating an expression:
|
||||
(mIs A.ValAbbrev A.Byte
|
||||
|
|
@ -84,7 +84,7 @@ testEachPass0 = TestCase $ testPassWithItemsStateCheck "testEachPass0" exp (tran
|
|||
)
|
||||
)
|
||||
)
|
||||
(A.OnlyP m (makeAssign (variable "c") (intLiteral 7)))
|
||||
(A.Only m (makeAssign (variable "c") (intLiteral 7)))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -114,12 +114,12 @@ testEachPass1 = TestCase $ testPassWithItemsStateCheck "testEachPass0" exp (tran
|
|||
orig = A.Par m A.PlainPar
|
||||
(A.Rep m
|
||||
(A.ForEach m (simpleName "c") (A.ExprVariable m (variable "d")))
|
||||
(A.OnlyP m (makeAssign (variable "c") (intLiteral 7)))
|
||||
(A.Only m (makeAssign (variable "c") (intLiteral 7)))
|
||||
)
|
||||
exp = tag3 A.Par DontCare A.PlainPar
|
||||
(tag3 A.Rep DontCare
|
||||
(mRepP
|
||||
(tag4 A.For DontCare indexVar (intLiteral 0) (tag2 A.SizeVariable DontCare (variable "d")))
|
||||
(tag3 A.Spec DontCare
|
||||
(mSpecP
|
||||
(tag3 A.Specification DontCare (simpleName "c")
|
||||
(tag4 A.Is DontCare A.Abbrev A.Byte
|
||||
(tag3 A.SubscriptedVariable DontCare
|
||||
|
|
@ -128,7 +128,7 @@ testEachPass1 = TestCase $ testPassWithItemsStateCheck "testEachPass0" exp (tran
|
|||
)
|
||||
)
|
||||
)
|
||||
(A.OnlyP m (makeAssign (variable "c") (intLiteral 7)))
|
||||
(A.Only m (makeAssign (variable "c") (intLiteral 7)))
|
||||
)
|
||||
)
|
||||
indexVar = Named "indexVar" DontCare
|
||||
|
|
@ -145,40 +145,40 @@ testEachRangePass0 = TestCase $ testPass "testEachRangePass0" exp (transformEach
|
|||
where
|
||||
orig = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m (intLiteral 0) (intLiteral 9))))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral 0) (intLiteral 10))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
testEachRangePass1 :: Test
|
||||
testEachRangePass1 = TestCase $ testPass "testEachRangePass1" exp (transformEachRange orig) (return ())
|
||||
where
|
||||
orig = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m (intLiteral (-5)) (intLiteral (-2)))))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral (-5)) (intLiteral 4))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
testEachRangePass2 :: Test
|
||||
testEachRangePass2 = TestCase $ testPass "testEachRangePass2" exp (transformEachRange orig) (return ())
|
||||
where
|
||||
orig = A.Seq m $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m (intLiteral 6) (intLiteral 6))))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Seq m $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral 6) (intLiteral 1))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
testEachRangePass3 :: Test
|
||||
testEachRangePass3 = TestCase $ testPass "testEachRangePass3" exp (transformEachRange orig) (return ())
|
||||
where
|
||||
orig = A.Seq m $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m (intLiteral 6) (intLiteral 0))))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Seq m $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral 6) (intLiteral (-5)))
|
||||
(A.OnlyP m (makeSimpleAssign "c" "x"))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
|
||||
-- | Test variable is made unique in a declaration:
|
||||
|
|
@ -186,7 +186,7 @@ testUnique0 :: Test
|
|||
testUnique0 = TestCase $ testPassWithItemsStateCheck "testUnique0" exp (uniquifyAndResolveVars orig) (return ()) check
|
||||
where
|
||||
orig = A.Spec m (A.Specification m (simpleName "c") $ A.Declaration m A.Byte Nothing) skipP
|
||||
exp = tag3 A.Spec DontCare (tag3 A.Specification DontCare ("newc"@@DontCare) $ A.Declaration m A.Byte Nothing) skipP
|
||||
exp = mSpecP (tag3 A.Specification DontCare ("newc"@@DontCare) $ A.Declaration m A.Byte Nothing) skipP
|
||||
check (items,state)
|
||||
= do newcName <- castAssertADI (Map.lookup "newc" items)
|
||||
assertNotEqual "testUnique0: Variable was not made unique" "c" (A.nameName newcName)
|
||||
|
|
@ -199,8 +199,8 @@ testUnique1 = TestCase $ testPassWithItemsStateCheck "testUnique1" exp (uniquify
|
|||
where
|
||||
orig = A.Several m [A.Spec m (A.Specification m (simpleName "c") $ A.Declaration m A.Byte Nothing) skipP,
|
||||
A.Spec m (A.Specification m (simpleName "c") $ A.Declaration m A.Int64 Nothing) skipP]
|
||||
exp = tag2 A.Several m [tag3 A.Spec DontCare (tag3 A.Specification DontCare ("newc0"@@DontCare) $ A.Declaration m A.Byte Nothing) skipP,
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare ("newc1"@@DontCare) $ A.Declaration m A.Int64 Nothing) skipP]
|
||||
exp = mSeveralP [mSpecP (tag3 A.Specification DontCare ("newc0"@@DontCare) $ A.Declaration m A.Byte Nothing) skipP,
|
||||
mSpecP (tag3 A.Specification DontCare ("newc1"@@DontCare) $ A.Declaration m A.Int64 Nothing) skipP]
|
||||
check (items,state)
|
||||
= do newc0Name <- castAssertADI (Map.lookup "newc0" items)
|
||||
newc1Name <- castAssertADI (Map.lookup "newc1" items)
|
||||
|
|
@ -216,9 +216,9 @@ testUnique1 = TestCase $ testPassWithItemsStateCheck "testUnique1" exp (uniquify
|
|||
testUnique2 :: Test
|
||||
testUnique2 = TestCase $ testPassWithItemsStateCheck "testUnique2" exp (uniquifyAndResolveVars orig) (return ()) check
|
||||
where
|
||||
orig = A.Spec m (A.Specification m (simpleName "c") $ A.Declaration m A.Byte Nothing) (A.OnlyP m $ makeSimpleAssign "c" "d")
|
||||
exp = tag3 A.Spec DontCare (tag3 A.Specification DontCare ("newc"@@DontCare) $ A.Declaration m A.Byte Nothing)
|
||||
(tag2 A.OnlyP m $ tag3 A.Assign DontCare [tag2 A.Variable DontCare ("newc"@@DontCare)] (tag2 A.ExpressionList DontCare [(exprVariable "d")]))
|
||||
orig = A.Spec m (A.Specification m (simpleName "c") $ A.Declaration m A.Byte Nothing) (A.Only m $ makeSimpleAssign "c" "d")
|
||||
exp = mSpecP (tag3 A.Specification DontCare ("newc"@@DontCare) $ A.Declaration m A.Byte Nothing)
|
||||
(mOnlyP' m $ tag3 A.Assign DontCare [tag2 A.Variable DontCare ("newc"@@DontCare)] (tag2 A.ExpressionList DontCare [(exprVariable "d")]))
|
||||
check (items,state) = do newcName <- castAssertADI (Map.lookup "newc" items)
|
||||
assertNotEqual "testUnique2: Variable was not made unique" "c" (A.nameName newcName)
|
||||
|
||||
|
|
@ -227,11 +227,11 @@ testUnique2b :: Test
|
|||
testUnique2b = TestCase $ testPassWithItemsStateCheck "testUnique2b" exp (uniquifyAndResolveVars orig) (return ()) check
|
||||
where
|
||||
orig = A.Spec m (A.Specification m (simpleName "c") $ A.Declaration m A.Byte Nothing) $
|
||||
A.Several m [(A.OnlyP m $ makeSimpleAssign "c" "d"),(A.OnlyP m $ makeSimpleAssign "c" "e")]
|
||||
exp = tag3 A.Spec DontCare (tag3 A.Specification DontCare ("newc"@@DontCare) $ A.Declaration m A.Byte Nothing) $
|
||||
tag2 A.Several DontCare [
|
||||
(tag2 A.OnlyP m $ tag3 A.Assign DontCare [tag2 A.Variable DontCare ("newc"@@DontCare)] (tag2 A.ExpressionList DontCare [(exprVariable "d")]))
|
||||
,(tag2 A.OnlyP m $ tag3 A.Assign DontCare [tag2 A.Variable DontCare ("newc"@@DontCare)] (tag2 A.ExpressionList DontCare [(exprVariable "e")]))
|
||||
A.Several m [(A.Only m $ makeSimpleAssign "c" "d"),(A.Only m $ makeSimpleAssign "c" "e")]
|
||||
exp = mSpecP (tag3 A.Specification DontCare ("newc"@@DontCare) $ A.Declaration m A.Byte Nothing) $
|
||||
mSeveralP [
|
||||
(mOnlyP' m $ tag3 A.Assign DontCare [tag2 A.Variable DontCare ("newc"@@DontCare)] (tag2 A.ExpressionList DontCare [(exprVariable "d")]))
|
||||
,(mOnlyP' m $ tag3 A.Assign DontCare [tag2 A.Variable DontCare ("newc"@@DontCare)] (tag2 A.ExpressionList DontCare [(exprVariable "e")]))
|
||||
]
|
||||
check (items,state) = do newcName <- castAssertADI (Map.lookup "newc" items)
|
||||
assertNotEqual "testUnique2: Variable was not made unique" "c" (A.nameName newcName)
|
||||
|
|
@ -241,7 +241,7 @@ testUnique2b = TestCase $ testPassWithItemsStateCheck "testUnique2b" exp (uniqui
|
|||
testUnique3 :: Test
|
||||
testUnique3 = TestCase $ testPassWithItemsStateCheck "testUnique3" exp (uniquifyAndResolveVars orig) (return ()) check
|
||||
where
|
||||
orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m A.PlainSpec [] $ A.Skip m) (A.OnlyP m $ A.ProcCall m (procName "foo") [])
|
||||
orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m A.PlainSpec [] $ A.Skip m) (A.Only m $ A.ProcCall m (procName "foo") [])
|
||||
exp = orig
|
||||
check (items,state) = assertVarDef "testUnique3: Variable was not recorded" state "foo"
|
||||
(tag7 A.NameDef DontCare "foo" "foo" A.ProcName (A.Proc m A.PlainSpec [] $ A.Skip m) A.Original A.Unplaced)
|
||||
|
|
@ -252,7 +252,7 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp (uniquify
|
|||
where
|
||||
orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m A.PlainSpec [A.Formal A.ValAbbrev A.Byte $ simpleName "c"] $
|
||||
A.ProcCall m (procName "foo") [A.ActualExpression A.Byte $ exprVariable "c"]) (skipP)
|
||||
exp = tag3 A.Spec DontCare
|
||||
exp = mSpecP
|
||||
(tag3 A.Specification DontCare (procNamePattern "foo") $ tag4 A.Proc DontCare A.PlainSpec
|
||||
[tag3 A.Formal A.ValAbbrev A.Byte newc]
|
||||
(bodyPattern newc)
|
||||
|
|
@ -302,7 +302,7 @@ testRecordInfNames2 = TestCase $ testPassWithStateCheck "testRecordInfNames2" ex
|
|||
startState' :: State CompState ()
|
||||
startState' = do defineName (simpleName "multi") $ simpleDef "multi" (A.Declaration m (A.List $ A.List A.Byte) Nothing)
|
||||
orig = A.Rep m (A.ForEach m (simpleName "c") (exprVariable "multi")) $
|
||||
A.OnlyP m $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "d") (exprVariable "c")) skipP
|
||||
A.Only m $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "d") (exprVariable "c")) skipP
|
||||
exp = orig
|
||||
check state = do assertVarDef "testRecordInfNames2" state "c"
|
||||
(tag7 A.NameDef DontCare "c" "c" A.VariableName (A.Declaration m (A.List A.Byte) Nothing) A.Original A.Unplaced)
|
||||
|
|
@ -327,9 +327,9 @@ testRecordInfNames3 = TestCase $ testPassShouldFail "testRecordInfNames3" (recor
|
|||
testFindMain0 :: Test
|
||||
testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
|
||||
where
|
||||
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m []
|
||||
exp = tag3 A.Spec DontCare (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $
|
||||
tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) $ tag2 A.Several DontCare ([] :: [A.Structured])
|
||||
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m [] :: A.AST
|
||||
exp = mSpecAST (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $
|
||||
tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) $ mSeveralAST ([] :: [A.AST])
|
||||
check (items,state)
|
||||
= do mainName <- castAssertADI (Map.lookup "main" items)
|
||||
assertNotEqual "testFindMain0 A" "main" mainName
|
||||
|
|
@ -340,17 +340,17 @@ testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp ((uni
|
|||
testFindMain1 :: Test
|
||||
testFindMain1 = TestCase $ testPassWithStateCheck "testFindMain1" orig ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
|
||||
where
|
||||
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m []
|
||||
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $ A.Several m ([] :: [A.AST])
|
||||
check state = assertEqual "testFindMain1" [] (csMainLocals state)
|
||||
|
||||
testFindMain2 :: Test
|
||||
testFindMain2 = TestCase $ testPassWithItemsStateCheck "testFindMain2" exp ((uniquifyAndResolveVars >>> findMain) orig) (return ()) check
|
||||
where
|
||||
inner = A.Spec m (A.Specification m (A.Name m A.ProcName "foo") $ A.Proc m A.PlainSpec [] (A.Skip m)) $
|
||||
A.Several m []
|
||||
A.Several m ([] :: [A.AST])
|
||||
orig = A.Spec m (A.Specification m (A.Name m A.ProcName "main") $ A.Proc m A.PlainSpec [] (A.Skip m)) inner
|
||||
|
||||
exp = tag3 A.Spec DontCare (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $
|
||||
exp = mSpecAST (tag3 A.Specification DontCare (tag3 A.Name DontCare A.ProcName ("main"@@DontCare)) $
|
||||
tag4 A.Proc DontCare A.PlainSpec ([] :: [A.Formal]) (tag1 A.Skip DontCare)) (stopCaringPattern m $ mkPattern inner)
|
||||
check (items,state)
|
||||
= do mainName <- castAssertADI (Map.lookup "main" items)
|
||||
|
|
@ -380,7 +380,7 @@ testParamPass testName formals params transParams
|
|||
startStateFunc = do defineName (simpleName "x") $ simpleDefDecl "x" (A.UInt16)
|
||||
case formals of
|
||||
Nothing -> return ()
|
||||
Just formals' -> defineName (funcName "foo") $ simpleDef "foo" $ A.Function m A.PlainSpec [A.Byte] formals' (A.OnlyP m $ A.Skip m)
|
||||
Just formals' -> defineName (funcName "foo") $ simpleDef "foo" $ A.Function m A.PlainSpec [A.Byte] formals' (A.Only m $ A.ExpressionList m [])
|
||||
origProc = A.ProcCall m (procName "foo") params
|
||||
expProc ps = A.ProcCall m (procName "foo") ps
|
||||
origFunc = A.FunctionCall m (funcName "foo") (deActualise params)
|
||||
|
|
@ -474,17 +474,18 @@ testRangeRepPass1 = TestCase $ testPassShouldFail "testRangeRepPass1" (transform
|
|||
|
||||
--TODO consider/test pulling up the definitions of variables involved in return statements in functions
|
||||
|
||||
{-
|
||||
-- | Test a fairly standard function:
|
||||
testTransformFunction0 :: Test
|
||||
testTransformFunction0 = TestCase $ testPass "testTransformFunction0" exp (transformFunction orig) (return ())
|
||||
where
|
||||
orig = A.Specification m (procName "id") $
|
||||
A.Function m A.PlainSpec [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $
|
||||
(A.OnlyP m $ A.Seq m $ A.Several m [A.OnlyEL m $ A.ExpressionList m [exprVariable "x"]])
|
||||
(A.Only m $ A.Seq m $ A.Several m [A.Only m $ A.ExpressionList m [exprVariable "x"]])
|
||||
exp = tag3 A.Specification DontCare (procNamePattern "id") $
|
||||
tag5 A.Function DontCare A.PlainSpec [A.Byte] [tag3 A.Formal A.ValAbbrev A.Byte (simpleNamePattern "x")] $
|
||||
tag3 A.ProcThen DontCare (tag2 A.Seq DontCare $ tag2 A.Several DontCare ([] :: [A.Structured])) $
|
||||
tag2 A.OnlyEL DontCare $ tag2 A.ExpressionList DontCare [exprVariablePattern "x"]
|
||||
tag3 A.ProcThen DontCare (tag2 A.Seq DontCare $ mSeveralP DontCare []) $
|
||||
mOnlyEL $ tag2 A.ExpressionList DontCare [exprVariablePattern "x"]
|
||||
|
||||
-- | Test a function without a return as the final statement:
|
||||
testTransformFunction1 :: Test
|
||||
|
|
@ -492,8 +493,8 @@ testTransformFunction1 = TestCase $ testPassShouldFail "testTransformFunction1"
|
|||
where
|
||||
orig = A.Specification m (procName "brokenid") $
|
||||
A.Function m A.PlainSpec [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $
|
||||
(A.OnlyP m $ A.Seq m $ A.Several m [])
|
||||
|
||||
(A.Only m $ A.Seq m $ A.Several m [])
|
||||
-}
|
||||
testPullUpParDecl0 :: Test
|
||||
testPullUpParDecl0 = TestCase $ testPass "testPullUpParDecl0" orig (pullUpParDeclarations orig) (return ())
|
||||
where
|
||||
|
|
@ -504,7 +505,7 @@ testPullUpParDecl1 = TestCase $ testPass "testPullUpParDecl1" exp (pullUpParDecl
|
|||
where
|
||||
orig = A.Par m A.PlainPar $
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Int Nothing) (A.Several m [])
|
||||
exp = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Int Nothing) (A.OnlyP m $ A.Par m A.PlainPar $ A.Several m [])
|
||||
exp = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Int Nothing) (A.Only m $ A.Par m A.PlainPar $ A.Several m [])
|
||||
|
||||
testPullUpParDecl2 :: Test
|
||||
testPullUpParDecl2 = TestCase $ testPass "testPullUpParDecl2" exp (pullUpParDeclarations orig) (return ())
|
||||
|
|
@ -515,7 +516,7 @@ testPullUpParDecl2 = TestCase $ testPass "testPullUpParDecl2" exp (pullUpParDecl
|
|||
(A.Several m [])
|
||||
exp = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Declaration m A.Int Nothing)
|
||||
$ A.Spec m (A.Specification m (simpleName "y") $ A.Declaration m A.Byte Nothing)
|
||||
(A.OnlyP m $ A.Par m A.PlainPar $ A.Several m [])
|
||||
(A.Only m $ A.Par m A.PlainPar $ A.Several m [])
|
||||
|
||||
---Returns the list of tests:
|
||||
tests :: Test
|
||||
|
|
@ -551,8 +552,9 @@ tests = TestLabel "RainPassesTest" $ TestList
|
|||
,testParamPass8
|
||||
,testRangeRepPass0
|
||||
,testRangeRepPass1
|
||||
,testTransformFunction0
|
||||
,testTransformFunction1
|
||||
-- TODO get functions working again
|
||||
-- ,testTransformFunction0
|
||||
-- ,testTransformFunction1
|
||||
,testPullUpParDecl0
|
||||
,testPullUpParDecl1
|
||||
,testPullUpParDecl2
|
||||
|
|
|
|||
|
|
@ -287,8 +287,8 @@ checkExpressionTest = TestList
|
|||
passWhileIf n exp src = TestList
|
||||
[
|
||||
TestCase $ testPass ("checkExpressionTest/if " ++ show n)
|
||||
(mIf $ tag2 A.OnlyC DontCare $ tag3 A.Choice DontCare (buildExprPattern exp) (tag1 A.Skip DontCare))
|
||||
(checkConditionalTypes $ A.If m $ A.OnlyC m $ A.Choice m (buildExpr src) (A.Skip m))
|
||||
(mIf $ mOnlyC $ tag3 A.Choice DontCare (buildExprPattern exp) (tag1 A.Skip DontCare))
|
||||
(checkConditionalTypes $ A.If m $ A.Only m $ A.Choice m (buildExpr src) (A.Skip m))
|
||||
state
|
||||
,TestCase $ testPass ("checkExpressionTest/while " ++ show n)
|
||||
(mWhile (buildExprPattern exp) (tag1 A.Skip DontCare))
|
||||
|
|
@ -300,7 +300,7 @@ checkExpressionTest = TestList
|
|||
failWhileIf n src = TestList
|
||||
[
|
||||
TestCase $ testPassShouldFail ("checkExpressionTest/if " ++ show n)
|
||||
(checkConditionalTypes $ A.If m $ A.OnlyC m $ A.Choice m (buildExpr src) (A.Skip m))
|
||||
(checkConditionalTypes $ A.If m $ A.Only m $ A.Choice m (buildExpr src) (A.Skip m))
|
||||
state
|
||||
,TestCase $ testPassShouldFail ("checkExpressionTest/while " ++ show n)
|
||||
(checkConditionalTypes $ A.While m (buildExpr src) (A.Skip m))
|
||||
|
|
@ -325,7 +325,7 @@ checkExpressionTest = TestList
|
|||
then TestCase $ testPass ("testCheckCommTypesIn " ++ show n) (mkPattern st) (checkCommTypes st) state
|
||||
else TestCase $ testPassShouldFail ("testCheckCommTypesIn " ++ show n) (checkCommTypes st) state
|
||||
where
|
||||
st = A.Alt m True $ A.OnlyA m $ A.Alternative m chanVar (A.InputSimple m [A.InVariable m destVar]) $ A.Skip m
|
||||
st = A.Alt m True $ A.Only m $ A.Alternative m chanVar (A.InputSimple m [A.InVariable m destVar]) $ A.Skip m
|
||||
|
||||
--Automatically tests checking inputs and outputs for various combinations of channel type and direction
|
||||
testAllCheckCommTypes :: Int -> Test
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ import Metadata
|
|||
import Pattern
|
||||
import SimplifyComms
|
||||
import SimplifyExprs
|
||||
import TagAST
|
||||
import TestUtils
|
||||
import TreeUtils
|
||||
|
||||
|
|
@ -38,12 +39,12 @@ noInit :: Maybe A.Expression
|
|||
noInit = Nothing
|
||||
|
||||
-- | An expression list containing a single value of 0.
|
||||
valof0 :: A.Structured
|
||||
valof0 = A.OnlyEL m $ A.ExpressionList m [intLiteral 0]
|
||||
valof0 :: A.Structured A.ExpressionList
|
||||
valof0 = A.Only m $ A.ExpressionList m [intLiteral 0]
|
||||
|
||||
-- | An expression list containing variables with the two given names.
|
||||
valofTwo :: String -> String -> A.Structured
|
||||
valofTwo a b = A.OnlyEL m $ A.ExpressionList m [exprVariable a,exprVariable b]
|
||||
valofTwo :: String -> String -> A.Structured A.ExpressionList
|
||||
valofTwo a b = A.Only m $ A.ExpressionList m [exprVariable a,exprVariable b]
|
||||
|
||||
-- | Looks up an item from the Items, and attempts to cast it. Fails (via assertions) if
|
||||
-- either the item is not found, or if the cast is invalid.
|
||||
|
|
@ -56,13 +57,12 @@ assertGetItemCast k kv
|
|||
Nothing -> (assertFailure $ "Wrong type when casting in assertGetItemCast for key: " ++ k) >> return (undefined)
|
||||
|
||||
-- | Given a body, returns a function spec:
|
||||
singleParamFunc :: A.Structured-> A.Specification
|
||||
singleParamFunc :: A.Structured A.ExpressionList -> A.Specification
|
||||
singleParamFunc body = A.Specification m (simpleName "foo") (A.Function m A.PlainSpec [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] body)
|
||||
|
||||
-- | Returns the expected body of the single parameter process (when the function had valof0 as a body)
|
||||
singleParamBodyExp :: Pattern -- ^ to match: A.Process
|
||||
singleParamBodyExp = tag2 A.Seq DontCare $
|
||||
tag2 A.OnlyP DontCare $
|
||||
singleParamBodyExp = tag2 A.Seq DontCare $ mOnlyP $
|
||||
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare)] $ tag2 A.ExpressionList DontCare [intLiteral 0]
|
||||
|
||||
-- | Returns the expected specification type of the single parameter process
|
||||
|
|
@ -98,7 +98,7 @@ testFunctionsToProcs1 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
|
|||
tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare),
|
||||
tag3 A.Formal A.Abbrev A.Real32 (Named "ret1" DontCare)] $
|
||||
tag2 A.Seq DontCare $
|
||||
tag2 A.OnlyP DontCare $
|
||||
mOnlyP $
|
||||
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare),tag2 A.Variable DontCare (Named "ret1" DontCare)] $
|
||||
tag2 A.ExpressionList DontCare [exprVariable "param0",exprVariable "param1"]
|
||||
--check return parameters were defined:
|
||||
|
|
@ -126,8 +126,8 @@ testFunctionsToProcs2 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
|
|||
procHeader body = tag4 A.Proc DontCare A.PlainSpec [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0"), tag3 A.Formal A.Abbrev A.Int (Named "retOuter0" DontCare)] body
|
||||
procBodyOuter = procHeader $
|
||||
tag2 A.Seq DontCare $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare (simpleName "foo") (singleParamSpecExp singleParamBodyExp)) $
|
||||
tag2 A.OnlyP DontCare $
|
||||
mSpecP (tag3 A.Specification DontCare (simpleName "foo") (singleParamSpecExp singleParamBodyExp)) $
|
||||
mOnlyP $
|
||||
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "retOuter0" DontCare)] $ tag2 A.ExpressionList DontCare [intLiteral 0]
|
||||
|
||||
|
||||
|
|
@ -147,8 +147,8 @@ testFunctionsToProcs2 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP
|
|||
assertEqual "testFunctionsToProcs2 F" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
|
||||
assertEqual "testFunctionsToProcs2 G" (Just [A.Int]) (Map.lookup "fooOuter" (csFunctionReturns state))
|
||||
|
||||
skipP :: A.Structured
|
||||
skipP = A.OnlyP m (A.Skip m)
|
||||
skipP :: A.Structured A.Process
|
||||
skipP = A.Only m (A.Skip m)
|
||||
|
||||
-- | Tests that a simple constructor (with no expression, nor function call) gets converted into the appropriate initialisation code
|
||||
testTransformConstr0 :: Test
|
||||
|
|
@ -161,10 +161,10 @@ testTransformConstr0 = TestCase $ testPass "transformConstr0" exp (transformCons
|
|||
exp' = A.Spec m (A.Specification m (simpleName "arr") (A.Declaration m (A.Array [A.Dimension 10] A.Int) Nothing)) $
|
||||
A.ProcThen m
|
||||
(A.Seq m $ A.Spec m (A.Specification m (simpleName "i") (A.Declaration m A.Int Nothing)) $
|
||||
A.Several m [A.OnlyP m $ A.Assign m [variable "i"] $ A.ExpressionList m [intLiteral 0],
|
||||
A.Rep m (A.For m (simpleName "x") (intLiteral 0) (intLiteral 10)) $ A.OnlyP m $ A.Seq m $ A.Several m
|
||||
[A.OnlyP m $ A.Assign m [A.SubscriptedVariable m (A.Subscript m $ exprVariable "i") (variable "arr")] $ A.ExpressionList m [exprVariable "x"],
|
||||
A.OnlyP m $ A.Assign m [variable "i"] $ A.ExpressionList m [A.Dyadic m A.Plus (exprVariable "i") (intLiteral 1)]]
|
||||
A.Several m [A.Only m $ A.Assign m [variable "i"] $ A.ExpressionList m [intLiteral 0],
|
||||
A.Rep m (A.For m (simpleName "x") (intLiteral 0) (intLiteral 10)) $ A.Only m $ A.Seq m $ A.Several m
|
||||
[A.Only m $ A.Assign m [A.SubscriptedVariable m (A.Subscript m $ exprVariable "i") (variable "arr")] $ A.ExpressionList m [exprVariable "x"],
|
||||
A.Only m $ A.Assign m [variable "i"] $ A.ExpressionList m [A.Dyadic m A.Plus (exprVariable "i") (intLiteral 1)]]
|
||||
]
|
||||
)
|
||||
skipP
|
||||
|
|
@ -176,7 +176,7 @@ testOutExprs = TestList
|
|||
-- Test outputting from an expression:
|
||||
TestCase $ testPassWithItemsStateCheck "testOutExprs 0"
|
||||
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Int (eXM 1))
|
||||
(tag2 A.OnlyP DontCare $ tag3 A.Output emptyMeta chan
|
||||
(mOnlyP $ tag3 A.Output emptyMeta chan
|
||||
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var" DontCare)))])
|
||||
)
|
||||
(outExprs $
|
||||
|
|
@ -188,7 +188,7 @@ testOutExprs = TestList
|
|||
-- Test outputting from a variable already:
|
||||
,TestCase $ testPass "testOutExprs 1"
|
||||
(tag2 A.Seq DontCare $
|
||||
(tag2 A.OnlyP DontCare $ tag3 A.Output emptyMeta chan
|
||||
(mOnlyP $ tag3 A.Output emptyMeta chan
|
||||
[outX])
|
||||
)
|
||||
(outExprs $
|
||||
|
|
@ -199,7 +199,7 @@ testOutExprs = TestList
|
|||
-- Test outputting from multiple output items:
|
||||
,TestCase $ testPassWithItemsStateCheck "testOutExprs 2"
|
||||
(tag2 A.Seq DontCare $ (abbr "temp_var0" A.Byte (eXM 1)) $ (abbr "temp_var1" A.Int (intLiteral 2))
|
||||
(tag2 A.OnlyP DontCare $ tag3 A.Output emptyMeta chan
|
||||
(mOnlyP $ tag3 A.Output emptyMeta chan
|
||||
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var0" DontCare)))
|
||||
,mkPattern outX
|
||||
,tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var1" DontCare)))
|
||||
|
|
@ -215,7 +215,7 @@ testOutExprs = TestList
|
|||
-- Test an OutCounted
|
||||
,TestCase $ testPassWithItemsStateCheck "testOutExprs 3"
|
||||
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Byte (eXM 1))
|
||||
(tag2 A.OnlyP DontCare $ tag3 A.Output emptyMeta chan
|
||||
(mOnlyP $ tag3 A.Output emptyMeta chan
|
||||
[tag3 A.OutCounted emptyMeta
|
||||
(tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var0" DontCare)))
|
||||
(exprVariable "x")
|
||||
|
|
@ -231,7 +231,7 @@ testOutExprs = TestList
|
|||
-- Test that OutputCase is also processed:
|
||||
,TestCase $ testPassWithItemsStateCheck "testOutExprs 4"
|
||||
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Int (eXM 1))
|
||||
(tag2 A.OnlyP DontCare $ tag4 A.OutputCase emptyMeta chan (simpleName "foo")
|
||||
(mOnlyP $ tag4 A.OutputCase emptyMeta chan (simpleName "foo")
|
||||
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var" DontCare)))])
|
||||
)
|
||||
(outExprs $
|
||||
|
|
@ -244,7 +244,7 @@ testOutExprs = TestList
|
|||
|
||||
,TestCase $ testPass "testOutExprs 5"
|
||||
(tag2 A.Seq DontCare $
|
||||
(tag2 A.OnlyP DontCare $ A.OutputCase emptyMeta chan (simpleName "foo") [])
|
||||
(mOnlyP $ A.OutputCase emptyMeta chan (simpleName "foo") [])
|
||||
)
|
||||
(outExprs $
|
||||
A.OutputCase emptyMeta chan (simpleName "foo") []
|
||||
|
|
@ -257,7 +257,7 @@ testOutExprs = TestList
|
|||
outXM n = A.OutExpression emptyMeta $ eXM n
|
||||
eXM n = buildExpr $ Dy (Var "x") A.Minus (Lit $ intLiteral n)
|
||||
|
||||
abbr key t e = tag3 A.Spec DontCare
|
||||
abbr key t e = mSpecP
|
||||
(tag3 A.Specification DontCare (Named key DontCare) $ tag4 A.IsExpr DontCare A.ValAbbrev t e)
|
||||
|
||||
chan = variable "c"
|
||||
|
|
@ -284,15 +284,15 @@ testInputCase = TestList
|
|||
-}
|
||||
TestCase $ testPass "testInputCase 0"
|
||||
(tag2 A.Seq DontCare $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $
|
||||
tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
mSeveralP
|
||||
[mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]
|
||||
,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $
|
||||
mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
]
|
||||
)
|
||||
(transformInputCase $
|
||||
A.Input emptyMeta c $ A.InputCase emptyMeta $ A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0
|
||||
A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0
|
||||
)
|
||||
(defineMyProtocol >> defineC)
|
||||
|
||||
|
|
@ -325,25 +325,25 @@ testInputCase = TestList
|
|||
-}
|
||||
,TestCase $ testPass "testInputCase 1"
|
||||
(tag2 A.Seq DontCare $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ tag2 A.Several emptyMeta
|
||||
[tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
,tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 2] $
|
||||
tag2 A.Seq DontCare $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],tag2 A.OnlyP DontCare p1]
|
||||
,tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 1] $
|
||||
tag2 A.Seq DontCare $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],tag2 A.OnlyP DontCare p2]
|
||||
mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
mSeveralP
|
||||
[mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]
|
||||
,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ mSeveralO
|
||||
[mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
,mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 2] $
|
||||
tag2 A.Seq DontCare $ mSeveralP
|
||||
[mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],mOnlyP p1]
|
||||
,mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 1] $
|
||||
tag2 A.Seq DontCare $ mSeveralP
|
||||
[mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],mOnlyP p2]
|
||||
]
|
||||
]
|
||||
)
|
||||
(transformInputCase $
|
||||
A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta
|
||||
[A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0
|
||||
,A.OnlyV emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1
|
||||
,A.OnlyV emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2
|
||||
[A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0
|
||||
,A.Only emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1
|
||||
,A.Only emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2
|
||||
]
|
||||
)
|
||||
(defineMyProtocol >> defineC)
|
||||
|
|
@ -383,25 +383,25 @@ testInputCase = TestList
|
|||
-}
|
||||
,TestCase $ testPass "testInputCase 2"
|
||||
(tag2 A.Seq DontCare $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]
|
||||
,tag2 A.OnlyP DontCare $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ tag2 A.Several emptyMeta
|
||||
[tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
,specIntPatt "z" $ tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 2] $
|
||||
tag2 A.Seq DontCare $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],tag2 A.OnlyP DontCare p1]
|
||||
,specIntPatt "x" $ specIntPatt "y" $ tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 1] $
|
||||
tag2 A.Seq DontCare $ tag2 A.Several DontCare
|
||||
[tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],tag2 A.OnlyP DontCare p2]
|
||||
mSpecP (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
mSeveralP
|
||||
[mOnlyP $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]
|
||||
,mOnlyP $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ mSeveralO
|
||||
[mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
,specIntPatt "z" $ mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 2] $
|
||||
tag2 A.Seq DontCare $ mSeveralP
|
||||
[mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],mOnlyP p1]
|
||||
,specIntPatt "x" $ specIntPatt "y" $ mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 1] $
|
||||
tag2 A.Seq DontCare $ mSeveralP
|
||||
[mOnlyP $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],mOnlyP p2]
|
||||
]
|
||||
]
|
||||
)
|
||||
(transformInputCase $
|
||||
A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta
|
||||
[A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0
|
||||
,specInt "z" $ A.OnlyV emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1
|
||||
,specInt "x" $ specInt "y" $ A.OnlyV emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2
|
||||
[A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0
|
||||
,specInt "z" $ A.Only emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1
|
||||
,specInt "x" $ specInt "y" $ A.Only emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2
|
||||
]
|
||||
)
|
||||
(defineMyProtocol >> defineC)
|
||||
|
|
@ -425,15 +425,15 @@ testInputCase = TestList
|
|||
-}
|
||||
,TestCase $ testPass "testInputCase 100"
|
||||
(tag3 A.Alt DontCare False $
|
||||
tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
tag2 A.OnlyA DontCare $ tag4 A.Alternative DontCare c
|
||||
mSpecA (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag3 A.Declaration DontCare A.Int noInit) $
|
||||
mOnlyA $ tag4 A.Alternative DontCare c
|
||||
(tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)]) $
|
||||
tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $
|
||||
tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
mOnlyO $ tag3 A.Option DontCare [intLiteralPattern 0] p0
|
||||
)
|
||||
(transformInputCase $
|
||||
A.Alt emptyMeta False $ A.OnlyA emptyMeta $ A.Alternative emptyMeta c
|
||||
(A.InputCase emptyMeta $ A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0)
|
||||
A.Alt emptyMeta False $ A.Only emptyMeta $ A.Alternative emptyMeta c
|
||||
(A.InputCase emptyMeta $ A.Only emptyMeta $ A.Variant emptyMeta a0 [] p0)
|
||||
(A.Skip emptyMeta)
|
||||
)
|
||||
(defineMyProtocol >> defineC)
|
||||
|
|
@ -459,7 +459,7 @@ testInputCase = TestList
|
|||
defineC = defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot"))
|
||||
|
||||
specInt s = A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int Nothing)
|
||||
specIntPatt s = tag3 A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int Nothing)
|
||||
specIntPatt s = mSpecA' emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int Nothing)
|
||||
|
||||
--Returns the list of tests:
|
||||
tests :: Test
|
||||
|
|
|
|||
|
|
@ -49,27 +49,27 @@ outExprs = doGeneric `extM` doProcess
|
|||
doProcess (A.Output m c ois)
|
||||
= do (ois', specs) <- mapAndUnzipM changeItem ois
|
||||
let foldedSpec = foldFuncs specs
|
||||
return $ A.Seq m (foldedSpec $ A.OnlyP m $ A.Output m c ois')
|
||||
return $ A.Seq m (foldedSpec $ A.Only m $ A.Output m c ois')
|
||||
doProcess (A.OutputCase m c tag ois)
|
||||
= do (ois', specs) <- mapAndUnzipM changeItem ois
|
||||
let foldedSpec = foldFuncs specs
|
||||
return $ A.Seq m (foldedSpec $ A.OnlyP m $ A.OutputCase m c tag ois')
|
||||
return $ A.Seq m (foldedSpec $ A.Only m $ A.OutputCase m c tag ois')
|
||||
doProcess p = doGeneric p
|
||||
|
||||
changeItem :: A.OutputItem -> PassM (A.OutputItem, A.Structured -> A.Structured)
|
||||
changeItem :: A.OutputItem -> PassM (A.OutputItem, A.Structured A.Process -> A.Structured A.Process)
|
||||
changeItem (A.OutExpression m e) = do (e', spec) <- transExpr m e
|
||||
return (A.OutExpression m e', spec)
|
||||
changeItem (A.OutCounted m ce ae) = do (ce', ceSpec) <- transExpr m ce
|
||||
(ae', aeSpec) <- transExpr m ae
|
||||
return (A.OutCounted m ce' ae', ceSpec . aeSpec)
|
||||
|
||||
transExpr :: Meta -> A.Expression -> PassM (A.Expression, A.Structured -> A.Structured)
|
||||
transExpr :: Meta -> A.Expression -> PassM (A.Expression, A.Structured A.Process -> A.Structured A.Process)
|
||||
-- If it's already an output direct from a variable, no need to change it:
|
||||
transExpr _ e@(A.ExprVariable {}) = return (e, id)
|
||||
transExpr m e = do (nm, spec) <- abbrevExpr m e
|
||||
return (A.ExprVariable m $ A.Variable m nm, spec)
|
||||
|
||||
abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured -> A.Structured)
|
||||
abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured A.Process -> A.Structured A.Process)
|
||||
abbrevExpr m e = do t <- typeOfExpression e
|
||||
specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev
|
||||
return (nm, A.Spec m specification)
|
||||
|
|
@ -143,56 +143,73 @@ transformInputCase = doGeneric `extM` doProcess
|
|||
doProcess :: A.Process -> PassM A.Process
|
||||
doProcess (A.Input m v (A.InputCase m' s))
|
||||
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int Nothing) A.VariableName A.Original
|
||||
s' <- doStructured v s
|
||||
s' <- doStructuredV v s
|
||||
return $ A.Seq m $ A.Spec m' spec $ A.Several m'
|
||||
[A.OnlyP m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)])
|
||||
,A.OnlyP m' $ A.Case m' (A.ExprVariable m $ A.Variable m n) s']
|
||||
[A.Only m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)])
|
||||
,A.Only m' $ A.Case m' (A.ExprVariable m $ A.Variable m n) s']
|
||||
doProcess (A.Alt m pri s)
|
||||
= do s' <- doStructured undefined s
|
||||
= do s' <- doStructuredA s
|
||||
return (A.Alt m pri s')
|
||||
doProcess p = doGeneric p
|
||||
|
||||
doStructured :: A.Variable -> A.Structured -> PassM A.Structured
|
||||
|
||||
-- Can't easily use generics here as we're switching from one type of Structured to another
|
||||
doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
|
||||
-- These entries all just burrow deeper into the structured:
|
||||
doStructured v (A.ProcThen m p s)
|
||||
= do s' <- doStructured v s
|
||||
doStructuredV v (A.ProcThen m p s)
|
||||
= do s' <- doStructuredV v s
|
||||
p' <- doProcess p
|
||||
return (A.ProcThen m p' s')
|
||||
doStructured v (A.Spec m sp st)
|
||||
= do st' <- doStructured v st
|
||||
doStructuredV v (A.Spec m sp st)
|
||||
= do st' <- doStructuredV v st
|
||||
return (A.Spec m sp st')
|
||||
doStructured v (A.Several m ss)
|
||||
= do ss' <- mapM (doStructured v) ss
|
||||
doStructuredV v (A.Several m ss)
|
||||
= do ss' <- mapM (doStructuredV v) ss
|
||||
return (A.Several m ss')
|
||||
doStructured v (A.Rep m rep s)
|
||||
= do s' <- doStructured v s
|
||||
doStructuredV v (A.Rep m rep s)
|
||||
= do s' <- doStructuredV v s
|
||||
return (A.Rep m rep s')
|
||||
|
||||
-- Transform variant options:
|
||||
doStructured chanVar (A.OnlyV m (A.Variant m' n iis p))
|
||||
doStructuredV chanVar (A.Only m (A.Variant m' n iis p))
|
||||
= do (Right items) <- protocolItems chanVar
|
||||
let (Just idx) = elemIndex n (fst $ unzip items)
|
||||
p' <- doProcess p
|
||||
return $ A.OnlyO m $ A.Option m' [makeConstant m' idx] $
|
||||
return $ A.Only m $ A.Option m' [makeConstant m' idx] $
|
||||
if (length iis == 0)
|
||||
then p'
|
||||
else A.Seq m' $ A.Several m'
|
||||
[A.OnlyP m' $ A.Input m' chanVar (A.InputSimple m' iis)
|
||||
,A.OnlyP (findMeta p') p']
|
||||
|
||||
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis)
|
||||
,A.Only (findMeta p') p']
|
||||
|
||||
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
|
||||
-- TODO use generics instead of this boilerplate, but don't omit the doProcess call in ProcThen!
|
||||
doStructuredA (A.ProcThen m p s)
|
||||
= do s' <- doStructuredA s
|
||||
p' <- doProcess p
|
||||
return (A.ProcThen m p' s')
|
||||
doStructuredA (A.Spec m sp st)
|
||||
= do st' <- doStructuredA st
|
||||
return (A.Spec m sp st')
|
||||
doStructuredA (A.Several m ss)
|
||||
= do ss' <- mapM doStructuredA ss
|
||||
return (A.Several m ss')
|
||||
doStructuredA (A.Rep m rep s)
|
||||
= do s' <- doStructuredA s
|
||||
return (A.Rep m rep s')
|
||||
|
||||
-- Transform alt guards:
|
||||
-- The processes that are the body of input-case guards are always skip, so we can discard them:
|
||||
doStructured _ (A.OnlyA m (A.Alternative m' v (A.InputCase m'' s) _))
|
||||
doStructuredA (A.Only m (A.Alternative m' v (A.InputCase m'' s) _))
|
||||
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int Nothing) A.VariableName A.Original
|
||||
s' <- doStructured v s
|
||||
return $ A.Spec m' spec $ A.OnlyA m $
|
||||
s' <- doStructuredV v s
|
||||
return $ A.Spec m' spec $ A.Only m $
|
||||
A.Alternative m' v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
|
||||
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
|
||||
doStructured _ (A.OnlyA m (A.AlternativeCond m' e v (A.InputCase m'' s) _))
|
||||
doStructuredA (A.Only m (A.AlternativeCond m' e v (A.InputCase m'' s) _))
|
||||
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int Nothing) A.VariableName A.Original
|
||||
s' <- doStructured v s
|
||||
return $ A.Spec m' spec $ A.OnlyA m $
|
||||
s' <- doStructuredV v s
|
||||
return $ A.Spec m' spec $ A.Only m $
|
||||
A.AlternativeCond m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
|
||||
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
|
||||
-- Leave other guards untouched:
|
||||
doStructured _ a@(A.OnlyA {}) = return a
|
||||
-- Leave other guards (and parts of Structured) untouched:
|
||||
doStructuredA s = return s
|
||||
|
||||
|
|
|
|||
|
|
@ -74,10 +74,10 @@ functionsToProcs = doGeneric `extM` doSpecification
|
|||
doGeneric spec
|
||||
doSpecification s = doGeneric s
|
||||
|
||||
vpToSeq :: A.Structured -> [A.Variable] -> A.Structured
|
||||
vpToSeq :: A.Structured A.ExpressionList -> [A.Variable] -> A.Structured A.Process
|
||||
vpToSeq (A.Spec m spec s) vs = A.Spec m spec (vpToSeq s vs)
|
||||
vpToSeq (A.ProcThen m p s) vs = A.ProcThen m p (vpToSeq s vs)
|
||||
vpToSeq (A.OnlyEL m el) vs = A.OnlyP m $ A.Assign m vs el
|
||||
vpToSeq (A.Only m el) vs = A.Only m $ A.Assign m vs el
|
||||
|
||||
-- | Convert AFTER expressions to the equivalent using MINUS (which is how the
|
||||
-- occam 3 manual defines AFTER).
|
||||
|
|
@ -121,23 +121,23 @@ expandArrayLiterals = doGeneric `extM` doArrayElem
|
|||
where m = findMeta e
|
||||
|
||||
transformConstr :: Data t => t -> PassM t
|
||||
transformConstr = doGeneric `extM` doStructured
|
||||
transformConstr = doGeneric `ext1M` doStructured
|
||||
where
|
||||
doGeneric :: Data t => t -> PassM t
|
||||
doGeneric = makeGeneric transformConstr
|
||||
|
||||
doStructured :: A.Structured -> PassM A.Structured
|
||||
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ t (A.ExprConstr m'' (A.RepConstr _ rep exp)))) scope)
|
||||
= do indexVarSpec@(A.Specification _ indexVar _) <- makeNonceVariable "array_constr_index" m'' A.Int A.VariableName A.Original
|
||||
scope' <- doGeneric scope
|
||||
return $ A.Spec m (A.Specification m' n (A.Declaration m' t Nothing)) $ A.ProcThen m''
|
||||
(A.Seq m'' $ A.Spec m'' (indexVarSpec) $ A.Several m'' [
|
||||
A.OnlyP m'' $ A.Assign m'' [A.Variable m'' indexVar] $ A.ExpressionList m'' [A.Literal m'' A.Int $ A.IntLiteral m'' "0"],
|
||||
A.Rep m'' rep $ A.OnlyP m'' $ A.Seq m'' $ A.Several m''
|
||||
[A.OnlyP m'' $ A.Assign m''
|
||||
A.Only m'' $ A.Assign m'' [A.Variable m'' indexVar] $ A.ExpressionList m'' [A.Literal m'' A.Int $ A.IntLiteral m'' "0"],
|
||||
A.Rep m'' rep $ A.Only m'' $ A.Seq m'' $ A.Several m''
|
||||
[A.Only m'' $ A.Assign m''
|
||||
[A.SubscriptedVariable m'' (A.Subscript m'' $ A.ExprVariable m'' $ A.Variable m'' indexVar) $ A.Variable m'' n]
|
||||
$ A.ExpressionList m'' [exp]
|
||||
,A.OnlyP m'' $ A.Assign m'' [A.Variable m'' indexVar] $ A.ExpressionList m'' [A.Dyadic m'' A.Plus
|
||||
,A.Only m'' $ A.Assign m'' [A.Variable m'' indexVar] $ A.ExpressionList m'' [A.Dyadic m'' A.Plus
|
||||
(A.ExprVariable m'' $ A.Variable m'' indexVar)
|
||||
(A.Literal m'' A.Int $ A.IntLiteral m'' "1")]
|
||||
]
|
||||
|
|
@ -149,7 +149,7 @@ transformConstr = doGeneric `extM` doStructured
|
|||
-- so.
|
||||
pullUp :: Data t => t -> PassM t
|
||||
pullUp = doGeneric
|
||||
`extM` doStructured
|
||||
`ext1M` doStructured
|
||||
`extM` doProcess
|
||||
`extM` doSpecification
|
||||
`extM` doLiteralRepr
|
||||
|
|
@ -162,7 +162,7 @@ pullUp = doGeneric
|
|||
|
||||
-- | When we encounter a Structured, create a new pulled items state,
|
||||
-- recurse over it, then apply whatever pulled items we found to it.
|
||||
doStructured :: A.Structured -> PassM A.Structured
|
||||
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
doStructured s
|
||||
= do pushPullContext
|
||||
-- Recurse over the body, then apply the pulled items to it
|
||||
|
|
@ -179,7 +179,7 @@ pullUp = doGeneric
|
|||
p' <- doGeneric p
|
||||
pulled <- havePulled
|
||||
p'' <- if pulled
|
||||
then liftM (A.Seq emptyMeta) $ applyPulled (A.OnlyP emptyMeta p')
|
||||
then liftM (A.Seq emptyMeta) $ applyPulled (A.Only emptyMeta p')
|
||||
else return p'
|
||||
popPullContext
|
||||
return p''
|
||||
|
|
@ -199,7 +199,7 @@ pullUp = doGeneric
|
|||
= do e' <- doExpression e
|
||||
fromT <- typeOfExpression e'
|
||||
spec@(A.Specification _ n' _) <- makeNonceIsExpr "retypes_expr" m' fromT e'
|
||||
addPulled $ A.Spec m' spec
|
||||
addPulled $ (m', Left spec)
|
||||
return $ A.Specification m n (A.Retypes m' am toT (A.Variable m' n'))
|
||||
doSpecification s = doGeneric s
|
||||
|
||||
|
|
@ -231,7 +231,7 @@ pullUp = doGeneric
|
|||
pull t e
|
||||
= do let m = findMeta e
|
||||
spec@(A.Specification _ n _) <- makeNonceIsExpr "array_expr" m t e
|
||||
addPulled $ A.Spec m spec
|
||||
addPulled $ (m, Left spec)
|
||||
return $ A.ExprVariable m (A.Variable m n)
|
||||
|
||||
-- | Pull any variable subscript that results in an array.
|
||||
|
|
@ -244,7 +244,7 @@ pullUp = doGeneric
|
|||
do origAM <- abbrevModeOfVariable v'
|
||||
let am = makeAbbrevAM origAM
|
||||
spec@(A.Specification _ n _) <- makeNonceIs "array_slice" m t am v'
|
||||
addPulled $ A.Spec m spec
|
||||
addPulled $ (m, Left spec)
|
||||
return $ A.Variable m n
|
||||
_ -> return v'
|
||||
doVariable v = doGeneric v
|
||||
|
|
@ -258,12 +258,12 @@ pullUp = doGeneric
|
|||
ps <- get
|
||||
rts <- Map.lookup (A.nameName n) (csFunctionReturns ps)
|
||||
specs <- sequence [makeNonceVariable "return_actual" m t A.VariableName A.Original | t <- rts]
|
||||
sequence_ [addPulled $ A.Spec m spec | spec <- specs]
|
||||
sequence_ [addPulled $ (m, Left spec) | spec <- specs]
|
||||
|
||||
let names = [n | A.Specification _ n _ <- specs]
|
||||
let vars = [A.Variable m n | n <- names]
|
||||
let call = A.ProcCall m n ([A.ActualExpression t e | (t, e) <- zip ets es'] ++ [A.ActualVariable A.Abbrev t v | (t, v) <- zip rts vars])
|
||||
addPulled $ A.ProcThen m call
|
||||
addPulled $ (m, Right call)
|
||||
|
||||
return vars
|
||||
|
||||
|
|
@ -278,7 +278,7 @@ pullUp = doGeneric
|
|||
s' <- pullUp s
|
||||
t <- typeOfExpression e'
|
||||
spec@(A.Specification _ n _) <- makeNonceIsExpr "subscripted_expr" m t e'
|
||||
addPulled $ A.Spec m spec
|
||||
addPulled $ (m, Left spec)
|
||||
return $ A.ExprVariable m (A.SubscriptedVariable m s' (A.Variable m n))
|
||||
doExpression' e = doGeneric e
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ parsToProcs = doGeneric `extM` doProcess
|
|||
doProcess p = doGeneric p
|
||||
|
||||
-- FIXME This should be generic and in Pass.
|
||||
doStructured :: A.Structured -> PassM A.Structured
|
||||
doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process)
|
||||
doStructured (A.Rep m r s)
|
||||
= do r' <- parsToProcs r
|
||||
s' <- doStructured s
|
||||
|
|
@ -65,10 +65,10 @@ parsToProcs = doGeneric `extM` doProcess
|
|||
= do p' <- parsToProcs p
|
||||
s' <- doStructured s
|
||||
return $ A.ProcThen m p' s'
|
||||
doStructured (A.OnlyP m p)
|
||||
doStructured (A.Only m p)
|
||||
= do p' <- parsToProcs p
|
||||
s@(A.Specification _ n _) <- makeNonceProc m p'
|
||||
return $ A.Spec m s (A.OnlyP m (A.ProcCall m n []))
|
||||
return $ A.Spec m s (A.Only m (A.ProcCall m n []))
|
||||
doStructured (A.Several m ss)
|
||||
= liftM (A.Several m) $ mapM doStructured ss
|
||||
|
||||
|
|
@ -86,7 +86,7 @@ removeParAssign = doGeneric `extM` doProcess
|
|||
let temps = [A.Variable m n | A.Specification _ n _ <- specs]
|
||||
let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es]
|
||||
let second = [A.Assign m [v] (A.ExpressionList m [A.ExprVariable m v']) | (v, v') <- zip vs temps]
|
||||
return $ A.Seq m $ foldl (\s spec -> A.Spec m spec s) (A.Several m (map (A.OnlyP m) (first ++ second))) specs
|
||||
return $ A.Seq m $ foldl (\s spec -> A.Spec m spec s) (A.Several m (map (A.Only m) (first ++ second))) specs
|
||||
doProcess p = doGeneric p
|
||||
|
||||
-- | Turn assignment of arrays and records into multiple assignments.
|
||||
|
|
@ -134,7 +134,7 @@ flattenAssign = doGeneric `extM` doProcess
|
|||
(A.SubscriptedVariable m sub destV) m'
|
||||
(A.ExprVariable m'
|
||||
(A.SubscriptedVariable m' sub srcV))
|
||||
return $ A.Rep m rep $ A.OnlyP m inner
|
||||
return $ A.Rep m rep $ A.Only m inner
|
||||
A.Record _ ->
|
||||
-- Record assignments become a sequence of
|
||||
-- assignments, one for each field.
|
||||
|
|
@ -147,7 +147,7 @@ flattenAssign = doGeneric `extM` doProcess
|
|||
(A.ExprVariable m'
|
||||
(A.SubscriptedVariable m' sub srcV))
|
||||
| (fName, fType) <- fs]
|
||||
return $ A.Several m $ map (A.OnlyP m) assigns
|
||||
return $ A.Several m $ map (A.Only m) assigns
|
||||
|
||||
return $ A.Seq m $ A.Spec m src $ A.Spec m dest body
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ freeNamesIn :: Data t => t -> NameMap
|
|||
freeNamesIn = doGeneric
|
||||
`extQ` (ignore :: String -> NameMap)
|
||||
`extQ` (ignore :: Meta -> NameMap)
|
||||
`extQ` doName `extQ` doStructured `extQ` doSpecType
|
||||
`extQ` doName `ext1Q` doStructured `extQ` doSpecType
|
||||
where
|
||||
doGeneric :: Data t => t -> NameMap
|
||||
doGeneric n = Map.unions $ gmapQ freeNamesIn n
|
||||
|
|
@ -58,7 +58,7 @@ freeNamesIn = doGeneric
|
|||
doName :: A.Name -> NameMap
|
||||
doName n = Map.singleton (A.nameName n) n
|
||||
|
||||
doStructured :: A.Structured -> NameMap
|
||||
doStructured :: Data a => A.Structured a -> NameMap
|
||||
doStructured (A.Rep _ rep s) = doRep rep s
|
||||
doStructured (A.Spec _ spec s) = doSpec spec s
|
||||
doStructured s = doGeneric s
|
||||
|
|
@ -171,7 +171,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
|
|||
doProcess p = doGeneric p
|
||||
|
||||
-- | Pull nested declarations to the top level.
|
||||
removeNesting :: A.Structured -> PassM A.Structured
|
||||
removeNesting :: forall a. Data a => A.Structured a -> PassM (A.Structured a)
|
||||
removeNesting p
|
||||
= do pushPullContext
|
||||
p' <- pullSpecs p
|
||||
|
|
@ -185,13 +185,13 @@ removeNesting p
|
|||
doGeneric :: Data t => t -> PassM t
|
||||
doGeneric = makeGeneric pullSpecs
|
||||
|
||||
doStructured :: A.Structured -> PassM A.Structured
|
||||
doStructured :: A.Structured a -> PassM (A.Structured a)
|
||||
doStructured s@(A.Spec m spec@(A.Specification _ n st) subS)
|
||||
= do isConst <- isConstantName n
|
||||
if isConst || canPull st then
|
||||
do debug $ "removeNesting: pulling up " ++ show n
|
||||
spec' <- doGeneric spec
|
||||
addPulled $ A.Spec m spec'
|
||||
addPulled $ (m, Left spec')
|
||||
doStructured subS
|
||||
else doGeneric s
|
||||
doStructured s = doGeneric s
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user