{-# LANGUAGE AllowAmbiguousTypes #-} -- For addEdgeLab
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Cubix.Language.Parametric.Semantics.Cfg.Graph (
    Cfg

  , CfgNodeType
  , pattern EnterNode
  , pattern LoopEntryNode
  , pattern ExitNode
  , isEnterNode
  , evalPointToNodeType
  , nodeTypeToEvalPoint

  , HasCurCfg(..)
  , CfgNode
  , cfg_node_prevs
  , cfg_node_succs
  , cfg_node_lab
  , cfg_node_type
  , cfg_node_term

  , emptyCfg
  , cfgNodes
  , addCfgNode
  , nodeForLab
  , addEdge
  , addEdgeLab
  , safeLookupCfg
  , lookupCfg
  , cfgNodeForTerm

  , contractNode

  , satisfyingPredBoundary
  , satisfyingSuccBoundary
  , satisfyingStrictPredBoundary
  , satisfyingStrictSuccBoundary

  , prettyCfg
  , debugCfg

  , isStartNode
  , startsBasicBlock

  ------- PRIVATE ---------

  , addCfgNodeWithLabel
  , mapCfgNode
 ) where

import Control.DeepSeq ( NFData )
import Control.Monad.State ( MonadState )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( fromJust, fromMaybe, isNothing, mapMaybe )
import Data.Set ( Set )
import qualified Data.Set as Set
import GHC.Generics ( Generic )

import Control.Lens ( (%=), (%~), (&), (?=), (^.), at, ix, makeClassy, makeClassyFor, use )

import Data.Comp.Multi ( All, E(..), EqHF, HFoldable, HFunctor(..), K(..), OrdHF, ShowHF, Sum, appSigFun, runE, subterms )
import Data.Comp.Multi.Derive ( KShow(..) )

import Cubix.Language.Info
import Cubix.Language.Parametric.Semantics.SemanticProperties
import Cubix.Sin.Compdata.Annotation ( getAnn, propAnnSigFun )

newtype CfgNodeType = CfgNodeType NodeEvaluationPoint
  deriving ( CfgNodeType -> CfgNodeType -> Bool
(CfgNodeType -> CfgNodeType -> Bool)
-> (CfgNodeType -> CfgNodeType -> Bool) -> Eq CfgNodeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CfgNodeType -> CfgNodeType -> Bool
== :: CfgNodeType -> CfgNodeType -> Bool
$c/= :: CfgNodeType -> CfgNodeType -> Bool
/= :: CfgNodeType -> CfgNodeType -> Bool
Eq, Eq CfgNodeType
Eq CfgNodeType =>
(CfgNodeType -> CfgNodeType -> Ordering)
-> (CfgNodeType -> CfgNodeType -> Bool)
-> (CfgNodeType -> CfgNodeType -> Bool)
-> (CfgNodeType -> CfgNodeType -> Bool)
-> (CfgNodeType -> CfgNodeType -> Bool)
-> (CfgNodeType -> CfgNodeType -> CfgNodeType)
-> (CfgNodeType -> CfgNodeType -> CfgNodeType)
-> Ord CfgNodeType
CfgNodeType -> CfgNodeType -> Bool
CfgNodeType -> CfgNodeType -> Ordering
CfgNodeType -> CfgNodeType -> CfgNodeType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CfgNodeType -> CfgNodeType -> Ordering
compare :: CfgNodeType -> CfgNodeType -> Ordering
$c< :: CfgNodeType -> CfgNodeType -> Bool
< :: CfgNodeType -> CfgNodeType -> Bool
$c<= :: CfgNodeType -> CfgNodeType -> Bool
<= :: CfgNodeType -> CfgNodeType -> Bool
$c> :: CfgNodeType -> CfgNodeType -> Bool
> :: CfgNodeType -> CfgNodeType -> Bool
$c>= :: CfgNodeType -> CfgNodeType -> Bool
>= :: CfgNodeType -> CfgNodeType -> Bool
$cmax :: CfgNodeType -> CfgNodeType -> CfgNodeType
max :: CfgNodeType -> CfgNodeType -> CfgNodeType
$cmin :: CfgNodeType -> CfgNodeType -> CfgNodeType
min :: CfgNodeType -> CfgNodeType -> CfgNodeType
Ord, Int -> CfgNodeType -> ShowS
[CfgNodeType] -> ShowS
CfgNodeType -> String
(Int -> CfgNodeType -> ShowS)
-> (CfgNodeType -> String)
-> ([CfgNodeType] -> ShowS)
-> Show CfgNodeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CfgNodeType -> ShowS
showsPrec :: Int -> CfgNodeType -> ShowS
$cshow :: CfgNodeType -> String
show :: CfgNodeType -> String
$cshowList :: [CfgNodeType] -> ShowS
showList :: [CfgNodeType] -> ShowS
Show, (forall x. CfgNodeType -> Rep CfgNodeType x)
-> (forall x. Rep CfgNodeType x -> CfgNodeType)
-> Generic CfgNodeType
forall x. Rep CfgNodeType x -> CfgNodeType
forall x. CfgNodeType -> Rep CfgNodeType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CfgNodeType -> Rep CfgNodeType x
from :: forall x. CfgNodeType -> Rep CfgNodeType x
$cto :: forall x. Rep CfgNodeType x -> CfgNodeType
to :: forall x. Rep CfgNodeType x -> CfgNodeType
Generic, CfgNodeType -> ()
(CfgNodeType -> ()) -> NFData CfgNodeType
forall a. (a -> ()) -> NFData a
$crnf :: CfgNodeType -> ()
rnf :: CfgNodeType -> ()
NFData )

pattern EnterNode :: CfgNodeType
pattern $mEnterNode :: forall {r}. CfgNodeType -> ((# #) -> r) -> ((# #) -> r) -> r
$bEnterNode :: CfgNodeType
EnterNode = CfgNodeType EnterEvalPoint

pattern LoopEntryNode :: CfgNodeType
pattern $mLoopEntryNode :: forall {r}. CfgNodeType -> ((# #) -> r) -> ((# #) -> r) -> r
$bLoopEntryNode :: CfgNodeType
LoopEntryNode = CfgNodeType LoopEntryPoint

pattern ExitNode :: CfgNodeType
pattern $mExitNode :: forall {r}. CfgNodeType -> ((# #) -> r) -> ((# #) -> r) -> r
$bExitNode :: CfgNodeType
ExitNode = CfgNodeType ExitEvalPoint

isEnterNode :: CfgNodeType -> Bool
isEnterNode :: CfgNodeType -> Bool
isEnterNode CfgNodeType
EnterNode = Bool
True
isEnterNode CfgNodeType
_         = Bool
False

evalPointToNodeType :: NodeEvaluationPoint -> CfgNodeType
evalPointToNodeType :: NodeEvaluationPoint -> CfgNodeType
evalPointToNodeType = NodeEvaluationPoint -> CfgNodeType
CfgNodeType

nodeTypeToEvalPoint :: CfgNodeType -> NodeEvaluationPoint
nodeTypeToEvalPoint :: CfgNodeType -> NodeEvaluationPoint
nodeTypeToEvalPoint (CfgNodeType NodeEvaluationPoint
p) = NodeEvaluationPoint
p

data CfgNode fs = CfgNode { forall (fs :: Signature). CfgNode fs -> Set Label
_cfg_node_prevs :: Set Label
                          , forall (fs :: Signature). CfgNode fs -> Set Label
_cfg_node_succs :: Set Label
                          , forall (fs :: Signature). CfgNode fs -> Label
_cfg_node_lab   :: Label
                          , forall (fs :: Signature). CfgNode fs -> CfgNodeType
_cfg_node_type  :: CfgNodeType
                          , forall (fs :: Signature). CfgNode fs -> E (TermLab fs)
_cfg_node_term  :: E (TermLab fs)
                          }
  deriving ( (forall x. CfgNode fs -> Rep (CfgNode fs) x)
-> (forall x. Rep (CfgNode fs) x -> CfgNode fs)
-> Generic (CfgNode fs)
forall (fs :: Signature) x. Rep (CfgNode fs) x -> CfgNode fs
forall (fs :: Signature) x. CfgNode fs -> Rep (CfgNode fs) x
forall x. Rep (CfgNode fs) x -> CfgNode fs
forall x. CfgNode fs -> Rep (CfgNode fs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (fs :: Signature) x. CfgNode fs -> Rep (CfgNode fs) x
from :: forall x. CfgNode fs -> Rep (CfgNode fs) x
$cto :: forall (fs :: Signature) x. Rep (CfgNode fs) x -> CfgNode fs
to :: forall x. Rep (CfgNode fs) x -> CfgNode fs
Generic )

deriving instance (All ShowHF fs, All HFunctor fs) => Show (CfgNode fs)
deriving instance (All HFunctor fs, All OrdHF fs, All EqHF fs) => Ord (CfgNode fs)
deriving instance (All EqHF fs) => Eq (CfgNode fs)

data Cfg fs = Cfg {
                   forall (fs :: Signature). Cfg fs -> Map Label (CfgNode fs)
_cfg_nodes     :: Map Label (CfgNode fs)
                 , forall (fs :: Signature).
Cfg fs -> Map Label (Map CfgNodeType Label)
_cfg_ast_nodes :: Map Label (Map CfgNodeType Label)
                 }
  deriving ( (forall x. Cfg fs -> Rep (Cfg fs) x)
-> (forall x. Rep (Cfg fs) x -> Cfg fs) -> Generic (Cfg fs)
forall (fs :: Signature) x. Rep (Cfg fs) x -> Cfg fs
forall (fs :: Signature) x. Cfg fs -> Rep (Cfg fs) x
forall x. Rep (Cfg fs) x -> Cfg fs
forall x. Cfg fs -> Rep (Cfg fs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (fs :: Signature) x. Cfg fs -> Rep (Cfg fs) x
from :: forall x. Cfg fs -> Rep (Cfg fs) x
$cto :: forall (fs :: Signature) x. Rep (Cfg fs) x -> Cfg fs
to :: forall x. Rep (Cfg fs) x -> Cfg fs
Generic )

deriving instance (All ShowHF fs, All HFunctor fs) => Show (Cfg fs)
deriving instance (All HFunctor fs, All OrdHF fs, All EqHF fs) => Ord (Cfg fs)
deriving instance (All EqHF fs) => Eq (Cfg fs)

makeClassyFor "HasCurCfg" "cur_cfg" [("_cfg_nodes", "cfg_nodes"), ("_cfg_ast_nodes", "cfg_ast_nodes")] ''Cfg

makeClassy ''CfgNode

mapCfgNode :: (All HFunctor fs) => (forall e i. Sum fs e i -> Sum gs e i) -> (CfgNode fs -> CfgNode gs)
mapCfgNode :: forall (fs :: Signature) (gs :: Signature).
All HFunctor fs =>
(forall (e :: * -> *) i. Sum fs e i -> Sum gs e i)
-> CfgNode fs -> CfgNode gs
mapCfgNode forall (e :: * -> *) i. Sum fs e i -> Sum gs e i
f CfgNode fs
n = CfgNode { _cfg_node_prevs :: Set Label
_cfg_node_prevs = CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_prevs
                         , _cfg_node_succs :: Set Label
_cfg_node_succs = CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs
                         , _cfg_node_lab :: Label
_cfg_node_lab   = CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab
                         , _cfg_node_type :: CfgNodeType
_cfg_node_type  = CfgNode fs
n CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: Signature). HasCfgNode c fs => Lens' c CfgNodeType
Lens' (CfgNode fs) CfgNodeType
cfg_node_type
                         , _cfg_node_term :: E (TermLab gs)
_cfg_node_term  = (CfgNode fs
n CfgNode fs
-> Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
-> E (TermLab fs)
forall s a. s -> Getting a s a -> a
^. Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
forall c (fs :: Signature).
HasCfgNode c fs =>
Lens' c (E (TermLab fs))
Lens' (CfgNode fs) (E (TermLab fs))
cfg_node_term) E (TermLab fs)
-> (E (TermLab fs) -> E (TermLab gs)) -> E (TermLab gs)
forall a b. a -> (a -> b) -> b
& (\(E TermLab fs i
x) -> TermLab gs i -> E (TermLab gs)
forall (f :: * -> *) i. f i -> E f
E (SigFun (Sum fs :&: Label) (Sum gs :&: Label)
-> CxtFun (Sum fs :&: Label) (Sum gs :&: Label)
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *).
HFunctor f =>
SigFun f g -> CxtFun f g
appSigFun ((forall (e :: * -> *) i. Sum fs e i -> Sum gs e i)
-> SigFun (Sum fs :&: Label) (Sum gs :&: Label)
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) a.
SigFun f g -> SigFun (f :&: a) (g :&: a)
propAnnSigFun Sum fs a i -> Sum gs a i
forall (e :: * -> *) i. Sum fs e i -> Sum gs e i
f) TermLab fs i
x))
                         }

emptyCfg :: Cfg fs
emptyCfg :: forall (fs :: Signature). Cfg fs
emptyCfg = Map Label (CfgNode fs)
-> Map Label (Map CfgNodeType Label) -> Cfg fs
forall (fs :: Signature).
Map Label (CfgNode fs)
-> Map Label (Map CfgNodeType Label) -> Cfg fs
Cfg Map Label (CfgNode fs)
forall k a. Map k a
Map.empty Map Label (Map CfgNodeType Label)
forall k a. Map k a
Map.empty

cfgNodes :: Cfg fs -> [CfgNode fs]
cfgNodes :: forall (fs :: Signature). Cfg fs -> [CfgNode fs]
cfgNodes Cfg fs
cfg = ((Label, CfgNode fs) -> CfgNode fs)
-> [(Label, CfgNode fs)] -> [CfgNode fs]
forall a b. (a -> b) -> [a] -> [b]
map (Label, CfgNode fs) -> CfgNode fs
forall a b. (a, b) -> b
snd ([(Label, CfgNode fs)] -> [CfgNode fs])
-> [(Label, CfgNode fs)] -> [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ Map Label (CfgNode fs) -> [(Label, CfgNode fs)]
forall k a. Map k a -> [(k, a)]
Map.toList (Cfg fs
cfg Cfg fs
-> Getting
     (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
-> Map Label (CfgNode fs)
forall s a. s -> Getting a s a -> a
^. Getting (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes)

addCfgNodeWithLabel :: (HasCurCfg s fs, MonadState s m) => TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel :: forall s (fs :: Signature) (m :: * -> *) l.
(HasCurCfg s fs, MonadState s m) =>
TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel TermLab fs l
t Label
l CfgNodeType
typ = do
  let node :: CfgNode fs
node = CfgNode { _cfg_node_prevs :: Set Label
_cfg_node_prevs = Set Label
forall a. Set a
Set.empty
                     , _cfg_node_succs :: Set Label
_cfg_node_succs = Set Label
forall a. Set a
Set.empty
                     , _cfg_node_lab :: Label
_cfg_node_lab   = Label
l
                     , _cfg_node_type :: CfgNodeType
_cfg_node_type  = CfgNodeType
typ
                     , _cfg_node_term :: E (TermLab fs)
_cfg_node_term  = TermLab fs l -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs l
t
                     }

  let astLab :: Label
astLab = TermLab fs l -> Label
TermLab fs :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn TermLab fs l
t
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: Signature). HasCurCfg c fs => Lens' c (Cfg fs)
Lens' s (Cfg fs)
cur_cfg((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> ((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
    -> Cfg fs -> Identity (Cfg fs))
-> (Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
    -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> (Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (CfgNode fs))
-> Lens'
     (Map Label (CfgNode fs)) (Maybe (IxValue (Map Label (CfgNode fs))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Label (CfgNode fs))
Label
l) ((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
 -> s -> Identity s)
-> CfgNode fs -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= CfgNode fs
node

  -- ensure map exists
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: Signature). HasCurCfg c fs => Lens' c (Cfg fs)
Lens' s (Cfg fs)
cur_cfg((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> ((Map Label (Map CfgNodeType Label)
     -> Identity (Map Label (Map CfgNodeType Label)))
    -> Cfg fs -> Identity (Cfg fs))
-> (Map Label (Map CfgNodeType Label)
    -> Identity (Map Label (Map CfgNodeType Label)))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Map Label (Map CfgNodeType Label)
 -> Identity (Map Label (Map CfgNodeType Label)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (Map CfgNodeType Label))
Lens' (Cfg fs) (Map Label (Map CfgNodeType Label))
cfg_ast_nodes ((Map Label (Map CfgNodeType Label)
  -> Identity (Map Label (Map CfgNodeType Label)))
 -> s -> Identity s)
-> (Map Label (Map CfgNodeType Label)
    -> Map Label (Map CfgNodeType Label))
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \Map Label (Map CfgNodeType Label)
m -> case Label
-> Map Label (Map CfgNodeType Label)
-> Maybe (Map CfgNodeType Label)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
astLab Map Label (Map CfgNodeType Label)
m of
                                   Maybe (Map CfgNodeType Label)
Nothing -> Label
-> Map CfgNodeType Label
-> Map Label (Map CfgNodeType Label)
-> Map Label (Map CfgNodeType Label)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Label
astLab Map CfgNodeType Label
forall k a. Map k a
Map.empty Map Label (Map CfgNodeType Label)
m
                                   Just  Map CfgNodeType Label
_ -> Map Label (Map CfgNodeType Label)
m

  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: Signature). HasCurCfg c fs => Lens' c (Cfg fs)
Lens' s (Cfg fs)
cur_cfg((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> ((Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
    -> Cfg fs -> Identity (Cfg fs))
-> (Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Map Label (Map CfgNodeType Label)
 -> Identity (Map Label (Map CfgNodeType Label)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (Map CfgNodeType Label))
Lens' (Cfg fs) (Map Label (Map CfgNodeType Label))
cfg_ast_nodes((Map Label (Map CfgNodeType Label)
  -> Identity (Map Label (Map CfgNodeType Label)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
    -> Map Label (Map CfgNodeType Label)
    -> Identity (Map Label (Map CfgNodeType Label)))
-> (Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (Map CfgNodeType Label))
-> Traversal'
     (Map Label (Map CfgNodeType Label))
     (IxValue (Map Label (Map CfgNodeType Label)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Label (Map CfgNodeType Label))
Label
astLab) ((Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
 -> s -> Identity s)
-> (Map CfgNodeType Label -> Map CfgNodeType Label) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNodeType
-> Label -> Map CfgNodeType Label -> Map CfgNodeType Label
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CfgNodeType
typ Label
l

  return CfgNode fs
node

addCfgNode :: (HasCurCfg s fs, HasLabelGen s, MonadState s m) => TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode :: forall s (fs :: Signature) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
typ = do
  Label
l <- m Label
forall s (m :: * -> *). (MonadState s m, HasLabelGen s) => m Label
nextLabel
  TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: Signature) (m :: * -> *) l.
(HasCurCfg s fs, MonadState s m) =>
TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel TermLab fs l
t Label
l CfgNodeType
typ

nodeForLab :: (HasCurCfg s fs, MonadState s m) => Label -> m (Maybe (CfgNode fs))
nodeForLab :: forall s (fs :: Signature) (m :: * -> *).
(HasCurCfg s fs, MonadState s m) =>
Label -> m (Maybe (CfgNode fs))
nodeForLab Label
l = Label -> Map Label (CfgNode fs) -> Maybe (CfgNode fs)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
l (Map Label (CfgNode fs) -> Maybe (CfgNode fs))
-> m (Map Label (CfgNode fs)) -> m (Maybe (CfgNode fs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Map Label (CfgNode fs)) s (Map Label (CfgNode fs))
-> m (Map Label (CfgNode fs))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Cfg fs -> Const (Map Label (CfgNode fs)) (Cfg fs))
-> s -> Const (Map Label (CfgNode fs)) s
forall c (fs :: Signature). HasCurCfg c fs => Lens' c (Cfg fs)
Lens' s (Cfg fs)
cur_cfg((Cfg fs -> Const (Map Label (CfgNode fs)) (Cfg fs))
 -> s -> Const (Map Label (CfgNode fs)) s)
-> ((Map Label (CfgNode fs)
     -> Const (Map Label (CfgNode fs)) (Map Label (CfgNode fs)))
    -> Cfg fs -> Const (Map Label (CfgNode fs)) (Cfg fs))
-> Getting (Map Label (CfgNode fs)) s (Map Label (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Map Label (CfgNode fs)
 -> Const (Map Label (CfgNode fs)) (Map Label (CfgNode fs)))
-> Cfg fs -> Const (Map Label (CfgNode fs)) (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes)

addEdge :: CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge :: forall (fs :: Signature).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
from CfgNode fs
to Cfg fs
cfg = Cfg fs
cfg''
  where
    fl :: Label
fl = CfgNode fs
from CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab
    tl :: Label
tl = CfgNode fs
to   CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab

    cfg' :: Cfg fs
cfg'  = Cfg fs
cfg  Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& ((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Set Label -> Identity (Set Label))
    -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (CfgNode fs))
-> Lens'
     (Map Label (CfgNode fs)) (Maybe (IxValue (Map Label (CfgNode fs))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Label (CfgNode fs))
Label
fl)((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
 -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Map Label (CfgNode fs)
-> Identity (Map Label (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CfgNode fs -> Identity (CfgNode fs))
-> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse((CfgNode fs -> Identity (CfgNode fs))
 -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> CfgNode fs -> Identity (CfgNode fs))
-> (Set Label -> Identity (Set Label))
-> Maybe (CfgNode fs)
-> Identity (Maybe (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set Label -> Identity (Set Label))
-> CfgNode fs -> Identity (CfgNode fs)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs) ((Set Label -> Identity (Set Label))
 -> Cfg fs -> Identity (Cfg fs))
-> (Set Label -> Set Label) -> Cfg fs -> Cfg fs
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Label -> Set Label -> Set Label
forall a. Ord a => a -> Set a -> Set a
Set.insert Label
tl)
    cfg'' :: Cfg fs
cfg'' = Cfg fs
cfg' Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& ((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Set Label -> Identity (Set Label))
    -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (CfgNode fs))
-> Lens'
     (Map Label (CfgNode fs)) (Maybe (IxValue (Map Label (CfgNode fs))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Label (CfgNode fs))
Label
tl)((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
 -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Map Label (CfgNode fs)
-> Identity (Map Label (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CfgNode fs -> Identity (CfgNode fs))
-> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse((CfgNode fs -> Identity (CfgNode fs))
 -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> CfgNode fs -> Identity (CfgNode fs))
-> (Set Label -> Identity (Set Label))
-> Maybe (CfgNode fs)
-> Identity (Maybe (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set Label -> Identity (Set Label))
-> CfgNode fs -> Identity (CfgNode fs)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_prevs) ((Set Label -> Identity (Set Label))
 -> Cfg fs -> Identity (Cfg fs))
-> (Set Label -> Set Label) -> Cfg fs -> Cfg fs
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Label -> Set Label -> Set Label
forall a. Ord a => a -> Set a -> Set a
Set.insert Label
fl)

addEdgeLab :: forall fs. Label -> Label -> Cfg fs -> Cfg fs
addEdgeLab :: forall (fs :: Signature). Label -> Label -> Cfg fs -> Cfg fs
addEdgeLab Label
l1 Label
l2 Cfg fs
cfg = Cfg fs -> Maybe (Cfg fs) -> Cfg fs
forall a. a -> Maybe a -> a
fromMaybe Cfg fs
cfg Maybe (Cfg fs)
cfg'
  where
    cfg' :: Maybe (Cfg fs)
    cfg' :: Maybe (Cfg fs)
cfg' = do
      CfgNode fs
n1 <- Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: Signature). Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l1
      CfgNode fs
n2 <- Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: Signature). Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l2
      return $ CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: Signature).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
n1 CfgNode fs
n2 Cfg fs
cfg

removeEdgeLab :: Label -> Label -> Cfg fs -> Cfg fs
removeEdgeLab :: forall (fs :: Signature). Label -> Label -> Cfg fs -> Cfg fs
removeEdgeLab Label
l1 Label
l2 Cfg fs
cfg = Cfg fs
cfg''
  where
    cfg' :: Cfg fs
cfg'  = Cfg fs
cfg  Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& ((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Set Label -> Identity (Set Label))
    -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (CfgNode fs))
-> Lens'
     (Map Label (CfgNode fs)) (Maybe (IxValue (Map Label (CfgNode fs))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Label (CfgNode fs))
Label
l1)((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
 -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Map Label (CfgNode fs)
-> Identity (Map Label (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CfgNode fs -> Identity (CfgNode fs))
-> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse((CfgNode fs -> Identity (CfgNode fs))
 -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> CfgNode fs -> Identity (CfgNode fs))
-> (Set Label -> Identity (Set Label))
-> Maybe (CfgNode fs)
-> Identity (Maybe (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set Label -> Identity (Set Label))
-> CfgNode fs -> Identity (CfgNode fs)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs) ((Set Label -> Identity (Set Label))
 -> Cfg fs -> Identity (Cfg fs))
-> (Set Label -> Set Label) -> Cfg fs -> Cfg fs
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Label -> Set Label -> Set Label
forall a. Ord a => a -> Set a -> Set a
Set.delete Label
l2)
    cfg'' :: Cfg fs
cfg'' = Cfg fs
cfg' Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& ((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Set Label -> Identity (Set Label))
    -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (CfgNode fs))
-> Lens'
     (Map Label (CfgNode fs)) (Maybe (IxValue (Map Label (CfgNode fs))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Label (CfgNode fs))
Label
l2)((Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
 -> Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> (Set Label -> Identity (Set Label))
-> Map Label (CfgNode fs)
-> Identity (Map Label (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CfgNode fs -> Identity (CfgNode fs))
-> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse((CfgNode fs -> Identity (CfgNode fs))
 -> Maybe (CfgNode fs) -> Identity (Maybe (CfgNode fs)))
-> ((Set Label -> Identity (Set Label))
    -> CfgNode fs -> Identity (CfgNode fs))
-> (Set Label -> Identity (Set Label))
-> Maybe (CfgNode fs)
-> Identity (Maybe (CfgNode fs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set Label -> Identity (Set Label))
-> CfgNode fs -> Identity (CfgNode fs)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_prevs) ((Set Label -> Identity (Set Label))
 -> Cfg fs -> Identity (Cfg fs))
-> (Set Label -> Set Label) -> Cfg fs -> Cfg fs
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Label -> Set Label -> Set Label
forall a. Ord a => a -> Set a -> Set a
Set.delete Label
l1)

safeLookupCfg :: Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg :: forall (fs :: Signature). Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l = Label -> Map Label (CfgNode fs) -> Maybe (CfgNode fs)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
l (Cfg fs
cfg Cfg fs
-> Getting
     (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
-> Map Label (CfgNode fs)
forall s a. s -> Getting a s a -> a
^. Getting (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes)

lookupCfg :: Cfg fs -> Label -> CfgNode fs
lookupCfg :: forall (fs :: Signature). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
cfg Label
l = case Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: Signature). Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l of
  Just CfgNode fs
n  -> CfgNode fs
n
  Maybe (CfgNode fs)
Nothing -> String -> CfgNode fs
forall a. HasCallStack => String -> a
error (String -> CfgNode fs) -> String -> CfgNode fs
forall a b. (a -> b) -> a -> b
$ String
"Label not found in CFG: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Label -> String
forall a. Show a => a -> String
show Label
l

cfgNodeForTerm :: Cfg fs -> CfgNodeType -> TermLab fs l -> Maybe (CfgNode fs)
cfgNodeForTerm :: forall (fs :: Signature) l.
Cfg fs -> CfgNodeType -> TermLab fs l -> Maybe (CfgNode fs)
cfgNodeForTerm Cfg fs
cfg CfgNodeType
typ TermLab fs l
t = do
  Map CfgNodeType Label
nodeMap <- Label
-> Map Label (Map CfgNodeType Label)
-> Maybe (Map CfgNodeType Label)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TermLab fs l -> Label
HFix (Sum fs :&: Label) :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn TermLab fs l
t) (Cfg fs
cfg Cfg fs
-> Getting
     (Map Label (Map CfgNodeType Label))
     (Cfg fs)
     (Map Label (Map CfgNodeType Label))
-> Map Label (Map CfgNodeType Label)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map Label (Map CfgNodeType Label))
  (Cfg fs)
  (Map Label (Map CfgNodeType Label))
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (Map CfgNodeType Label))
Lens' (Cfg fs) (Map Label (Map CfgNodeType Label))
cfg_ast_nodes)
  Label
cfgLab <- CfgNodeType -> Map CfgNodeType Label -> Maybe Label
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CfgNodeType
typ Map CfgNodeType Label
nodeMap
  Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: Signature). Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
cfgLab

removeNode :: CfgNode fs -> Cfg fs -> Cfg fs
removeNode :: forall (fs :: Signature). CfgNode fs -> Cfg fs -> Cfg fs
removeNode CfgNode fs
n Cfg fs
g = Cfg fs
g Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& Cfg fs -> Cfg fs
removePredEdges
                   Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& Cfg fs -> Cfg fs
removeSuccEdges
                   Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& ((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes     ((Map Label (CfgNode fs) -> Identity (Map Label (CfgNode fs)))
 -> Cfg fs -> Identity (Cfg fs))
-> (Map Label (CfgNode fs) -> Map Label (CfgNode fs))
-> Cfg fs
-> Cfg fs
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Label -> Map Label (CfgNode fs) -> Map Label (CfgNode fs)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Label
lab)
                   Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& ((Map Label (Map CfgNodeType Label)
 -> Identity (Map Label (Map CfgNodeType Label)))
-> Cfg fs -> Identity (Cfg fs)
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (Map CfgNodeType Label))
Lens' (Cfg fs) (Map Label (Map CfgNodeType Label))
cfg_ast_nodes((Map Label (Map CfgNodeType Label)
  -> Identity (Map Label (Map CfgNodeType Label)))
 -> Cfg fs -> Identity (Cfg fs))
-> ((Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
    -> Map Label (Map CfgNodeType Label)
    -> Identity (Map Label (Map CfgNodeType Label)))
-> (Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
-> Cfg fs
-> Identity (Cfg fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Index (Map Label (Map CfgNodeType Label))
-> Traversal'
     (Map Label (Map CfgNodeType Label))
     (IxValue (Map Label (Map CfgNodeType Label)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Label (Map CfgNodeType Label))
Label
termLab) ((Map CfgNodeType Label -> Identity (Map CfgNodeType Label))
 -> Cfg fs -> Identity (Cfg fs))
-> (Map CfgNodeType Label -> Map CfgNodeType Label)
-> Cfg fs
-> Cfg fs
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ CfgNodeType -> Map CfgNodeType Label -> Map CfgNodeType Label
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete CfgNodeType
nodeType)
  where
    lab :: Label
lab = CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab
    termLab :: Label
termLab = (TermLab fs :=> Label) -> E (TermLab fs) -> Label
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE HFix (Sum fs :&: Label) i -> Label
TermLab fs :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn (CfgNode fs
n CfgNode fs
-> Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
-> E (TermLab fs)
forall s a. s -> Getting a s a -> a
^. Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
forall c (fs :: Signature).
HasCfgNode c fs =>
Lens' c (E (TermLab fs))
Lens' (CfgNode fs) (E (TermLab fs))
cfg_node_term)
    nodeType :: CfgNodeType
nodeType = CfgNode fs
n CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: Signature). HasCfgNode c fs => Lens' c CfgNodeType
Lens' (CfgNode fs) CfgNodeType
cfg_node_type

    removePredEdges :: Cfg fs -> Cfg fs
removePredEdges Cfg fs
gr = (Label -> Cfg fs -> Cfg fs) -> Cfg fs -> [Label] -> Cfg fs
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Label
p -> Label -> Label -> Cfg fs -> Cfg fs
forall (fs :: Signature). Label -> Label -> Cfg fs -> Cfg fs
removeEdgeLab Label
p Label
lab) Cfg fs
gr (Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_prevs))
    removeSuccEdges :: Cfg fs -> Cfg fs
removeSuccEdges Cfg fs
gr = (Label -> Cfg fs -> Cfg fs) -> Cfg fs -> [Label] -> Cfg fs
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Label
s -> Label -> Label -> Cfg fs -> Cfg fs
forall (fs :: Signature). Label -> Label -> Cfg fs -> Cfg fs
removeEdgeLab Label
lab Label
s) Cfg fs
gr (Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs))

-- TODO: Find out what this is actually called; "vertex contraction" is something else
contractNode :: Label -> Cfg fs -> Cfg fs
contractNode :: forall (fs :: Signature). Label -> Cfg fs -> Cfg fs
contractNode Label
l Cfg fs
g = CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: Signature). CfgNode fs -> Cfg fs -> Cfg fs
removeNode CfgNode fs
n (Cfg fs -> Cfg fs) -> Cfg fs -> Cfg fs
forall a b. (a -> b) -> a -> b
$
                   ((Label, Label) -> Cfg fs -> Cfg fs)
-> Cfg fs -> [(Label, Label)] -> Cfg fs
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Label, Label) -> Cfg fs -> Cfg fs
forall {fs :: Signature}. (Label, Label) -> Cfg fs -> Cfg fs
add Cfg fs
g [(Label
x, Label
y) | Label
x <- (Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_prevs))
                                       , Label
y <- (Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (CfgNode fs
n CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs))]
  where
    n :: CfgNode fs
n = Cfg fs -> Label -> CfgNode fs
forall (fs :: Signature). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
g Label
l
    add :: (Label, Label) -> Cfg fs -> Cfg fs
add (Label
x, Label
y) Cfg fs
gr = CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: Signature).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (Cfg fs -> Label -> CfgNode fs
forall (fs :: Signature). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
gr Label
x) (Cfg fs -> Label -> CfgNode fs
forall (fs :: Signature). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
gr Label
y) Cfg fs
gr

satisfyingBoundary :: Set Label -> (CfgNode fs -> Set Label) -> (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingBoundary :: forall (fs :: Signature).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
satisfyingBoundary Set Label
seen CfgNode fs -> Set Label
succ CfgNode fs -> Bool
pred Cfg fs
cfg CfgNode fs
node =
  if Label -> Set Label -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (CfgNode fs
node CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab) Set Label
seen then
    Maybe [CfgNode fs]
forall a. Maybe a
Nothing
  else if CfgNode fs -> Bool
pred CfgNode fs
node then
    [CfgNode fs] -> Maybe [CfgNode fs]
forall a. a -> Maybe a
Just [ CfgNode fs
node ]
  else
    let labs :: [Label]
labs = Set Label -> [Label]
forall a. Set a -> [a]
Set.toList (Set Label -> [Label]) -> Set Label -> [Label]
forall a b. (a -> b) -> a -> b
$ CfgNode fs -> Set Label
succ CfgNode fs
node in
    if [Label]
labs [Label] -> [Label] -> Bool
forall a. Eq a => a -> a -> Bool
== [] then
      Maybe [CfgNode fs]
forall a. Maybe a
Nothing
    else  [CfgNode fs] -> Maybe [CfgNode fs]
forall a. a -> Maybe a
Just ([CfgNode fs] -> Maybe [CfgNode fs])
-> [CfgNode fs] -> Maybe [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ [[CfgNode fs]] -> [CfgNode fs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CfgNode fs]] -> [CfgNode fs]) -> [[CfgNode fs]] -> [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ (Label -> Maybe [CfgNode fs]) -> [Label] -> [[CfgNode fs]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Label -> Maybe [CfgNode fs]
getNext [Label]
labs  where -- In this case, we convert [ Maybe [ CfgNode fs ] ] always into Just [ CfgNode fs ].
      -- getNext :: CfgNode fs -> Maybe [ CfgNode fs ]
      getNext :: Label -> Maybe [CfgNode fs]
getNext Label
nextLab = Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
forall (fs :: Signature).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
satisfyingBoundary (Label -> Set Label -> Set Label
forall a. Ord a => a -> Set a -> Set a
Set.insert (CfgNode fs
node CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab) Set Label
seen) CfgNode fs -> Set Label
succ CfgNode fs -> Bool
pred Cfg fs
cfg (Cfg fs -> Label -> CfgNode fs
forall (fs :: Signature). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
cfg Label
nextLab)

satisfyingPredBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingPredBoundary :: forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingPredBoundary = Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
forall (fs :: Signature).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
satisfyingBoundary Set Label
forall a. Set a
Set.empty (CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_prevs)

satisfyingSuccBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingSuccBoundary :: forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingSuccBoundary = Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
forall (fs :: Signature).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> Maybe [CfgNode fs]
satisfyingBoundary Set Label
forall a. Set a
Set.empty (CfgNode fs
-> Getting (Set Label) (CfgNode fs) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode fs) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode fs) (Set Label)
cfg_node_succs)

satisfyingStrictPredBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictPredBoundary :: forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictPredBoundary CfgNode fs -> Bool
pred Cfg fs
cfg CfgNode fs
node = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingPredBoundary CfgNode fs -> Bool
pred' Cfg fs
cfg CfgNode fs
node
  where
    pred' :: CfgNode fs -> Bool
pred' CfgNode fs
n = ((CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab) Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
/= (CfgNode fs
node CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab)) Bool -> Bool -> Bool
&& CfgNode fs -> Bool
pred CfgNode fs
n

satisfyingStrictSuccBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictSuccBoundary :: forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictSuccBoundary CfgNode fs -> Bool
pred Cfg fs
cfg CfgNode fs
node = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingSuccBoundary CfgNode fs -> Bool
pred' Cfg fs
cfg CfgNode fs
node
  where
    pred' :: CfgNode fs -> Bool
pred' CfgNode fs
n = ((CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab) Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
/= (CfgNode fs
node CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab)) Bool -> Bool -> Bool
&& CfgNode fs -> Bool
pred CfgNode fs
n

enterNodePreds :: Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds :: forall (fs :: Signature).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds Cfg fs
cfg CfgNode fs
n = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictPredBoundary (CfgNodeType -> Bool
isEnterNode (CfgNodeType -> Bool)
-> (CfgNode fs -> CfgNodeType) -> CfgNode fs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: Signature). HasCfgNode c fs => Lens' c CfgNodeType
Lens' (CfgNode fs) CfgNodeType
cfg_node_type)) Cfg fs
cfg CfgNode fs
n

enterNodeSuccs :: Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodeSuccs :: forall (fs :: Signature).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodeSuccs Cfg fs
cfg CfgNode fs
n = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictSuccBoundary (CfgNodeType -> Bool
isEnterNode (CfgNodeType -> Bool)
-> (CfgNode fs -> CfgNodeType) -> CfgNode fs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: Signature). HasCfgNode c fs => Lens' c CfgNodeType
Lens' (CfgNode fs) CfgNodeType
cfg_node_type)) Cfg fs
cfg CfgNode fs
n

--------------------------------------------------------------------------------------

prettyCfg :: Cfg fs -> String
prettyCfg :: forall (fs :: Signature). Cfg fs -> String
prettyCfg Cfg fs
cfg = (CfgNode fs -> String) -> [CfgNode fs] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CfgNode fs -> String
forall (f :: Signature). CfgNode f -> String
nodeEdges [CfgNode fs]
nodes
  where
    nodes :: [CfgNode fs]
nodes = ((Label, CfgNode fs) -> CfgNode fs)
-> [(Label, CfgNode fs)] -> [CfgNode fs]
forall a b. (a -> b) -> [a] -> [b]
map (Label, CfgNode fs) -> CfgNode fs
forall a b. (a, b) -> b
snd ([(Label, CfgNode fs)] -> [CfgNode fs])
-> [(Label, CfgNode fs)] -> [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ Map Label (CfgNode fs) -> [(Label, CfgNode fs)]
forall k a. Map k a -> [(k, a)]
Map.toList (Cfg fs
cfg Cfg fs
-> Getting
     (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
-> Map Label (CfgNode fs)
forall s a. s -> Getting a s a -> a
^. Getting (Map Label (CfgNode fs)) (Cfg fs) (Map Label (CfgNode fs))
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
Lens' (Cfg fs) (Map Label (CfgNode fs))
cfg_nodes)

    nodeEdges :: CfgNode f -> String
    nodeEdges :: forall (f :: Signature). CfgNode f -> String
nodeEdges CfgNode f
n = (Label -> String) -> Set Label -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Label -> Label -> String
pEdge (CfgNode f
n CfgNode f -> Getting Label (CfgNode f) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode f) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode f) Label
cfg_node_lab)) (CfgNode f
n CfgNode f
-> Getting (Set Label) (CfgNode f) (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) (CfgNode f) (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' (CfgNode f) (Set Label)
cfg_node_succs)
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ CfgNode f -> String
forall {s} {fs :: Signature}. HasCfgNode s fs => s -> String
pInterestingDegree CfgNode f
n

    pEdge :: Label -> Label -> String
    pEdge :: Label -> Label -> String
pEdge Label
x Label
y = String
"Edge: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Label -> String
ppLabel Label
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Label -> String
ppLabel Label
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

    pInterestingDegree :: s -> String
pInterestingDegree s
n |
          (Set Label -> Int
forall a. Set a -> Int
Set.size  (s
n s -> Getting (Set Label) s (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) s (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' s (Set Label)
cfg_node_succs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1)
       Bool -> Bool -> Bool
|| (Set Label -> Int
forall a. Set a -> Int
Set.size  (s
n s -> Getting (Set Label) s (Set Label) -> Set Label
forall s a. s -> Getting a s a -> a
^. Getting (Set Label) s (Set Label)
forall c (fs :: Signature). HasCfgNode c fs => Lens' c (Set Label)
Lens' s (Set Label)
cfg_node_prevs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1)
       = String
"Node " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Label -> String
ppLabel (s
n s -> Getting Label s Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label s Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' s Label
cfg_node_lab) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has interesting degree\n"
    pInterestingDegree s
_ = String
""


getCfgLab :: forall fs l. Cfg fs -> TermLab fs l -> [Label]
getCfgLab :: forall (fs :: Signature) l. Cfg fs -> TermLab fs l -> [Label]
getCfgLab Cfg fs
cfg TermLab fs l
t = case Label
-> Map Label (Map CfgNodeType Label)
-> Maybe (Map CfgNodeType Label)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
astLab (Cfg fs
cfg Cfg fs
-> Getting
     (Map Label (Map CfgNodeType Label))
     (Cfg fs)
     (Map Label (Map CfgNodeType Label))
-> Map Label (Map CfgNodeType Label)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map Label (Map CfgNodeType Label))
  (Cfg fs)
  (Map Label (Map CfgNodeType Label))
forall c (fs :: Signature).
HasCurCfg c fs =>
Lens' c (Map Label (Map CfgNodeType Label))
Lens' (Cfg fs) (Map Label (Map CfgNodeType Label))
cfg_ast_nodes) of
                    Maybe (Map CfgNodeType Label)
Nothing -> []
                    Just Map CfgNodeType Label
m -> ((CfgNodeType, Label) -> Label)
-> [(CfgNodeType, Label)] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (CfgNodeType, Label) -> Label
forall a b. (a, b) -> b
snd ([(CfgNodeType, Label)] -> [Label])
-> [(CfgNodeType, Label)] -> [Label]
forall a b. (a -> b) -> a -> b
$ Map CfgNodeType Label -> [(CfgNodeType, Label)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CfgNodeType Label
m
  where
    astLab :: Label
astLab = TermLab fs l -> Label
HFix (Sum fs :&: Label) :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn TermLab fs l
t

putSubtree :: (All ShowHF fs, All HFoldable fs, All HFunctor fs) => TermLab fs l -> Cfg fs ->  IO ()
putSubtree :: forall (fs :: Signature) l.
(All ShowHF fs, All HFoldable fs, All HFunctor fs) =>
TermLab fs l -> Cfg fs -> IO ()
putSubtree TermLab fs l
t Cfg fs
cfg = do
 let cfgLab :: [Label]
cfgLab = Cfg fs -> TermLab fs l -> [Label]
forall (fs :: Signature) l. Cfg fs -> TermLab fs l -> [Label]
getCfgLab Cfg fs
cfg TermLab fs l
t
 if [Label] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Label]
cfgLab Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
   String -> IO ()
putStrLn String
""
   String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (Label -> String
forall a. Show a => a -> String
show (Label -> String) -> Label -> String
forall a b. (a -> b) -> a -> b
$ TermLab fs l -> Label
Cxt NoHole (Sum fs :&: Label) (K ()) :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn TermLab fs l
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(cfg: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Label] -> String
forall a. Show a => a -> String
show [Label]
cfgLab String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
   String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TermLab fs l -> String
forall a. Show a => a -> String
show TermLab fs l
t
  else
   () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Prints a large amount of debug information about a CFG,
--   including a node list, an edge list, and a record of which nodes begin basic blocks.
--
-- For an actual graph visualization, see "Cubix.Language.Parametric.Semantics.CfgDot"
debugCfg :: (All ShowHF fs, All HFoldable fs, All HFunctor fs) => TermLab fs l -> Cfg fs -> IO ()
debugCfg :: forall (fs :: Signature) l.
(All ShowHF fs, All HFoldable fs, All HFunctor fs) =>
TermLab fs l -> Cfg fs -> IO ()
debugCfg TermLab fs l
t Cfg fs
cfg = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Cfg fs -> String
forall (fs :: Signature). Cfg fs -> String
prettyCfg Cfg fs
cfg
  (E (Cxt NoHole (Sum fs :&: Label) (K ())) -> IO ())
-> [E (Cxt NoHole (Sum fs :&: Label) (K ()))] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(E Cxt NoHole (Sum fs :&: Label) (K ()) i
t) -> Cxt NoHole (Sum fs :&: Label) (K ()) i -> Cfg fs -> IO ()
forall (fs :: Signature) l.
(All ShowHF fs, All HFoldable fs, All HFunctor fs) =>
TermLab fs l -> Cfg fs -> IO ()
putSubtree Cxt NoHole (Sum fs :&: Label) (K ()) i
t Cfg fs
cfg) ([E (Cxt NoHole (Sum fs :&: Label) (K ()))] -> IO [()])
-> [E (Cxt NoHole (Sum fs :&: Label) (K ()))] -> IO [()]
forall a b. (a -> b) -> a -> b
$ TermLab fs l -> [E (Cxt NoHole (Sum fs :&: Label) (K ()))]
Cxt NoHole (Sum fs :&: Label) (K ())
:=> [E (Cxt NoHole (Sum fs :&: Label) (K ()))]
forall h (f :: (* -> *) -> * -> *) (a :: * -> *).
HFoldable f =>
Cxt h f a :=> [E (Cxt h f a)]
subterms TermLab fs l
t
  String -> IO ()
putStrLn String
"\nBasic blocks: "
  [Label] -> IO ()
forall a. Show a => a -> IO ()
print ([Label] -> IO ()) -> [Label] -> IO ()
forall a b. (a -> b) -> a -> b
$ (CfgNode fs -> Label) -> [CfgNode fs] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: Signature). HasCfgNode c fs => Lens' c Label
Lens' (CfgNode fs) Label
cfg_node_lab) ([CfgNode fs] -> [Label]) -> [CfgNode fs] -> [Label]
forall a b. (a -> b) -> a -> b
$ (CfgNode fs -> Bool) -> [CfgNode fs] -> [CfgNode fs]
forall a. (a -> Bool) -> [a] -> [a]
filter (Cfg fs -> CfgNode fs -> Bool
forall (fs :: Signature). Cfg fs -> CfgNode fs -> Bool
startsBasicBlock Cfg fs
cfg) ([CfgNode fs] -> [CfgNode fs]) -> [CfgNode fs] -> [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ Cfg fs -> [CfgNode fs]
forall (fs :: Signature). Cfg fs -> [CfgNode fs]
cfgNodes Cfg fs
cfg

--------------------------------------------------------------------------------------

isStartNode :: Cfg fs -> CfgNode fs -> Bool
isStartNode :: forall (fs :: Signature). Cfg fs -> CfgNode fs -> Bool
isStartNode Cfg fs
cfg CfgNode fs
n = Maybe [CfgNode fs] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [CfgNode fs]
maybePrecs Bool -> Bool -> Bool
|| Int
numPrecs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
  where
    maybePrecs :: Maybe [CfgNode fs]
maybePrecs = Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds Cfg fs
cfg CfgNode fs
n
    numPrecs :: Int
numPrecs = [CfgNode fs] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CfgNode fs] -> Int) -> [CfgNode fs] -> Int
forall a b. (a -> b) -> a -> b
$ Maybe [CfgNode fs] -> [CfgNode fs]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [CfgNode fs]
maybePrecs


startsBasicBlock :: Cfg fs -> CfgNode fs -> Bool
startsBasicBlock :: forall (fs :: Signature). Cfg fs -> CfgNode fs -> Bool
startsBasicBlock Cfg fs
cfg CfgNode fs
n = (CfgNodeType -> Bool
isEnterNode (CfgNode fs
n CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: Signature). HasCfgNode c fs => Lens' c CfgNodeType
Lens' (CfgNode fs) CfgNodeType
cfg_node_type)) Bool -> Bool -> Bool
&& (Cfg fs -> CfgNode fs -> Bool
forall (fs :: Signature). Cfg fs -> CfgNode fs -> Bool
isStartNode Cfg fs
cfg CfgNode fs
n Bool -> Bool -> Bool
|| Bool
isJoinNode Bool -> Bool -> Bool
|| Bool
predIsFork)
  where
    maybePrecs :: Maybe [CfgNode fs]
maybePrecs = Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds Cfg fs
cfg CfgNode fs
n

    numPrecs :: Int
numPrecs = [CfgNode fs] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CfgNode fs] -> Int) -> [CfgNode fs] -> Int
forall a b. (a -> b) -> a -> b
$ Maybe [CfgNode fs] -> [CfgNode fs]
forall a. HasCallStack => Maybe a -> a
fromJust Maybe [CfgNode fs]
maybePrecs
    isJoinNode :: Bool
isJoinNode  = Int
numPrecs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1

    uniquePred :: CfgNode fs
uniquePred = [CfgNode fs] -> CfgNode fs
forall a. HasCallStack => [a] -> a
head ([CfgNode fs] -> CfgNode fs) -> [CfgNode fs] -> CfgNode fs
forall a b. (a -> b) -> a -> b
$ Maybe [CfgNode fs] -> [CfgNode fs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Maybe [CfgNode fs]
maybePrecs
    predSuccs :: Maybe [CfgNode fs]
predSuccs = Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: Signature).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodeSuccs Cfg fs
cfg CfgNode fs
uniquePred
    predIsFork :: Bool
predIsFork = case Maybe [CfgNode fs]
predSuccs of
                   Maybe [CfgNode fs]
Nothing -> Bool
True
                   Just [CfgNode fs]
l  -> [CfgNode fs] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CfgNode fs]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1