-- | Analyse a program file and create basic blocks.

module Language.Fortran.Analysis.BBlocks
  ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode
  , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock )
where

import Prelude hiding (exp)
import Data.Generics.Uniplate.Data hiding (transform)
import Data.Char (toLower)
import Data.Data
import Data.List (unfoldr, foldl')
import Control.Monad
import Control.Monad.State.Lazy hiding (fix)
import Control.Monad.Writer hiding (fix)
import Control.Monad ( forM_ ) -- required for mtl-2.3 (GHC 9.6)
import Text.PrettyPrint.GenericPretty (pretty, Out)
import Text.PrettyPrint               (render)
import Language.Fortran.Analysis
import Language.Fortran.AST hiding (setName)
import Language.Fortran.AST.Literal.Real
import Language.Fortran.Util.Position
import Language.Fortran.PrettyPrint
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Data.Graph.Inductive
import Data.List (intercalate)
import Data.Maybe
import Data.Functor.Identity
import qualified Data.List.NonEmpty as NE

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

-- | Insert basic block graphs into each program unit's analysis
analyseBBlocks :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks :: forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks ProgramFile (Analysis a)
pf = State ASTExprNode (ProgramFile (Analysis a))
-> ASTExprNode -> ProgramFile (Analysis a)
forall s a. State s a -> s -> a
evalState (ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
analyse (ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseAllLhsVars ProgramFile (Analysis a)
pf)) ASTExprNode
1
  where
    analyse :: ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
analyse = ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocksInBBGr (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a) -> ProgramFile (Analysis a))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransFunc ProgramUnit ProgramFile a
forall a. Data a => TransFunc ProgramUnit ProgramFile a
trans ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
forall a.
Data a =>
ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprs (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocks
    trans :: Data a => TransFunc ProgramUnit ProgramFile a
    trans :: forall a. Data a => TransFunc ProgramUnit ProgramFile a
trans = (ProgramUnit (Analysis a) -> ProgramUnit (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi

-- | A mapping of program unit names to bblock graphs.
type BBlockMap a = M.Map ProgramUnitName (BBGr a)

-- | Create a mapping of (non-module) program unit names to their
-- associated bblock graph.
genBBlockMap :: Data a => ProgramFile (Analysis a) -> BBlockMap (Analysis a)
genBBlockMap :: forall a.
Data a =>
ProgramFile (Analysis a) -> BBlockMap (Analysis a)
genBBlockMap ProgramFile (Analysis a)
pf = [(ProgramUnitName, BBGr (Analysis a))]
-> Map ProgramUnitName (BBGr (Analysis a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
    (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu, BBGr (Analysis a)
gr) | ProgramUnit (Analysis a)
pu <- ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs ProgramFile (Analysis a)
pf, Just BBGr (Analysis a)
gr <- [Analysis a -> Maybe (BBGr (Analysis a))
forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks (ProgramUnit (Analysis a) -> Analysis a
forall a. ProgramUnit a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu)]
  ]
  where
    getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    getPUs :: forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs = ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

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

type ASTBlockNode = Int

-- Insert unique labels on each AST-block for easier look-up later.
labelBlocks :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a))
labelBlocks :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocks = TransFuncM (StateT ASTExprNode Identity) Block ProgramFile a
forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Block ProgramFile a
transform Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock
  where
    eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a))
    eachBlock :: forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock Block (Analysis a)
b = do
      ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
      ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1)
      Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> State ASTExprNode (Block (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Block (Analysis a) -> Block (Analysis a)
forall a. a -> Block a -> Block a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) { insLabel = Just n }) Block (Analysis a)
b
    transform :: Data a => TransFuncM (State ASTBlockNode) Block ProgramFile a
    transform :: forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Block ProgramFile a
transform = (Block (Analysis a)
 -> StateT ASTExprNode Identity (Block (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT ASTExprNode Identity (ProgramFile (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

-- A version of labelBlocks that works on all AST-blocks inside of a
-- basic-block graph that have not already been labelled with
-- numbers. The reason that this function must exist is because
-- additional AST-blocks are generated within the process of creating
-- basic-block graphs, and must also be labelled.
labelBlocksInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a))
labelBlocksInBBGr :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocksInBBGr = (BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transform ((Gr (BB (Analysis a)) ()
 -> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ()))
-> BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a))
forall (m :: * -> *) a1 a2.
Monad m =>
(Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)
bbgrMapM ((BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a)))
-> Gr (BB (Analysis a)) ()
-> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ())
forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' ((Block (Analysis a)
 -> StateT ASTExprNode Identity (Block (Analysis a)))
-> BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a))
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 Block (Analysis a)
-> StateT ASTExprNode Identity (Block (Analysis a))
forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock)))
  where
    eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a))
    eachBlock :: forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock Block (Analysis a)
b
      | a :: Analysis a
a@Analysis { insLabel :: forall a. Analysis a -> Maybe ASTExprNode
insLabel = Maybe ASTExprNode
Nothing } <- Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b = do
          ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
          ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode -> StateT ASTExprNode Identity ())
-> ASTExprNode -> StateT ASTExprNode Identity ()
forall a b. (a -> b) -> a -> b
$ ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1
          Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> State ASTExprNode (Block (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> Block (Analysis a))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> Block (Analysis a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Block (Analysis a) -> Block (Analysis a)
forall a. a -> Block a -> Block a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { insLabel = Just n }) Block (Analysis a)
b
      | Bool
otherwise = Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> State ASTExprNode (Block (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b
    transform :: Data a => (BBGr a -> State ASTBlockNode (BBGr a)) ->
                           ProgramFile a -> State ASTBlockNode (ProgramFile a)
    transform :: forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transform = (BBGr a -> StateT ASTExprNode Identity (BBGr a))
-> ProgramFile a -> StateT ASTExprNode Identity (ProgramFile a)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

-- Sets the label on each Index within a Block to match the Block, for
-- later look-up.
labelWithinBlocks :: forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks :: forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks = Block (Analysis a) -> Block (Analysis a)
perBlock'
  where
    perBlock' :: Block (Analysis a) -> Block (Analysis a)
    perBlock' :: Block (Analysis a) -> Block (Analysis a)
perBlock' Block (Analysis a)
b =
      case Block (Analysis a)
b of
        BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e Statement (Analysis a)
st               -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e) (Maybe ASTExprNode
-> Statement (Analysis a) -> Statement (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Statement (Analysis a)
st)
        BlIf        Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn NonEmpty (Expression (Analysis a), [Block (Analysis a)])
bs Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el  ->
          Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> NonEmpty (Expression (Analysis a), [Block (Analysis a)])
-> Maybe [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> NonEmpty (Expression a, [Block a])
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlIf      Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn (((Expression (Analysis a), [Block (Analysis a)])
 -> (Expression (Analysis a), [Block (Analysis a)]))
-> NonEmpty (Expression (Analysis a), [Block (Analysis a)])
-> NonEmpty (Expression (Analysis a), [Block (Analysis a)])
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ASTExprNode
-> (Expression (Analysis a), [Block (Analysis a)])
-> (Expression (Analysis a), [Block (Analysis a)])
fillIf Maybe ASTExprNode
i) NonEmpty (Expression (Analysis a), [Block (Analysis a)])
bs) Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el
        BlCase      Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn Expression (Analysis a)
e2 [(AList Index (Analysis a), [Block (Analysis a)])]
bs Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el ->
          Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> Expression (Analysis a)
-> [(AList Index (Analysis a), [Block (Analysis a)])]
-> Maybe [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [(AList Index a, [Block a])]
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlCase    Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn (Maybe ASTExprNode
-> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e2) (((AList Index (Analysis a), [Block (Analysis a)])
 -> (AList Index (Analysis a), [Block (Analysis a)]))
-> [(AList Index (Analysis a), [Block (Analysis a)])]
-> [(AList Index (Analysis a), [Block (Analysis a)])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ASTExprNode
-> (AList Index (Analysis a), [Block (Analysis a)])
-> (AList Index (Analysis a), [Block (Analysis a)])
fillCaseClause Maybe ASTExprNode
i) [(AList Index (Analysis a), [Block (Analysis a)])]
bs) Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el
        BlDo        Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn Maybe (Expression (Analysis a))
tl Maybe (DoSpecification (Analysis a))
e2 [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el  -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> Maybe (Expression (Analysis a))
-> Maybe (DoSpecification (Analysis a))
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo        Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn Maybe (Expression (Analysis a))
tl (Maybe ASTExprNode
-> Maybe (DoSpecification (Analysis a))
-> Maybe (DoSpecification (Analysis a))
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (DoSpecification (Analysis a))
e2) [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el
        BlDoWhile   Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
n Maybe (Expression (Analysis a))
tl Expression (Analysis a)
e2 [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el   -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile   Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
n Maybe (Expression (Analysis a))
tl (Maybe ASTExprNode
-> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e2) [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el
        Block (Analysis a)
_                             -> Block (Analysis a)
b
      where i :: Maybe ASTExprNode
i = Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel (Analysis a -> Maybe ASTExprNode)
-> Analysis a -> Maybe ASTExprNode
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b

    mfill
        :: forall f. (Data (f (Analysis a)))
        => Maybe ASTBlockNode -> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
    mfill :: forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i  = (f (Analysis a) -> f (Analysis a))
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i)

    fillCaseClause :: Maybe ASTExprNode
-> (AList Index (Analysis a), [Block (Analysis a)])
-> (AList Index (Analysis a), [Block (Analysis a)])
fillCaseClause Maybe ASTExprNode
i (AList Index (Analysis a)
rs, [Block (Analysis a)]
b) = (Maybe ASTExprNode
-> AList Index (Analysis a) -> AList Index (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i AList Index (Analysis a)
rs, [Block (Analysis a)]
b)
    fillIf :: Maybe ASTExprNode
-> (Expression (Analysis a), [Block (Analysis a)])
-> (Expression (Analysis a), [Block (Analysis a)])
fillIf Maybe ASTExprNode
i (Expression (Analysis a)
e, [Block (Analysis a)]
b) = (Maybe ASTExprNode
-> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e, [Block (Analysis a)]
b)

    fill
        :: forall f. (Data (f (Analysis a)))
        => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)
    fill :: forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
Nothing  = f (Analysis a) -> f (Analysis a)
forall a. a -> a
id
    fill (Just ASTExprNode
i) = (Index (Analysis a) -> Index (Analysis a))
-> f (Analysis a) -> f (Analysis a)
transform Index (Analysis a) -> Index (Analysis a)
perIndex
      where
        transform :: (Index (Analysis a) -> Index (Analysis a)) -> f (Analysis a) -> f (Analysis a)
        transform :: (Index (Analysis a) -> Index (Analysis a))
-> f (Analysis a) -> f (Analysis a)
transform = (Index (Analysis a) -> Index (Analysis a))
-> f (Analysis a) -> f (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi

        perIndex :: (Index (Analysis a) -> Index (Analysis a))
        perIndex :: Index (Analysis a) -> Index (Analysis a)
perIndex Index (Analysis a)
x = Analysis a -> Index (Analysis a) -> Index (Analysis a)
forall a. a -> Index a -> Index a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((Index (Analysis a) -> Analysis a
forall a. Index a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Index (Analysis a)
x) { insLabel = Just i }) Index (Analysis a)
x

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

type ASTExprNode = Int

-- Insert unique labels on each expression for easier look-up later.
labelExprs :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a))
labelExprs :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprs = TransFuncM (StateT ASTExprNode Identity) Expression ProgramFile a
forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Expression ProgramFile a
transform Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr
  where
    eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))
    eachExpr :: forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr Expression (Analysis a)
e = do
      ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
      ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1)
      Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Expression (Analysis a) -> Expression (Analysis a)
forall a. a -> Expression a -> Expression a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e) { insLabel = Just n }) Expression (Analysis a)
e
    transform :: Data a => TransFuncM (State ASTExprNode) Expression ProgramFile a
    transform :: forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Expression ProgramFile a
transform = (Expression (Analysis a)
 -> StateT ASTExprNode Identity (Expression (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT ASTExprNode Identity (ProgramFile (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

-- A version of labelExprs that works on all expressions inside of a
-- basic-block graph that have not already been labelled with
-- numbers. The reason that this function must exist is because
-- additional expressions are generated within the process of creating
-- basic-block graphs, and must also be labelled.
labelExprsInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr = (BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transformBB ((Gr (BB (Analysis a)) ()
 -> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ()))
-> BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a))
forall (m :: * -> *) a1 a2.
Monad m =>
(Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)
bbgrMapM ((BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a)))
-> Gr (BB (Analysis a)) ()
-> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ())
forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' ((Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a))
forall a.
Data a =>
(Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
transformExpr Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr)))
  where
    eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))
    eachExpr :: forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr Expression (Analysis a)
e
      | a :: Analysis a
a@Analysis { insLabel :: forall a. Analysis a -> Maybe ASTExprNode
insLabel = Maybe ASTExprNode
Nothing } <- Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e = do
          ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
          ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode -> StateT ASTExprNode Identity ())
-> ASTExprNode -> StateT ASTExprNode Identity ()
forall a b. (a -> b) -> a -> b
$ ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1
          Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Expression (Analysis a) -> Expression (Analysis a)
forall a. a -> Expression a -> Expression a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { insLabel = Just n }) Expression (Analysis a)
e
      | Bool
otherwise = Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a. a -> StateT ASTExprNode Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e
    transformBB :: Data a => (BBGr a -> State ASTExprNode (BBGr a)) ->
                             ProgramFile a -> State ASTExprNode (ProgramFile a)
    transformBB :: forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transformBB = (BBGr a -> StateT ASTExprNode Identity (BBGr a))
-> ProgramFile a -> StateT ASTExprNode Identity (ProgramFile a)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM
    transformExpr :: Data a => (Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))) ->
                               [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
    transformExpr :: forall a.
Data a =>
(Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
transformExpr = (Expression (Analysis a)
 -> StateT ASTExprNode Identity (Expression (Analysis a)))
-> [Block (Analysis a)]
-> StateT ASTExprNode Identity [Block (Analysis a)]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

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

-- Analyse each program unit
toBBlocksPerPU :: Data a => ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU :: forall a.
Data a =>
ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU ProgramUnit (Analysis a)
pu
  | [Block (Analysis a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block (Analysis a)]
bs   = ProgramUnit (Analysis a)
pu
  | Bool
otherwise = ProgramUnit (Analysis a)
pu'
  where
    bs :: [Block (Analysis a)]
bs  =
      case ProgramUnit (Analysis a)
pu of
        PUMain Analysis a
_ SrcSpan
_ Maybe String
_ [Block (Analysis a)]
bs' Maybe [ProgramUnit (Analysis a)]
_ -> [Block (Analysis a)]
bs';
        PUSubroutine Analysis a
_ SrcSpan
_ PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
_ [Block (Analysis a)]
bs' Maybe [ProgramUnit (Analysis a)]
_ -> [Block (Analysis a)]
bs';
        PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
_ PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
bs' Maybe [ProgramUnit (Analysis a)]
_ -> [Block (Analysis a)]
bs'
        ProgramUnit (Analysis a)
_ -> []
    bbs :: BBState (Analysis a)
bbs = BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
-> BBState (Analysis a)
forall a b. BBlocker a b -> BBState a
execBBlocker ([Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs)
    fix :: Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
fix = Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
delUnreachable (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramUnit (Analysis a)
-> Map String ASTExprNode
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> Map String ASTExprNode
-> gr [Block (Analysis a)] ()
-> gr [Block (Analysis a)] ()
insExitEdges ProgramUnit (Analysis a)
pu Map String ASTExprNode
lm (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
gr [Block a] b -> gr [Block a] b
delInvalidExits (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramUnit (Analysis a)
-> Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges ProgramUnit (Analysis a)
pu
    gr :: BBGr (Analysis a)
gr  = (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
fix (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEdge ()]
-> Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (BBState (Analysis a) -> [LEdge ()]
forall a. BBState a -> [LEdge ()]
newEdges BBState (Analysis a)
bbs)) (BBGr (Analysis a) -> BBGr (Analysis a))
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (a -> b) -> a -> b
$ BBState (Analysis a) -> BBGr (Analysis a)
forall a. BBState a -> BBGr a
bbGraph BBState (Analysis a)
bbs
    gr' :: BBGr (Analysis a)
gr' = BBGr (Analysis a)
gr { bbgrEntries = [0], bbgrExits = [-1] } -- conventional entry/exit blocks
    pu' :: ProgramUnit (Analysis a)
pu' = Analysis a -> ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
forall a. a -> ProgramUnit a -> ProgramUnit a
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((ProgramUnit (Analysis a) -> Analysis a
forall a. ProgramUnit a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu) { bBlocks = Just gr' }) ProgramUnit (Analysis a)
pu
    lm :: Map String ASTExprNode
lm  = BBState (Analysis a) -> Map String ASTExprNode
forall a. BBState a -> Map String ASTExprNode
labelMap BBState (Analysis a)
bbs

-- Create node 0 "the start node" and link it
-- for now assume only one entry
insEntryEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges :: forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges ProgramUnit (Analysis a)
pu = LEdge ()
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (ASTExprNode
0, ASTExprNode
1, ()) (gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ())
-> (gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ())
-> gr [Block (Analysis a)] ()
-> gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNode [Block (Analysis a)]
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
0, [Block (Analysis a)]
bs)
  where
    bs :: [Block (Analysis a)]
bs = ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
forall a.
Data a =>
ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
False

-- create assignments of the form "x = f[1]" or "f[1] = x" at the
-- entry/exit bblocks.
genInOutAssignments :: Data a => ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments :: forall a.
Data a =>
ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
exit
  | Bool
exit, PUFunction{} <- ProgramUnit (Analysis a)
pu = (Expression (Analysis a) -> Integer -> Block (Analysis a))
-> [Expression (Analysis a)] -> [Integer] -> [Block (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Block (Analysis a)
genAssign (Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
noSrcSpan String
fnExpression (Analysis a)
-> [Expression (Analysis a)] -> [Expression (Analysis a)]
forall a. a -> [a] -> [a]
:[Expression (Analysis a)]
vs) [(Integer
0::Integer)..]
  | Bool
otherwise                = (Expression (Analysis a) -> Integer -> Block (Analysis a))
-> [Expression (Analysis a)] -> [Integer] -> [Block (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Block (Analysis a)
genAssign [Expression (Analysis a)]
vs [(Integer
1::Integer)..]
  where
    Named String
fn      = ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu
    name :: Integer -> String
name Integer
i        = String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    a0 :: Analysis a
a0            = [Analysis a] -> Analysis a
forall a. HasCallStack => [a] -> a
head ([Analysis a] -> Analysis a) -> [Analysis a] -> Analysis a
forall a b. (a -> b) -> a -> b
$ [a] -> [Analysis a]
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis [Analysis a -> a
forall a. Analysis a -> a
prevAnnotation Analysis a
a]
    (Analysis a
a, SrcSpan
s, [Expression (Analysis a)]
vs)    = case ProgramUnit (Analysis a)
pu of
      PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
_ PrefixSuffix (Analysis a)
_ String
_ (Just (AList Analysis a
a' SrcSpan
s' [Expression (Analysis a)]
vs')) Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_ -> (Analysis a
a', SrcSpan
s', [Expression (Analysis a)]
vs')
      PUSubroutine Analysis a
_ SrcSpan
_ PrefixSuffix (Analysis a)
_ String
_ (Just (AList Analysis a
a' SrcSpan
s' [Expression (Analysis a)]
vs')) [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_   -> (Analysis a
a', SrcSpan
s', [Expression (Analysis a)]
vs')
      PUFunction Analysis a
a' SrcSpan
s' Maybe (TypeSpec (Analysis a))
_ PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
Nothing Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_               -> (Analysis a
a', SrcSpan
s', [])
      PUSubroutine Analysis a
a' SrcSpan
s' PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
Nothing [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_                 -> (Analysis a
a', SrcSpan
s', [])
      ProgramUnit (Analysis a)
_                                                -> (String -> Analysis a
forall a. HasCallStack => String -> a
error String
"genInOutAssignments", String -> SrcSpan
forall a. HasCallStack => String -> a
error String
"genInOutAssignments", [])
    genAssign :: Expression (Analysis a) -> Integer -> Block (Analysis a)
genAssign Expression (Analysis a)
v Integer
i = Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a) -> Block (Analysis a)
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a0 SrcSpan
s Expression (Analysis a)
vl Expression (Analysis a)
vr)
      where
        (Expression (Analysis a)
vl, Expression (Analysis a)
vr) = if Bool
exit then (Expression (Analysis a)
v', Expression (Analysis a)
v) else (Expression (Analysis a)
v, Expression (Analysis a)
v')
        v' :: Expression (Analysis a)
v'       = case Expression (Analysis a)
v of
          ExpValue Analysis a
_ SrcSpan
s' (ValVariable String
_) -> Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s' (Integer -> String
name Integer
i)
          Expression (Analysis a)
_               -> String -> Expression (Analysis a)
forall a. HasCallStack => String -> a
error (String -> Expression (Analysis a))
-> String -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ String
"unhandled genAssign case: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ () -> String
forall a. Show a => a -> String
show ((Expression (Analysis a) -> ()) -> Expression (Analysis a) -> ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (() -> Expression (Analysis a) -> ()
forall a b. a -> b -> a
const ()) Expression (Analysis a)
v)

-- Remove exit edges for bblocks where standard construction doesn't apply.
delInvalidExits :: DynGraph gr => gr [Block a] b -> gr [Block a] b
delInvalidExits :: forall (gr :: * -> * -> *) a b.
DynGraph gr =>
gr [Block a] b -> gr [Block a] b
delInvalidExits gr [Block a] b
gr = ([(ASTExprNode, ASTExprNode)] -> gr [Block a] b -> gr [Block a] b)
-> gr [Block a] b -> [(ASTExprNode, ASTExprNode)] -> gr [Block a] b
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(ASTExprNode, ASTExprNode)] -> gr [Block a] b -> gr [Block a] b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[(ASTExprNode, ASTExprNode)] -> gr a b -> gr a b
delEdges gr [Block a] b
gr ([(ASTExprNode, ASTExprNode)] -> gr [Block a] b)
-> [(ASTExprNode, ASTExprNode)] -> gr [Block a] b
forall a b. (a -> b) -> a -> b
$ do
  ASTExprNode
n  <- gr [Block a] b -> [ASTExprNode]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes gr [Block a] b
gr
  [Block a]
bs <- Maybe [Block a] -> [[Block a]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Block a] -> [[Block a]]) -> Maybe [Block a] -> [[Block a]]
forall a b. (a -> b) -> a -> b
$ gr [Block a] b -> ASTExprNode -> Maybe [Block a]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab gr [Block a] b
gr ASTExprNode
n
  Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [Block a] -> Bool
forall a. [Block a] -> Bool
isFinalBlockCtrlXfer [Block a]
bs
  LEdge b
le <- gr [Block a] b -> ASTExprNode -> [LEdge b]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr [Block a] b
gr ASTExprNode
n
  (ASTExprNode, ASTExprNode) -> [(ASTExprNode, ASTExprNode)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ((ASTExprNode, ASTExprNode) -> [(ASTExprNode, ASTExprNode)])
-> (ASTExprNode, ASTExprNode) -> [(ASTExprNode, ASTExprNode)]
forall a b. (a -> b) -> a -> b
$ LEdge b -> (ASTExprNode, ASTExprNode)
forall b. LEdge b -> (ASTExprNode, ASTExprNode)
toEdge LEdge b
le

-- Insert exit edges for bblocks with special handling.
insExitEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> M.Map String Node -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insExitEdges :: forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> Map String ASTExprNode
-> gr [Block (Analysis a)] ()
-> gr [Block (Analysis a)] ()
insExitEdges ProgramUnit (Analysis a)
pu Map String ASTExprNode
lm gr [Block (Analysis a)] ()
gr = ([LEdge ()]
 -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ())
-> gr [Block (Analysis a)] ()
-> [LEdge ()]
-> gr [Block (Analysis a)] ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip [LEdge ()]
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (LNode [Block (Analysis a)]
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (-ASTExprNode
1, [Block (Analysis a)]
bs) gr [Block (Analysis a)] ()
gr) ([LEdge ()] -> gr [Block (Analysis a)] ())
-> [LEdge ()] -> gr [Block (Analysis a)] ()
forall a b. (a -> b) -> a -> b
$ do
  ASTExprNode
n <- gr [Block (Analysis a)] () -> [ASTExprNode]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes gr [Block (Analysis a)] ()
gr
  [Block (Analysis a)]
bs' <- Maybe [Block (Analysis a)] -> [[Block (Analysis a)]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Block (Analysis a)] -> [[Block (Analysis a)]])
-> Maybe [Block (Analysis a)] -> [[Block (Analysis a)]]
forall a b. (a -> b) -> a -> b
$ gr [Block (Analysis a)] ()
-> ASTExprNode -> Maybe [Block (Analysis a)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab gr [Block (Analysis a)] ()
gr ASTExprNode
n
  Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [LEdge ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (gr [Block (Analysis a)] () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr [Block (Analysis a)] ()
gr ASTExprNode
n) Bool -> Bool -> Bool
|| [Block (Analysis a)] -> Bool
forall a. [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer [Block (Analysis a)]
bs'
  ASTExprNode
n' <- Map String ASTExprNode -> [Block (Analysis a)] -> [ASTExprNode]
forall a1 a2. Num a1 => Map String a1 -> [Block a2] -> [a1]
examineFinalBlock Map String ASTExprNode
lm [Block (Analysis a)]
bs'
  LEdge () -> [LEdge ()]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
n', ())
  where
    bs :: [Block (Analysis a)]
bs = ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
forall a.
Data a =>
ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
True

-- Given a list of ControlPairs for a StRead, return (if any exists)
-- the expression accompanying an END or ERR, respectively
getReadCtrlXfers :: [ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers :: forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers = ((Maybe (Expression a), Maybe (Expression a))
 -> ControlPair a -> (Maybe (Expression a), Maybe (Expression a)))
-> (Maybe (Expression a), Maybe (Expression a))
-> [ControlPair a]
-> (Maybe (Expression a), Maybe (Expression a))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
forall {a}.
(Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
handler (Maybe (Expression a)
forall a. Maybe a
Nothing, Maybe (Expression a)
forall a. Maybe a
Nothing)
  where
    handler :: (Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
handler r :: (Maybe (Expression a), Maybe (Expression a))
r@(Maybe (Expression a)
r1, Maybe (Expression a)
r2) (ControlPair a
_ SrcSpan
_ Maybe String
ms Expression a
e) = case Maybe String
ms of
      Maybe String
Nothing -> (Maybe (Expression a), Maybe (Expression a))
r
      Just String
s  ->
        case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
          String
"end" -> (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
e, Maybe (Expression a)
r2)
          String
"err" -> (Maybe (Expression a)
r1, Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
e)
          String
_     -> (Maybe (Expression a), Maybe (Expression a))
r

-- Find target of Goto statements (Return statements default target to -1).
examineFinalBlock :: Num a1 => M.Map String a1 -> [Block a2] -> [a1]
examineFinalBlock :: forall a1 a2. Num a1 => Map String a1 -> [Block a2] -> [a1]
examineFinalBlock Map String a1
lm bs :: [Block a2]
bs@(Block a2
_:[Block a2]
_)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StGotoUnconditional a2
_ SrcSpan
_ Expression a2
k) <- [Block a2] -> Block a2
forall a. HasCallStack => [a] -> a
last [Block a2]
bs = [Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k]
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StGotoAssigned a2
_ SrcSpan
_ Expression a2
_ Maybe (AList Expression a2)
ks)   <- [Block a2] -> Block a2
forall a. HasCallStack => [a] -> a
last [Block a2]
bs = (Expression a2 -> a1) -> [Expression a2] -> [a1]
forall a b. (a -> b) -> [a] -> [b]
map (Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm) ([Expression a2]
-> (AList Expression a2 -> [Expression a2])
-> Maybe (AList Expression a2)
-> [Expression a2]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] AList Expression a2 -> [Expression a2]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip Maybe (AList Expression a2)
ks)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StGotoComputed a2
_ SrcSpan
_ AList Expression a2
ks Expression a2
_)   <- [Block a2] -> Block a2
forall a. HasCallStack => [a] -> a
last [Block a2]
bs = (Expression a2 -> a1) -> [Expression a2] -> [a1]
forall a b. (a -> b) -> [a] -> [b]
map (Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm) (AList Expression a2 -> [Expression a2]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression a2
ks)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ StReturn{}            <- [Block a2] -> Block a2
forall a. HasCallStack => [a] -> a
last [Block a2]
bs = [-a1
1]
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StIfArithmetic a2
_ SrcSpan
_ Expression a2
_ Expression a2
k1 Expression a2
k2 Expression a2
k3) <- [Block a2] -> Block a2
forall a. HasCallStack => [a] -> a
last [Block a2]
bs =
      [Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k1, Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k2, Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k3]
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StRead a2
_ SrcSpan
_ AList ControlPair a2
cs Maybe (AList Expression a2)
_) <- [Block a2] -> Block a2
forall a. HasCallStack => [a] -> a
last [Block a2]
bs =
      let (Maybe (Expression a2)
me, Maybe (Expression a2)
mr) = [ControlPair a2] -> (Maybe (Expression a2), Maybe (Expression a2))
forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers ([ControlPair a2]
 -> (Maybe (Expression a2), Maybe (Expression a2)))
-> [ControlPair a2]
-> (Maybe (Expression a2), Maybe (Expression a2))
forall a b. (a -> b) -> a -> b
$ AList ControlPair a2 -> [ControlPair a2]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList ControlPair a2
cs
          f :: Maybe (Expression a2) -> [a1]
f = [a1] -> (Expression a2 -> [a1]) -> Maybe (Expression a2) -> [a1]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Expression a2 -> [a1]) -> Maybe (Expression a2) -> [a1])
-> (Expression a2 -> [a1]) -> Maybe (Expression a2) -> [a1]
forall a b. (a -> b) -> a -> b
$ \Expression a2
v -> [Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
v]
      in  Maybe (Expression a2) -> [a1]
f Maybe (Expression a2)
me [a1] -> [a1] -> [a1]
forall a. [a] -> [a] -> [a]
++ Maybe (Expression a2) -> [a1]
f Maybe (Expression a2)
mr
examineFinalBlock Map String a1
_ [Block a2]
_                                        = [-a1
1]

-- True iff the final block in the list is an explicit control transfer.
isFinalBlockCtrlXfer :: [Block a] -> Bool
isFinalBlockCtrlXfer :: forall a. [Block a] -> Bool
isFinalBlockCtrlXfer bs :: [Block a]
bs@(Block a
_:[Block a]
_)
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoUnconditional{} <- [Block a] -> Block a
forall a. HasCallStack => [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoAssigned{}      <- [Block a] -> Block a
forall a. HasCallStack => [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StReturn{}            <- [Block a] -> Block a
forall a. HasCallStack => [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StIfArithmetic{}      <- [Block a] -> Block a
forall a. HasCallStack => [a] -> a
last [Block a]
bs = Bool
True
  -- Note that StGotoComputed is not handled here since it
  -- is not an explicit control transfer if the expression
  -- does not index into one of the labels, in which case
  -- it acts as a StContinue
isFinalBlockCtrlXfer [Block a]
_                                 = Bool
False

-- True iff the final block in the list has an control transfer
-- with exceptional circumstances, like a StGotoComputed or a StRead
isFinalBlockExceptionalCtrlXfer :: [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer :: forall a. [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer bs :: [Block a]
bs@(Block a
_:[Block a]
_)
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoComputed{} <- [Block a] -> Block a
forall a. HasCallStack => [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StRead{}         <- [Block a] -> Block a
forall a. HasCallStack => [a] -> a
last [Block a]
bs = Bool
True
isFinalBlockExceptionalCtrlXfer [Block a]
_                   = Bool
False

-- Drop any '0' that appear at the beginning of a label since
-- labels like "40" and "040" are considered equivalent.
dropLeadingZeroes :: String -> String
dropLeadingZeroes :: String -> String
dropLeadingZeroes = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0')

lookupBBlock :: Num a1 => M.Map String a1 -> Expression a2 -> a1
lookupBBlock :: forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
a =
  case Expression a2
a of
    ExpValue a2
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam a2)
_) -> (-a1
1) a1 -> Maybe a1 -> a1
forall a. a -> Maybe a -> a
`fromMaybe` String -> Map String a1 -> Maybe a1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> String
dropLeadingZeroes String
l) Map String a1
lm
-- This occurs if a variable is being used for a label, e.g., from a Fortran 77 ASSIGN statement
    ExpValue a2
_ SrcSpan
_ (ValVariable String
l) -> (-a1
1) a1 -> Maybe a1 -> a1
forall a. a -> Maybe a -> a
`fromMaybe` String -> Map String a1 -> Maybe a1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
l Map String a1
lm
    Expression a2
_ -> String -> a1
forall a. HasCallStack => String -> a
error String
"unhandled lookupBBlock"

-- Seek out empty bblocks with a single entrance and a single exit
-- edge, and remove them, re-establishing the edges without them.
delEmptyBBlocks :: (Foldable t, DynGraph gr) => gr (t a) b -> gr (t a) b
delEmptyBBlocks :: forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks gr (t a) b
gr
  | (ASTExprNode
n, ASTExprNode
s, ASTExprNode
t, b
l):[(ASTExprNode, ASTExprNode, ASTExprNode, b)]
_ <- [(ASTExprNode, ASTExprNode, ASTExprNode, b)]
candidates = gr (t a) b -> gr (t a) b
forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks (gr (t a) b -> gr (t a) b)
-> (gr (t a) b -> gr (t a) b) -> gr (t a) b -> gr (t a) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEdge b -> gr (t a) b -> gr (t a) b
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (ASTExprNode
s, ASTExprNode
t, b
l) (gr (t a) b -> gr (t a) b)
-> (gr (t a) b -> gr (t a) b) -> gr (t a) b -> gr (t a) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTExprNode -> gr (t a) b -> gr (t a) b
forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> gr a b
delNode ASTExprNode
n (gr (t a) b -> gr (t a) b) -> gr (t a) b -> gr (t a) b
forall a b. (a -> b) -> a -> b
$ gr (t a) b
gr
  | Bool
otherwise                    = gr (t a) b
gr
  where
    -- recompute candidate nodes each iteration
    candidates :: [(ASTExprNode, ASTExprNode, ASTExprNode, b)]
candidates = do
      let emptyBBs :: [(ASTExprNode, t a)]
emptyBBs = ((ASTExprNode, t a) -> Bool)
-> [(ASTExprNode, t a)] -> [(ASTExprNode, t a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (t a -> Bool)
-> ((ASTExprNode, t a) -> t a) -> (ASTExprNode, t a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASTExprNode, t a) -> t a
forall a b. (a, b) -> b
snd) (gr (t a) b -> [(ASTExprNode, t a)]
forall a b. gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr (t a) b
gr)
      let adjs :: [(ASTExprNode, [LEdge b], [LEdge b])]
adjs     = ((ASTExprNode, t a) -> (ASTExprNode, [LEdge b], [LEdge b]))
-> [(ASTExprNode, t a)] -> [(ASTExprNode, [LEdge b], [LEdge b])]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ASTExprNode
n, t a
_) -> (ASTExprNode
n, gr (t a) b -> ASTExprNode -> [LEdge b]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
inn gr (t a) b
gr ASTExprNode
n, gr (t a) b -> ASTExprNode -> [LEdge b]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr (t a) b
gr ASTExprNode
n)) [(ASTExprNode, t a)]
emptyBBs
      (ASTExprNode
n, [(ASTExprNode
s,ASTExprNode
_,b
l)], [(ASTExprNode
_,ASTExprNode
t,b
_)]) <- [(ASTExprNode, [LEdge b], [LEdge b])]
adjs
      (ASTExprNode, ASTExprNode, ASTExprNode, b)
-> [(ASTExprNode, ASTExprNode, ASTExprNode, b)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
s, ASTExprNode
t, b
l)

-- Delete unreachable nodes.
delUnreachable :: DynGraph gr => gr a b -> gr a b
delUnreachable :: forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
delUnreachable gr a b
gr = [ASTExprNode] -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[ASTExprNode] -> gr a b -> gr a b
subgraph (ASTExprNode -> gr a b -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> [ASTExprNode]
reachable ASTExprNode
0 gr a b
gr) gr a b
gr

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

-- Running state during basic block analyser.
data BBState a = BBS { forall a. BBState a -> BBGr a
bbGraph  :: BBGr a
                     , forall a. BBState a -> BB a
curBB    :: BB a
                     , forall a. BBState a -> ASTExprNode
curNode  :: Node
                     , forall a. BBState a -> Map String ASTExprNode
labelMap :: M.Map String Node
                     , forall a. BBState a -> [ASTExprNode]
nums     :: [Int]
                     , forall a. BBState a -> [ASTExprNode]
tempNums :: [Int]
                     , forall a. BBState a -> [LEdge ()]
newEdges :: [LEdge ()] }

-- Initial state
bbs0 :: BBState a
bbs0 :: forall a. BBState a
bbs0 = BBS { bbGraph :: BBGr a
bbGraph = BBGr a
forall a. BBGr a
bbgrEmpty, curBB :: BB a
curBB = [], curNode :: ASTExprNode
curNode = ASTExprNode
1
           , labelMap :: Map String ASTExprNode
labelMap = Map String ASTExprNode
forall k a. Map k a
M.empty, nums :: [ASTExprNode]
nums = [ASTExprNode
2..], tempNums :: [ASTExprNode]
tempNums = [ASTExprNode
0..]
           , newEdges :: [LEdge ()]
newEdges = [] }

-- Monad
type BBlocker a = State (BBState a)

-- Monad entry function.
execBBlocker :: BBlocker a b -> BBState a
execBBlocker :: forall a b. BBlocker a b -> BBState a
execBBlocker = (BBlocker a b -> BBState a -> BBState a)
-> BBState a -> BBlocker a b -> BBState a
forall a b c. (a -> b -> c) -> b -> a -> c
flip BBlocker a b -> BBState a -> BBState a
forall s a. State s a -> s -> s
execState BBState a
forall a. BBState a
bbs0

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

-- Handle a list of blocks (typically from ProgramUnit or nested inside a BlDo, BlIf, etc).
processBlocks :: Data a => [Block (Analysis a)] -> BBlocker (Analysis a) (Node, Node)
-- precondition: curNode is not yet in the graph && will label the first block
-- postcondition: final bblock is in the graph labeled as endN && curNode == endN
-- returns start and end nodes for basic block graph corresponding to parameter bs
processBlocks :: forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs = do
  ASTExprNode
startN <- (BBState (Analysis a) -> ASTExprNode)
-> StateT (BBState (Analysis a)) Identity ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> [Block (Analysis a)]
-> StateT (BBState (Analysis a)) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
perBlock [Block (Analysis a)]
bs
  ASTExprNode
endN   <- (BBState (Analysis a) -> ASTExprNode)
-> StateT (BBState (Analysis a)) Identity ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  (BBState (Analysis a) -> BBState (Analysis a))
-> StateT (BBState (Analysis a)) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState (Analysis a) -> BBState (Analysis a))
 -> StateT (BBState (Analysis a)) Identity ())
-> (BBState (Analysis a) -> BBState (Analysis a))
-> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState (Analysis a)
st -> BBState (Analysis a)
st { bbGraph = bbgrMap (insNode (endN, reverse (curBB st))) (bbGraph st)
                      , curBB   = [] }
  (ASTExprNode, ASTExprNode)
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
startN, ASTExprNode
endN)

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

msnoc :: Maybe a -> [a] -> [a]
msnoc :: forall a. Maybe a -> [a] -> [a]
msnoc Maybe a
Nothing  [a]
xs = [a]
xs
msnoc (Just a
x) [a]
xs = [a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
x]

-- Handle an AST-block element
perBlock :: Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
-- invariant: curNode corresponds to curBB, and is not yet in the graph
-- invariant: curBB is in reverse order
perBlock :: forall a. Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
perBlock b :: Block (Analysis a)
b@(BlIf Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ NonEmpty (Expression (Analysis a), [Block (Analysis a)])
clauses Maybe [Block (Analysis a)]
elseBlock Maybe (Expression (Analysis a))
_) = do
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  NonEmpty (Expression (Analysis a))
_ <- NonEmpty (Expression (Analysis a))
-> (Expression (Analysis a)
    -> StateT
         (BBState (Analysis a)) Identity (Expression (Analysis a)))
-> StateT
     (BBState (Analysis a))
     Identity
     (NonEmpty (Expression (Analysis a)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (((Expression (Analysis a), [Block (Analysis a)])
 -> Expression (Analysis a))
-> NonEmpty (Expression (Analysis a), [Block (Analysis a)])
-> NonEmpty (Expression (Analysis a))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expression (Analysis a), [Block (Analysis a)])
-> Expression (Analysis a)
forall a b. (a, b) -> a
fst NonEmpty (Expression (Analysis a), [Block (Analysis a)])
clauses) Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode
ifN, ASTExprNode
_) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- go through nested AST-blocks
  let bss :: [[Block (Analysis a)]]
bss = Maybe [Block (Analysis a)]
-> [[Block (Analysis a)]] -> [[Block (Analysis a)]]
forall a. Maybe a -> [a] -> [a]
msnoc Maybe [Block (Analysis a)]
elseBlock ([[Block (Analysis a)]] -> [[Block (Analysis a)]])
-> [[Block (Analysis a)]] -> [[Block (Analysis a)]]
forall a b. (a -> b) -> a -> b
$ ((Expression (Analysis a), [Block (Analysis a)])
 -> [Block (Analysis a)])
-> [(Expression (Analysis a), [Block (Analysis a)])]
-> [[Block (Analysis a)]]
forall a b. (a -> b) -> [a] -> [b]
map (Expression (Analysis a), [Block (Analysis a)])
-> [Block (Analysis a)]
forall a b. (a, b) -> b
snd ([(Expression (Analysis a), [Block (Analysis a)])]
 -> [[Block (Analysis a)]])
-> [(Expression (Analysis a), [Block (Analysis a)])]
-> [[Block (Analysis a)]]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Expression (Analysis a), [Block (Analysis a)])
-> [(Expression (Analysis a), [Block (Analysis a)])]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Expression (Analysis a), [Block (Analysis a)])
clauses
  [(ASTExprNode, ASTExprNode)]
startEnds <- [[Block (Analysis a)]]
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Block (Analysis a)]]
bss (([Block (Analysis a)]
  -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
 -> StateT
      (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)])
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall a b. (a -> b) -> a -> b
$ \ [Block (Analysis a)]
bs -> do
    (ASTExprNode
thenN, ASTExprNode
endN) <- [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
    ASTExprNode
_ <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
    (ASTExprNode, ASTExprNode)
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
thenN, ASTExprNode
endN)

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN   <- (BBState (Analysis a) -> ASTExprNode)
-> BBlocker (Analysis a) ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  let es :: [LEdge ()]
es  = [(ASTExprNode, ASTExprNode)]
startEnds [(ASTExprNode, ASTExprNode)]
-> ((ASTExprNode, ASTExprNode) -> [LEdge ()]) -> [LEdge ()]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ASTExprNode
thenN, ASTExprNode
endN) -> [(ASTExprNode
ifN, ASTExprNode
thenN, ()), (ASTExprNode
endN, ASTExprNode
nxtN, ())]
  -- if there is no "Else"-statement then we need an edge from ifN -> nxtN
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges ([LEdge ()] -> BBlocker (Analysis a) ())
-> [LEdge ()] -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ case Maybe [Block (Analysis a)]
elseBlock of Maybe [Block (Analysis a)]
Nothing -> (ASTExprNode
ifN, ASTExprNode
nxtN, ())LEdge () -> [LEdge ()] -> [LEdge ()]
forall a. a -> [a] -> [a]
:[LEdge ()]
es -- es
                                  Just{}  -> [LEdge ()]
es

perBlock b :: Block (Analysis a)
b@(BlCase Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Expression (Analysis a)
_ [(AList Index (Analysis a), [Block (Analysis a)])]
clauses Maybe [Block (Analysis a)]
defCase Maybe (Expression (Analysis a))
_) = do
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode
selectN, ASTExprNode
_) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- go through nested AST-blocks
  let bss :: [[Block (Analysis a)]]
bss = Maybe [Block (Analysis a)]
-> [[Block (Analysis a)]] -> [[Block (Analysis a)]]
forall a. Maybe a -> [a] -> [a]
msnoc Maybe [Block (Analysis a)]
defCase ([[Block (Analysis a)]] -> [[Block (Analysis a)]])
-> [[Block (Analysis a)]] -> [[Block (Analysis a)]]
forall a b. (a -> b) -> a -> b
$ ((AList Index (Analysis a), [Block (Analysis a)])
 -> [Block (Analysis a)])
-> [(AList Index (Analysis a), [Block (Analysis a)])]
-> [[Block (Analysis a)]]
forall a b. (a -> b) -> [a] -> [b]
map (AList Index (Analysis a), [Block (Analysis a)])
-> [Block (Analysis a)]
forall a b. (a, b) -> b
snd [(AList Index (Analysis a), [Block (Analysis a)])]
clauses
  [(ASTExprNode, ASTExprNode)]
startEnds <- [[Block (Analysis a)]]
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Block (Analysis a)]]
bss (([Block (Analysis a)]
  -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
 -> StateT
      (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)])
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall a b. (a -> b) -> a -> b
$ \ [Block (Analysis a)]
bs -> do
    (ASTExprNode
caseN, ASTExprNode
endN) <- [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
    ASTExprNode
_ <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
    (ASTExprNode, ASTExprNode)
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
caseN, ASTExprNode
endN)

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN   <- (BBState (Analysis a) -> ASTExprNode)
-> BBlocker (Analysis a) ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  let es :: [LEdge ()]
es  = [(ASTExprNode, ASTExprNode)]
startEnds [(ASTExprNode, ASTExprNode)]
-> ((ASTExprNode, ASTExprNode) -> [LEdge ()]) -> [LEdge ()]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ASTExprNode
caseN, ASTExprNode
endN) -> [(ASTExprNode
selectN, ASTExprNode
caseN, ()), (ASTExprNode
endN, ASTExprNode
nxtN, ())]
  -- if there is no "CASE DEFAULT"-statement then we need an edge from selectN -> nxtN
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges ([LEdge ()] -> BBlocker (Analysis a) ())
-> [LEdge ()] -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ case Maybe [Block (Analysis a)]
defCase of Maybe [Block (Analysis a)]
Nothing -> (ASTExprNode
selectN, ASTExprNode
nxtN, ())LEdge () -> [LEdge ()] -> [LEdge ()]
forall a. a -> [a] -> [a]
:[LEdge ()]
es
                                Just{}  -> [LEdge ()]
es

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StGotoComputed Analysis a
_ SrcSpan
_ AList Expression (Analysis a)
_ Expression (Analysis a)
exp)) = do
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Expression (Analysis a)
_ <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
exp
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b
  (ASTExprNode
gotoN, ASTExprNode
nxtN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
gotoN, ASTExprNode
nxtN, ())]

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
a SrcSpan
ss Maybe (Expression (Analysis a))
_ (StIfLogical Analysis a
_ SrcSpan
_ Expression (Analysis a)
exp Statement (Analysis a)
stm)) = do
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Expression (Analysis a)
_ <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
exp
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b

  -- start a bblock for the nested statement inside the If
  (ASTExprNode
ifN, ASTExprNode
thenN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- build pseudo-AST-block to contain nested statement
  (ASTExprNode, ASTExprNode)
_ <- [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel = Nothing } SrcSpan
ss Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing Statement (Analysis a)
stm]
  ASTExprNode
_ <- (BBState (Analysis a) -> ASTExprNode)
-> BBlocker (Analysis a) ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
ifN, ASTExprNode
thenN, ()), (ASTExprNode
ifN, ASTExprNode
nxtN, ()), (ASTExprNode
thenN, ASTExprNode
nxtN, ())]

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StIfArithmetic{}) =
  -- Treat an arithmetic if similarly to a goto
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b.
StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
-> StateT (BBState (Analysis a)) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b.
StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
-> StateT (BBState (Analysis a)) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BBlocker (Analysis a) ()
forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b :: Block (Analysis a)
b@(BlDo Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Maybe (Expression (Analysis a))
_ (Just DoSpecification (Analysis a)
spec) [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
_) = do
  let DoSpecification Analysis a
_ SrcSpan
_ (StExpressionAssign Analysis a
_ SrcSpan
_ Expression (Analysis a)
_ Expression (Analysis a)
e1) Expression (Analysis a)
e2 Maybe (Expression (Analysis a))
me3 = DoSpecification (Analysis a)
spec
  Expression (Analysis a)
_  <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e1
  Expression (Analysis a)
_  <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e2
  Maybe (Expression (Analysis a))
_  <- case Maybe (Expression (Analysis a))
me3 of Just Expression (Analysis a)
e3 -> Expression (Analysis a) -> Maybe (Expression (Analysis a))
forall a. a -> Maybe a
Just (Expression (Analysis a) -> Maybe (Expression (Analysis a)))
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
-> StateT
     (BBState (Analysis a)) Identity (Maybe (Expression (Analysis a)))
forall a b.
(a -> b)
-> StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e3; Maybe (Expression (Analysis a))
Nothing -> Maybe (Expression (Analysis a))
-> StateT
     (BBState (Analysis a)) Identity (Maybe (Expression (Analysis a)))
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing
  Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing Block (Analysis a)
b [Block (Analysis a)]
bs
perBlock b :: Block (Analysis a)
b@(BlDo Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Maybe (Expression (Analysis a))
_ Maybe (DoSpecification (Analysis a))
Nothing [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
_) = Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing Block (Analysis a)
b [Block (Analysis a)]
bs
perBlock b :: Block (Analysis a)
b@(BlDoWhile Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Maybe (Expression (Analysis a))
_ Expression (Analysis a)
exp [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
_) = Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock (Expression (Analysis a) -> Maybe (Expression (Analysis a))
forall a. a -> Maybe a
Just Expression (Analysis a)
exp) Block (Analysis a)
b [Block (Analysis a)]
bs
perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StReturn{}) =
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b.
StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
-> StateT (BBState (Analysis a)) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b.
StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
-> StateT (BBState (Analysis a)) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BBlocker (Analysis a) ()
forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StGotoUnconditional{}) =
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b.
StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
-> StateT (BBState (Analysis a)) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b.
StateT (BBState (Analysis a)) Identity a
-> StateT (BBState (Analysis a)) Identity b
-> StateT (BBState (Analysis a)) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BBlocker (Analysis a) ()
forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b' :: Block (Analysis a)
b'@(BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l (StCall Analysis a
a' SrcSpan
s' cn :: Expression (Analysis a)
cn@ExpValue{} AList Argument (Analysis a)
aargs)) = do
    case AList Argument (Analysis a) -> [Argument (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument (Analysis a)
aargs of
      []  -> do
        (ASTExprNode
prevN, ASTExprNode
callN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
        -- put StCall in a bblock by itself
        Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b'
        (ASTExprNode
_, ASTExprNode
nextN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
        [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
callN, ()), (ASTExprNode
callN, ASTExprNode
nextN, ()) ]
      Argument (Analysis a)
_:[Argument (Analysis a)]
_ -> do
        let a0 :: Analysis a
a0 = [Analysis a] -> Analysis a
forall a. HasCallStack => [a] -> a
head ([Analysis a] -> Analysis a)
-> ([a] -> [Analysis a]) -> [a] -> Analysis a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [Analysis a]
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis ([a] -> Analysis a) -> [a] -> Analysis a
forall a b. (a -> b) -> a -> b
$ [Analysis a -> a
forall a. Analysis a -> a
prevAnnotation Analysis a
a]
        let exps :: [Expression (Analysis a)]
exps = (Argument (Analysis a) -> Expression (Analysis a))
-> [Argument (Analysis a)] -> [Expression (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map Argument (Analysis a) -> Expression (Analysis a)
forall a. Argument a -> Expression a
argExtractExpr ([Argument (Analysis a)] -> [Expression (Analysis a)])
-> (AList Argument (Analysis a) -> [Argument (Analysis a)])
-> AList Argument (Analysis a)
-> [Expression (Analysis a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList Argument (Analysis a) -> [Argument (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip (AList Argument (Analysis a) -> [Expression (Analysis a)])
-> AList Argument (Analysis a) -> [Expression (Analysis a)]
forall a b. (a -> b) -> a -> b
$ AList Argument (Analysis a)
aargs
        (ASTExprNode
prevN, ASTExprNode
formalN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

        -- create bblock that assigns formal parameters (n[1], n[2], ...)
        case Maybe (Expression (Analysis a))
l of
          Just (ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
l' Maybe (KindParam (Analysis a))
_)) -> String -> ASTExprNode -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l' ASTExprNode
formalN -- label goes here, if present
          Maybe (Expression (Analysis a))
_                                   -> () -> BBlocker (Analysis a) ()
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        let name :: Integer -> String
name Integer
i   = Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
cn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
        let formal :: Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal (ExpValue Analysis a
a'' SrcSpan
s'' (ValVariable String
_)) Integer
i = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a''{ insLabel = Nothing } SrcSpan
s'' (Integer -> String
name Integer
i)
            formal Expression (Analysis a)
e Integer
i                                  = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a''{ insLabel = Nothing } SrcSpan
s'' (Integer -> String
name Integer
i)
              where a'' :: Analysis a
a'' = Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e; s'' :: SrcSpan
s'' = Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e
        [(Expression (Analysis a), Integer)]
-> ((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Expression (Analysis a)]
-> [Integer] -> [(Expression (Analysis a), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) (((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
 -> BBlocker (Analysis a) ())
-> ((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) -> do
          Expression (Analysis a)
e' <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e -- may generate additional bblocks
          let b :: Block (Analysis a)
b = Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel = Nothing } SrcSpan
s Maybe (Expression (Analysis a))
l (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e' Integer
i) Expression (Analysis a)
e')
          Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 Block (Analysis a)
b

        (ASTExprNode
formalN', ASTExprNode
dummyCallN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
        -- formalN' may differ from formalN when additional bblocks were
        -- generated by processFunctionCalls.

        let dummyArgs :: [Argument (Analysis a)]
dummyArgs = (Expression (Analysis a) -> Argument (Analysis a))
-> [Expression (Analysis a)] -> [Argument (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Expression (Analysis a)
e -> Analysis a
-> SrcSpan
-> Maybe String
-> ArgumentExpression (Analysis a)
-> Argument (Analysis a)
forall a.
a -> SrcSpan -> Maybe String -> ArgumentExpression a -> Argument a
Argument Analysis a
a0 SrcSpan
s' Maybe String
forall a. Maybe a
Nothing (Expression (Analysis a) -> ArgumentExpression (Analysis a)
forall a. Expression a -> ArgumentExpression a
ArgExpr Expression (Analysis a)
e))
                            ((Expression (Analysis a) -> Integer -> Expression (Analysis a))
-> [Expression (Analysis a)]
-> [Integer]
-> [Expression (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal [Expression (Analysis a)]
exps [(Integer
1::Integer)..])

        -- create "dummy call" bblock with dummy parameters in the StCall AST-node.
        Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> BBlocker (Analysis a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> AList Argument (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Statement a
StCall Analysis a
a' SrcSpan
s' Expression (Analysis a)
cn (Analysis a
-> [Argument (Analysis a)] -> AList Argument (Analysis a)
forall (t :: * -> *) a. Spanned (t a) => a -> [t a] -> AList t a
fromList Analysis a
a0 [Argument (Analysis a)]
dummyArgs))
        (ASTExprNode
_, ASTExprNode
returnedN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

        -- re-assign the variables using the values of the formal parameters, if possible
        -- (because call-by-reference)
        [(Expression (Analysis a), Integer)]
-> ((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Expression (Analysis a)]
-> [Integer] -> [(Expression (Analysis a), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) (((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
 -> BBlocker (Analysis a) ())
-> ((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) ->
          -- this is only possible for l-expressions
          (Bool -> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Expression (Analysis a) -> Bool
forall a. Expression a -> Bool
isLExpr Expression (Analysis a)
e) (BBlocker (Analysis a) () -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$
            Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> BBlocker (Analysis a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$
              Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel = Nothing } SrcSpan
s Maybe (Expression (Analysis a))
l (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' Expression (Analysis a)
e (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e Integer
i)))
        (ASTExprNode
_, ASTExprNode
nextN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

        -- connect the bblocks
        [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
formalN, ()), (ASTExprNode
formalN', ASTExprNode
dummyCallN, ())
                    , (ASTExprNode
dummyCallN, ASTExprNode
returnedN, ()), (ASTExprNode
returnedN, ASTExprNode
nextN, ()) ]

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StRead Analysis a
_ SrcSpan
_ AList ControlPair (Analysis a)
cs Maybe (AList Expression (Analysis a))
_)) = do
  let (Maybe (Expression (Analysis a))
end, Maybe (Expression (Analysis a))
err) = [ControlPair (Analysis a)]
-> (Maybe (Expression (Analysis a)),
    Maybe (Expression (Analysis a)))
forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers ([ControlPair (Analysis a)]
 -> (Maybe (Expression (Analysis a)),
     Maybe (Expression (Analysis a))))
-> [ControlPair (Analysis a)]
-> (Maybe (Expression (Analysis a)),
    Maybe (Expression (Analysis a)))
forall a b. (a -> b) -> a -> b
$ AList ControlPair (Analysis a) -> [ControlPair (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList ControlPair (Analysis a)
cs

  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Block (Analysis a)
b' <- (Expression (Analysis a)
 -> StateT
      (BBState (Analysis a)) Identity (Expression (Analysis a)))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Block (Analysis a))
forall from to (m :: * -> *).
(Biplate from to, Applicative m) =>
(to -> m to) -> from -> m from
forall (m :: * -> *).
Applicative m =>
(Expression (Analysis a) -> m (Expression (Analysis a)))
-> Block (Analysis a) -> m (Block (Analysis a))
descendBiM Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Block (Analysis a)
b
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b'

  Bool -> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Expression (Analysis a)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Expression (Analysis a))
end Bool -> Bool -> Bool
|| Maybe (Expression (Analysis a)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Expression (Analysis a))
err) (BBlocker (Analysis a) () -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ do
    (ASTExprNode
readN, ASTExprNode
nxtN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
    [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
readN, ASTExprNode
nxtN, ())]

perBlock Block (Analysis a)
b = do
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Block (Analysis a)
b' <- (Expression (Analysis a)
 -> StateT
      (BBState (Analysis a)) Identity (Expression (Analysis a)))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Block (Analysis a))
forall from to (m :: * -> *).
(Biplate from to, Applicative m) =>
(to -> m to) -> from -> m from
forall (m :: * -> *).
Applicative m =>
(Expression (Analysis a) -> m (Expression (Analysis a)))
-> Block (Analysis a) -> m (Block (Analysis a))
descendBiM Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Block (Analysis a)
b
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b'

--------------------------------------------------
-- helper monadic combinators

-- Do-block helper
perDoBlock :: Data a => Maybe (Expression (Analysis a)) -> Block (Analysis a) -> [Block (Analysis a)] -> BBlocker (Analysis a) ()
perDoBlock :: forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock Maybe (Expression (Analysis a))
repeatExpr Block (Analysis a)
b [Block (Analysis a)]
bs = do
  (ASTExprNode
n, ASTExprNode
doN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  case Block (Analysis a) -> Maybe (Expression (Analysis a))
forall a. Block a -> Maybe (Expression a)
forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block (Analysis a)
b of
    Just (ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam (Analysis a))
_)) -> String -> ASTExprNode -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
doN
    Maybe (Expression (Analysis a))
_                                  -> () -> BBlocker (Analysis a) ()
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  case Maybe (Expression (Analysis a))
repeatExpr of Just Expression (Analysis a)
e -> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
-> BBlocker (Analysis a) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e); Maybe (Expression (Analysis a))
Nothing -> () -> BBlocker (Analysis a) ()
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode, ASTExprNode)
_ <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  -- process nested bblocks inside of do-statement
  (ASTExprNode
startN, ASTExprNode
endN) <- [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
  ASTExprNode
n' <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
  -- connect all the new bblocks with edges, link to subsequent bblock labeled n'
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
n, ASTExprNode
doN, ()), (ASTExprNode
doN, ASTExprNode
n', ()), (ASTExprNode
doN, ASTExprNode
startN, ()), (ASTExprNode
endN, ASTExprNode
doN, ())]

-- Maintains perBlock invariants while potentially starting a new
-- bblock in case of a label.
processLabel :: Block a -> BBlocker a ()
processLabel :: forall a. Block a -> BBlocker a ()
processLabel Block a
b | Just (ExpValue a
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam a)
_)) <- Block a -> Maybe (Expression a)
forall a. Block a -> Maybe (Expression a)
forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block a
b = do
  (ASTExprNode
n, ASTExprNode
n') <- BBlocker a (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  String -> ASTExprNode -> BBlocker a ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
n'
  [LEdge ()] -> BBlocker a ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
n, ASTExprNode
n', ())]
processLabel Block a
_ = () -> BBlocker a ()
forall a. a -> StateT (BBState a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Inserts into labelMap
insertLabel :: MonadState (BBState a) m => String -> Node -> m ()
insertLabel :: forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
n = (BBState a -> BBState a) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> m ())
-> (BBState a -> BBState a) -> m ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { labelMap = M.insert (dropLeadingZeroes l) n (labelMap st) }

-- Puts an AST block into the current bblock.
addToBBlock :: Block a -> BBlocker a ()
addToBBlock :: forall a. Block a -> BBlocker a ()
addToBBlock Block a
b = (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { curBB = b:curBB st }

-- Closes down the current bblock and opens a new one.
closeBBlock :: BBlocker a (Node, Node)
closeBBlock :: forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock = do
  ASTExprNode
n  <- (BBState a -> ASTExprNode)
-> StateT (BBState a) Identity ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState a -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { bbGraph = bbgrMap (insNode (n, reverse (curBB st))) (bbGraph st), curBB = [] }
  ASTExprNode
n' <- StateT (BBState a) Identity ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
  (ASTExprNode, ASTExprNode) -> BBlocker a (ASTExprNode, ASTExprNode)
forall a. a -> StateT (BBState a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
n')
closeBBlock_ :: StateT (BBState a) Identity ()
closeBBlock_ :: forall a. StateT (BBState a) Identity ()
closeBBlock_ = StateT (BBState a) Identity (ASTExprNode, ASTExprNode)
-> StateT (BBState a) Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void StateT (BBState a) Identity (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

-- Starts up a new bblock.
genBBlock :: BBlocker a Int
genBBlock :: forall a. BBlocker a ASTExprNode
genBBlock = do
  ASTExprNode
n' <- BBlocker a ASTExprNode
forall a. BBlocker a ASTExprNode
gen
  (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { curNode = n', curBB = [] }
  ASTExprNode -> BBlocker a ASTExprNode
forall a. a -> StateT (BBState a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ASTExprNode
n'

-- Adds labeled-edge mappings.
createEdges :: MonadState (BBState a) m => [LEdge ()] -> m ()
createEdges :: forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [LEdge ()]
es = (BBState a -> BBState a) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> m ())
-> (BBState a -> BBState a) -> m ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { newEdges = es ++ newEdges st }

-- Generates a new node number.
gen :: BBlocker a Int
gen :: forall a. BBlocker a ASTExprNode
gen = do
  ~(ASTExprNode
n:[ASTExprNode]
ns) <- (BBState a -> [ASTExprNode])
-> StateT (BBState a) Identity [ASTExprNode]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState a -> [ASTExprNode]
forall a. BBState a -> [ASTExprNode]
nums
  (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
s -> BBState a
s { nums = ns }
  ASTExprNode -> BBlocker a ASTExprNode
forall a. a -> StateT (BBState a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ASTExprNode
n

genTemp :: String -> BBlocker a String
genTemp :: forall a. String -> BBlocker a String
genTemp String
str = do
  ~(ASTExprNode
n:[ASTExprNode]
ns) <- (BBState a -> [ASTExprNode])
-> StateT (BBState a) Identity [ASTExprNode]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState a -> [ASTExprNode]
forall a. BBState a -> [ASTExprNode]
tempNums
  (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
s -> BBState a
s { tempNums = ns }
  String -> BBlocker a String
forall a. a -> StateT (BBState a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> BBlocker a String) -> String -> BBlocker a String
forall a b. (a -> b) -> a -> b
$ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_t#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n

-- Strip nested code not necessary since it is duplicated in another
-- basic block.
stripNestedBlocks :: Block a -> Block a
stripNestedBlocks :: forall a. Block a -> Block a
stripNestedBlocks (BlDo a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Maybe (Expression a)
tl Maybe (DoSpecification a)
ds [Block a]
_ Maybe (Expression a)
el)     = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Maybe (Expression a)
tl Maybe (DoSpecification a)
ds [] Maybe (Expression a)
el
stripNestedBlocks (BlDoWhile a
a SrcSpan
s Maybe (Expression a)
l Maybe String
tl Maybe (Expression a)
n Expression a
e [Block a]
_ Maybe (Expression a)
el)  = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile a
a SrcSpan
s Maybe (Expression a)
l Maybe String
tl Maybe (Expression a)
n Expression a
e [] Maybe (Expression a)
el
stripNestedBlocks (BlIf a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn NonEmpty (Expression a, [Block a])
clauses Maybe [Block a]
elseBlock Maybe (Expression a)
el) =
    a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> NonEmpty (Expression a, [Block a])
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> NonEmpty (Expression a, [Block a])
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlIf a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn (((Expression a, [Block a]) -> (Expression a, [Block a]))
-> NonEmpty (Expression a, [Block a])
-> NonEmpty (Expression a, [Block a])
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Expression a
e, [Block a]
_bs) -> (Expression a
e, [])) NonEmpty (Expression a, [Block a])
clauses) (([Block a] -> [Block a]) -> Maybe [Block a] -> Maybe [Block a]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> [Block a] -> [Block a]
forall a b. a -> b -> a
const []) Maybe [Block a]
elseBlock) Maybe (Expression a)
el
stripNestedBlocks (BlCase a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Expression a
sc [(AList Index a, [Block a])]
clauses Maybe [Block a]
caseDef Maybe (Expression a)
el) =
    a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [(AList Index a, [Block a])]
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [(AList Index a, [Block a])]
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlCase a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Expression a
sc (((AList Index a, [Block a]) -> (AList Index a, [Block a]))
-> [(AList Index a, [Block a])] -> [(AList Index a, [Block a])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(AList Index a
r, [Block a]
_bs) -> (AList Index a
r, [])) [(AList Index a, [Block a])]
clauses) (([Block a] -> [Block a]) -> Maybe [Block a] -> Maybe [Block a]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> [Block a] -> [Block a]
forall a b. a -> b -> a
const []) Maybe [Block a]
caseDef) Maybe (Expression a)
el
stripNestedBlocks Block a
b                              = Block a
b

-- Flatten out function calls within the expression, returning an
-- expression that replaces the original expression (probably becoming
-- a temporary variable).
processFunctionCalls :: Data a => Expression (Analysis a) -> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls :: forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls = (Expression (Analysis a)
 -> StateT
      (BBState (Analysis a)) Identity (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCall -- work bottom-up

-- Flatten out a single function call.
processFunctionCall :: Data a => Expression (Analysis a) -> BBlocker (Analysis a) (Expression (Analysis a))
-- precondition: there are no more nested function calls within the actual arguments
processFunctionCall :: forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCall (ExpFunctionCall Analysis a
a SrcSpan
s fn :: Expression (Analysis a)
fn@(ExpValue Analysis a
a' SrcSpan
s' Value (Analysis a)
_) AList Argument (Analysis a)
aargs) = do
  let a0 :: Analysis a
a0 = [Analysis a] -> Analysis a
forall a. HasCallStack => [a] -> a
head ([Analysis a] -> Analysis a)
-> ([a] -> [Analysis a]) -> [a] -> Analysis a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [Analysis a]
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis ([a] -> Analysis a) -> [a] -> Analysis a
forall a b. (a -> b) -> a -> b
$ [Analysis a -> a
forall a. Analysis a -> a
prevAnnotation Analysis a
a]
  (ASTExprNode
prevN, ASTExprNode
formalN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  let exps :: [Expression (Analysis a)]
exps = (Argument (Analysis a) -> Expression (Analysis a))
-> [Argument (Analysis a)] -> [Expression (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map Argument (Analysis a) -> Expression (Analysis a)
forall a. Argument a -> Expression a
argExtractExpr ([Argument (Analysis a)] -> [Expression (Analysis a)])
-> [Argument (Analysis a)] -> [Expression (Analysis a)]
forall a b. (a -> b) -> a -> b
$ AList Argument (Analysis a) -> [Argument (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument (Analysis a)
aargs

  -- create bblock that assigns formal parameters (fn[1], fn[2], ...)
  let name :: Integer -> String
name Integer
i   = Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  let formal :: Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal (ExpValue Analysis a
_ SrcSpan
s'' (ValVariable String
_)) Integer
i = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s'' (String -> Expression (Analysis a))
-> String -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ Integer -> String
name Integer
i
      formal Expression (Analysis a)
e Integer
i                                = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) (String -> Expression (Analysis a))
-> String -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ Integer -> String
name Integer
i

  [(Expression (Analysis a), Integer)]
-> ((Expression (Analysis a), Integer)
    -> StateT (BBState (Analysis a)) Identity ())
-> StateT (BBState (Analysis a)) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Expression (Analysis a)]
-> [Integer] -> [(Expression (Analysis a), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) (((Expression (Analysis a), Integer)
  -> StateT (BBState (Analysis a)) Identity ())
 -> StateT (BBState (Analysis a)) Identity ())
-> ((Expression (Analysis a), Integer)
    -> StateT (BBState (Analysis a)) Identity ())
-> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) ->
    Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e Integer
i) Expression (Analysis a)
e)
  (ASTExprNode
_, ASTExprNode
dummyCallN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  let retV :: Expression (Analysis a)
retV = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s (String -> Expression (Analysis a))
-> String -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ Integer -> String
name (Integer
0::Integer)
  let dummyArgs :: [Argument (Analysis a)]
dummyArgs = (Expression (Analysis a) -> Argument (Analysis a))
-> [Expression (Analysis a)] -> [Argument (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Expression (Analysis a)
e -> Analysis a
-> SrcSpan
-> Maybe String
-> ArgumentExpression (Analysis a)
-> Argument (Analysis a)
forall a.
a -> SrcSpan -> Maybe String -> ArgumentExpression a -> Argument a
Argument Analysis a
a0 SrcSpan
s' Maybe String
forall a. Maybe a
Nothing (Expression (Analysis a) -> ArgumentExpression (Analysis a)
forall a. Expression a -> ArgumentExpression a
ArgExpr Expression (Analysis a)
e))
                      (Expression (Analysis a)
retVExpression (Analysis a)
-> [Expression (Analysis a)] -> [Expression (Analysis a)]
forall a. a -> [a] -> [a]
:(Expression (Analysis a) -> Integer -> Expression (Analysis a))
-> [Expression (Analysis a)]
-> [Integer]
-> [Expression (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal [Expression (Analysis a)]
exps [(Integer
1::Integer)..])

  -- create "dummy call" bblock with dummy arguments in the StCall AST-node.
  Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> AList Argument (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Statement a
StCall Analysis a
a' SrcSpan
s' Expression (Analysis a)
fn (Analysis a
-> [Argument (Analysis a)] -> AList Argument (Analysis a)
forall (t :: * -> *) a. Spanned (t a) => a -> [t a] -> AList t a
fromList Analysis a
a0 [Argument (Analysis a)]
dummyArgs))
  (ASTExprNode
_, ASTExprNode
returnedN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- re-assign the variables using the values of the formal parameters, if possible
  -- (because call-by-reference)
  [(Expression (Analysis a), Integer)]
-> ((Expression (Analysis a), Integer)
    -> StateT (BBState (Analysis a)) Identity ())
-> StateT (BBState (Analysis a)) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Expression (Analysis a)]
-> [Integer] -> [(Expression (Analysis a), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) (((Expression (Analysis a), Integer)
  -> StateT (BBState (Analysis a)) Identity ())
 -> StateT (BBState (Analysis a)) Identity ())
-> ((Expression (Analysis a), Integer)
    -> StateT (BBState (Analysis a)) Identity ())
-> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) ->
    -- this is only possible for l-expressions
    (Bool
-> StateT (BBState (Analysis a)) Identity ()
-> StateT (BBState (Analysis a)) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Expression (Analysis a) -> Bool
forall a. Expression a -> Bool
isLExpr Expression (Analysis a)
e) (StateT (BBState (Analysis a)) Identity ()
 -> StateT (BBState (Analysis a)) Identity ())
-> StateT (BBState (Analysis a)) Identity ()
-> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$
      Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' Expression (Analysis a)
e (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e Integer
i)))
  String
tempName <- String -> BBlocker (Analysis a) String
forall a. String -> BBlocker a String
genTemp (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
fn)
  let temp :: Expression (Analysis a)
temp = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s String
tempName

  Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a0 SrcSpan
s' Expression (Analysis a)
temp Expression (Analysis a)
retV)
  (ASTExprNode
_, ASTExprNode
nextN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- connect the bblocks
  [LEdge ()] -> StateT (BBState (Analysis a)) Identity ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
formalN, ()), (ASTExprNode
formalN, ASTExprNode
dummyCallN, ())
              , (ASTExprNode
dummyCallN, ASTExprNode
returnedN, ()), (ASTExprNode
returnedN, ASTExprNode
nextN, ()) ]
  Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
temp
processFunctionCall Expression (Analysis a)
e = Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
forall a. a -> StateT (BBState (Analysis a)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e

--------------------------------------------------
-- Supergraph: all program units in one basic-block graph

data SuperBBGr a = SuperBBGr { forall a. SuperBBGr a -> BBGr a
superBBGrGraph :: BBGr a
                             , forall a. SuperBBGr a -> IntMap ProgramUnitName
superBBGrClusters :: IM.IntMap ProgramUnitName
                             , forall a. SuperBBGr a -> Map ProgramUnitName ASTExprNode
superBBGrEntries :: M.Map PUName SuperNode }

type SuperNode = Node
type SuperEdge = (SuperNode, SuperNode, ELabel)
type PUName = ProgramUnitName
type NLabel a = BB (Analysis a)
type ELabel = ()

genSuperBBGr :: forall a. Data a => BBlockMap (Analysis a) -> SuperBBGr (Analysis a)
genSuperBBGr :: forall a.
Data a =>
BBlockMap (Analysis a) -> SuperBBGr (Analysis a)
genSuperBBGr BBlockMap (Analysis a)
bbm = SuperBBGr { superBBGrGraph :: BBGr (Analysis a)
superBBGrGraph = BBGr (Analysis a)
superGraph''
                             , superBBGrClusters :: IntMap ProgramUnitName
superBBGrClusters = IntMap ProgramUnitName
cmap
                             , superBBGrEntries :: Map ProgramUnitName ASTExprNode
superBBGrEntries = Map ProgramUnitName ASTExprNode
entryMap }
  where
    namedNodes   :: [((PUName, Node), NLabel a)]
    namedNodes :: [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes   = [ ((ProgramUnitName
name, ASTExprNode
n), NLabel a
bs) | (ProgramUnitName
name, BBGr (Analysis a)
gr) <- BBlockMap (Analysis a) -> [(ProgramUnitName, BBGr (Analysis a))]
forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bbm, (ASTExprNode
n, NLabel a
bs) <- Gr (NLabel a) () -> [(ASTExprNode, NLabel a)]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (BBGr (Analysis a) -> Gr (NLabel a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) ]
    namedEdges   :: [((PUName, Node), (PUName, Node), ELabel)]
    namedEdges :: [((ProgramUnitName, ASTExprNode), (ProgramUnitName, ASTExprNode),
  ())]
namedEdges   = [ ((ProgramUnitName
name, ASTExprNode
n), (ProgramUnitName
name, ASTExprNode
m), ()
l) | (ProgramUnitName
name, BBGr (Analysis a)
gr) <- BBlockMap (Analysis a) -> [(ProgramUnitName, BBGr (Analysis a))]
forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bbm, (ASTExprNode
n, ASTExprNode
m, ()
l) <- Gr (NLabel a) () -> [LEdge ()]
forall a b. Gr a b -> [LEdge b]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges (BBGr (Analysis a) -> Gr (NLabel a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) ]
    superNodeMap :: M.Map (PUName, Node) SuperNode
    superNodeMap :: Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap = [((ProgramUnitName, ASTExprNode), ASTExprNode)]
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((ProgramUnitName, ASTExprNode), ASTExprNode)]
 -> Map (ProgramUnitName, ASTExprNode) ASTExprNode)
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
forall a b. (a -> b) -> a -> b
$ [(ProgramUnitName, ASTExprNode)]
-> [ASTExprNode] -> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((((ProgramUnitName, ASTExprNode), NLabel a)
 -> (ProgramUnitName, ASTExprNode))
-> [((ProgramUnitName, ASTExprNode), NLabel a)]
-> [(ProgramUnitName, ASTExprNode)]
forall a b. (a -> b) -> [a] -> [b]
map ((ProgramUnitName, ASTExprNode), NLabel a)
-> (ProgramUnitName, ASTExprNode)
forall a b. (a, b) -> a
fst [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes) [ASTExprNode
1..]
    getSuperNode :: (PUName, Node) -> SuperNode
    getSuperNode :: (ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode = String -> Maybe ASTExprNode -> ASTExprNode
forall a. String -> Maybe a -> a
fromJustMsg String
"UNDEFINED SUPERNODE" (Maybe ASTExprNode -> ASTExprNode)
-> ((ProgramUnitName, ASTExprNode) -> Maybe ASTExprNode)
-> (ProgramUnitName, ASTExprNode)
-> ASTExprNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProgramUnitName, ASTExprNode)
 -> Map (ProgramUnitName, ASTExprNode) ASTExprNode
 -> Maybe ASTExprNode)
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> (ProgramUnitName, ASTExprNode)
-> Maybe ASTExprNode
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ProgramUnitName, ASTExprNode)
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> Maybe ASTExprNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap
    superNodes   :: [(SuperNode, NLabel a)]
    superNodes :: [(ASTExprNode, NLabel a)]
superNodes   = [ ((ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
n, NLabel a
bs) | ((ProgramUnitName, ASTExprNode)
n, NLabel a
bs) <- [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes ]
    superEdges   :: [(SuperNode, SuperNode, ELabel)]
    superEdges :: [LEdge ()]
superEdges   = [ ((ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
n, (ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
m, ()
l) | ((ProgramUnitName, ASTExprNode)
n, (ProgramUnitName, ASTExprNode)
m, ()
l) <- [((ProgramUnitName, ASTExprNode), (ProgramUnitName, ASTExprNode),
  ())]
namedEdges ]
    superGraph   :: Gr (NLabel a) ELabel
    superGraph :: Gr (NLabel a) ()
superGraph   = [(ASTExprNode, NLabel a)] -> [LEdge ()] -> Gr (NLabel a) ()
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(ASTExprNode, NLabel a)]
superNodes [LEdge ()]
superEdges
    entryMap     :: M.Map PUName SuperNode
    entryMap :: Map ProgramUnitName ASTExprNode
entryMap     = [(ProgramUnitName, ASTExprNode)] -> Map ProgramUnitName ASTExprNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (ProgramUnitName
name, ASTExprNode
n') | ((ProgramUnitName
name, ASTExprNode
n), ASTExprNode
n') <- Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap, ASTExprNode
n ASTExprNode -> ASTExprNode -> Bool
forall a. Eq a => a -> a -> Bool
== ASTExprNode
0  ]
    exitMap      :: M.Map PUName SuperNode
    exitMap :: Map ProgramUnitName ASTExprNode
exitMap      = [(ProgramUnitName, ASTExprNode)] -> Map ProgramUnitName ASTExprNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (ProgramUnitName
name, ASTExprNode
n') | ((ProgramUnitName
name, ASTExprNode
n), ASTExprNode
n') <- Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap, ASTExprNode
n ASTExprNode -> ASTExprNode -> Bool
forall a. Eq a => a -> a -> Bool
== -ASTExprNode
1 ]
    -- List of Calls and their corresponding SuperNode where they appear.
    -- Assumption: all StCalls appear by themselves in a bblock.
    stCalls      :: [(SuperNode, String)]
    stCalls :: [(ASTExprNode, String)]
stCalls      = [ ((ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
n, String
sub) | ((ProgramUnitName, ASTExprNode)
n, [BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
e AList Argument (Analysis a)
_)]) <- [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes
                                           , v :: Expression (Analysis a)
v@ExpValue{}                              <- [Expression (Analysis a)
e]
                                           , let sub :: String
sub = Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v
                                           , String -> ProgramUnitName
Named String
sub ProgramUnitName -> Map ProgramUnitName ASTExprNode -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map ProgramUnitName ASTExprNode
entryMap Bool -> Bool -> Bool
&& String -> ProgramUnitName
Named String
sub ProgramUnitName -> Map ProgramUnitName ASTExprNode -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map ProgramUnitName ASTExprNode
exitMap ]
    stCallCtxts  :: [([SuperEdge], SuperNode, String, [SuperEdge])]
    stCallCtxts :: [([LEdge ()], ASTExprNode, String, [LEdge ()])]
stCallCtxts  = [ (Gr (NLabel a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
inn Gr (NLabel a) ()
superGraph ASTExprNode
n, ASTExprNode
n, String
sub, Gr (NLabel a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (NLabel a) ()
superGraph ASTExprNode
n) | (ASTExprNode
n, String
sub) <- [(ASTExprNode, String)]
stCalls ]
    stCallEdges  :: [SuperEdge]
    stCallEdges :: [LEdge ()]
stCallEdges  = [[LEdge ()]] -> [LEdge ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [   [ (ASTExprNode
m, ASTExprNode
nEn, ()
l) | (ASTExprNode
m, ASTExprNode
_, ()
l) <- [LEdge ()]
inEdges  ] [LEdge ()] -> [LEdge ()] -> [LEdge ()]
forall a. [a] -> [a] -> [a]
++
                              [ (ASTExprNode
nEx, ASTExprNode
m, ()
l) | (ASTExprNode
_, ASTExprNode
m, ()
l) <- [LEdge ()]
outEdges ]
                          | ([LEdge ()]
inEdges, ASTExprNode
_, String
sub, [LEdge ()]
outEdges) <- [([LEdge ()], ASTExprNode, String, [LEdge ()])]
stCallCtxts
                          , let nEn :: ASTExprNode
nEn = String -> Maybe ASTExprNode -> ASTExprNode
forall a. String -> Maybe a -> a
fromJustMsg (String
"UNDEFINED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sub) (ProgramUnitName
-> Map ProgramUnitName ASTExprNode -> Maybe ASTExprNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> ProgramUnitName
Named String
sub) Map ProgramUnitName ASTExprNode
entryMap)
                          , let nEx :: ASTExprNode
nEx = String -> Maybe ASTExprNode -> ASTExprNode
forall a. String -> Maybe a -> a
fromJustMsg (String
"UNDEFINED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sub) (ProgramUnitName
-> Map ProgramUnitName ASTExprNode -> Maybe ASTExprNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> ProgramUnitName
Named String
sub) Map ProgramUnitName ASTExprNode
exitMap) ]
    superGraph'  :: Gr (NLabel a) ELabel
    superGraph' :: Gr (NLabel a) ()
superGraph'  = [LEdge ()] -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [LEdge ()]
stCallEdges (Gr (NLabel a) () -> Gr (NLabel a) ())
-> (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) ()
-> Gr (NLabel a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ASTExprNode] -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[ASTExprNode] -> gr a b -> gr a b
delNodes (((ASTExprNode, String) -> ASTExprNode)
-> [(ASTExprNode, String)] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (ASTExprNode, String) -> ASTExprNode
forall a b. (a, b) -> a
fst [(ASTExprNode, String)]
stCalls) (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) () -> Gr (NLabel a) ()
forall a b. (a -> b) -> a -> b
$ Gr (NLabel a) ()
superGraph
    cmap         :: IM.IntMap PUName -- SuperNode ==> PUName
    cmap :: IntMap ProgramUnitName
cmap         = [(ASTExprNode, ProgramUnitName)] -> IntMap ProgramUnitName
forall a. [(ASTExprNode, a)] -> IntMap a
IM.fromList [ (ASTExprNode
n, ProgramUnitName
name) | ((ProgramUnitName
name, ASTExprNode
_), ASTExprNode
n) <- Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap ]
    mainEntry    :: SuperNode -- (possibly more than one, arbitrarily take first)
    ASTExprNode
mainEntry:[ASTExprNode]
_  = [ ASTExprNode
n | (ASTExprNode
n, NLabel a
_) <- Gr (NLabel a) () -> [(ASTExprNode, NLabel a)]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr (NLabel a) ()
superGraph', [ASTExprNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Gr (NLabel a) () -> ASTExprNode -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
pre Gr (NLabel a) ()
superGraph' ASTExprNode
n) ]
    -- Rename the main entry point to 0
    superGraph'' :: BBGr (Analysis a)
    superGraph'' :: BBGr (Analysis a)
superGraph'' = BBGr { bbgrGr :: Gr (NLabel a) ()
bbgrGr = ASTExprNode -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> gr a b
delNode ASTExprNode
mainEntry (Gr (NLabel a) () -> Gr (NLabel a) ())
-> (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) ()
-> Gr (NLabel a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   [LEdge ()] -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [ (ASTExprNode
0, ASTExprNode
m, ()
l) | (ASTExprNode
_, ASTExprNode
m, ()
l) <- Gr (NLabel a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (NLabel a) ()
superGraph' ASTExprNode
mainEntry ] (Gr (NLabel a) () -> Gr (NLabel a) ())
-> (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) ()
-> Gr (NLabel a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   (ASTExprNode, NLabel a) -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
0, []) (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) () -> Gr (NLabel a) ()
forall a b. (a -> b) -> a -> b
$ Gr (NLabel a) ()
superGraph'
                        , bbgrEntries :: [ASTExprNode]
bbgrEntries = (ASTExprNode
0ASTExprNode -> [ASTExprNode] -> [ASTExprNode]
forall a. a -> [a] -> [a]
:) ([ASTExprNode] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASTExprNode -> Bool) -> [ASTExprNode] -> [ASTExprNode]
forall a. (a -> Bool) -> [a] -> [a]
filter (ASTExprNode -> ASTExprNode -> Bool
forall a. Eq a => a -> a -> Bool
/=ASTExprNode
mainEntry) ([ASTExprNode] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProgramUnitName, ASTExprNode) -> ASTExprNode)
-> [(ProgramUnitName, ASTExprNode)] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (ProgramUnitName, ASTExprNode) -> ASTExprNode
forall a b. (a, b) -> b
snd ([(ProgramUnitName, ASTExprNode)] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode
    -> [(ProgramUnitName, ASTExprNode)])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ProgramUnitName ASTExprNode -> [(ProgramUnitName, ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode -> [ASTExprNode]
forall a b. (a -> b) -> a -> b
$ Map ProgramUnitName ASTExprNode
entryMap
                        , bbgrExits :: [ASTExprNode]
bbgrExits   = (-ASTExprNode
1ASTExprNode -> [ASTExprNode] -> [ASTExprNode]
forall a. a -> [a] -> [a]
:) ([ASTExprNode] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProgramUnitName, ASTExprNode) -> ASTExprNode)
-> [(ProgramUnitName, ASTExprNode)] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (ProgramUnitName, ASTExprNode) -> ASTExprNode
forall a b. (a, b) -> b
snd ([(ProgramUnitName, ASTExprNode)] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode
    -> [(ProgramUnitName, ASTExprNode)])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ProgramUnitName ASTExprNode -> [(ProgramUnitName, ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode -> [ASTExprNode]
forall a b. (a -> b) -> a -> b
$ Map ProgramUnitName ASTExprNode
exitMap }

fromJustMsg :: String -> Maybe a -> a
fromJustMsg :: forall a. String -> Maybe a -> a
fromJustMsg String
_ (Just a
x) = a
x
fromJustMsg String
msg Maybe a
_      = String -> a
forall a. HasCallStack => String -> a
error String
msg

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

findLabeledBBlock :: String -> BBGr a -> Maybe Node
findLabeledBBlock :: forall a. String -> BBGr a -> Maybe ASTExprNode
findLabeledBBlock String
llab BBGr a
gr =
  [ASTExprNode] -> Maybe ASTExprNode
forall a. [a] -> Maybe a
listToMaybe [ ASTExprNode
n | (ASTExprNode
n, BB a
bs) <- Gr (BB a) () -> [(ASTExprNode, BB a)]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr), Block a
b <- BB a
bs
                  , ExpValue a
_ SrcSpan
_ (ValInteger String
llab' Maybe (KindParam a)
_) <- Maybe (Expression a) -> [Expression a]
forall a. Maybe a -> [a]
maybeToList (Block a -> Maybe (Expression a)
forall a. Block a -> Maybe (Expression a)
forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block a
b)
                  , String
llab String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
llab' ]

-- | Show a basic block graph in a somewhat decent way.
showBBGr :: (Out a, Show a) => BBGr a -> String
showBBGr :: forall a. (Out a, Show a) => BBGr a -> String
showBBGr (BBGr Gr (BB a) ()
gr [ASTExprNode]
_ [ASTExprNode]
_) = Writer String [()] -> String
forall w a. Writer w a -> w
execWriter (Writer String [()] -> String)
-> ((LNode (BB a) -> WriterT String Identity ())
    -> Writer String [()])
-> (LNode (BB a) -> WriterT String Identity ())
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LNode (BB a)]
-> (LNode (BB a) -> WriterT String Identity ())
-> Writer String [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Gr (BB a) () -> [LNode (BB a)]
forall a b. Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr (BB a) ()
gr) ((LNode (BB a) -> WriterT String Identity ()) -> String)
-> (LNode (BB a) -> WriterT String Identity ()) -> String
forall a b. (a -> b) -> a -> b
$ \ (ASTExprNode
n, BB a
bs) -> do
  let b :: String
b = String
"BBLOCK " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ASTExprNode] -> String
forall a. Show a => a -> String
show ((LEdge () -> ASTExprNode) -> [LEdge ()] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ASTExprNode
_, ASTExprNode
m, ()
_) -> ASTExprNode
m) ([LEdge ()] -> [ASTExprNode]) -> [LEdge ()] -> [ASTExprNode]
forall a b. (a -> b) -> a -> b
$ Gr (BB a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (BB a) ()
gr ASTExprNode
n)
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (String -> ASTExprNode
forall a. [a] -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
b) Char
'-' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") (String -> String) -> (Block a -> String) -> Block a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block a -> String
forall a. Out a => a -> String
pretty) (Block a -> String) -> BB a -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BB a
bs)

-- | Show a basic block graph without the clutter
showAnalysedBBGr :: (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr :: forall a. (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr = BBGr (Maybe ASTExprNode) -> String
forall a. (Out a, Show a) => BBGr a -> String
showBBGr (BBGr (Maybe ASTExprNode) -> String)
-> (BBGr (Analysis a) -> BBGr (Maybe ASTExprNode))
-> BBGr (Analysis a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ())
-> BBGr (Analysis a) -> BBGr (Maybe ASTExprNode)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap ((BB (Analysis a) -> BB (Maybe ASTExprNode))
-> Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ()
forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap BB (Analysis a) -> BB (Maybe ASTExprNode)
forall {a}. [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip)
  where
    strip :: [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip = (Block (Analysis a) -> Block (Maybe ASTExprNode))
-> [Block (Analysis a)] -> BB (Maybe ASTExprNode)
forall a b. (a -> b) -> [a] -> [b]
map ((Analysis a -> Maybe ASTExprNode)
-> Block (Analysis a) -> Block (Maybe ASTExprNode)
forall a b. (a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel)

-- | Show a basic block supergraph
showSuperBBGr :: (Out a, Show a) => SuperBBGr (Analysis a) -> String
showSuperBBGr :: forall a. (Out a, Show a) => SuperBBGr (Analysis a) -> String
showSuperBBGr = BBGr (Analysis a) -> String
forall a. (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr (BBGr (Analysis a) -> String)
-> (SuperBBGr (Analysis a) -> BBGr (Analysis a))
-> SuperBBGr (Analysis a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperBBGr (Analysis a) -> BBGr (Analysis a)
forall a. SuperBBGr a -> BBGr a
superBBGrGraph

-- | Pick out and show the basic block graphs in the program file analysis.
showBBlocks :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String
showBBlocks :: forall a.
(Data a, Out a, Show a) =>
ProgramFile (Analysis a) -> String
showBBlocks ProgramFile (Analysis a)
pf = ProgramUnit (Analysis a) -> String
perPU (ProgramUnit (Analysis a) -> String)
-> [ProgramUnit (Analysis a)] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs ProgramFile (Analysis a)
pf
  where
    perPU :: ProgramUnit (Analysis a) -> String
perPU PUComment{} = String
""
    perPU ProgramUnit (Analysis a)
pu | Analysis { bBlocks :: forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks = Just BBGr (Analysis a)
gr } <- ProgramUnit (Analysis a) -> Analysis a
forall a. ProgramUnit a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu =
      String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BBGr (Maybe ASTExprNode) -> String
forall a. (Out a, Show a) => BBGr a -> String
showBBGr ((Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ())
-> BBGr (Analysis a) -> BBGr (Maybe ASTExprNode)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap ((BB (Analysis a) -> BB (Maybe ASTExprNode))
-> Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ()
forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap BB (Analysis a) -> BB (Maybe ASTExprNode)
forall {a}. [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip) BBGr (Analysis a)
gr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (String -> ASTExprNode
forall a. [a] -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
p) Char
'-'
    perPU ProgramUnit (Analysis a)
pu =
      String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((Block (Analysis a) -> String) -> BB (Analysis a) -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Block (Maybe ASTExprNode) -> String
forall a. Out a => a -> String
pretty (Block (Maybe ASTExprNode) -> String)
-> (Block (Analysis a) -> Block (Maybe ASTExprNode))
-> Block (Analysis a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Analysis a -> Maybe ASTExprNode)
-> Block (Analysis a) -> Block (Maybe ASTExprNode)
forall a b. (a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel) (ProgramUnit (Analysis a) -> BB (Analysis a)
forall a. ProgramUnit a -> [Block a]
programUnitBody ProgramUnit (Analysis a)
pu)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (String -> ASTExprNode
forall a. [a] -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
p) Char
'-'
    strip :: [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip = (Block (Analysis a) -> Block (Maybe ASTExprNode))
-> [Block (Analysis a)] -> BB (Maybe ASTExprNode)
forall a b. (a -> b) -> [a] -> [b]
map ((Analysis a -> Maybe ASTExprNode)
-> Block (Analysis a) -> Block (Maybe ASTExprNode)
forall a b. (a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel)
    getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    getPUs :: forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs = ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

-- | Output a graph in the GraphViz DOT format
bbgrToDOT :: BBGr a -> String
bbgrToDOT :: forall a. BBGr a -> String
bbgrToDOT = IntMap ProgramUnitName -> BBGr a -> String
forall a. IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' IntMap ProgramUnitName
forall a. IntMap a
IM.empty

-- | Output a supergraph in the GraphViz DOT format
superBBGrToDOT :: SuperBBGr a -> String
superBBGrToDOT :: forall a. SuperBBGr a -> String
superBBGrToDOT SuperBBGr a
sgr = IntMap ProgramUnitName -> BBGr a -> String
forall a. IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' (SuperBBGr a -> IntMap ProgramUnitName
forall a. SuperBBGr a -> IntMap ProgramUnitName
superBBGrClusters SuperBBGr a
sgr) (SuperBBGr a -> BBGr a
forall a. SuperBBGr a -> BBGr a
superBBGrGraph SuperBBGr a
sgr)

-- shared code for DOT output
bbgrToDOT' :: IM.IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' :: forall a. IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' IntMap ProgramUnitName
clusters' (BBGr{ bbgrGr :: forall a. BBGr a -> Gr (BB a) ()
bbgrGr = Gr (BB a) ()
gr }) = WriterT String Identity () -> String
forall w a. Writer w a -> w
execWriter (WriterT String Identity () -> String)
-> WriterT String Identity () -> String
forall a b. (a -> b) -> a -> b
$ do
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"strict digraph {\n"
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"node [shape=box,fontname=\"Courier New\"]\n"
  let entryNodes :: [ASTExprNode]
entryNodes = (ASTExprNode -> Bool) -> [ASTExprNode] -> [ASTExprNode]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ASTExprNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ASTExprNode] -> Bool)
-> (ASTExprNode -> [ASTExprNode]) -> ASTExprNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr (BB a) () -> ASTExprNode -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
pre Gr (BB a) ()
gr) (Gr (BB a) () -> [ASTExprNode]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes Gr (BB a) ()
gr)
  let nodes' :: [ASTExprNode]
nodes' = [ASTExprNode] -> Gr (BB a) () -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[ASTExprNode] -> gr a b -> [ASTExprNode]
bfsn [ASTExprNode]
entryNodes Gr (BB a) ()
gr
  [()]
_ <- [ASTExprNode]
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ASTExprNode]
nodes' ((ASTExprNode -> WriterT String Identity ()) -> Writer String [()])
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall a b. (a -> b) -> a -> b
$ \ ASTExprNode
n -> do
    let Just BB a
bs = Gr (BB a) () -> ASTExprNode -> Maybe (BB a)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab Gr (BB a) ()
gr ASTExprNode
n
    let mname :: Maybe ProgramUnitName
mname = ASTExprNode -> IntMap ProgramUnitName -> Maybe ProgramUnitName
forall a. ASTExprNode -> IntMap a -> Maybe a
IM.lookup ASTExprNode
n IntMap ProgramUnitName
clusters'
    case Maybe ProgramUnitName
mname of Just ProgramUnitName
name -> do String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"subgraph \"cluster " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
showPUName ProgramUnitName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" {\n"
                                  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
showPUName ProgramUnitName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\n"
                                  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"fontname=\"Courier New\"\nfontsize=24\n"
                  Maybe ProgramUnitName
_         -> () -> WriterT String Identity ()
forall a. a -> WriterT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\l" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Block a -> String) -> BB a -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block a -> String
forall a. Block a -> String
showBlock BB a
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]\n"
    Bool -> WriterT String Identity () -> WriterT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BB a -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null BB a
bs) (WriterT String Identity () -> WriterT String Identity ())
-> (String -> WriterT String Identity ())
-> String
-> WriterT String Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[shape=circle]\n"
    String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> {"
    [()]
_ <- [ASTExprNode]
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Gr (BB a) () -> ASTExprNode -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
suc Gr (BB a) ()
gr ASTExprNode
n) ((ASTExprNode -> WriterT String Identity ()) -> Writer String [()])
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall a b. (a -> b) -> a -> b
$ \ ASTExprNode
m -> String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String
" bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
m)
    String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
    Bool -> WriterT String Identity () -> WriterT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ProgramUnitName -> Bool
forall a. Maybe a -> Bool
isJust Maybe ProgramUnitName
mname) (WriterT String Identity () -> WriterT String Identity ())
-> WriterT String Identity () -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"

showPUName :: ProgramUnitName -> String
showPUName :: ProgramUnitName -> String
showPUName (Named String
n) = String
n
showPUName ProgramUnitName
NamelessBlockData = String
".blockdata."
showPUName ProgramUnitName
NamelessMain = String
".main."
showPUName ProgramUnitName
NamelessComment = String
".comment."

-- | Some helper functions to output some pseudo-code for readability.
showBlock :: Block a -> String
showBlock :: forall a. Block a -> String
showBlock (BlStatement a
_ SrcSpan
_ Maybe (Expression a)
mlab Statement a
st)
    | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String
str :: String) = String
""
    | Bool
otherwise = Maybe (Expression a) -> String
forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\l"
  where
    str :: String
str =
      case Statement a
st of
        StExpressionAssign a
_ SrcSpan
_ Expression a
e1 Expression a
e2 -> Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e2
        StIfLogical a
_ SrcSpan
_ Expression a
e1 Statement a
_         -> String
"if " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1
        StWrite a
_ SrcSpan
_ AList ControlPair a
_ (Just AList Expression a
aexps)   -> String
"write " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Expression a -> String) -> AList Expression a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Expression a -> String
forall a. Expression a -> String
showExpr AList Expression a
aexps
        StPrint a
_ SrcSpan
_ Expression a
_ (Just AList Expression a
aexps)   -> String
"print " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Expression a -> String) -> AList Expression a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Expression a -> String
forall a. Expression a -> String
showExpr AList Expression a
aexps
        StCall a
_ SrcSpan
_ Expression a
cn AList Argument a
_              -> String
"call " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
cn
        StDeclaration a
_ SrcSpan
_ TypeSpec a
ty Maybe (AList Attribute a)
Nothing AList Declarator a
adecls ->
          TypeSpec a -> String
forall a. TypeSpec a -> String
showType TypeSpec a
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Declarator a -> String) -> AList Declarator a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Declarator a -> String
forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StDeclaration a
_ SrcSpan
_ TypeSpec a
ty (Just AList Attribute a
aattrs) AList Declarator a
adecls ->
          TypeSpec a -> String
forall a. TypeSpec a -> String
showType TypeSpec a
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String -> (Attribute a -> String) -> AList Attribute a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Attribute a -> String
forall a. Attribute a -> String
showAttr AList Attribute a
aattrs String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String -> (Declarator a -> String) -> AList Declarator a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Declarator a -> String
forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StDimension a
_ SrcSpan
_ AList Declarator a
adecls       -> String
"dimension " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Declarator a -> String) -> AList Declarator a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Declarator a -> String
forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StExit{}                     -> String
"exit"
        Statement a
_                            -> String
"<unhandled statement: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Statement () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Statement a -> Statement ()
forall a b. (a -> b) -> Statement a -> Statement b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Statement a
st)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
showBlock (BlIf a
_ SrcSpan
_ Maybe (Expression a)
mlab Maybe String
_ ((Expression a
e1, [Block a]
_) :| [(Expression a, [Block a])]
_) Maybe [Block a]
_ Maybe (Expression a)
_) =
    Maybe (Expression a) -> String
forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"if " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\l"
showBlock (BlDo a
_ SrcSpan
_ Maybe (Expression a)
mlab Maybe String
_ Maybe (Expression a)
_ (Just DoSpecification a
spec) [Block a]
_ Maybe (Expression a)
_) =
    Maybe (Expression a) -> String
forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"do " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e3 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"1" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
me4 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\l"
  where DoSpecification a
_ SrcSpan
_ (StExpressionAssign a
_ SrcSpan
_ Expression a
e1 Expression a
e2) Expression a
e3 Maybe (Expression a)
me4 = DoSpecification a
spec
showBlock (BlDo a
_ SrcSpan
_ Maybe (Expression a)
_ Maybe String
_ Maybe (Expression a)
_ Maybe (DoSpecification a)
Nothing [Block a]
_ Maybe (Expression a)
_) = String
"do"
showBlock (BlComment{})                = String
""
showBlock Block a
b = String
"<unhandled block: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Block () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Block a -> Block ()
forall a b. (a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Block a
b)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

showAttr :: Attribute a -> String
showAttr :: forall a. Attribute a -> String
showAttr (AttrParameter a
_ SrcSpan
_) = String
"parameter"
showAttr (AttrPublic a
_ SrcSpan
_) = String
"public"
showAttr (AttrPrivate a
_ SrcSpan
_) = String
"private"
showAttr (AttrProtected a
_ SrcSpan
_) = String
"protected"
showAttr (AttrAllocatable a
_ SrcSpan
_) = String
"allocatable"
showAttr (AttrAsynchronous a
_ SrcSpan
_) = String
"asynchronous"
showAttr (AttrDimension a
_ SrcSpan
_ AList DimensionDeclarator a
aDimDecs) =
  String
"dimension ( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (DimensionDeclarator a -> String)
-> AList DimensionDeclarator a
-> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " DimensionDeclarator a -> String
forall a. DimensionDeclarator a -> String
showDim AList DimensionDeclarator a
aDimDecs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"
showAttr (AttrExternal a
_ SrcSpan
_) = String
"external"
showAttr (AttrIntent a
_ SrcSpan
_ Intent
In) = String
"intent (in)"
showAttr (AttrIntent a
_ SrcSpan
_ Intent
Out) = String
"intent (out)"
showAttr (AttrIntent a
_ SrcSpan
_ Intent
InOut) = String
"intent (inout)"
showAttr (AttrIntrinsic a
_ SrcSpan
_) = String
"intrinsic"
showAttr (AttrOptional a
_ SrcSpan
_) = String
"optional"
showAttr (AttrPointer a
_ SrcSpan
_) = String
"pointer"
showAttr (AttrSave a
_ SrcSpan
_) = String
"save"
showAttr (AttrTarget a
_ SrcSpan
_) = String
"target"
showAttr (AttrValue a
_ SrcSpan
_) = String
"value"
showAttr (AttrVolatile a
_ SrcSpan
_) = String
"volatile"
showAttr (AttrSuffix a
_ SrcSpan
_ (SfxBind a
_ SrcSpan
_ Maybe (Expression a)
Nothing)) = String
"bind(c)"
showAttr (AttrSuffix a
_ SrcSpan
_ (SfxBind a
_ SrcSpan
_ (Just Expression a
e))) = String
"bind(c,name=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

showLab :: Maybe (Expression a) -> String
showLab :: forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
a =
  case Maybe (Expression a)
a of
    Maybe (Expression a)
Nothing -> ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate ASTExprNode
6 Char
' '
    Just (ExpValue a
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam a)
_)) -> Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (ASTExprNode
5 ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
- String -> ASTExprNode
forall a. [a] -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
l) Char
' '
    Maybe (Expression a)
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"unhandled showLab"

showValue :: Value a -> String
showValue :: forall a. Value a -> String
showValue (ValVariable String
v)       = String
v
showValue (ValIntrinsic String
v)      = String
v
showValue (ValInteger String
v Maybe (KindParam a)
_)      = String
v
showValue (ValReal RealLit
v Maybe (KindParam a)
_)         = RealLit -> String
prettyHsRealLit RealLit
v
showValue v :: Value a
v@ValComplex{}        = Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ FortranVersion -> Value a -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
forall a. HasCallStack => a
undefined Value a
v
showValue (ValString String
s)         = String
"\\\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escapeStr String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\\""
showValue Value a
v                     = String
"<unhandled value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Value () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Value a -> Value ()
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Value a
v)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

escapeStr :: String -> String
escapeStr :: String -> String
escapeStr = ((Char, Bool) -> Char) -> [(Char, Bool)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char, Bool) -> Char
forall a b. (a, b) -> a
fst ([(Char, Bool)] -> String)
-> (String -> [(Char, Bool)]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Char, Bool)] -> Maybe ((Char, Bool), [(Char, Bool)]))
-> [(Char, Bool)] -> [(Char, Bool)]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [(Char, Bool)] -> Maybe ((Char, Bool), [(Char, Bool)])
f ([(Char, Bool)] -> [(Char, Bool)])
-> (String -> [(Char, Bool)]) -> String -> [(Char, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> (Char, Bool)) -> String -> [(Char, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bool
False)
  where
    f :: [(Char, Bool)] -> Maybe ((Char, Bool), [(Char, Bool)])
f []                = Maybe ((Char, Bool), [(Char, Bool)])
forall a. Maybe a
Nothing
    f ((Char
c,Bool
False):[(Char, Bool)]
cs)
      | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\"\\" = ((Char, Bool), [(Char, Bool)])
-> Maybe ((Char, Bool), [(Char, Bool)])
forall a. a -> Maybe a
Just ((Char
'\\', Bool
False), (Char
c, Bool
True)(Char, Bool) -> [(Char, Bool)] -> [(Char, Bool)]
forall a. a -> [a] -> [a]
:[(Char, Bool)]
cs)
    f ((Char
c,Bool
_):[(Char, Bool)]
cs)        = ((Char, Bool), [(Char, Bool)])
-> Maybe ((Char, Bool), [(Char, Bool)])
forall a. a -> Maybe a
Just ((Char
c, Bool
False), [(Char, Bool)]
cs)

showExpr :: Expression a -> String
showExpr :: forall a. Expression a -> String
showExpr (ExpValue a
_ SrcSpan
_ Value a
v)         = Value a -> String
forall a. Value a -> String
showValue Value a
v
showExpr (ExpBinary a
_ SrcSpan
_ BinaryOp
op Expression a
e1 Expression a
e2) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
showOp BinaryOp
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showExpr (ExpUnary a
_ SrcSpan
_ UnaryOp
op Expression a
e)      = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnaryOp -> String
showUOp UnaryOp
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showExpr (ExpSubscript a
_ SrcSpan
_ Expression a
e1 AList Index a
aexps) = Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       String -> (Index a -> String) -> AList Index a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Index a -> String
forall a. Index a -> String
showIndex AList Index a
aexps String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
showExpr Expression a
e                        = String
"<unhandled expr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Expression () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Expression a -> Expression ()
forall a b. (a -> b) -> Expression a -> Expression b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Expression a
e)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

showIndex :: Index a -> String
showIndex :: forall a. Index a -> String
showIndex (IxSingle a
_ SrcSpan
_ Maybe String
_ Expression a
i) = Expression a -> String
forall a. Expression a -> String
showExpr Expression a
i
showIndex (IxRange a
_ SrcSpan
_ Maybe (Expression a)
l Maybe (Expression a)
u Maybe (Expression a)
s) =
  String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ -- Lower
  Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ -- Upper
  String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
u' -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Expression a -> String
forall a. Expression a -> String
showExpr Expression a
u') Maybe (Expression a)
s -- Stride

showUOp :: UnaryOp -> String
showUOp :: UnaryOp -> String
showUOp UnaryOp
Plus = String
"+"
showUOp UnaryOp
Minus = String
"-"
showUOp UnaryOp
Not = String
"!"
-- needs a custom instance
showUOp (UnCustom String
x) = String -> String
forall a. Show a => a -> String
show String
x

showOp :: BinaryOp -> String
showOp :: BinaryOp -> String
showOp BinaryOp
Addition = String
" + "
showOp BinaryOp
Multiplication = String
" * "
showOp BinaryOp
Subtraction = String
" - "
showOp BinaryOp
Division = String
" / "
showOp BinaryOp
Concatenation = String
" // "
showOp BinaryOp
op = String
" ." String -> String -> String
forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
forall a. Show a => a -> String
show BinaryOp
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". "

showType :: TypeSpec a -> String
showType :: forall a. TypeSpec a -> String
showType (TypeSpec a
_ SrcSpan
_ BaseType
t (Just Selector a
_)) = BaseType -> String
showBaseType BaseType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(selector)" -- ++ show s
showType (TypeSpec a
_ SrcSpan
_ BaseType
t Maybe (Selector a)
Nothing)  = BaseType -> String
showBaseType BaseType
t

showBaseType :: BaseType -> String
showBaseType :: BaseType -> String
showBaseType BaseType
TypeInteger         = String
"integer"
showBaseType BaseType
TypeReal            = String
"real"
showBaseType BaseType
TypeDoublePrecision = String
"double"
showBaseType BaseType
TypeComplex         = String
"complex"
showBaseType BaseType
TypeDoubleComplex   = String
"doublecomplex"
showBaseType BaseType
TypeLogical         = String
"logical"
showBaseType BaseType
TypeCharacter       = String
"character"
showBaseType (TypeCustom String
s)      = String
"type(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showBaseType BaseType
TypeByte            = String
"byte"
showBaseType BaseType
ClassStar           = String
"class(*)"
showBaseType (ClassCustom String
s)     = String
"class(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

showDecl :: Declarator a -> String
showDecl :: forall a. Declarator a -> String
showDecl (Declarator a
_ SrcSpan
_ Expression a
e DeclaratorType a
mAdims Maybe (Expression a)
length' Maybe (Expression a)
initial) =
    let partDims :: String
partDims = case DeclaratorType a
mAdims of
                     DeclaratorType a
ScalarDecl -> String
forall a. Monoid a => a
mempty
                     ArrayDecl AList DimensionDeclarator a
dims ->
                       String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (DimensionDeclarator a -> String)
-> AList DimensionDeclarator a
-> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
"," DimensionDeclarator a -> String
forall a. DimensionDeclarator a -> String
showDim AList DimensionDeclarator a
dims String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
     in  Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
partDims
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
"*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
length'
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
initial

showDim :: DimensionDeclarator a -> String
showDim :: forall a. DimensionDeclarator a -> String
showDim (DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
me1 Maybe (Expression a)
me2) = String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
":") (String -> String)
-> (Expression a -> String) -> Expression a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression a -> String
forall a. Expression a -> String
showExpr) Maybe (Expression a)
me1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
me2

aIntercalate :: [a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate :: forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate [a1]
sep t a2 -> [a1]
f = [a1] -> [[a1]] -> [a1]
forall a. [a] -> [[a]] -> [a]
intercalate [a1]
sep ([[a1]] -> [a1]) -> (AList t a2 -> [[a1]]) -> AList t a2 -> [a1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t a2 -> [a1]) -> [t a2] -> [[a1]]
forall a b. (a -> b) -> [a] -> [b]
map t a2 -> [a1]
f ([t a2] -> [[a1]])
-> (AList t a2 -> [t a2]) -> AList t a2 -> [[a1]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList t a2 -> [t a2]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip

noSrcSpan :: SrcSpan
noSrcSpan :: SrcSpan
noSrcSpan = Position -> Position -> SrcSpan
SrcSpan Position
initPosition Position
initPosition

--------------------------------------------------
-- Some helper functions that really should be in fgl.

-- | Fold a function over the graph. Monadically.
ufoldM' :: (Graph gr, Monad m) => (Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' :: forall (gr :: * -> * -> *) (m :: * -> *) a b c.
(Graph gr, Monad m) =>
(Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' Context a b -> c -> m c
f c
u gr a b
g
  | gr a b -> Bool
forall a b. gr a b -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty gr a b
g = c -> m c
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return c
u
  | Bool
otherwise = Context a b -> c -> m c
f Context a b
c (c -> m c) -> m c -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Context a b -> c -> m c) -> c -> gr a b -> m c
forall (gr :: * -> * -> *) (m :: * -> *) a b c.
(Graph gr, Monad m) =>
(Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' Context a b -> c -> m c
f c
u gr a b
g'
  where
    (Context a b
c,gr a b
g') = gr a b -> (Context a b, gr a b)
forall a b. gr a b -> GDecomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> GDecomp gr a b
matchAny gr a b
g

-- | Map a function over the graph. Monadically.
gmapM' :: (DynGraph gr, Monad m) => (Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' :: forall (gr :: * -> * -> *) (m :: * -> *) a b c d.
(DynGraph gr, Monad m) =>
(Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' Context a b -> m (Context c d)
f = (Context a b -> gr c d -> m (gr c d))
-> gr c d -> gr a b -> m (gr c d)
forall (gr :: * -> * -> *) (m :: * -> *) a b c.
(Graph gr, Monad m) =>
(Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' (\ Context a b
c gr c d
g -> Context a b -> m (Context c d)
f Context a b
c m (Context c d) -> (Context c d -> m (gr c d)) -> m (gr c d)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Context c d
c' -> gr c d -> m (gr c d)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context c d
c' Context c d -> gr c d -> gr c d
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr c d
g)) gr c d
forall a b. gr a b
forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty

-- | Map a function over the 'Node' labels in a graph. Monadically.
nmapM' :: (DynGraph gr, Monad m) => (a -> m c) -> gr a b -> m (gr c b)
nmapM' :: forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' a -> m c
f = (Context a b -> m (Context c b)) -> gr a b -> m (gr c b)
forall (gr :: * -> * -> *) (m :: * -> *) a b c d.
(DynGraph gr, Monad m) =>
(Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' (\ (Adj b
p,ASTExprNode
v,a
l,Adj b
s) -> a -> m c
f a
l m c -> (c -> m (Context c b)) -> m (Context c b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ c
l' -> Context c b -> m (Context c b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Adj b
p,ASTExprNode
v,c
l',Adj b
s))

-- Local variables:
-- mode: haskell
-- haskell-program-name: "cabal repl"
-- End: