Upgraded the Par edges in the flow graph from Int to Integer, which makes the design a bit nicer
This commit is contained in:
parent
7cf83512c5
commit
7f8ced3c3a
|
@ -41,13 +41,13 @@ joinCheckParFunctions f g x = seqPair (f x, g x)
|
||||||
checkPar :: forall m a b. Monad m => (a -> Maybe (A.Name, A.Replicator)) -> ((Meta, ParItems a) -> m b) -> FlowGraph m a -> m [b]
|
checkPar :: forall m a b. Monad m => (a -> Maybe (A.Name, A.Replicator)) -> ((Meta, ParItems a) -> m b) -> FlowGraph m a -> m [b]
|
||||||
checkPar getRep f g = mapM f =<< allParItems
|
checkPar getRep f g = mapM f =<< allParItems
|
||||||
where
|
where
|
||||||
allStartParEdges :: m (Map.Map Int (Maybe (A.Name, A.Replicator), [(Node,Node)]))
|
allStartParEdges :: m (Map.Map Integer (Maybe (A.Name, A.Replicator), [(Node,Node)]))
|
||||||
allStartParEdges = foldM helper Map.empty parEdges
|
allStartParEdges = foldM helper Map.empty parEdges
|
||||||
where
|
where
|
||||||
parEdges = mapMaybe tagStartParEdge $ labEdges g
|
parEdges = mapMaybe tagStartParEdge $ labEdges g
|
||||||
|
|
||||||
helper :: Map.Map Int (Maybe (A.Name, A.Replicator), [(Node,Node)]) -> (Node,Node,Int) ->
|
helper :: Map.Map Integer (Maybe (A.Name, A.Replicator), [(Node,Node)]) -> (Node,Node,Integer) ->
|
||||||
m (Map.Map Int (Maybe (A.Name, A.Replicator), [(Node,Node)]))
|
m (Map.Map Integer (Maybe (A.Name, A.Replicator), [(Node,Node)]))
|
||||||
helper mp (s,e,n)
|
helper mp (s,e,n)
|
||||||
| r == Nothing = fail "Could not find label for node"
|
| r == Nothing = fail "Could not find label for node"
|
||||||
| prevR == Nothing || prevR == r = return $ Map.insertWith add n (join r,[(s,e)]) mp
|
| prevR == Nothing || prevR == r = return $ Map.insertWith add n (join r,[(s,e)]) mp
|
||||||
|
@ -61,7 +61,7 @@ checkPar getRep f g = mapM f =<< allParItems
|
||||||
r :: Maybe (Maybe (A.Name, A.Replicator))
|
r :: Maybe (Maybe (A.Name, A.Replicator))
|
||||||
r = lab g s >>* (getRep . getNodeData)
|
r = lab g s >>* (getRep . getNodeData)
|
||||||
|
|
||||||
tagStartParEdge :: (Node,Node,EdgeLabel) -> Maybe (Node,Node,Int)
|
tagStartParEdge :: (Node,Node,EdgeLabel) -> Maybe (Node,Node,Integer)
|
||||||
tagStartParEdge (s,e,EStartPar n) = Just (s,e,n)
|
tagStartParEdge (s,e,EStartPar n) = Just (s,e,n)
|
||||||
tagStartParEdge _ = Nothing
|
tagStartParEdge _ = Nothing
|
||||||
|
|
||||||
|
@ -78,13 +78,13 @@ checkPar getRep f g = mapM f =<< allParItems
|
||||||
where
|
where
|
||||||
distinctItems = nub $ map fst ns
|
distinctItems = nub $ map fst ns
|
||||||
|
|
||||||
findMetaAndNodes :: (Int,(Maybe (A.Name, A.Replicator), [(Node,Node)])) -> m (Meta, ParItems a)
|
findMetaAndNodes :: (Integer,(Maybe (A.Name, A.Replicator), [(Node,Node)])) -> m (Meta, ParItems a)
|
||||||
findMetaAndNodes x@(_,(_,ns)) = seqPair (checkAndGetMeta ns, return $ findNodes x)
|
findMetaAndNodes x@(_,(_,ns)) = seqPair (checkAndGetMeta ns, return $ findNodes x)
|
||||||
|
|
||||||
findNodes :: (Int,(Maybe (A.Name, A.Replicator), [(Node,Node)])) -> ParItems a
|
findNodes :: (Integer,(Maybe (A.Name, A.Replicator), [(Node,Node)])) -> ParItems a
|
||||||
findNodes (n, (mr, ses)) = maybe id RepParItem mr $ ParItems $ map (makeSeqItems n . snd) ses
|
findNodes (n, (mr, ses)) = maybe id RepParItem mr $ ParItems $ map (makeSeqItems n . snd) ses
|
||||||
|
|
||||||
makeSeqItems :: Int -> Node -> ParItems a
|
makeSeqItems :: Integer -> Node -> ParItems a
|
||||||
makeSeqItems n e = SeqItems (followUntilEdge e (EEndPar n))
|
makeSeqItems n e = SeqItems (followUntilEdge e (EEndPar n))
|
||||||
|
|
||||||
-- | We need to follow all edges out of a particular node until we reach
|
-- | We need to follow all edges out of a particular node until we reach
|
||||||
|
|
|
@ -194,7 +194,7 @@ buildStructuredSeq (A.ProcThen _ p str) route
|
||||||
pe --> ss
|
pe --> ss
|
||||||
return (ps, se)
|
return (ps, se)
|
||||||
|
|
||||||
buildStructuredPar :: (Monad mLabel, Monad mAlter) => Int -> (Node, Node) ->
|
buildStructuredPar :: (Monad mLabel, Monad mAlter) => Integer -> (Node, Node) ->
|
||||||
A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType ->
|
A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType ->
|
||||||
GraphMaker mLabel mAlter label structType (Either Bool (Node, Node))
|
GraphMaker mLabel mAlter label structType (Either Bool (Node, Node))
|
||||||
buildStructuredPar pId (nStart, nEnd) (A.Several m ss) route
|
buildStructuredPar pId (nStart, nEnd) (A.Several m ss) route
|
||||||
|
|
|
@ -39,7 +39,7 @@ import Utils
|
||||||
-- Multiple Seq links means choice.
|
-- Multiple Seq links means choice.
|
||||||
-- Multiple Par links means a parallel branch. All outgoing par links should have the same identifier,
|
-- Multiple Par links means a parallel branch. All outgoing par links should have the same identifier,
|
||||||
-- and this identifier is unique and matches a later endpar link
|
-- and this identifier is unique and matches a later endpar link
|
||||||
data EdgeLabel = ESeq (Maybe Bool) | EStartPar Int | EEndPar Int deriving (Show, Eq, Ord)
|
data EdgeLabel = ESeq (Maybe Bool) | EStartPar Integer | EEndPar Integer deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- | A type used to build up tree-modifying functions. When given an inner modification function,
|
-- | 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
|
-- it returns a modification function for the whole tree. The functions are monadic, to
|
||||||
|
@ -92,7 +92,7 @@ type NodesEdges m a b = ([LNode (FNode' b m a)],[LEdge EdgeLabel])
|
||||||
-- * The list of terminator nodes thus far (those with no links from them)
|
-- * The list of terminator nodes thus far (those with no links from them)
|
||||||
data GraphMakerState mAlter a b = GraphMakerState
|
data GraphMakerState mAlter a b = GraphMakerState
|
||||||
{ nextNodeId :: Node
|
{ nextNodeId :: Node
|
||||||
, nextParId :: Int
|
, nextParId :: Integer
|
||||||
, graphNodesEdges :: NodesEdges mAlter a b
|
, graphNodesEdges :: NodesEdges mAlter a b
|
||||||
, rootNodes :: [Node]
|
, rootNodes :: [Node]
|
||||||
, termNodes :: [Node]
|
, termNodes :: [Node]
|
||||||
|
@ -248,18 +248,18 @@ addDummyNode :: (Monad mLabel, Monad mAlter) => Meta -> ASTModifier mAlter a str
|
||||||
-> GraphMaker mLabel mAlter label structType Node
|
-> GraphMaker mLabel mAlter label structType Node
|
||||||
addDummyNode m mod = addNode' m labelDummy m (AlterNothing $ routeId mod)
|
addDummyNode m mod = addNode' m labelDummy m (AlterNothing $ routeId mod)
|
||||||
|
|
||||||
getNextParEdgeId :: (Monad mLabel, Monad mAlter) => GraphMaker mLabel mAlter label structType Int
|
getNextParEdgeId :: (Monad mLabel, Monad mAlter) => GraphMaker mLabel mAlter label structType Integer
|
||||||
getNextParEdgeId = do st <- get
|
getNextParEdgeId = do st <- get
|
||||||
put $ st {nextParId = nextParId st + 1}
|
put $ st {nextParId = nextParId st + 1}
|
||||||
return $ nextParId st
|
return $ nextParId st
|
||||||
|
|
||||||
addParEdges :: (Monad mLabel, Monad mAlter) => Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
|
addParEdges :: (Monad mLabel, Monad mAlter) => Integer -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
|
||||||
addParEdges usePI (s,e) pairs
|
addParEdges usePI (s,e) pairs
|
||||||
= do st <- get
|
= do st <- get
|
||||||
let (nodes,edges) = graphNodesEdges st
|
let (nodes,edges) = graphNodesEdges st
|
||||||
put $ st {graphNodesEdges = (nodes,edges ++ (concatMap (parEdge usePI) pairs))}
|
put $ st {graphNodesEdges = (nodes,edges ++ (concatMap (parEdge usePI) pairs))}
|
||||||
where
|
where
|
||||||
parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel]
|
parEdge :: Integer -> (Node, Node) -> [LEdge EdgeLabel]
|
||||||
parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))]
|
parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))]
|
||||||
|
|
||||||
mapMR :: forall inner mAlter mLabel label retType structType. (Monad mLabel, Monad mAlter) =>
|
mapMR :: forall inner mAlter mLabel label retType structType. (Monad mLabel, Monad mAlter) =>
|
||||||
|
|
Loading…
Reference in New Issue
Block a user