{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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 ( mzero )
import Control.Monad.List ( ListT(..) )
import Control.Monad.State ( MonadState )
import Control.Monad.Trans ( lift )

import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( fromJust, fromMaybe, isNothing )
import Data.Proxy ( Proxy(..) )

import Data.Set ( Set )
import qualified Data.Set as Set

import GHC.Generics ( Generic )

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

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

import Cubix.Language.Info
import Cubix.Language.Parametric.Semantics.SemanticProperties

import Cubix.Sin.Compdata.Annotation ( getAnn, propAnnSigFun )

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

instance KShow f => Show (E f) where
  show :: E f -> String
show (E x :: f i
x) = K String i -> String
forall a i. K a i -> a
unK (K String i -> String) -> K String i -> String
forall a b. (a -> b) -> a -> b
$ f i -> K String i
forall (a :: * -> *) i. KShow a => a i -> K String i
kshow f i
x

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

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
/= :: CfgNodeType -> CfgNodeType -> Bool
$c/= :: CfgNodeType -> CfgNodeType -> Bool
== :: CfgNodeType -> CfgNodeType -> Bool
$c== :: 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
min :: CfgNodeType -> CfgNodeType -> CfgNodeType
$cmin :: CfgNodeType -> CfgNodeType -> CfgNodeType
max :: CfgNodeType -> CfgNodeType -> CfgNodeType
$cmax :: CfgNodeType -> CfgNodeType -> CfgNodeType
>= :: CfgNodeType -> CfgNodeType -> Bool
$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
compare :: CfgNodeType -> CfgNodeType -> Ordering
$ccompare :: CfgNodeType -> CfgNodeType -> Ordering
$cp1Ord :: Eq 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
showList :: [CfgNodeType] -> ShowS
$cshowList :: [CfgNodeType] -> ShowS
show :: CfgNodeType -> String
$cshow :: CfgNodeType -> String
showsPrec :: Int -> CfgNodeType -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep CfgNodeType x -> CfgNodeType
$cfrom :: forall x. CfgNodeType -> Rep CfgNodeType x
Generic, CfgNodeType -> ()
(CfgNodeType -> ()) -> NFData CfgNodeType
forall a. (a -> ()) -> NFData a
rnf :: CfgNodeType -> ()
$crnf :: CfgNodeType -> ()
NFData )

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

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

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

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

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

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

data CfgNode fs = CfgNode { CfgNode fs -> Set Label
_cfg_node_prevs :: Set Label
                          , CfgNode fs -> Set Label
_cfg_node_succs :: Set Label
                          , CfgNode fs -> Label
_cfg_node_lab   :: Label
                          , CfgNode fs -> CfgNodeType
_cfg_node_type  :: CfgNodeType
                          , 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 :: [(* -> *) -> * -> *]) x.
Rep (CfgNode fs) x -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) 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
$cto :: forall (fs :: [(* -> *) -> * -> *]) x.
Rep (CfgNode fs) x -> CfgNode fs
$cfrom :: forall (fs :: [(* -> *) -> * -> *]) x.
CfgNode fs -> Rep (CfgNode fs) x
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 {
                   Cfg fs -> Map Label (CfgNode fs)
_cfg_nodes     :: Map Label (CfgNode fs)
                 , 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 :: [(* -> *) -> * -> *]) x. Rep (Cfg fs) x -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]) 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
$cto :: forall (fs :: [(* -> *) -> * -> *]) x. Rep (Cfg fs) x -> Cfg fs
$cfrom :: forall (fs :: [(* -> *) -> * -> *]) x. Cfg fs -> Rep (Cfg fs) x
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 (e :: * -> *) i. Sum fs e i -> Sum gs e i)
-> CfgNode fs -> CfgNode gs
mapCfgNode f :: forall (e :: * -> *) i. Sum fs e i -> Sum gs e i
f n :: CfgNode fs
n = CfgNode :: forall (fs :: [(* -> *) -> * -> *]).
Set Label
-> Set Label
-> Label
-> CfgNodeType
-> E (TermLab fs)
-> CfgNode fs
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 x :: TermLab fs i
x) -> Cxt NoHole (Sum gs :&: Label) (K ()) i -> E (TermLab gs)
forall (f :: * -> *) i. f i -> E f
E (SigFun (Sum fs :&: Label) (Sum gs :&: Label)
-> TermLab fs i -> Cxt NoHole (Sum gs :&: Label) (K ()) i
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 forall (e :: * -> *) i. Sum fs e i -> Sum gs e i
f) TermLab fs i
x))
                         }

emptyCfg :: Cfg fs
emptyCfg :: Cfg fs
emptyCfg = Map Label (CfgNode fs)
-> Map Label (Map CfgNodeType Label) -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
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 :: Cfg fs -> [CfgNode fs]
cfgNodes cfg :: 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
cfg_nodes)

addCfgNodeWithLabel :: (HasCurCfg s fs, MonadState s m) => TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel :: TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel t :: TermLab fs l
t l :: Label
l typ :: CfgNodeType
typ = do
  let node :: CfgNode fs
node = CfgNode :: forall (fs :: [(* -> *) -> * -> *]).
Set Label
-> Set Label
-> Label
-> CfgNodeType
-> E (TermLab fs)
-> CfgNode fs
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
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn TermLab fs l
t
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 ()
%= \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
                                   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 Label (Map CfgNodeType Label)
m

  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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

  CfgNode fs -> m (CfgNode fs)
forall (m :: * -> *) a. Monad m => a -> m a
return CfgNode fs
node

addCfgNode :: (HasCurCfg s fs, HasLabelGen s, MonadState s m) => TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode :: TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode t :: TermLab fs l
t typ :: CfgNodeType
typ = do
  Label
l <- m Label
forall s (m :: * -> *). MonadLabeler s m => m Label
nextLabel
  TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (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 :: Label -> m (Maybe (CfgNode fs))
nodeForLab l :: 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
cfg_nodes)

addEdge :: CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge :: CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge from :: CfgNode fs
from to :: CfgNode fs
to cfg :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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)
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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)
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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. Proxy fs -> Label -> Label -> Cfg fs -> Cfg fs
addEdgeLab :: Proxy fs -> Label -> Label -> Cfg fs -> Cfg fs
addEdgeLab _ l1 :: Label
l1 l2 :: Label
l2 cfg :: 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 :: [(* -> *) -> * -> *]).
Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l1
      CfgNode fs
n2 <- Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]).
Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l2
      Cfg fs -> Maybe (Cfg fs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cfg fs -> Maybe (Cfg fs)) -> Cfg fs -> Maybe (Cfg fs)
forall a b. (a -> b) -> a -> b
$ CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
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 :: Label -> Label -> Cfg fs -> Cfg fs
removeEdgeLab l1 :: Label
l1 l2 :: Label
l2 cfg :: 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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)
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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)
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg cfg :: Cfg fs
cfg l :: 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
cfg_nodes)

lookupCfg :: Cfg fs -> Label -> CfgNode fs
lookupCfg :: Cfg fs -> Label -> CfgNode fs
lookupCfg cfg :: Cfg fs
cfg l :: Label
l = case Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]).
Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
l of
  Just n :: CfgNode fs
n  -> CfgNode fs
n
  Nothing -> String -> CfgNode fs
forall a. HasCallStack => String -> a
error (String -> CfgNode fs) -> String -> CfgNode fs
forall a b. (a -> b) -> a -> b
$ "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 :: Cfg fs -> CfgNodeType -> TermLab fs l -> Maybe (CfgNode fs)
cfgNodeForTerm cfg :: Cfg fs
cfg typ :: CfgNodeType
typ t :: 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
forall (f :: (* -> *) -> * -> *) a. Annotated f a => 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
cfg Label
cfgLab

removeNode :: CfgNode fs -> Cfg fs -> Cfg fs
removeNode :: CfgNode fs -> Cfg fs -> Cfg fs
removeNode n :: CfgNode fs
n g :: 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
forall (fs :: [(* -> *) -> * -> *]). Cfg fs -> Cfg fs
removePredEdges
                   Cfg fs -> (Cfg fs -> Cfg fs) -> Cfg fs
forall a b. a -> (a -> b) -> b
& Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]). 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab
    termLab :: Label
termLab = (TermLab fs :=> Label) -> E (TermLab fs) -> Label
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE TermLab fs :=> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c CfgNodeType
cfg_node_type

    removePredEdges :: Cfg fs -> Cfg fs
removePredEdges gr :: Cfg fs
gr = (Label -> Cfg fs -> Cfg fs) -> Cfg fs -> [Label] -> Cfg fs
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\p :: Label
p -> Label -> Label -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_prevs))
    removeSuccEdges :: Cfg fs -> Cfg fs
removeSuccEdges gr :: Cfg fs
gr = (Label -> Cfg fs -> Cfg fs) -> Cfg fs -> [Label] -> Cfg fs
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\s :: Label
s -> Label -> Label -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: Label -> Cfg fs -> Cfg fs
contractNode l :: Label
l g :: Cfg fs
g = CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]). 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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Label, Label) -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
(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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_succs))]
  where
    n :: CfgNode fs
n = Cfg fs -> Label -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
g Label
l
    add :: (Label, Label) -> Cfg fs -> Cfg fs
add (x :: Label
x, y :: Label
y) gr :: Cfg fs
gr = CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (Cfg fs -> Label -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
gr Label
x) (Cfg fs -> Label -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]). 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 -> ListT Maybe (CfgNode fs)
satisfyingBoundary :: Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT Maybe (CfgNode fs)
satisfyingBoundary seen :: Set Label
seen succ :: CfgNode fs -> Set Label
succ pred :: CfgNode fs -> Bool
pred cfg :: Cfg fs
cfg node :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab) Set Label
seen then
    ListT Maybe (CfgNode fs)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  else if CfgNode fs -> Bool
pred CfgNode fs
node then
    CfgNode fs -> ListT Maybe (CfgNode fs)
forall (m :: * -> *) a. Monad m => a -> m a
return 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) -> ListT Maybe (CfgNode fs)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Maybe (CfgNode fs)
forall a. Maybe a
Nothing
    else do
      Label
nextLab <- Maybe [Label] -> ListT Maybe Label
forall (m :: * -> *) a. m [a] -> ListT m a
ListT ([Label] -> Maybe [Label]
forall a. a -> Maybe a
Just [Label]
labs)
      Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]). Cfg fs -> Label -> CfgNode fs
lookupCfg Cfg fs
cfg Label
nextLab)


satisfyingPredBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingPredBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingPredBoundary pred :: CfgNode fs -> Bool
pred cfg :: Cfg fs
cfg node :: CfgNode fs
node = ListT Maybe (CfgNode fs) -> Maybe [CfgNode fs]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (ListT Maybe (CfgNode fs) -> Maybe [CfgNode fs])
-> ListT Maybe (CfgNode fs) -> Maybe [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_prevs) CfgNode fs -> Bool
pred Cfg fs
cfg CfgNode fs
node

satisfyingSuccBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingSuccBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingSuccBoundary pred :: CfgNode fs -> Bool
pred cfg :: Cfg fs
cfg node :: CfgNode fs
node = ListT Maybe (CfgNode fs) -> Maybe [CfgNode fs]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (ListT Maybe (CfgNode fs) -> Maybe [CfgNode fs])
-> ListT Maybe (CfgNode fs) -> Maybe [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]).
Set Label
-> (CfgNode fs -> Set Label)
-> (CfgNode fs -> Bool)
-> Cfg fs
-> CfgNode fs
-> ListT 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_succs) CfgNode fs -> Bool
pred Cfg fs
cfg CfgNode fs
node

satisfyingStrictPredBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictPredBoundary :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictPredBoundary pred :: CfgNode fs -> Bool
pred cfg :: Cfg fs
cfg node :: CfgNode fs
node = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(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' n :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingStrictSuccBoundary pred :: CfgNode fs -> Bool
pred cfg :: Cfg fs
cfg node :: CfgNode fs
node = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(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' n :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)) Bool -> Bool -> Bool
&& CfgNode fs -> Bool
pred CfgNode fs
n

enterNodePreds :: Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds :: Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds cfg :: Cfg fs
cfg n :: CfgNode fs
n = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c CfgNodeType
cfg_node_type)) Cfg fs
cfg CfgNode fs
n

enterNodeSuccs :: Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodeSuccs :: Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodeSuccs cfg :: Cfg fs
cfg n :: CfgNode fs
n = (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c CfgNodeType
cfg_node_type)) Cfg fs
cfg CfgNode fs
n

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

prettyCfg :: Cfg fs -> String
prettyCfg :: Cfg fs -> String
prettyCfg cfg :: 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 :: [(* -> *) -> * -> *]). 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Map Label (CfgNode fs))
cfg_nodes)

    nodeEdges :: CfgNode f -> String
    nodeEdges :: CfgNode f -> String
nodeEdges n :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_succs)
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ CfgNode f -> String
forall s (fs :: [(* -> *) -> * -> *]).
HasCfgNode s fs =>
s -> String
pInterestingDegree CfgNode f
n

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

    pInterestingDegree :: s -> String
pInterestingDegree n :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_succs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (Set Label)
cfg_node_prevs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 1)
       = "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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " has interesting degree\n"
    pInterestingDegree _ = ""


getCfgLab :: forall fs l. Cfg fs -> TermLab fs l -> [Label]
getCfgLab :: Cfg fs -> TermLab fs l -> [Label]
getCfgLab cfg :: Cfg fs
cfg t :: 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 :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Map Label (Map CfgNodeType Label))
cfg_ast_nodes) of
                    Nothing -> []
                    Just m :: 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
forall (f :: (* -> *) -> * -> *) a. Annotated f a => 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 :: TermLab fs l -> Cfg fs -> IO ()
putSubtree t :: TermLab fs l
t cfg :: Cfg fs
cfg = do
 let cfgLab :: [Label]
cfgLab = Cfg fs -> TermLab fs l -> [Label]
forall (fs :: [(* -> *) -> * -> *]) l.
Cfg fs -> TermLab fs l -> [Label]
getCfgLab Cfg fs
cfg TermLab fs l
t
 if [Label] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Label]
cfgLab Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then do
   String -> IO ()
putStrLn ""
   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
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn TermLab fs l
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(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 -> 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 (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 :: TermLab fs l -> Cfg fs -> IO ()
debugCfg t :: TermLab fs l
t cfg :: Cfg fs
cfg = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Cfg fs -> String
forall (fs :: [(* -> *) -> * -> *]). Cfg fs -> String
prettyCfg Cfg fs
cfg
  (E (HFix (Sum fs :&: Label)) -> IO ())
-> [E (HFix (Sum fs :&: Label))] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(E t :: HFix (Sum fs :&: Label) i
t) -> HFix (Sum fs :&: Label) i -> Cfg fs -> IO ()
forall (fs :: [(* -> *) -> * -> *]) l.
(All ShowHF fs, All HFoldable fs, All HFunctor fs) =>
TermLab fs l -> Cfg fs -> IO ()
putSubtree HFix (Sum fs :&: Label) i
t Cfg fs
cfg) ([E (HFix (Sum fs :&: Label))] -> IO [()])
-> [E (HFix (Sum fs :&: Label))] -> IO [()]
forall a b. (a -> b) -> a -> b
$ TermLab fs l -> [E (HFix (Sum fs :&: Label))]
forall (f :: (* -> *) -> * -> *).
HFoldable f =>
HFix f :=> [E (HFix f)]
subterms TermLab fs l
t
  String -> IO ()
putStrLn "\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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c 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 :: [(* -> *) -> * -> *]). 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 :: [(* -> *) -> * -> *]). Cfg fs -> [CfgNode fs]
cfgNodes Cfg fs
cfg

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

isStartNode :: Cfg fs -> CfgNode fs -> Bool
isStartNode :: Cfg fs -> CfgNode fs -> Bool
isStartNode cfg :: Cfg fs
cfg n :: 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
== 0
  where
    maybePrecs :: Maybe [CfgNode fs]
maybePrecs = Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds Cfg fs
cfg CfgNode fs
n
    numPrecs :: Int
numPrecs = [CfgNode fs] -> 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 :: Cfg fs -> CfgNode fs -> Bool
startsBasicBlock cfg :: Cfg fs
cfg n :: 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c CfgNodeType
cfg_node_type)) Bool -> Bool -> Bool
&& (Cfg fs -> CfgNode fs -> Bool
forall (fs :: [(* -> *) -> * -> *]). 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 :: [(* -> *) -> * -> *]).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodePreds Cfg fs
cfg CfgNode fs
n

    numPrecs :: Int
numPrecs = [CfgNode fs] -> 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
> 1

    uniquePred :: CfgNode fs
uniquePred = [CfgNode fs] -> CfgNode fs
forall a. [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 :: [(* -> *) -> * -> *]).
Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
enterNodeSuccs Cfg fs
cfg CfgNode fs
uniquePred
    predIsFork :: Bool
predIsFork = case Maybe [CfgNode fs]
predSuccs of
                   Nothing -> Bool
True
                   Just l :: [CfgNode fs]
l  -> [CfgNode fs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CfgNode fs]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1