{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
module ShellCheck.CFG (
CFNode (..),
CFEdge (..),
CFEffect (..),
CFStringPart (..),
CFVariableProp (..),
CFGResult (..),
CFValue (..),
CFGraph,
CFGParameters (..),
IdTagged (..),
Scope (..),
buildGraph
, ShellCheck.CFG.runTests
)
where
import GHC.Generics (Generic)
import ShellCheck.AST
import ShellCheck.ASTLib
import ShellCheck.Data
import ShellCheck.Interface
import ShellCheck.Prelude
import ShellCheck.Regex
import Control.DeepSeq
import Control.Monad
import Control.Monad.Identity
import Data.Array.Unboxed
import Data.Array.ST
import Data.List hiding (map)
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.RWS.Lazy
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Query.Dominators
import Data.Graph.Inductive.PatriciaTree as G
import Debug.Trace
import Test.QuickCheck.All (forAllProperties)
import Test.QuickCheck.Test (quickCheckWithResult, stdArgs, maxSuccess)
type CFGraph = G.Gr CFNode CFEdge
data CFNode =
CFStructuralNode
| CFEntryPoint String
| CFDropPrefixAssignments
| CFApplyEffects [IdTagged CFEffect]
| CFExecuteCommand (Maybe String)
| CFExecuteSubshell String Node Node
| CFSetExitCode Id
| CFImpliedExit
| CFResolvedExit
| CFUnresolvedExit
| CFUnreachable
| CFSetBackgroundPid Id
deriving (CFNode -> CFNode -> Bool
(CFNode -> CFNode -> Bool)
-> (CFNode -> CFNode -> Bool) -> Eq CFNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CFNode -> CFNode -> Bool
== :: CFNode -> CFNode -> Bool
$c/= :: CFNode -> CFNode -> Bool
/= :: CFNode -> CFNode -> Bool
Eq, Eq CFNode
Eq CFNode =>
(CFNode -> CFNode -> Ordering)
-> (CFNode -> CFNode -> Bool)
-> (CFNode -> CFNode -> Bool)
-> (CFNode -> CFNode -> Bool)
-> (CFNode -> CFNode -> Bool)
-> (CFNode -> CFNode -> CFNode)
-> (CFNode -> CFNode -> CFNode)
-> Ord CFNode
CFNode -> CFNode -> Bool
CFNode -> CFNode -> Ordering
CFNode -> CFNode -> CFNode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CFNode -> CFNode -> Ordering
compare :: CFNode -> CFNode -> Ordering
$c< :: CFNode -> CFNode -> Bool
< :: CFNode -> CFNode -> Bool
$c<= :: CFNode -> CFNode -> Bool
<= :: CFNode -> CFNode -> Bool
$c> :: CFNode -> CFNode -> Bool
> :: CFNode -> CFNode -> Bool
$c>= :: CFNode -> CFNode -> Bool
>= :: CFNode -> CFNode -> Bool
$cmax :: CFNode -> CFNode -> CFNode
max :: CFNode -> CFNode -> CFNode
$cmin :: CFNode -> CFNode -> CFNode
min :: CFNode -> CFNode -> CFNode
Ord, Node -> CFNode -> ShowS
[CFNode] -> ShowS
CFNode -> String
(Node -> CFNode -> ShowS)
-> (CFNode -> String) -> ([CFNode] -> ShowS) -> Show CFNode
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFNode -> ShowS
showsPrec :: Node -> CFNode -> ShowS
$cshow :: CFNode -> String
show :: CFNode -> String
$cshowList :: [CFNode] -> ShowS
showList :: [CFNode] -> ShowS
Show, (forall x. CFNode -> Rep CFNode x)
-> (forall x. Rep CFNode x -> CFNode) -> Generic CFNode
forall x. Rep CFNode x -> CFNode
forall x. CFNode -> Rep CFNode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFNode -> Rep CFNode x
from :: forall x. CFNode -> Rep CFNode x
$cto :: forall x. Rep CFNode x -> CFNode
to :: forall x. Rep CFNode x -> CFNode
Generic, CFNode -> ()
(CFNode -> ()) -> NFData CFNode
forall a. (a -> ()) -> NFData a
$crnf :: CFNode -> ()
rnf :: CFNode -> ()
NFData)
data CFEdge =
CFEErrExit
| CFEFlow
| CFEFalseFlow
| CFEExit
deriving (CFEdge -> CFEdge -> Bool
(CFEdge -> CFEdge -> Bool)
-> (CFEdge -> CFEdge -> Bool) -> Eq CFEdge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CFEdge -> CFEdge -> Bool
== :: CFEdge -> CFEdge -> Bool
$c/= :: CFEdge -> CFEdge -> Bool
/= :: CFEdge -> CFEdge -> Bool
Eq, Eq CFEdge
Eq CFEdge =>
(CFEdge -> CFEdge -> Ordering)
-> (CFEdge -> CFEdge -> Bool)
-> (CFEdge -> CFEdge -> Bool)
-> (CFEdge -> CFEdge -> Bool)
-> (CFEdge -> CFEdge -> Bool)
-> (CFEdge -> CFEdge -> CFEdge)
-> (CFEdge -> CFEdge -> CFEdge)
-> Ord CFEdge
CFEdge -> CFEdge -> Bool
CFEdge -> CFEdge -> Ordering
CFEdge -> CFEdge -> CFEdge
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CFEdge -> CFEdge -> Ordering
compare :: CFEdge -> CFEdge -> Ordering
$c< :: CFEdge -> CFEdge -> Bool
< :: CFEdge -> CFEdge -> Bool
$c<= :: CFEdge -> CFEdge -> Bool
<= :: CFEdge -> CFEdge -> Bool
$c> :: CFEdge -> CFEdge -> Bool
> :: CFEdge -> CFEdge -> Bool
$c>= :: CFEdge -> CFEdge -> Bool
>= :: CFEdge -> CFEdge -> Bool
$cmax :: CFEdge -> CFEdge -> CFEdge
max :: CFEdge -> CFEdge -> CFEdge
$cmin :: CFEdge -> CFEdge -> CFEdge
min :: CFEdge -> CFEdge -> CFEdge
Ord, Node -> CFEdge -> ShowS
[CFEdge] -> ShowS
CFEdge -> String
(Node -> CFEdge -> ShowS)
-> (CFEdge -> String) -> ([CFEdge] -> ShowS) -> Show CFEdge
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFEdge -> ShowS
showsPrec :: Node -> CFEdge -> ShowS
$cshow :: CFEdge -> String
show :: CFEdge -> String
$cshowList :: [CFEdge] -> ShowS
showList :: [CFEdge] -> ShowS
Show, (forall x. CFEdge -> Rep CFEdge x)
-> (forall x. Rep CFEdge x -> CFEdge) -> Generic CFEdge
forall x. Rep CFEdge x -> CFEdge
forall x. CFEdge -> Rep CFEdge x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFEdge -> Rep CFEdge x
from :: forall x. CFEdge -> Rep CFEdge x
$cto :: forall x. Rep CFEdge x -> CFEdge
to :: forall x. Rep CFEdge x -> CFEdge
Generic, CFEdge -> ()
(CFEdge -> ()) -> NFData CFEdge
forall a. (a -> ()) -> NFData a
$crnf :: CFEdge -> ()
rnf :: CFEdge -> ()
NFData)
data CFEffect =
CFSetProps (Maybe Scope) String (S.Set CFVariableProp)
| CFUnsetProps (Maybe Scope) String (S.Set CFVariableProp)
| CFReadVariable String
| CFWriteVariable String CFValue
| CFWriteGlobal String CFValue
| CFWriteLocal String CFValue
| CFWritePrefix String CFValue
| CFDefineFunction String Id Node Node
| CFUndefine String
| CFUndefineVariable String
| CFUndefineFunction String
| CFUndefineNameref String
| CFHintArray String
| CFHintDefined String
deriving (CFEffect -> CFEffect -> Bool
(CFEffect -> CFEffect -> Bool)
-> (CFEffect -> CFEffect -> Bool) -> Eq CFEffect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CFEffect -> CFEffect -> Bool
== :: CFEffect -> CFEffect -> Bool
$c/= :: CFEffect -> CFEffect -> Bool
/= :: CFEffect -> CFEffect -> Bool
Eq, Eq CFEffect
Eq CFEffect =>
(CFEffect -> CFEffect -> Ordering)
-> (CFEffect -> CFEffect -> Bool)
-> (CFEffect -> CFEffect -> Bool)
-> (CFEffect -> CFEffect -> Bool)
-> (CFEffect -> CFEffect -> Bool)
-> (CFEffect -> CFEffect -> CFEffect)
-> (CFEffect -> CFEffect -> CFEffect)
-> Ord CFEffect
CFEffect -> CFEffect -> Bool
CFEffect -> CFEffect -> Ordering
CFEffect -> CFEffect -> CFEffect
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CFEffect -> CFEffect -> Ordering
compare :: CFEffect -> CFEffect -> Ordering
$c< :: CFEffect -> CFEffect -> Bool
< :: CFEffect -> CFEffect -> Bool
$c<= :: CFEffect -> CFEffect -> Bool
<= :: CFEffect -> CFEffect -> Bool
$c> :: CFEffect -> CFEffect -> Bool
> :: CFEffect -> CFEffect -> Bool
$c>= :: CFEffect -> CFEffect -> Bool
>= :: CFEffect -> CFEffect -> Bool
$cmax :: CFEffect -> CFEffect -> CFEffect
max :: CFEffect -> CFEffect -> CFEffect
$cmin :: CFEffect -> CFEffect -> CFEffect
min :: CFEffect -> CFEffect -> CFEffect
Ord, Node -> CFEffect -> ShowS
[CFEffect] -> ShowS
CFEffect -> String
(Node -> CFEffect -> ShowS)
-> (CFEffect -> String) -> ([CFEffect] -> ShowS) -> Show CFEffect
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFEffect -> ShowS
showsPrec :: Node -> CFEffect -> ShowS
$cshow :: CFEffect -> String
show :: CFEffect -> String
$cshowList :: [CFEffect] -> ShowS
showList :: [CFEffect] -> ShowS
Show, (forall x. CFEffect -> Rep CFEffect x)
-> (forall x. Rep CFEffect x -> CFEffect) -> Generic CFEffect
forall x. Rep CFEffect x -> CFEffect
forall x. CFEffect -> Rep CFEffect x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFEffect -> Rep CFEffect x
from :: forall x. CFEffect -> Rep CFEffect x
$cto :: forall x. Rep CFEffect x -> CFEffect
to :: forall x. Rep CFEffect x -> CFEffect
Generic, CFEffect -> ()
(CFEffect -> ()) -> NFData CFEffect
forall a. (a -> ()) -> NFData a
$crnf :: CFEffect -> ()
rnf :: CFEffect -> ()
NFData)
data IdTagged a = IdTagged Id a
deriving (IdTagged a -> IdTagged a -> Bool
(IdTagged a -> IdTagged a -> Bool)
-> (IdTagged a -> IdTagged a -> Bool) -> Eq (IdTagged a)
forall a. Eq a => IdTagged a -> IdTagged a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => IdTagged a -> IdTagged a -> Bool
== :: IdTagged a -> IdTagged a -> Bool
$c/= :: forall a. Eq a => IdTagged a -> IdTagged a -> Bool
/= :: IdTagged a -> IdTagged a -> Bool
Eq, Eq (IdTagged a)
Eq (IdTagged a) =>
(IdTagged a -> IdTagged a -> Ordering)
-> (IdTagged a -> IdTagged a -> Bool)
-> (IdTagged a -> IdTagged a -> Bool)
-> (IdTagged a -> IdTagged a -> Bool)
-> (IdTagged a -> IdTagged a -> Bool)
-> (IdTagged a -> IdTagged a -> IdTagged a)
-> (IdTagged a -> IdTagged a -> IdTagged a)
-> Ord (IdTagged a)
IdTagged a -> IdTagged a -> Bool
IdTagged a -> IdTagged a -> Ordering
IdTagged a -> IdTagged a -> IdTagged a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (IdTagged a)
forall a. Ord a => IdTagged a -> IdTagged a -> Bool
forall a. Ord a => IdTagged a -> IdTagged a -> Ordering
forall a. Ord a => IdTagged a -> IdTagged a -> IdTagged a
$ccompare :: forall a. Ord a => IdTagged a -> IdTagged a -> Ordering
compare :: IdTagged a -> IdTagged a -> Ordering
$c< :: forall a. Ord a => IdTagged a -> IdTagged a -> Bool
< :: IdTagged a -> IdTagged a -> Bool
$c<= :: forall a. Ord a => IdTagged a -> IdTagged a -> Bool
<= :: IdTagged a -> IdTagged a -> Bool
$c> :: forall a. Ord a => IdTagged a -> IdTagged a -> Bool
> :: IdTagged a -> IdTagged a -> Bool
$c>= :: forall a. Ord a => IdTagged a -> IdTagged a -> Bool
>= :: IdTagged a -> IdTagged a -> Bool
$cmax :: forall a. Ord a => IdTagged a -> IdTagged a -> IdTagged a
max :: IdTagged a -> IdTagged a -> IdTagged a
$cmin :: forall a. Ord a => IdTagged a -> IdTagged a -> IdTagged a
min :: IdTagged a -> IdTagged a -> IdTagged a
Ord, Node -> IdTagged a -> ShowS
[IdTagged a] -> ShowS
IdTagged a -> String
(Node -> IdTagged a -> ShowS)
-> (IdTagged a -> String)
-> ([IdTagged a] -> ShowS)
-> Show (IdTagged a)
forall a. Show a => Node -> IdTagged a -> ShowS
forall a. Show a => [IdTagged a] -> ShowS
forall a. Show a => IdTagged a -> String
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Node -> IdTagged a -> ShowS
showsPrec :: Node -> IdTagged a -> ShowS
$cshow :: forall a. Show a => IdTagged a -> String
show :: IdTagged a -> String
$cshowList :: forall a. Show a => [IdTagged a] -> ShowS
showList :: [IdTagged a] -> ShowS
Show, (forall x. IdTagged a -> Rep (IdTagged a) x)
-> (forall x. Rep (IdTagged a) x -> IdTagged a)
-> Generic (IdTagged a)
forall x. Rep (IdTagged a) x -> IdTagged a
forall x. IdTagged a -> Rep (IdTagged a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (IdTagged a) x -> IdTagged a
forall a x. IdTagged a -> Rep (IdTagged a) x
$cfrom :: forall a x. IdTagged a -> Rep (IdTagged a) x
from :: forall x. IdTagged a -> Rep (IdTagged a) x
$cto :: forall a x. Rep (IdTagged a) x -> IdTagged a
to :: forall x. Rep (IdTagged a) x -> IdTagged a
Generic, IdTagged a -> ()
(IdTagged a -> ()) -> NFData (IdTagged a)
forall a. NFData a => IdTagged a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => IdTagged a -> ()
rnf :: IdTagged a -> ()
NFData)
data CFValue =
CFValueUninitialized
| CFValueArray
| CFValueString
| CFValueInteger
| CFValueComputed Id [CFStringPart]
deriving (CFValue -> CFValue -> Bool
(CFValue -> CFValue -> Bool)
-> (CFValue -> CFValue -> Bool) -> Eq CFValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CFValue -> CFValue -> Bool
== :: CFValue -> CFValue -> Bool
$c/= :: CFValue -> CFValue -> Bool
/= :: CFValue -> CFValue -> Bool
Eq, Eq CFValue
Eq CFValue =>
(CFValue -> CFValue -> Ordering)
-> (CFValue -> CFValue -> Bool)
-> (CFValue -> CFValue -> Bool)
-> (CFValue -> CFValue -> Bool)
-> (CFValue -> CFValue -> Bool)
-> (CFValue -> CFValue -> CFValue)
-> (CFValue -> CFValue -> CFValue)
-> Ord CFValue
CFValue -> CFValue -> Bool
CFValue -> CFValue -> Ordering
CFValue -> CFValue -> CFValue
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CFValue -> CFValue -> Ordering
compare :: CFValue -> CFValue -> Ordering
$c< :: CFValue -> CFValue -> Bool
< :: CFValue -> CFValue -> Bool
$c<= :: CFValue -> CFValue -> Bool
<= :: CFValue -> CFValue -> Bool
$c> :: CFValue -> CFValue -> Bool
> :: CFValue -> CFValue -> Bool
$c>= :: CFValue -> CFValue -> Bool
>= :: CFValue -> CFValue -> Bool
$cmax :: CFValue -> CFValue -> CFValue
max :: CFValue -> CFValue -> CFValue
$cmin :: CFValue -> CFValue -> CFValue
min :: CFValue -> CFValue -> CFValue
Ord, Node -> CFValue -> ShowS
[CFValue] -> ShowS
CFValue -> String
(Node -> CFValue -> ShowS)
-> (CFValue -> String) -> ([CFValue] -> ShowS) -> Show CFValue
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFValue -> ShowS
showsPrec :: Node -> CFValue -> ShowS
$cshow :: CFValue -> String
show :: CFValue -> String
$cshowList :: [CFValue] -> ShowS
showList :: [CFValue] -> ShowS
Show, (forall x. CFValue -> Rep CFValue x)
-> (forall x. Rep CFValue x -> CFValue) -> Generic CFValue
forall x. Rep CFValue x -> CFValue
forall x. CFValue -> Rep CFValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFValue -> Rep CFValue x
from :: forall x. CFValue -> Rep CFValue x
$cto :: forall x. Rep CFValue x -> CFValue
to :: forall x. Rep CFValue x -> CFValue
Generic, CFValue -> ()
(CFValue -> ()) -> NFData CFValue
forall a. (a -> ()) -> NFData a
$crnf :: CFValue -> ()
rnf :: CFValue -> ()
NFData)
data CFStringPart =
CFStringLiteral String
| CFStringVariable String
| CFStringInteger
| CFStringUnknown
deriving (CFStringPart -> CFStringPart -> Bool
(CFStringPart -> CFStringPart -> Bool)
-> (CFStringPart -> CFStringPart -> Bool) -> Eq CFStringPart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CFStringPart -> CFStringPart -> Bool
== :: CFStringPart -> CFStringPart -> Bool
$c/= :: CFStringPart -> CFStringPart -> Bool
/= :: CFStringPart -> CFStringPart -> Bool
Eq, Eq CFStringPart
Eq CFStringPart =>
(CFStringPart -> CFStringPart -> Ordering)
-> (CFStringPart -> CFStringPart -> Bool)
-> (CFStringPart -> CFStringPart -> Bool)
-> (CFStringPart -> CFStringPart -> Bool)
-> (CFStringPart -> CFStringPart -> Bool)
-> (CFStringPart -> CFStringPart -> CFStringPart)
-> (CFStringPart -> CFStringPart -> CFStringPart)
-> Ord CFStringPart
CFStringPart -> CFStringPart -> Bool
CFStringPart -> CFStringPart -> Ordering
CFStringPart -> CFStringPart -> CFStringPart
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CFStringPart -> CFStringPart -> Ordering
compare :: CFStringPart -> CFStringPart -> Ordering
$c< :: CFStringPart -> CFStringPart -> Bool
< :: CFStringPart -> CFStringPart -> Bool
$c<= :: CFStringPart -> CFStringPart -> Bool
<= :: CFStringPart -> CFStringPart -> Bool
$c> :: CFStringPart -> CFStringPart -> Bool
> :: CFStringPart -> CFStringPart -> Bool
$c>= :: CFStringPart -> CFStringPart -> Bool
>= :: CFStringPart -> CFStringPart -> Bool
$cmax :: CFStringPart -> CFStringPart -> CFStringPart
max :: CFStringPart -> CFStringPart -> CFStringPart
$cmin :: CFStringPart -> CFStringPart -> CFStringPart
min :: CFStringPart -> CFStringPart -> CFStringPart
Ord, Node -> CFStringPart -> ShowS
[CFStringPart] -> ShowS
CFStringPart -> String
(Node -> CFStringPart -> ShowS)
-> (CFStringPart -> String)
-> ([CFStringPart] -> ShowS)
-> Show CFStringPart
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFStringPart -> ShowS
showsPrec :: Node -> CFStringPart -> ShowS
$cshow :: CFStringPart -> String
show :: CFStringPart -> String
$cshowList :: [CFStringPart] -> ShowS
showList :: [CFStringPart] -> ShowS
Show, (forall x. CFStringPart -> Rep CFStringPart x)
-> (forall x. Rep CFStringPart x -> CFStringPart)
-> Generic CFStringPart
forall x. Rep CFStringPart x -> CFStringPart
forall x. CFStringPart -> Rep CFStringPart x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFStringPart -> Rep CFStringPart x
from :: forall x. CFStringPart -> Rep CFStringPart x
$cto :: forall x. Rep CFStringPart x -> CFStringPart
to :: forall x. Rep CFStringPart x -> CFStringPart
Generic, CFStringPart -> ()
(CFStringPart -> ()) -> NFData CFStringPart
forall a. (a -> ()) -> NFData a
$crnf :: CFStringPart -> ()
rnf :: CFStringPart -> ()
NFData)
data CFVariableProp = CFVPExport | CFVPArray | CFVPAssociative | CFVPInteger
deriving (CFVariableProp -> CFVariableProp -> Bool
(CFVariableProp -> CFVariableProp -> Bool)
-> (CFVariableProp -> CFVariableProp -> Bool) -> Eq CFVariableProp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CFVariableProp -> CFVariableProp -> Bool
== :: CFVariableProp -> CFVariableProp -> Bool
$c/= :: CFVariableProp -> CFVariableProp -> Bool
/= :: CFVariableProp -> CFVariableProp -> Bool
Eq, Eq CFVariableProp
Eq CFVariableProp =>
(CFVariableProp -> CFVariableProp -> Ordering)
-> (CFVariableProp -> CFVariableProp -> Bool)
-> (CFVariableProp -> CFVariableProp -> Bool)
-> (CFVariableProp -> CFVariableProp -> Bool)
-> (CFVariableProp -> CFVariableProp -> Bool)
-> (CFVariableProp -> CFVariableProp -> CFVariableProp)
-> (CFVariableProp -> CFVariableProp -> CFVariableProp)
-> Ord CFVariableProp
CFVariableProp -> CFVariableProp -> Bool
CFVariableProp -> CFVariableProp -> Ordering
CFVariableProp -> CFVariableProp -> CFVariableProp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CFVariableProp -> CFVariableProp -> Ordering
compare :: CFVariableProp -> CFVariableProp -> Ordering
$c< :: CFVariableProp -> CFVariableProp -> Bool
< :: CFVariableProp -> CFVariableProp -> Bool
$c<= :: CFVariableProp -> CFVariableProp -> Bool
<= :: CFVariableProp -> CFVariableProp -> Bool
$c> :: CFVariableProp -> CFVariableProp -> Bool
> :: CFVariableProp -> CFVariableProp -> Bool
$c>= :: CFVariableProp -> CFVariableProp -> Bool
>= :: CFVariableProp -> CFVariableProp -> Bool
$cmax :: CFVariableProp -> CFVariableProp -> CFVariableProp
max :: CFVariableProp -> CFVariableProp -> CFVariableProp
$cmin :: CFVariableProp -> CFVariableProp -> CFVariableProp
min :: CFVariableProp -> CFVariableProp -> CFVariableProp
Ord, Node -> CFVariableProp -> ShowS
[CFVariableProp] -> ShowS
CFVariableProp -> String
(Node -> CFVariableProp -> ShowS)
-> (CFVariableProp -> String)
-> ([CFVariableProp] -> ShowS)
-> Show CFVariableProp
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFVariableProp -> ShowS
showsPrec :: Node -> CFVariableProp -> ShowS
$cshow :: CFVariableProp -> String
show :: CFVariableProp -> String
$cshowList :: [CFVariableProp] -> ShowS
showList :: [CFVariableProp] -> ShowS
Show, (forall x. CFVariableProp -> Rep CFVariableProp x)
-> (forall x. Rep CFVariableProp x -> CFVariableProp)
-> Generic CFVariableProp
forall x. Rep CFVariableProp x -> CFVariableProp
forall x. CFVariableProp -> Rep CFVariableProp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFVariableProp -> Rep CFVariableProp x
from :: forall x. CFVariableProp -> Rep CFVariableProp x
$cto :: forall x. Rep CFVariableProp x -> CFVariableProp
to :: forall x. Rep CFVariableProp x -> CFVariableProp
Generic, CFVariableProp -> ()
(CFVariableProp -> ()) -> NFData CFVariableProp
forall a. (a -> ()) -> NFData a
$crnf :: CFVariableProp -> ()
rnf :: CFVariableProp -> ()
NFData)
data CFGParameters = CFGParameters {
CFGParameters -> Bool
cfLastpipe :: Bool,
CFGParameters -> Bool
cfPipefail :: Bool
}
data CFGResult = CFGResult {
CFGResult -> CFGraph
cfGraph :: CFGraph,
CFGResult -> Map Id (Node, Node)
cfIdToRange :: M.Map Id (Node, Node),
CFGResult -> Map Id (Set Node)
cfIdToNodes :: M.Map Id (S.Set Node),
CFGResult -> Array Node [Node]
cfPostDominators :: Array Node [Node]
}
deriving (Node -> CFGResult -> ShowS
[CFGResult] -> ShowS
CFGResult -> String
(Node -> CFGResult -> ShowS)
-> (CFGResult -> String)
-> ([CFGResult] -> ShowS)
-> Show CFGResult
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> CFGResult -> ShowS
showsPrec :: Node -> CFGResult -> ShowS
$cshow :: CFGResult -> String
show :: CFGResult -> String
$cshowList :: [CFGResult] -> ShowS
showList :: [CFGResult] -> ShowS
Show)
buildGraph :: CFGParameters -> Token -> CFGResult
buildGraph :: CFGParameters -> Token -> CFGResult
buildGraph CFGParameters
params Token
root =
let
(Node
nextNode, ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
base) = RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> CFContext
-> Node
-> (Node,
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)]))
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS (Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
buildRoot Token
root) (CFGParameters -> CFContext
newCFContext CFGParameters
params) Node
0
([LNode CFNode]
nodes, [LEdge CFEdge]
edges, [(Id, (Node, Node))]
mapping, [(Id, Node)]
association) =
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
removeUnnecessaryStructuralNodes
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
base
idToRange :: Map Id (Node, Node)
idToRange = [(Id, (Node, Node))] -> Map Id (Node, Node)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Id, (Node, Node))]
mapping
isRealEdge :: (a, b, CFEdge) -> Bool
isRealEdge (a
from, b
to, CFEdge
edge) = case CFEdge
edge of CFEdge
CFEFlow -> Bool
True; CFEdge
CFEExit -> Bool
True; CFEdge
_ -> Bool
False
onlyRealEdges :: [LEdge CFEdge]
onlyRealEdges = (LEdge CFEdge -> Bool) -> [LEdge CFEdge] -> [LEdge CFEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter LEdge CFEdge -> Bool
forall {a} {b}. (a, b, CFEdge) -> Bool
isRealEdge [LEdge CFEdge]
edges
(Node
_, Node
mainExit) = Maybe (Node, Node) -> (Node, Node)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Node, Node) -> (Node, Node))
-> Maybe (Node, Node) -> (Node, Node)
forall a b. (a -> b) -> a -> b
$ Id -> Map Id (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Token -> Id
getId Token
root) Map Id (Node, Node)
idToRange
result :: CFGResult
result = CFGResult {
cfGraph :: CFGraph
cfGraph = [LNode CFNode] -> [LEdge CFEdge] -> CFGraph
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode CFNode]
nodes [LEdge CFEdge]
edges,
cfIdToRange :: Map Id (Node, Node)
cfIdToRange = Map Id (Node, Node)
idToRange,
cfIdToNodes :: Map Id (Set Node)
cfIdToNodes = (Set Node -> Set Node -> Set Node)
-> [(Id, Set Node)] -> Map Id (Set Node)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set Node -> Set Node -> Set Node
forall a. Ord a => Set a -> Set a -> Set a
S.union ([(Id, Set Node)] -> Map Id (Set Node))
-> [(Id, Set Node)] -> Map Id (Set Node)
forall a b. (a -> b) -> a -> b
$ ((Id, Node) -> (Id, Set Node)) -> [(Id, Node)] -> [(Id, Set Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, Node
n) -> (Id
id, Node -> Set Node
forall a. a -> Set a
S.singleton Node
n)) [(Id, Node)]
association,
cfPostDominators :: Array Node [Node]
cfPostDominators = Node -> CFGraph -> Array Node [Node]
findPostDominators Node
mainExit (CFGraph -> Array Node [Node]) -> CFGraph -> Array Node [Node]
forall a b. (a -> b) -> a -> b
$ [LNode CFNode] -> [LEdge CFEdge] -> CFGraph
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode CFNode]
nodes [LEdge CFEdge]
onlyRealEdges
}
in
CFGResult
result
remapGraph :: M.Map Node Node -> CFW -> CFW
remapGraph :: Map Node Node
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
remapGraph Map Node Node
remap ([LNode CFNode]
nodes, [LEdge CFEdge]
edges, [(Id, (Node, Node))]
mapping, [(Id, Node)]
assoc) =
(
(LNode CFNode -> LNode CFNode) -> [LNode CFNode] -> [LNode CFNode]
forall a b. (a -> b) -> [a] -> [b]
map (Map Node Node -> LNode CFNode -> LNode CFNode
remapNode Map Node Node
remap) [LNode CFNode]
nodes,
(LEdge CFEdge -> LEdge CFEdge) -> [LEdge CFEdge] -> [LEdge CFEdge]
forall a b. (a -> b) -> [a] -> [b]
map (Map Node Node -> LEdge CFEdge -> LEdge CFEdge
remapEdge Map Node Node
remap) [LEdge CFEdge]
edges,
((Id, (Node, Node)) -> (Id, (Node, Node)))
-> [(Id, (Node, Node))] -> [(Id, (Node, Node))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, (Node
a,Node
b)) -> (Id
id, (Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
remap Node
a, Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
remap Node
b))) [(Id, (Node, Node))]
mapping,
((Id, Node) -> (Id, Node)) -> [(Id, Node)] -> [(Id, Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, Node
n) -> (Id
id, Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
remap Node
n)) [(Id, Node)]
assoc
)
prop_testRenumbering :: Bool
prop_testRenumbering =
let
s :: CFNode
s = CFNode
CFStructuralNode
before :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
before = (
[(Node
1,CFNode
s), (Node
3,CFNode
s), (Node
4, CFNode
s), (Node
8,CFNode
s)],
[(Node
1,Node
3,CFEdge
CFEFlow), (Node
3,Node
4, CFEdge
CFEFlow), (Node
4,Node
8,CFEdge
CFEFlow)],
[(Node -> Id
Id Node
0, (Node
3,Node
4))],
[(Node -> Id
Id Node
1, Node
3), (Node -> Id
Id Node
2, Node
4)]
)
after :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
after = (
[(Node
0,CFNode
s), (Node
1,CFNode
s), (Node
2,CFNode
s), (Node
3,CFNode
s)],
[(Node
0,Node
1,CFEdge
CFEFlow), (Node
1,Node
2, CFEdge
CFEFlow), (Node
2,Node
3,CFEdge
CFEFlow)],
[(Node -> Id
Id Node
0, (Node
1,Node
2))],
[(Node -> Id
Id Node
1, Node
1), (Node -> Id
Id Node
2, Node
2)]
)
in ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
after ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> Bool
forall a. Eq a => a -> a -> Bool
== ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
renumberGraph ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
before
renumberGraph :: CFW -> CFW
renumberGraph :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
renumberGraph g :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
g@([LNode CFNode]
nodes, [LEdge CFEdge]
edges, [(Id, (Node, Node))]
mapping, [(Id, Node)]
assoc) =
let renumbering :: Map Node Node
renumbering = [(Node, Node)] -> Map Node Node
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (([Node] -> [Node] -> [(Node, Node)])
-> [Node] -> [Node] -> [(Node, Node)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Node
0..] ([Node] -> [(Node, Node)]) -> [Node] -> [(Node, Node)]
forall a b. (a -> b) -> a -> b
$ [Node] -> [Node]
forall a. Ord a => [a] -> [a]
sort ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ (LNode CFNode -> Node) -> [LNode CFNode] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode CFNode -> Node
forall a b. (a, b) -> a
fst [LNode CFNode]
nodes)
in Map Node Node
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
remapGraph Map Node Node
renumbering ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
g
prop_testRenumberTopologically :: Bool
prop_testRenumberTopologically =
let
s :: CFNode
s = CFNode
CFStructuralNode
before :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))], [a])
before = (
[(Node
4,CFNode
s), (Node
2,CFNode
s), (Node
3, CFNode
s)],
[(Node
4,Node
2,CFEdge
CFEFlow), (Node
2,Node
3, CFEdge
CFEFlow)],
[(Node -> Id
Id Node
0, (Node
4,Node
2))],
[]
)
after :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))], [a])
after = (
[(Node
0,CFNode
s), (Node
1,CFNode
s), (Node
2,CFNode
s)],
[(Node
0,Node
1,CFEdge
CFEFlow), (Node
1,Node
2, CFEdge
CFEFlow)],
[(Node -> Id
Id Node
0, (Node
0,Node
1))],
[]
)
in ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
forall {a}.
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))], [a])
after ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> Bool
forall a. Eq a => a -> a -> Bool
== ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
renumberTopologically ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
forall {a}.
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))], [a])
before
renumberTopologically :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
renumberTopologically g :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
g@([LNode CFNode]
nodes, [LEdge CFEdge]
edges, [(Id, (Node, Node))]
mapping, [(Id, Node)]
assoc) =
let renumbering :: Map Node Node
renumbering = [(Node, Node)] -> Map Node Node
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (([Node] -> [Node] -> [(Node, Node)])
-> [Node] -> [Node] -> [(Node, Node)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Node
0..] ([Node] -> [(Node, Node)]) -> [Node] -> [(Node, Node)]
forall a b. (a -> b) -> a -> b
$ CFGraph -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
topsort ([LNode CFNode] -> [LEdge CFEdge] -> CFGraph
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode CFNode]
nodes [LEdge CFEdge]
edges :: CFGraph))
in Map Node Node
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
remapGraph Map Node Node
renumbering ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
g
prop_testRemoveStructural :: Bool
prop_testRemoveStructural =
let
s :: CFNode
s = CFNode
CFStructuralNode
before :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
before = (
[(Node
1,CFNode
s), (Node
2,CFNode
s), (Node
3, CFNode
s), (Node
4,CFNode
s)],
[(Node
1,Node
2,CFEdge
CFEFlow), (Node
2,Node
3, CFEdge
CFEFlow), (Node
3,Node
4,CFEdge
CFEFlow)],
[(Node -> Id
Id Node
0, (Node
2,Node
3))],
[(Node -> Id
Id Node
0, Node
3)]
)
after :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
after = (
[(Node
1,CFNode
s), (Node
2,CFNode
s), (Node
4,CFNode
s)],
[(Node
1,Node
2,CFEdge
CFEFlow), (Node
2,Node
4,CFEdge
CFEFlow)],
[(Node -> Id
Id Node
0, (Node
2,Node
2))],
[(Node -> Id
Id Node
0, Node
2)]
)
in ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
after ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> Bool
forall a. Eq a => a -> a -> Bool
== ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
removeUnnecessaryStructuralNodes ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
before
removeUnnecessaryStructuralNodes :: ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
removeUnnecessaryStructuralNodes ([LNode CFNode]
nodes, [LEdge CFEdge]
edges, [(Id, (Node, Node))]
mapping, [(Id, Node)]
association) =
Map Node Node
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
remapGraph Map Node Node
recursiveRemapping
(
(LNode CFNode -> Bool) -> [LNode CFNode] -> [LNode CFNode]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Node
n, CFNode
_) -> Node
n Node -> Map Node Node -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Map Node Node
recursiveRemapping) [LNode CFNode]
nodes,
(LEdge CFEdge -> Bool) -> [LEdge CFEdge] -> [LEdge CFEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter (LEdge CFEdge -> Set (LEdge CFEdge) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set (LEdge CFEdge)
edgesToCollapse) [LEdge CFEdge]
edges,
[(Id, (Node, Node))]
mapping,
[(Id, Node)]
association
)
where
regularEdges :: [LEdge CFEdge]
regularEdges = (LEdge CFEdge -> Bool) -> [LEdge CFEdge] -> [LEdge CFEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter LEdge CFEdge -> Bool
forall {a} {b}. (a, b, CFEdge) -> Bool
isRegularEdge [LEdge CFEdge]
edges
inDegree :: Map Node Integer
inDegree = [Node] -> Map Node Integer
counter ([Node] -> Map Node Integer) -> [Node] -> Map Node Integer
forall a b. (a -> b) -> a -> b
$ (LEdge CFEdge -> Node) -> [LEdge CFEdge] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
from,Node
to,CFEdge
_) -> Node
from) [LEdge CFEdge]
regularEdges
outDegree :: Map Node Integer
outDegree = [Node] -> Map Node Integer
counter ([Node] -> Map Node Integer) -> [Node] -> Map Node Integer
forall a b. (a -> b) -> a -> b
$ (LEdge CFEdge -> Node) -> [LEdge CFEdge] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
from,Node
to,CFEdge
_) -> Node
to) [LEdge CFEdge]
regularEdges
structuralNodes :: Set Node
structuralNodes = [Node] -> Set Node
forall a. Ord a => [a] -> Set a
S.fromList ([Node] -> Set Node) -> [Node] -> Set Node
forall a b. (a -> b) -> a -> b
$ (LNode CFNode -> Node) -> [LNode CFNode] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode CFNode -> Node
forall a b. (a, b) -> a
fst ([LNode CFNode] -> [Node]) -> [LNode CFNode] -> [Node]
forall a b. (a -> b) -> a -> b
$ (LNode CFNode -> Bool) -> [LNode CFNode] -> [LNode CFNode]
forall a. (a -> Bool) -> [a] -> [a]
filter LNode CFNode -> Bool
forall {a}. (a, CFNode) -> Bool
isStructural [LNode CFNode]
nodes
candidateNodes :: Set Node
candidateNodes = (Node -> Bool) -> Set Node -> Set Node
forall a. (a -> Bool) -> Set a -> Set a
S.filter Node -> Bool
isLinear Set Node
structuralNodes
edgesToCollapse :: Set (LEdge CFEdge)
edgesToCollapse = [LEdge CFEdge] -> Set (LEdge CFEdge)
forall a. Ord a => [a] -> Set a
S.fromList ([LEdge CFEdge] -> Set (LEdge CFEdge))
-> [LEdge CFEdge] -> Set (LEdge CFEdge)
forall a b. (a -> b) -> a -> b
$ (LEdge CFEdge -> Bool) -> [LEdge CFEdge] -> [LEdge CFEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter LEdge CFEdge -> Bool
forall {c}. (Node, Node, c) -> Bool
filterEdges [LEdge CFEdge]
regularEdges
remapping :: M.Map Node Node
remapping :: Map Node Node
remapping = (Map Node Node -> (Node, Node) -> Map Node Node)
-> Map Node Node -> [(Node, Node)] -> Map Node Node
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Node Node
m (Node
new, Node
old) -> Node -> Node -> Map Node Node -> Map Node Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Node
old Node
new Map Node Node
m) Map Node Node
forall k a. Map k a
M.empty ([(Node, Node)] -> Map Node Node)
-> [(Node, Node)] -> Map Node Node
forall a b. (a -> b) -> a -> b
$ (LEdge CFEdge -> (Node, Node)) -> [LEdge CFEdge] -> [(Node, Node)]
forall a b. (a -> b) -> [a] -> [b]
map LEdge CFEdge -> (Node, Node)
forall {b} {c}. Ord b => (b, b, c) -> (b, b)
orderEdge ([LEdge CFEdge] -> [(Node, Node)])
-> [LEdge CFEdge] -> [(Node, Node)]
forall a b. (a -> b) -> a -> b
$ Set (LEdge CFEdge) -> [LEdge CFEdge]
forall a. Set a -> [a]
S.toList Set (LEdge CFEdge)
edgesToCollapse
recursiveRemapping :: Map Node Node
recursiveRemapping = [(Node, Node)] -> Map Node Node
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Node, Node)] -> Map Node Node)
-> [(Node, Node)] -> Map Node Node
forall a b. (a -> b) -> a -> b
$ (Node -> (Node, Node)) -> [Node] -> [(Node, Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\Node
c -> (Node
c, Map Node Node -> Node -> Node
recursiveLookup Map Node Node
remapping Node
c)) ([Node] -> [(Node, Node)]) -> [Node] -> [(Node, Node)]
forall a b. (a -> b) -> a -> b
$ Map Node Node -> [Node]
forall k a. Map k a -> [k]
M.keys Map Node Node
remapping
filterEdges :: (Node, Node, c) -> Bool
filterEdges (Node
a,Node
b,c
_) =
Node
a Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Node
candidateNodes Bool -> Bool -> Bool
&& Node
b Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Node
candidateNodes
orderEdge :: (b, b, c) -> (b, b)
orderEdge (b
a,b
b,c
_) = if b
a b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
b then (b
a,b
b) else (b
b,b
a)
counter :: [Node] -> Map Node Integer
counter = (Map Node Integer -> Node -> Map Node Integer)
-> Map Node Integer -> [Node] -> Map Node Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Node Integer
map Node
key -> (Integer -> Integer -> Integer)
-> Node -> Integer -> Map Node Integer -> Map Node Integer
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Node
key Integer
1 Map Node Integer
map) Map Node Integer
forall k a. Map k a
M.empty
isRegularEdge :: (a, b, CFEdge) -> Bool
isRegularEdge (a
_, b
_, CFEdge
CFEFlow) = Bool
True
isRegularEdge (a, b, CFEdge)
_ = Bool
False
recursiveLookup :: M.Map Node Node -> Node -> Node
recursiveLookup :: Map Node Node -> Node -> Node
recursiveLookup Map Node Node
map Node
node =
case Node -> Map Node Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Node
node Map Node Node
map of
Maybe Node
Nothing -> Node
node
Just Node
x -> Map Node Node -> Node -> Node
recursiveLookup Map Node Node
map Node
x
isStructural :: (a, CFNode) -> Bool
isStructural (a
node, CFNode
label) =
case CFNode
label of
CFNode
CFStructuralNode -> Bool
True
CFNode
_ -> Bool
False
isLinear :: Node -> Bool
isLinear Node
node =
Integer -> Node -> Map Node Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Integer
0 Node
node Map Node Integer
inDegree Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
Bool -> Bool -> Bool
&& Integer -> Node -> Map Node Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Integer
0 Node
node Map Node Integer
outDegree Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
remapNode :: M.Map Node Node -> LNode CFNode -> LNode CFNode
remapNode :: Map Node Node -> LNode CFNode -> LNode CFNode
remapNode Map Node Node
m (Node
node, CFNode
label) =
(Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
m Node
node, CFNode
newLabel)
where
newLabel :: CFNode
newLabel = case CFNode
label of
CFApplyEffects [IdTagged CFEffect]
effects -> [IdTagged CFEffect] -> CFNode
CFApplyEffects ((IdTagged CFEffect -> IdTagged CFEffect)
-> [IdTagged CFEffect] -> [IdTagged CFEffect]
forall a b. (a -> b) -> [a] -> [b]
map (Map Node Node -> IdTagged CFEffect -> IdTagged CFEffect
remapEffect Map Node Node
m) [IdTagged CFEffect]
effects)
CFExecuteSubshell String
s Node
a Node
b -> String -> Node -> Node -> CFNode
CFExecuteSubshell String
s (Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
m Node
a) (Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
m Node
b)
CFNode
_ -> CFNode
label
remapEffect :: Map Node Node -> IdTagged CFEffect -> IdTagged CFEffect
remapEffect Map Node Node
map old :: IdTagged CFEffect
old@(IdTagged Id
id CFEffect
effect) =
case CFEffect
effect of
CFDefineFunction String
name Id
id Node
start Node
end -> Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> Id -> Node -> Node -> CFEffect
CFDefineFunction String
name Id
id (Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
map Node
start) (Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
map Node
end)
CFEffect
_ -> IdTagged CFEffect
old
remapEdge :: M.Map Node Node -> LEdge CFEdge -> LEdge CFEdge
remapEdge :: Map Node Node -> LEdge CFEdge -> LEdge CFEdge
remapEdge Map Node Node
map (Node
from, Node
to, CFEdge
label) = (Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
map Node
from, Map Node Node -> Node -> Node
forall {k}. Ord k => Map k k -> k -> k
remapHelper Map Node Node
map Node
to, CFEdge
label)
remapHelper :: Map k k -> k -> k
remapHelper Map k k
map k
n = k -> k -> Map k k -> k
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault k
n k
n Map k k
map
data Range = Range Node Node
deriving (Range -> Range -> Bool
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
/= :: Range -> Range -> Bool
Eq, Node -> Range -> ShowS
[Range] -> ShowS
Range -> String
(Node -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> Range -> ShowS
showsPrec :: Node -> Range -> ShowS
$cshow :: Range -> String
show :: Range -> String
$cshowList :: [Range] -> ShowS
showList :: [Range] -> ShowS
Show)
data CFContext = CFContext {
CFContext -> Bool
cfIsCondition :: Bool,
CFContext -> Bool
cfIsFunction :: Bool,
CFContext -> [(Node, Node)]
cfLoopStack :: [(Node, Node)],
CFContext -> [Id]
cfTokenStack :: [Id],
CFContext -> Maybe Node
cfExitTarget :: Maybe Node,
CFContext -> Maybe Node
cfReturnTarget :: Maybe Node,
CFContext -> CFGParameters
cfParameters :: CFGParameters
}
newCFContext :: CFGParameters -> CFContext
newCFContext CFGParameters
params = CFContext {
cfIsCondition :: Bool
cfIsCondition = Bool
False,
cfIsFunction :: Bool
cfIsFunction = Bool
False,
cfLoopStack :: [(Node, Node)]
cfLoopStack = [],
cfTokenStack :: [Id]
cfTokenStack = [],
cfExitTarget :: Maybe Node
cfExitTarget = Maybe Node
forall a. Maybe a
Nothing,
cfReturnTarget :: Maybe Node
cfReturnTarget = Maybe Node
forall a. Maybe a
Nothing,
cfParameters :: CFGParameters
cfParameters = CFGParameters
params
}
type CFM a = RWS CFContext CFW Int a
type CFW = ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))], [(Id, Node)])
newNode :: CFNode -> CFM Node
newNode :: CFNode -> CFM Node
newNode CFNode
label = do
n <- CFM Node
forall s (m :: * -> *). MonadState s m => m s
get
stack <- asks cfTokenStack
put (n+1)
tell ([(n, label)], [], [], map (\Id
c -> (Id
c, Node
n)) stack)
return n
newNodeRange :: CFNode -> CFM Range
newNodeRange :: CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange CFNode
label = Node -> Range
nodeToRange (Node -> Range)
-> CFM Node
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CFNode -> CFM Node
newNode CFNode
label
subshell :: Id -> String -> CFM Range -> CFM Range
subshell :: Id
-> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
subshell Id
id String
reason RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
p = do
start <- CFNode -> CFM Node
newNode (CFNode -> CFM Node) -> CFNode -> CFM Node
forall a b. (a -> b) -> a -> b
$ String -> CFNode
CFEntryPoint (String -> CFNode) -> String -> CFNode
forall a b. (a -> b) -> a -> b
$ String
"Subshell " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
id String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
end <- newNode CFStructuralNode
middle <- local (\CFContext
c -> CFContext
c { cfExitTarget = Just end, cfReturnTarget = Just end}) p
linkRanges [nodeToRange start, middle, nodeToRange end]
newNodeRange $ CFExecuteSubshell reason start end
withFunctionScope :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
withFunctionScope RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
p = do
end <- CFNode -> CFM Node
newNode CFNode
CFStructuralNode
body <- local (\CFContext
c -> CFContext
c { cfReturnTarget = Just end, cfIsFunction = True }) p
linkRanges [body, nodeToRange end]
under :: Id -> CFM a -> CFM a
under :: forall a. Id -> CFM a -> CFM a
under Id
id CFM a
f = (CFContext -> CFContext) -> CFM a -> CFM a
forall a.
(CFContext -> CFContext)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CFContext
c -> CFContext
c { cfTokenStack = id:(cfTokenStack c) }) CFM a
f
nodeToRange :: Node -> Range
nodeToRange :: Node -> Range
nodeToRange Node
n = Node -> Node -> Range
Range Node
n Node
n
link :: Node -> Node -> CFEdge -> CFM ()
link :: Node
-> Node
-> CFEdge
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
()
link Node
from Node
to CFEdge
label = do
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([], [(Node
from, Node
to, CFEdge
label)], [], [])
registerNode :: Id -> Range -> CFM ()
registerNode :: Id
-> Range
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
()
registerNode Id
id (Range Node
start Node
end) = ([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([], [], [(Id
id, (Node
start, Node
end))], [])
linkRange :: Range -> Range -> CFM Range
linkRange :: Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRange = CFEdge
-> Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRangeAs CFEdge
CFEFlow
linkRangeAs :: CFEdge -> Range -> Range -> CFM Range
linkRangeAs :: CFEdge
-> Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRangeAs CFEdge
label (Range Node
start Node
mid1) (Range Node
mid2 Node
end) = do
Node
-> Node
-> CFEdge
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
()
link Node
mid1 Node
mid2 CFEdge
label
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a.
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> Node -> Range
Range Node
start Node
end)
spanRange :: Range -> Range -> Range
spanRange :: Range -> Range -> Range
spanRange (Range Node
start Node
mid1) (Range Node
mid2 Node
end) = Node -> Node -> Range
Range Node
start Node
end
linkRanges :: [Range] -> CFM Range
linkRanges :: [Range]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRanges [] = String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a. HasCallStack => String -> a
error String
"Empty range"
linkRanges (Range
first:[Range]
rest) = (Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> Range
-> [Range]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRange Range
first [Range]
rest
sequentially :: [Token] -> CFM Range
sequentially :: [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list = do
first <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
rest <- mapM build list
linkRanges (first:rest)
withContext :: (CFContext -> CFContext) -> CFM a -> CFM a
withContext :: forall a.
(CFContext -> CFContext)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
withContext = (CFContext -> CFContext)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall a.
(CFContext -> CFContext)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
withReturn :: Range -> CFM a -> CFM a
withReturn :: forall a. Range -> CFM a -> CFM a
withReturn Range
_ CFM a
p = CFM a
p
asCondition :: CFM Range -> CFM Range
asCondition :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
asCondition = (CFContext -> CFContext)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a.
(CFContext -> CFContext)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
withContext (\CFContext
c -> CFContext
c { cfIsCondition = True })
newStructuralNode :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode = CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange CFNode
CFStructuralNode
buildRoot :: Token -> CFM Range
buildRoot :: Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
buildRoot Token
t = Id
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a. Id -> CFM a -> CFM a
under (Token -> Id
getId Token
t) (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ do
entry <- CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ String -> CFNode
CFEntryPoint String
"MAIN"
impliedExit <- newNode CFImpliedExit
end <- newNode CFStructuralNode
start <- local (\CFContext
c -> CFContext
c { cfExitTarget = Just end, cfReturnTarget = Just impliedExit}) $ build t
range <- linkRanges [entry, start, nodeToRange impliedExit, nodeToRange end]
registerNode (getId t) range
return range
applySingle :: IdTagged CFEffect -> CFNode
applySingle IdTagged CFEffect
e = [IdTagged CFEffect] -> CFNode
CFApplyEffects [IdTagged CFEffect
e]
build :: Token -> CFM Range
build :: Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t = do
range <- Id
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a. Id -> CFM a -> CFM a
under (Token -> Id
getId Token
t) (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build' Token
t
registerNode (getId t) range
return range
where
build' :: Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build' Token
t = case Token
t of
T_Annotation Id
_ [Annotation]
_ Token
list -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
list
T_Script Id
_ Token
_ [Token]
list -> do
[Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
TA_Assignment Id
id String
op var :: Token
var@(TA_Variable Id
_ String
name [Token]
indices) Token
rhs -> do
value <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
rhs
subscript <- sequentially indices
read <-
if op == "="
then none
else newNodeRange $ applySingle $ IdTagged id $ CFReadVariable name
write <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name $
if null indices
then CFValueInteger
else CFValueArray
linkRanges [value, subscript, read, write]
TA_Assignment Id
id String
op Token
lhs Token
rhs -> do
[Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token
lhs, Token
rhs]
TA_Binary Id
_ String
_ Token
a Token
b -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token
a,Token
b]
TA_Expansion Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
TA_Sequence Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
TA_Parentesis Id
_ Token
t -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
TA_Trinary Id
_ Token
cond Token
a Token
b -> do
condition <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
cond
ifthen <- build a
elsethen <- build b
end <- newStructuralNode
linkRanges [condition, ifthen, end]
linkRanges [condition, elsethen, end]
TA_Variable Id
id String
name [Token]
indices -> do
subscript <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
indices
hint <-
if null indices
then none
else nodeToRange <$> newNode (applySingle $ IdTagged id $ CFHintArray name)
read <- nodeToRange <$> newNode (applySingle $ IdTagged id $ CFReadVariable name)
linkRanges [subscript, hint, read]
TA_Unary Id
id String
op (TA_Variable Id
_ String
name [Token]
indices) | String
"--" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
op Bool -> Bool -> Bool
|| String
"++" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
op -> do
subscript <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
indices
read <- newNodeRange $ applySingle $ IdTagged id $ CFReadVariable name
write <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name $
if null indices
then CFValueInteger
else CFValueArray
linkRanges [subscript, read, write]
TA_Unary Id
_ String
_ Token
arg -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
arg
TC_And Id
_ ConditionType
SingleBracket String
_ Token
lhs Token
rhs -> do
[Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token
lhs, Token
rhs]
TC_And Id
_ ConditionType
DoubleBracket String
_ Token
lhs Token
rhs -> do
left <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
lhs
right <- build rhs
end <- newStructuralNode
linkRanges [left, right, end]
linkRange left end
TC_Binary Id
_ ConditionType
mode String
str Token
lhs Token
rhs -> do
left <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
lhs
right <- build rhs
linkRange left right
TC_Empty {} -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
TC_Group Id
_ ConditionType
_ Token
t -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
TC_Nullary Id
_ ConditionType
_ Token
arg -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
arg
TC_Or Id
_ ConditionType
SingleBracket String
_ Token
lhs Token
rhs -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token
lhs, Token
rhs]
TC_Or Id
_ ConditionType
DoubleBracket String
_ Token
lhs Token
rhs -> do
left <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
lhs
right <- build rhs
end <- newStructuralNode
linkRanges [left, right, end]
linkRange left end
TC_Unary Id
_ ConditionType
_ String
op Token
arg -> do
Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
arg
T_Arithmetic Id
id Token
root -> do
exe <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
root
status <- newNodeRange (CFSetExitCode id)
linkRange exe status
T_AndIf Id
_ Token
lhs Token
rhs -> do
left <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
lhs
right <- build rhs
end <- newStructuralNode
linkRange left right
linkRange right end
linkRange left end
T_Array Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_Assignment {} -> Maybe Scope
-> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
buildAssignment Maybe Scope
forall a. Maybe a
Nothing Token
t
T_Backgrounded Id
id Token
body -> do
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
fork <- subshell id "backgrounding '&'" $ build body
pid <- newNodeRange $ CFSetBackgroundPid id
status <- newNodeRange $ CFSetExitCode id
linkRange start fork
linkRangeAs CFEFalseFlow fork pid
linkRanges [start, pid, status]
T_Backticked Id
id [Token]
body ->
Id
-> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
subshell Id
id String
"`..` expansion" (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
body
T_Banged Id
id Token
cmd -> do
main <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
cmd
status <- newNodeRange (CFSetExitCode id)
linkRange main status
T_BatsTest Id
id String
_ Token
body -> do
status <- CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ IdTagged CFEffect -> CFNode
applySingle (IdTagged CFEffect -> CFNode) -> IdTagged CFEffect -> CFNode
forall a b. (a -> b) -> a -> b
$ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFValue -> CFEffect
CFWriteVariable String
"status" CFValue
CFValueInteger
output <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable "output" CFValueString
main <- build body
linkRanges [status, output, main]
T_BraceExpansion Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_BraceGroup Id
id [Token]
body ->
[Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
body
T_CaseExpression Id
id Token
t [] -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
T_CaseExpression Id
id Token
t list :: [(CaseType, [Token], [Token])]
list@((CaseType, [Token], [Token])
hd:[(CaseType, [Token], [Token])]
tl) -> do
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
token <- build t
branches <- mapM buildBranch (hd NE.:| tl)
end <- newStructuralNode
let neighbors = [(CaseType, Range, Range)]
-> [(CaseType, Range, Range)]
-> [((CaseType, Range, Range), (CaseType, Range, Range))]
forall a b. [a] -> [b] -> [(a, b)]
zip (NonEmpty (CaseType, Range, Range) -> [(CaseType, Range, Range)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (CaseType, Range, Range)
branches) ([(CaseType, Range, Range)]
-> [((CaseType, Range, Range), (CaseType, Range, Range))])
-> [(CaseType, Range, Range)]
-> [((CaseType, Range, Range), (CaseType, Range, Range))]
forall a b. (a -> b) -> a -> b
$ NonEmpty (CaseType, Range, Range) -> [(CaseType, Range, Range)]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty (CaseType, Range, Range)
branches
let (_, firstCond, _) = NE.head branches
let (_, lastCond, lastBody) = NE.last branches
linkRange start token
linkRange token firstCond
mapM_ (uncurry $ linkBranch end) neighbors
linkRange lastBody end
unless (any hasCatchAll list) $
void $ linkRange token end
return $ spanRange start end
where
buildCond :: [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
buildCond [Token]
list = do
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
conds <- mapM build list
end <- newStructuralNode
linkRanges (start:conds)
mapM_ (`linkRange` end) conds
return $ spanRange start end
buildBranch :: (a, [Token], [Token])
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
(a, Range, Range)
buildBranch (a
typ, [Token]
cond, [Token]
body) = do
c <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
buildCond [Token]
cond
b <- sequentially body
linkRange c b
return (typ, c, b)
linkBranch :: Range
-> (CaseType, Range, Range)
-> (a, Range, Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkBranch Range
end (CaseType
typ, Range
cond, Range
body) (a
_, Range
nextCond, Range
nextBody) = do
Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRange Range
cond Range
nextCond
case CaseType
typ of
CaseType
CaseBreak -> Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRange Range
body Range
end
CaseType
CaseFallThrough -> Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRange Range
body Range
nextBody
CaseType
CaseContinue -> Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRange Range
body Range
nextCond
hasCatchAll :: (a, t Token, c) -> Bool
hasCatchAll (a
_,t Token
cond,c
_) = (Token -> Bool) -> t Token -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Token -> Bool
isCatchAll t Token
cond
isCatchAll :: Token -> Bool
isCatchAll Token
c = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
pg <- Token -> Maybe [PseudoGlob]
wordToExactPseudoGlob Token
c
return $ pg `pseudoGlobIsSuperSetof` [PGMany]
T_Condition Id
id ConditionType
_ Token
op -> do
cond <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
op
status <- newNodeRange $ CFSetExitCode id
linkRange cond status
T_CoProc Id
id Maybe String
maybeName Token
t -> do
let name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"COPROC" Maybe String
maybeName
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
parent <- newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name CFValueArray
child <- subshell id "coproc" $ build t
end <- newNodeRange $ CFSetExitCode id
linkRange start parent
linkRange start child
linkRange parent end
linkRangeAs CFEFalseFlow child end
return $ spanRange start end
T_CoProcBody Id
_ Token
t -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
T_DollarArithmetic Id
_ Token
arith -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
arith
T_DollarDoubleQuoted Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_DollarSingleQuoted Id
_ String
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_DollarBracket Id
_ Token
t -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
T_DollarBraced Id
id Bool
_ Token
t -> do
let str :: String
str = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Token -> [String]
oversimplify Token
t
let modifier :: String
modifier = ShowS
getBracedModifier String
str
let reference :: String
reference = ShowS
getBracedReference String
str
let indices :: [String]
indices = String -> [String]
getIndexReferences String
str
let offsets :: [String]
offsets = String -> [String]
getOffsetReferences String
str
vals <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
others <- mapM (\String
x -> Node -> Range
nodeToRange (Node -> Range)
-> CFM Node
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CFNode -> CFM Node
newNode (IdTagged CFEffect -> CFNode
applySingle (IdTagged CFEffect -> CFNode) -> IdTagged CFEffect -> CFNode
forall a b. (a -> b) -> a -> b
$ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFEffect
CFReadVariable String
x)) (indices ++ offsets)
deps <- linkRanges (vals:others)
read <- nodeToRange <$> newNode (applySingle $ IdTagged id $ CFReadVariable reference)
totalRead <- linkRange deps read
if any (`isPrefixOf` modifier) ["=", ":="]
then do
optionalAssign <- newNodeRange (applySingle $ IdTagged id $ CFWriteVariable reference CFValueString)
result <- newStructuralNode
linkRange optionalAssign result
linkRange totalRead result
else return totalRead
T_DoubleQuoted Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_DollarExpansion Id
id [Token]
body ->
Id
-> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
subshell Id
id String
"$(..) expansion" (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
body
T_Extglob Id
_ String
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_FdRedirect Id
id (Char
'{':String
identifier) Token
op -> do
let name :: String
name = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}') String
identifier
expression <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
op
rw <- newNodeRange $
if isClosingFileOp op
then applySingle $ IdTagged id $ CFReadVariable name
else applySingle $ IdTagged id $ CFWriteVariable name CFValueInteger
linkRange expression rw
T_FdRedirect Id
_ String
name Token
t -> do
Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
T_ForArithmetic Id
_ Token
initT Token
condT Token
incT [Token]
bodyT -> do
init <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
initT
cond <- build condT
body <- sequentially bodyT
inc <- build incT
end <- newStructuralNode
linkRanges [init, cond, body, inc]
linkRange cond end
linkRange inc cond
return $ spanRange init end
T_ForIn Id
id String
name [Token]
words [Token]
body -> Id
-> String
-> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forInHelper Id
id String
name [Token]
words [Token]
body
T_Function Id
id FunctionKeyword
_ FunctionParentheses
_ String
name Token
body -> do
range <- (CFContext -> CFContext)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a.
(CFContext -> CFContext)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CFContext
c -> CFContext
c { cfExitTarget = Nothing }) (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ do
entry <- CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ String -> CFNode
CFEntryPoint (String -> CFNode) -> String -> CFNode
forall a b. (a -> b) -> a -> b
$ String
"function " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
f <- withFunctionScope $ build body
linkRange entry f
let (Range entry exit) = range
definition <- newNodeRange (applySingle $ IdTagged id $ CFDefineFunction name id entry exit)
exe <- newNodeRange (CFSetExitCode id)
linkRange definition exe
T_Glob {} -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_HereString Id
_ Token
t -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
T_HereDoc Id
_ Dashed
_ Quoted
_ String
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_IfExpression Id
id [([Token], [Token])]
ifs [Token]
elses -> do
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
branches <- doBranches start ifs elses []
end <- newStructuralNode
mapM_ (`linkRange` end) branches
return $ spanRange start end
where
doBranches :: Range
-> [([Token], [Token])]
-> [Token]
-> [Range]
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
[Range]
doBranches Range
start (([Token]
conds, [Token]
thens):[([Token], [Token])]
rest) [Token]
elses [Range]
result = do
cond <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
asCondition (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
conds
action <- sequentially thens
linkRange start cond
linkRange cond action
doBranches cond rest elses (action:result)
doBranches Range
start [] [Token]
elses [Range]
result = do
rest <-
if [Token] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
elses
then CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (Id -> CFNode
CFSetExitCode Id
id)
else [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
elses
linkRange start rest
return (rest:result)
T_Include Id
_ Token
t -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
T_IndexedElement Id
_ [Token]
indicesT Token
valueT -> do
indices <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
indicesT
value <- build valueT
linkRange indices value
T_IoDuplicate Id
_ Token
op String
_ -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
op
T_IoFile Id
_ Token
op Token
t -> do
exp <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
t
doesntDoMuch <- build op
linkRange exp doesntDoMuch
T_Literal {} -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_NormalWord Id
_ [Token]
list -> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
list
T_OrIf Id
_ Token
lhs Token
rhs -> do
left <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
lhs
right <- build rhs
end <- newStructuralNode
linkRange left right
linkRange right end
linkRange left end
T_Pipeline Id
_ [Token]
_ [Token
cmd] -> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
cmd
T_Pipeline Id
id [Token]
_ [Token]
cmds -> do
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
hasLastpipe <- reader $ cfLastpipe . cfParameters
(leading, last) <- buildPipe hasLastpipe cmds
end <- newNodeRange $ CFSetExitCode id
mapM_ (linkRange start) leading
mapM_ (\Range
c -> CFEdge
-> Range
-> Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRangeAs CFEdge
CFEFalseFlow Range
c Range
end) leading
linkRanges $ [start] ++ last ++ [end]
where
buildPipe :: Bool
-> [Token]
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
([Range], [Range])
buildPipe Bool
True [Token
x] = do
last <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
x
return ([], [last])
buildPipe Bool
lp (Token
first:[Token]
rest) = do
this <- Id
-> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
subshell Id
id String
"pipeline" (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
first
(leading, last) <- buildPipe lp rest
return (this:leading, last)
buildPipe Bool
_ [] = ([Range], [Range])
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
([Range], [Range])
forall a.
a
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
T_ProcSub Id
id String
op [Token]
cmds -> do
start <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
body <- subshell id (op ++ "() process substitution") $ sequentially cmds
end <- newStructuralNode
linkRange start body
linkRangeAs CFEFalseFlow body end
linkRange start end
T_Redirecting Id
_ [Token]
redirs Token
cmd -> do
redir <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
redirs
body <- build cmd
linkRange redir body
T_SelectIn Id
id String
name [Token]
words [Token]
body -> Id
-> String
-> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forInHelper Id
id String
name [Token]
words [Token]
body
T_SimpleCommand Id
id [Token]
vars [] -> do
assignments <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
vars
status <- newNodeRange (CFSetExitCode id)
linkRange assignments status
T_SimpleCommand Id
id [Token]
vars (Token
cmd:[Token]
args) ->
Token
-> [Token]
-> NonEmpty Token
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleCommand Token
t [Token]
vars (Token
cmd Token -> [Token] -> NonEmpty Token
forall a. a -> [a] -> NonEmpty a
NE.:| [Token]
args) (Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ Token -> Maybe String
getUnquotedLiteral Token
cmd
T_SingleQuoted Id
_ String
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_SourceCommand Id
_ Token
originalCommand Token
inlinedSource -> do
cmd <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
originalCommand
end <- newStructuralNode
inline <- withReturn end $ build inlinedSource
linkRange cmd inline
linkRange inline end
return $ spanRange cmd inline
T_Subshell Id
id [Token]
body -> do
main <- Id
-> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
subshell Id
id String
"explicit (..) subshell" (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
body
status <- newNodeRange (CFSetExitCode id)
linkRange main status
T_UntilExpression Id
id [Token]
cond [Token]
body -> Id
-> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
whileHelper Id
id [Token]
cond [Token]
body
T_WhileExpression Id
id [Token]
cond [Token]
body -> Id
-> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
whileHelper Id
id [Token]
cond [Token]
body
T_CLOBBER Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_GREATAND Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_LESSAND Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_LESSGREAT Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_DGREAT Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_Greater Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_Less Id
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
T_ParamSubSpecialChar Id
_ String
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
Token
x -> do
String
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
Any
forall a. HasCallStack => String -> a
error (String
"Unimplemented: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
x)
RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
forInHelper :: Id
-> String
-> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forInHelper Id
id String
name [Token]
words [Token]
body = do
entry <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
expansion <- sequentially words
assignmentChoice <- newStructuralNode
assignments <-
if null words || any willSplit words
then (:[]) <$> (newNodeRange $ applySingle $ IdTagged id $ CFWriteVariable name CFValueString)
else mapM (\Token
t -> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ IdTagged CFEffect -> CFNode
applySingle (IdTagged CFEffect -> CFNode) -> IdTagged CFEffect -> CFNode
forall a b. (a -> b) -> a -> b
$ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFValue -> CFEffect
CFWriteVariable String
name (CFValue -> CFEffect) -> CFValue -> CFEffect
forall a b. (a -> b) -> a -> b
$ Id -> [CFStringPart] -> CFValue
CFValueComputed (Token -> Id
getId Token
t) ([CFStringPart] -> CFValue) -> [CFStringPart] -> CFValue
forall a b. (a -> b) -> a -> b
$ Token -> [CFStringPart]
tokenToParts Token
t) words
body <- sequentially body
exit <- newStructuralNode
linkRanges [entry, expansion, assignmentChoice]
mapM_ (\Range
t -> [Range]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
linkRanges [Range
assignmentChoice, Range
t, Range
body]) assignments
linkRange body exit
linkRange expansion exit
linkRange body assignmentChoice
return $ spanRange entry exit
whileHelper :: Id
-> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
whileHelper Id
id [Token]
cond [Token]
body = do
condRange <- RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
asCondition (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
cond
bodyRange <- sequentially body
end <- newNodeRange (CFSetExitCode id)
linkRange condRange bodyRange
linkRange bodyRange condRange
linkRange condRange end
handleCommand :: Token
-> [Token]
-> NonEmpty Token
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleCommand Token
cmd [Token]
vars NonEmpty Token
args Maybe String
literalCmd = do
case Maybe String
literalCmd of
Just String
"exit" -> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansion [Token]
vars (NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Token
args) (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleExit
Just String
"return" -> [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansion [Token]
vars (NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Token
args) (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleReturn
Just String
"unset" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleUnset NonEmpty Token
args
Just String
"declare" -> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDeclare NonEmpty Token
args
Just String
"local" -> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDeclare NonEmpty Token
args
Just String
"typeset" -> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDeclare NonEmpty Token
args
Just String
"printf" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handlePrintf NonEmpty Token
args
Just String
"wait" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleWait NonEmpty Token
args
Just String
"mapfile" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleMapfile NonEmpty Token
args
Just String
"readarray" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleMapfile NonEmpty Token
args
Just String
"read" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleRead NonEmpty Token
args
Just String
"DEFINE_boolean" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDEFINE NonEmpty Token
args
Just String
"DEFINE_float" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDEFINE NonEmpty Token
args
Just String
"DEFINE_integer" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDEFINE NonEmpty Token
args
Just String
"DEFINE_string" -> [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars NonEmpty Token
args (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDEFINE NonEmpty Token
args
Just String
"builtin" ->
case NonEmpty Token
args of
Token
_ NE.:| [] -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regular
(Token
_ NE.:| Token
newcmd:[Token]
newargs) ->
Token
-> [Token]
-> NonEmpty Token
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleCommand Token
newcmd [Token]
vars (Token
newcmd Token -> [Token] -> NonEmpty Token
forall a. a -> [a] -> NonEmpty a
NE.:| [Token]
newargs) (Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ Token -> Maybe String
getLiteralString Token
newcmd
Just String
"command" ->
case NonEmpty Token
args of
Token
_ NE.:| [] -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regular
(Token
_ NE.:| Token
newcmd:[Token]
newargs) ->
Id
-> [Token]
-> NonEmpty Token
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleOthers (Token -> Id
getId Token
newcmd) [Token]
vars (Token
newcmd Token -> [Token] -> NonEmpty Token
forall a. a -> [a] -> NonEmpty a
NE.:| [Token]
newargs) (Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ Token -> Maybe String
getLiteralString Token
newcmd
Maybe String
_ -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regular
where
regular :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regular = Id
-> [Token]
-> NonEmpty Token
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleOthers (Token -> Id
getId Token
cmd) [Token]
vars NonEmpty Token
args Maybe String
literalCmd
handleExit :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleExit = do
exitNode <- (CFContext -> Maybe Node)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
(Maybe Node)
forall a.
(CFContext -> a)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader CFContext -> Maybe Node
cfExitTarget
case exitNode of
Just Node
target -> do
exit <- CFNode -> CFM Node
newNode CFNode
CFResolvedExit
link exit target CFEExit
unreachable <- newNode CFUnreachable
return $ Range exit unreachable
Maybe Node
Nothing -> do
exit <- CFNode -> CFM Node
newNode CFNode
CFUnresolvedExit
unreachable <- newNode CFUnreachable
return $ Range exit unreachable
handleReturn :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleReturn = do
returnTarget <- (CFContext -> Maybe Node)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
(Maybe Node)
forall a.
(CFContext -> a)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader CFContext -> Maybe Node
cfReturnTarget
case returnTarget of
Maybe Node
Nothing -> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a. HasCallStack => String -> a
error (String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ ShowS
pleaseReport String
"missing return target"
Just Node
target -> do
ret <- CFNode -> CFM Node
newNode CFNode
CFStructuralNode
link ret target CFEFlow
unreachable <- newNode CFUnreachable
return $ Range ret unreachable
handleUnset :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleUnset (Token
cmd NE.:| [Token]
args) = do
case () of
()
_ | String
"n" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flagNames -> (String -> CFEffect)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
unsetWith String -> CFEffect
CFUndefineNameref
()
_ | String
"v" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flagNames -> (String -> CFEffect)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
unsetWith String -> CFEffect
CFUndefineVariable
()
_ | String
"f" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flagNames -> (String -> CFEffect)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
unsetWith String -> CFEffect
CFUndefineFunction
()
_ -> (String -> CFEffect)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
unsetWith String -> CFEffect
CFUndefine
where
pairs :: [(String, Token)]
pairs :: [(String, Token)]
pairs = ((String, (Token, Token)) -> (String, Token))
-> [(String, (Token, Token))] -> [(String, Token)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
str, (Token
flag, Token
val)) -> (String
str, Token
flag)) ([(String, (Token, Token))] -> [(String, Token)])
-> [(String, (Token, Token))] -> [(String, Token)]
forall a b. (a -> b) -> a -> b
$ [(String, (Token, Token))]
-> Maybe [(String, (Token, Token))] -> [(String, (Token, Token))]
forall a. a -> Maybe a -> a
fromMaybe ((Token -> (String, (Token, Token)))
-> [Token] -> [(String, (Token, Token))]
forall a b. (a -> b) -> [a] -> [b]
map (\Token
c -> (String
"", (Token
c,Token
c))) [Token]
args) (Maybe [(String, (Token, Token))] -> [(String, (Token, Token))])
-> Maybe [(String, (Token, Token))] -> [(String, (Token, Token))]
forall a b. (a -> b) -> a -> b
$ String -> [Token] -> Maybe [(String, (Token, Token))]
getGnuOpts String
"vfn" [Token]
args
([(String, Token)]
names, [(String, Token)]
flags) = ((String, Token) -> Bool)
-> [(String, Token)] -> ([(String, Token)], [(String, Token)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((String, Token) -> String) -> (String, Token) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Token) -> String
forall a b. (a, b) -> a
fst) [(String, Token)]
pairs
flagNames :: [String]
flagNames = ((String, Token) -> String) -> [(String, Token)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Token) -> String
forall a b. (a, b) -> a
fst [(String, Token)]
flags
literalNames :: [(Token, String)]
literalNames :: [(Token, String)]
literalNames = ((String, Token) -> Maybe (Token, String))
-> [(String, Token)] -> [(Token, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(String
_, Token
t) -> (,) Token
t (String -> (Token, String))
-> Maybe String -> Maybe (Token, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token -> Maybe String
getLiteralString Token
t) [(String, Token)]
names
unsetWith :: (String -> CFEffect)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
unsetWith String -> CFEffect
c = CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [IdTagged CFEffect] -> CFNode
CFApplyEffects ([IdTagged CFEffect] -> CFNode) -> [IdTagged CFEffect] -> CFNode
forall a b. (a -> b) -> a -> b
$ ((Token, String) -> IdTagged CFEffect)
-> [(Token, String)] -> [IdTagged CFEffect]
forall a b. (a -> b) -> [a] -> [b]
map (\(Token
token, String
name) -> Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged (Token -> Id
getId Token
token) (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFEffect
c String
name) [(Token, String)]
literalNames
variableAssignRegex :: Regex
variableAssignRegex = String -> Regex
mkRegex String
"^([_a-zA-Z][_a-zA-Z0-9]*)="
handleDeclare :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDeclare (Token
cmd NE.:| [Token]
args) = do
isFunc <- (CFContext -> Bool)
-> RWST
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Identity
Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CFContext -> Bool
cfIsFunction
let (evaluated, assignments, added, removed) = mconcat $ map (toEffects isFunc) args
before <- sequentially $ evaluated
assignments <- newNodeRange $ CFApplyEffects assignments
addedProps <- if null added then newStructuralNode else newNodeRange $ CFApplyEffects added
removedProps <- if null removed then newStructuralNode else newNodeRange $ CFApplyEffects removed
result <- newNodeRange $ CFSetExitCode (getId cmd)
linkRanges [before, assignments, addedProps, removedProps, result]
where
opts :: [String]
opts = ((String, (Token, Token)) -> String)
-> [(String, (Token, Token))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Token, Token)) -> String
forall a b. (a, b) -> a
fst ([(String, (Token, Token))] -> [String])
-> [(String, (Token, Token))] -> [String]
forall a b. (a -> b) -> a -> b
$ [Token] -> [(String, (Token, Token))]
getGenericOpts [Token]
args
array :: Bool
array = String
"a" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts Bool -> Bool -> Bool
|| Bool
associative
associative :: Bool
associative = String
"A" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts
integer :: Bool
integer = String
"i" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts
func :: Bool
func = String
"f" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts Bool -> Bool -> Bool
|| String
"F" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts
global :: Bool
global = String
"g" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts
export :: Bool
export = String
"x" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
opts
writer :: Bool -> String -> CFValue -> CFEffect
writer Bool
isFunc =
case () of
()
_ | Bool
global -> String -> CFValue -> CFEffect
CFWriteGlobal
()
_ | Bool
isFunc -> String -> CFValue -> CFEffect
CFWriteLocal
()
_ -> String -> CFValue -> CFEffect
CFWriteVariable
scope :: Bool -> Maybe Scope
scope Bool
isFunc =
case () of
()
_ | Bool
global -> Scope -> Maybe Scope
forall a. a -> Maybe a
Just Scope
GlobalScope
()
_ | Bool
isFunc -> Scope -> Maybe Scope
forall a. a -> Maybe a
Just Scope
LocalScope
()
_ -> Maybe Scope
forall a. Maybe a
Nothing
addedProps :: Set CFVariableProp
addedProps = [CFVariableProp] -> Set CFVariableProp
forall a. Ord a => [a] -> Set a
S.fromList ([CFVariableProp] -> Set CFVariableProp)
-> [CFVariableProp] -> Set CFVariableProp
forall a b. (a -> b) -> a -> b
$ [[CFVariableProp]] -> [CFVariableProp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CFVariableProp]] -> [CFVariableProp])
-> [[CFVariableProp]] -> [CFVariableProp]
forall a b. (a -> b) -> a -> b
$ [
[ CFVariableProp
CFVPArray | Bool
array ],
[ CFVariableProp
CFVPInteger | Bool
integer ],
[ CFVariableProp
CFVPExport | Bool
export ],
[ CFVariableProp
CFVPAssociative | Bool
associative ]
]
removedProps :: Set CFVariableProp
removedProps = [CFVariableProp] -> Set CFVariableProp
forall a. Ord a => [a] -> Set a
S.fromList ([CFVariableProp] -> Set CFVariableProp)
-> [CFVariableProp] -> Set CFVariableProp
forall a b. (a -> b) -> a -> b
$ [[CFVariableProp]] -> [CFVariableProp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CFVariableProp]] -> [CFVariableProp])
-> [[CFVariableProp]] -> [CFVariableProp]
forall a b. (a -> b) -> a -> b
$ [
[ CFVariableProp
CFVPInteger | Char
'i' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unsetOptions ],
[ CFVariableProp
CFVPExport | Char
'e' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unsetOptions ]
]
toEffects :: Bool
-> Token
-> ([Token], [IdTagged CFEffect], [IdTagged CFEffect],
[IdTagged CFEffect])
toEffects Bool
isFunc (T_Assignment Id
id AssignmentMode
mode String
var [Token]
idx Token
t) =
let
pre :: [Token]
pre = [Token]
idx [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
t]
val :: [IdTagged CFEffect]
val = [ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ (Bool -> String -> CFValue -> CFEffect
writer Bool
isFunc) String
var (CFValue -> CFEffect) -> CFValue -> CFEffect
forall a b. (a -> b) -> a -> b
$ Id -> [CFStringPart] -> CFValue
CFValueComputed (Token -> Id
getId Token
t) ([CFStringPart] -> CFValue) -> [CFStringPart] -> CFValue
forall a b. (a -> b) -> a -> b
$ [ String -> CFStringPart
CFStringVariable String
var | AssignmentMode
mode AssignmentMode -> AssignmentMode -> Bool
forall a. Eq a => a -> a -> Bool
== AssignmentMode
Append ] [CFStringPart] -> [CFStringPart] -> [CFStringPart]
forall a. [a] -> [a] -> [a]
++ Token -> [CFStringPart]
tokenToParts Token
t ]
added :: [IdTagged CFEffect]
added = [ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ Maybe Scope -> String -> Set CFVariableProp -> CFEffect
CFSetProps (Bool -> Maybe Scope
scope Bool
isFunc) String
var Set CFVariableProp
addedProps | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set CFVariableProp -> Bool
forall a. Set a -> Bool
S.null Set CFVariableProp
addedProps ]
removed :: [IdTagged CFEffect]
removed = [ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ Maybe Scope -> String -> Set CFVariableProp -> CFEffect
CFUnsetProps (Bool -> Maybe Scope
scope Bool
isFunc) String
var Set CFVariableProp
addedProps | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set CFVariableProp -> Bool
forall a. Set a -> Bool
S.null Set CFVariableProp
removedProps ]
in
([Token]
pre, [IdTagged CFEffect]
val, [IdTagged CFEffect]
added, [IdTagged CFEffect]
removed)
toEffects Bool
isFunc Token
t =
let
id :: Id
id = Token -> Id
getId Token
t
pre :: [Token]
pre = [Token
t]
literal :: String
literal = String -> Token -> String
getLiteralStringDef String
"\0" Token
t
isKnown :: Bool
isKnown = Char
'\0' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
literal
match :: Maybe String
match = ([String] -> String) -> Maybe [String] -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
forall a. HasCallStack => [a] -> a
head (Maybe [String] -> Maybe String) -> Maybe [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Regex
variableAssignRegex Regex -> String -> Maybe [String]
`matchRegex` String
literal
name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
literal Maybe String
match
asLiteral :: IdTagged CFEffect
asLiteral =
Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ (Bool -> String -> CFValue -> CFEffect
writer Bool
isFunc) String
name (CFValue -> CFEffect) -> CFValue -> CFEffect
forall a b. (a -> b) -> a -> b
$
Id -> [CFStringPart] -> CFValue
CFValueComputed (Token -> Id
getId Token
t) [ String -> CFStringPart
CFStringLiteral (String -> CFStringPart) -> String -> CFStringPart
forall a b. (a -> b) -> a -> b
$ Node -> ShowS
forall a. Node -> [a] -> [a]
drop Node
1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
literal ]
asUnknown :: IdTagged CFEffect
asUnknown =
Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ (Bool -> String -> CFValue -> CFEffect
writer Bool
isFunc) String
name (CFValue -> CFEffect) -> CFValue -> CFEffect
forall a b. (a -> b) -> a -> b
$
CFValue
CFValueString
added :: [IdTagged CFEffect]
added = [ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ Maybe Scope -> String -> Set CFVariableProp -> CFEffect
CFSetProps (Bool -> Maybe Scope
scope Bool
isFunc) String
name Set CFVariableProp
addedProps ]
removed :: [IdTagged CFEffect]
removed = [ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ Maybe Scope -> String -> Set CFVariableProp -> CFEffect
CFUnsetProps (Bool -> Maybe Scope
scope Bool
isFunc) String
name Set CFVariableProp
removedProps ]
in
case () of
()
_ | Bool -> Bool
not (String -> Bool
isVariableName String
name) -> ([Token]
pre, [], [], [])
()
_ | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
match Bool -> Bool -> Bool
&& Bool
isKnown -> ([Token]
pre, [IdTagged CFEffect
asLiteral], [IdTagged CFEffect]
added, [IdTagged CFEffect]
removed)
()
_ | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
match -> ([Token]
pre, [IdTagged CFEffect
asUnknown], [IdTagged CFEffect]
added, [IdTagged CFEffect]
removed)
()
_ -> ([Token]
pre, [], [IdTagged CFEffect]
added, [IdTagged CFEffect]
removed)
unsetOptions :: String
unsetOptions :: String
unsetOptions =
let
strings :: [String]
strings = (Token -> Maybe String) -> [Token] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Token -> Maybe String
getLiteralString [Token]
args
plusses :: [String]
plusses = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"+" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
strings
in
ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Node -> ShowS
forall a. Node -> [a] -> [a]
drop Node
1) [String]
plusses
handlePrintf :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handlePrintf (Token
cmd NE.:| [Token]
args) =
CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [IdTagged CFEffect] -> CFNode
CFApplyEffects ([IdTagged CFEffect] -> CFNode) -> [IdTagged CFEffect] -> CFNode
forall a b. (a -> b) -> a -> b
$ Maybe (IdTagged CFEffect) -> [IdTagged CFEffect]
forall a. Maybe a -> [a]
maybeToList Maybe (IdTagged CFEffect)
findVar
where
findVar :: Maybe (IdTagged CFEffect)
findVar = do
flags <- String -> [Token] -> Maybe [(String, (Token, Token))]
getBsdOpts String
"v:" [Token]
args
(flag, arg) <- lookup "v" flags
name <- getLiteralString arg
return $ IdTagged (getId arg) $ CFWriteVariable name CFValueString
handleWait :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleWait (Token
cmd NE.:| [Token]
args) =
CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [IdTagged CFEffect] -> CFNode
CFApplyEffects ([IdTagged CFEffect] -> CFNode) -> [IdTagged CFEffect] -> CFNode
forall a b. (a -> b) -> a -> b
$ Maybe (IdTagged CFEffect) -> [IdTagged CFEffect]
forall a. Maybe a -> [a]
maybeToList Maybe (IdTagged CFEffect)
findVar
where
findVar :: Maybe (IdTagged CFEffect)
findVar = do
let flags :: [(String, (Token, Token))]
flags = [Token] -> [(String, (Token, Token))]
getGenericOpts [Token]
args
(flag, arg) <- String -> [(String, (Token, Token))] -> Maybe (Token, Token)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"p" [(String, (Token, Token))]
flags
name <- getLiteralString arg
return $ IdTagged (getId arg) $ CFWriteVariable name CFValueInteger
handleMapfile :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleMapfile (Token
cmd NE.:| [Token]
args) =
CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [IdTagged CFEffect] -> CFNode
CFApplyEffects [IdTagged CFEffect
findVar]
where
findVar :: IdTagged CFEffect
findVar =
let (Id
id, String
name) = (Id, String) -> Maybe (Id, String) -> (Id, String)
forall a. a -> Maybe a -> a
fromMaybe (Token -> Id
getId Token
cmd, String
"MAPFILE") (Maybe (Id, String) -> (Id, String))
-> Maybe (Id, String) -> (Id, String)
forall a b. (a -> b) -> a -> b
$ Maybe (Id, String)
getFromArg Maybe (Id, String) -> Maybe (Id, String) -> Maybe (Id, String)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (Id, String)
getFromFallback
in Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFValue -> CFEffect
CFWriteVariable String
name CFValue
CFValueArray
getFromArg :: Maybe (Id, String)
getFromArg = do
flags <- String -> [Token] -> Maybe [(String, (Token, Token))]
getGnuOpts String
flagsForMapfile [Token]
args
(_, arg) <- lookup "" flags
name <- getLiteralString arg
return (getId arg, name)
getFromFallback :: Maybe (Id, String)
getFromFallback =
[(Id, String)] -> Maybe (Id, String)
forall a. [a] -> Maybe a
listToMaybe ([(Id, String)] -> Maybe (Id, String))
-> [(Id, String)] -> Maybe (Id, String)
forall a b. (a -> b) -> a -> b
$ (Token -> Maybe (Id, String)) -> [Token] -> [(Id, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Token -> Maybe (Id, String)
getIfVar ([Token] -> [(Id, String)]) -> [Token] -> [(Id, String)]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
args
getIfVar :: Token -> Maybe (Id, String)
getIfVar Token
c = do
name <- Token -> Maybe String
getLiteralString Token
c
guard $ isVariableName name
return (getId c, name)
handleRead :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleRead (Token
cmd NE.:| [Token]
args) = CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [IdTagged CFEffect] -> CFNode
CFApplyEffects [IdTagged CFEffect]
main
where
main :: [IdTagged CFEffect]
main = [IdTagged CFEffect]
-> Maybe [IdTagged CFEffect] -> [IdTagged CFEffect]
forall a. a -> Maybe a -> a
fromMaybe [IdTagged CFEffect]
fallback (Maybe [IdTagged CFEffect] -> [IdTagged CFEffect])
-> Maybe [IdTagged CFEffect] -> [IdTagged CFEffect]
forall a b. (a -> b) -> a -> b
$ do
flags <- String -> [Token] -> Maybe [(String, (Token, Token))]
getGnuOpts String
flagsForRead [Token]
args
return $ fromMaybe (withFields flags) $ withArray flags
withArray :: [(String, (Token, Token))] -> Maybe [IdTagged CFEffect]
withArray :: [(String, (Token, Token))] -> Maybe [IdTagged CFEffect]
withArray [(String, (Token, Token))]
flags = do
(_, token) <- String -> [(String, (Token, Token))] -> Maybe (Token, Token)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"a" [(String, (Token, Token))]
flags
return $ fromMaybe [] $ do
name <- getLiteralString token
return [ IdTagged (getId token) $ CFWriteVariable name CFValueArray ]
withFields :: [(String, (Token, Token))] -> [IdTagged CFEffect]
withFields [(String, (Token, Token))]
flags = ((String, (Token, Token)) -> Maybe (IdTagged CFEffect))
-> [(String, (Token, Token))] -> [IdTagged CFEffect]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String, (Token, Token)) -> Maybe (IdTagged CFEffect)
getAssignment [(String, (Token, Token))]
flags
getAssignment :: (String, (Token, Token)) -> Maybe (IdTagged CFEffect)
getAssignment :: (String, (Token, Token)) -> Maybe (IdTagged CFEffect)
getAssignment (String, (Token, Token))
f = do
("", (t, _)) <- (String, (Token, Token)) -> Maybe (String, (Token, Token))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String, (Token, Token))
f
name <- getLiteralString t
return $ IdTagged (getId t) $ CFWriteVariable name CFValueString
fallback :: [IdTagged CFEffect]
fallback =
let
names :: [(Id, String)]
names = [(Id, String)] -> [(Id, String)]
forall a. [a] -> [a]
reverse ([(Id, String)] -> [(Id, String)])
-> [(Id, String)] -> [(Id, String)]
forall a b. (a -> b) -> a -> b
$ (Maybe (Id, String) -> (Id, String))
-> [Maybe (Id, String)] -> [(Id, String)]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Id, String) -> (Id, String)
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe (Id, String)] -> [(Id, String)])
-> [Maybe (Id, String)] -> [(Id, String)]
forall a b. (a -> b) -> a -> b
$ (Maybe (Id, String) -> Bool)
-> [Maybe (Id, String)] -> [Maybe (Id, String)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Maybe (Id, String) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (Id, String)] -> [Maybe (Id, String)])
-> [Maybe (Id, String)] -> [Maybe (Id, String)]
forall a b. (a -> b) -> a -> b
$ (Token -> Maybe (Id, String)) -> [Token] -> [Maybe (Id, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Token
c -> (Id, Maybe String) -> Maybe (Id, String)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => (Id, m a) -> m (Id, a)
sequence (Token -> Id
getId Token
c, Token -> Maybe String
getLiteralString Token
c)) ([Token] -> [Maybe (Id, String)])
-> [Token] -> [Maybe (Id, String)]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
args
namesOrDefault :: [(Id, String)]
namesOrDefault = if [(Id, String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, String)]
names then [(Token -> Id
getId Token
cmd, String
"REPLY")] else [(Id, String)]
names
hasDashA :: Bool
hasDashA = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"a") ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ ((String, (Token, Token)) -> String)
-> [(String, (Token, Token))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Token, Token)) -> String
forall a b. (a, b) -> a
fst ([(String, (Token, Token))] -> [String])
-> [(String, (Token, Token))] -> [String]
forall a b. (a -> b) -> a -> b
$ [Token] -> [(String, (Token, Token))]
getGenericOpts [Token]
args
value :: CFValue
value = if Bool
hasDashA then CFValue
CFValueArray else CFValue
CFValueString
in
((Id, String) -> IdTagged CFEffect)
-> [(Id, String)] -> [IdTagged CFEffect]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, String
name) -> Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFValue -> CFEffect
CFWriteVariable String
name CFValue
value) [(Id, String)]
namesOrDefault
handleDEFINE :: NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleDEFINE (Token
cmd NE.:| [Token]
args) =
CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ [IdTagged CFEffect] -> CFNode
CFApplyEffects ([IdTagged CFEffect] -> CFNode) -> [IdTagged CFEffect] -> CFNode
forall a b. (a -> b) -> a -> b
$ Maybe (IdTagged CFEffect) -> [IdTagged CFEffect]
forall a. Maybe a -> [a]
maybeToList Maybe (IdTagged CFEffect)
findVar
where
findVar :: Maybe (IdTagged CFEffect)
findVar = do
name <- [Token] -> Maybe Token
forall a. [a] -> Maybe a
listToMaybe ([Token] -> Maybe Token) -> [Token] -> Maybe Token
forall a b. (a -> b) -> a -> b
$ Node -> [Token] -> [Token]
forall a. Node -> [a] -> [a]
drop Node
1 [Token]
args
str <- getLiteralString name
guard $ isVariableName str
return $ IdTagged (getId name) $ CFWriteVariable str CFValueString
handleOthers :: Id
-> [Token]
-> NonEmpty Token
-> Maybe String
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
handleOthers Id
id [Token]
vars NonEmpty Token
args Maybe String
cmd =
[Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansion [Token]
vars (NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Token
args) (RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ do
exe <- CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range)
-> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
forall a b. (a -> b) -> a -> b
$ Maybe String -> CFNode
CFExecuteCommand Maybe String
cmd
status <- newNodeRange $ CFSetExitCode id
linkRange exe status
regularExpansion :: [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansion [Token]
vars [Token]
args RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
p = do
args <- [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
sequentially [Token]
args
assignments <- mapM (buildAssignment (Just PrefixScope)) vars
exe <- p
dropAssignments <-
if null vars
then
return []
else do
drop <- newNodeRange CFDropPrefixAssignments
return [drop]
linkRanges $ [args] ++ assignments ++ [exe] ++ dropAssignments
regularExpansionWithStatus :: [Token]
-> NonEmpty Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansionWithStatus [Token]
vars args :: NonEmpty Token
args@(Token
cmd NE.:| [Token]
_) RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
p = do
initial <- [Token]
-> [Token]
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
regularExpansion [Token]
vars (NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Token
args) RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
p
status <- newNodeRange $ CFSetExitCode (getId cmd)
linkRange initial status
none :: RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none = RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newStructuralNode
data Scope = GlobalScope | LocalScope | PrefixScope
deriving (Scope -> Scope -> Bool
(Scope -> Scope -> Bool) -> (Scope -> Scope -> Bool) -> Eq Scope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
/= :: Scope -> Scope -> Bool
Eq, Eq Scope
Eq Scope =>
(Scope -> Scope -> Ordering)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Scope)
-> (Scope -> Scope -> Scope)
-> Ord Scope
Scope -> Scope -> Bool
Scope -> Scope -> Ordering
Scope -> Scope -> Scope
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Scope -> Scope -> Ordering
compare :: Scope -> Scope -> Ordering
$c< :: Scope -> Scope -> Bool
< :: Scope -> Scope -> Bool
$c<= :: Scope -> Scope -> Bool
<= :: Scope -> Scope -> Bool
$c> :: Scope -> Scope -> Bool
> :: Scope -> Scope -> Bool
$c>= :: Scope -> Scope -> Bool
>= :: Scope -> Scope -> Bool
$cmax :: Scope -> Scope -> Scope
max :: Scope -> Scope -> Scope
$cmin :: Scope -> Scope -> Scope
min :: Scope -> Scope -> Scope
Ord, Node -> Scope -> ShowS
[Scope] -> ShowS
Scope -> String
(Node -> Scope -> ShowS)
-> (Scope -> String) -> ([Scope] -> ShowS) -> Show Scope
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Node -> Scope -> ShowS
showsPrec :: Node -> Scope -> ShowS
$cshow :: Scope -> String
show :: Scope -> String
$cshowList :: [Scope] -> ShowS
showList :: [Scope] -> ShowS
Show, (forall x. Scope -> Rep Scope x)
-> (forall x. Rep Scope x -> Scope) -> Generic Scope
forall x. Rep Scope x -> Scope
forall x. Scope -> Rep Scope x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Scope -> Rep Scope x
from :: forall x. Scope -> Rep Scope x
$cto :: forall x. Rep Scope x -> Scope
to :: forall x. Rep Scope x -> Scope
Generic, Scope -> ()
(Scope -> ()) -> NFData Scope
forall a. (a -> ()) -> NFData a
$crnf :: Scope -> ()
rnf :: Scope -> ()
NFData)
buildAssignment :: Maybe Scope
-> Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
buildAssignment Maybe Scope
scope Token
t = do
op <- case Token
t of
T_Assignment Id
id AssignmentMode
mode String
var [Token]
indices Token
value -> do
expand <- Token
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
build Token
value
index <- sequentially indices
read <- case mode of
AssignmentMode
Append -> CFNode
-> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
newNodeRange (IdTagged CFEffect -> CFNode
applySingle (IdTagged CFEffect -> CFNode) -> IdTagged CFEffect -> CFNode
forall a b. (a -> b) -> a -> b
$ Id -> CFEffect -> IdTagged CFEffect
forall a. Id -> a -> IdTagged a
IdTagged Id
id (CFEffect -> IdTagged CFEffect) -> CFEffect -> IdTagged CFEffect
forall a b. (a -> b) -> a -> b
$ String -> CFEffect
CFReadVariable String
var)
AssignmentMode
Assign -> RWS
CFContext
([LNode CFNode], [LEdge CFEdge], [(Id, (Node, Node))],
[(Id, Node)])
Node
Range
none
let valueType = if [Token] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
indices then Id -> Token -> CFValue
f Id
id Token
value else CFValue
CFValueArray
let scoper =
case Maybe Scope
scope of
Just Scope
PrefixScope -> String -> CFValue -> CFEffect
CFWritePrefix
Just Scope
LocalScope -> String -> CFValue -> CFEffect
CFWriteLocal
Just Scope
GlobalScope -> String -> CFValue -> CFEffect
CFWriteGlobal
Maybe Scope
Nothing -> String -> CFValue -> CFEffect
CFWriteVariable
write <- newNodeRange $ applySingle $ IdTagged id $ scoper var valueType
linkRanges [expand, index, read, write]
where
f :: Id -> Token -> CFValue
f :: Id -> Token -> CFValue
f Id
id t :: Token
t@T_NormalWord {} = Id -> [CFStringPart] -> CFValue
CFValueComputed Id
id ([CFStringPart] -> CFValue) -> [CFStringPart] -> CFValue
forall a b. (a -> b) -> a -> b
$ [String -> CFStringPart
CFStringVariable String
var | AssignmentMode
mode AssignmentMode -> AssignmentMode -> Bool
forall a. Eq a => a -> a -> Bool
== AssignmentMode
Append] [CFStringPart] -> [CFStringPart] -> [CFStringPart]
forall a. [a] -> [a] -> [a]
++ Token -> [CFStringPart]
tokenToParts Token
t
f Id
id t :: Token
t@(T_Literal Id
_ String
str) = Id -> [CFStringPart] -> CFValue
CFValueComputed Id
id ([CFStringPart] -> CFValue) -> [CFStringPart] -> CFValue
forall a b. (a -> b) -> a -> b
$ [String -> CFStringPart
CFStringVariable String
var | AssignmentMode
mode AssignmentMode -> AssignmentMode -> Bool
forall a. Eq a => a -> a -> Bool
== AssignmentMode
Append] [CFStringPart] -> [CFStringPart] -> [CFStringPart]
forall a. [a] -> [a] -> [a]
++ Token -> [CFStringPart]
tokenToParts Token
t
f Id
_ T_Array {} = CFValue
CFValueArray
registerNode (getId t) op
return op
tokenToParts :: Token -> [CFStringPart]
tokenToParts Token
t =
case Token
t of
T_NormalWord Id
_ [Token]
list -> (Token -> [CFStringPart]) -> [Token] -> [CFStringPart]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Token -> [CFStringPart]
tokenToParts [Token]
list
T_DoubleQuoted Id
_ [Token]
list -> (Token -> [CFStringPart]) -> [Token] -> [CFStringPart]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Token -> [CFStringPart]
tokenToParts [Token]
list
T_SingleQuoted Id
_ String
str -> [ String -> CFStringPart
CFStringLiteral String
str ]
T_Literal Id
_ String
str -> [ String -> CFStringPart
CFStringLiteral String
str ]
T_DollarArithmetic {} -> [ CFStringPart
CFStringInteger ]
T_DollarBracket {} -> [ CFStringPart
CFStringInteger ]
T_DollarBraced Id
_ Bool
_ Token
list | Token -> Bool
isUnmodifiedParameterExpansion Token
t -> [ String -> CFStringPart
CFStringVariable (ShowS
getBracedReference ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Token -> [String]
oversimplify Token
list) ]
Token
_ -> [CFStringPart
-> (String -> CFStringPart) -> Maybe String -> CFStringPart
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CFStringPart
CFStringUnknown String -> CFStringPart
CFStringLiteral (Maybe String -> CFStringPart) -> Maybe String -> CFStringPart
forall a b. (a -> b) -> a -> b
$ Token -> Maybe String
getLiteralString Token
t]
safeUpdate :: (Adj b, Node, a, Adj b) -> gr a b -> gr a b
safeUpdate ctx :: (Adj b, Node, a, Adj b)
ctx@(Adj b
_,Node
node,a
_,Adj b
_) gr a b
graph = (Adj b, Node, a, Adj b)
ctx (Adj b, Node, a, Adj b) -> gr a b -> gr a b
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
& (Node -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> gr a b
delNode Node
node gr a b
graph)
inlineSubshells :: CFGraph -> CFGraph
inlineSubshells :: CFGraph -> CFGraph
inlineSubshells CFGraph
graph = CFGraph
relinkedGraph
where
subshells :: [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
subshells = (Context CFNode CFEdge
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)])
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
-> CFGraph
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
forall (gr :: * -> * -> *) a b c.
Graph gr =>
(Context a b -> c -> c) -> c -> gr a b -> c
ufold Context CFNode CFEdge
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
forall {e} {a} {f}.
(e, a, CFNode, f)
-> [(a, CFNode, Node, Node, e, f)]
-> [(a, CFNode, Node, Node, e, f)]
find [] CFGraph
graph
find :: (e, a, CFNode, f)
-> [(a, CFNode, Node, Node, e, f)]
-> [(a, CFNode, Node, Node, e, f)]
find (e
incoming, a
node, CFNode
label, f
outgoing) [(a, CFNode, Node, Node, e, f)]
acc =
case CFNode
label of
CFExecuteSubshell String
_ Node
start Node
end -> (a
node, CFNode
label, Node
start, Node
end, e
incoming, f
outgoing)(a, CFNode, Node, Node, e, f)
-> [(a, CFNode, Node, Node, e, f)]
-> [(a, CFNode, Node, Node, e, f)]
forall a. a -> [a] -> [a]
:[(a, CFNode, Node, Node, e, f)]
acc
CFNode
_ -> [(a, CFNode, Node, Node, e, f)]
acc
relinkedGraph :: CFGraph
relinkedGraph = (CFGraph
-> (Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge) -> CFGraph)
-> CFGraph
-> [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
-> CFGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CFGraph
-> (Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge) -> CFGraph
forall {gr :: * -> * -> *} {a}.
DynGraph gr =>
gr a CFEdge
-> (Node, a, Node, Node, Adj CFEdge, Adj CFEdge) -> gr a CFEdge
relink CFGraph
graph [(Node, CFNode, Node, Node, Adj CFEdge, Adj CFEdge)]
subshells
relink :: gr a CFEdge
-> (Node, a, Node, Node, Adj CFEdge, Adj CFEdge) -> gr a CFEdge
relink gr a CFEdge
graph (Node
node, a
label, Node
start, Node
end, Adj CFEdge
incoming, Adj CFEdge
outgoing) =
let
subshellToStart :: (Adj CFEdge, Node, a, Adj CFEdge)
subshellToStart = (Adj CFEdge
incoming, Node
node, a
label, [(CFEdge
CFEFlow, Node
start)])
endToNexts :: (Adj CFEdge, Node, a, Adj CFEdge)
endToNexts = (Adj CFEdge
endIncoming, Node
endNode, a
endLabel, Adj CFEdge
outgoing)
(Adj CFEdge
endIncoming, Node
endNode, a
endLabel, Adj CFEdge
_) = gr a CFEdge -> Node -> (Adj CFEdge, Node, a, Adj CFEdge)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context gr a CFEdge
graph Node
end
in
(Adj CFEdge, Node, a, Adj CFEdge)
subshellToStart (Adj CFEdge, Node, a, Adj CFEdge) -> gr a CFEdge -> gr a CFEdge
forall {gr :: * -> * -> *} {b} {a}.
DynGraph gr =>
(Adj b, Node, a, Adj b) -> gr a b -> gr a b
`safeUpdate` ((Adj CFEdge, Node, a, Adj CFEdge)
endToNexts (Adj CFEdge, Node, a, Adj CFEdge) -> gr a CFEdge -> gr a CFEdge
forall {gr :: * -> * -> *} {b} {a}.
DynGraph gr =>
(Adj b, Node, a, Adj b) -> gr a b -> gr a b
`safeUpdate` gr a CFEdge
graph)
findEntryNodes :: CFGraph -> [Node]
findEntryNodes :: CFGraph -> [Node]
findEntryNodes CFGraph
graph = (Context CFNode CFEdge -> [Node] -> [Node])
-> [Node] -> CFGraph -> [Node]
forall (gr :: * -> * -> *) a b c.
Graph gr =>
(Context a b -> c -> c) -> c -> gr a b -> c
ufold Context CFNode CFEdge -> [Node] -> [Node]
forall {t :: * -> *} {a} {a} {d}.
Foldable t =>
(t a, a, CFNode, d) -> [a] -> [a]
find [] CFGraph
graph
where
find :: (t a, a, CFNode, d) -> [a] -> [a]
find (t a
incoming, a
node, CFNode
label, d
_) [a]
list =
case CFNode
label of
CFEntryPoint {} | t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
incoming -> a
nodea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list
CFNode
_ -> [a]
list
findDominators :: Node -> CFGraph -> Map Node (Set Node)
findDominators Node
main CFGraph
graph = Map Node (Set Node)
asSetMap
where
inlined :: CFGraph
inlined = CFGraph -> CFGraph
inlineSubshells CFGraph
graph
entryNodes :: [Node]
entryNodes = Node
main Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: CFGraph -> [Node]
findEntryNodes CFGraph
graph
asLists :: [(Node, [Node])]
asLists = (Node -> [(Node, [Node])]) -> [Node] -> [(Node, [Node])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CFGraph -> Node -> [(Node, [Node])]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [(Node, [Node])]
dom CFGraph
inlined) [Node]
entryNodes
asSetMap :: Map Node (Set Node)
asSetMap = [(Node, Set Node)] -> Map Node (Set Node)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Node, Set Node)] -> Map Node (Set Node))
-> [(Node, Set Node)] -> Map Node (Set Node)
forall a b. (a -> b) -> a -> b
$ ((Node, [Node]) -> (Node, Set Node))
-> [(Node, [Node])] -> [(Node, Set Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
node, [Node]
list) -> (Node
node, [Node] -> Set Node
forall a. Ord a => [a] -> Set a
S.fromList [Node]
list)) [(Node, [Node])]
asLists
findTerminalNodes :: CFGraph -> [Node]
findTerminalNodes :: CFGraph -> [Node]
findTerminalNodes CFGraph
graph = (Context CFNode CFEdge -> [Node] -> [Node])
-> [Node] -> CFGraph -> [Node]
forall (gr :: * -> * -> *) a b c.
Graph gr =>
(Context a b -> c -> c) -> c -> gr a b -> c
ufold Context CFNode CFEdge -> [Node] -> [Node]
forall {a} {d}. (a, Node, CFNode, d) -> [Node] -> [Node]
find [] CFGraph
graph
where
find :: (a, Node, CFNode, d) -> [Node] -> [Node]
find (a
_, Node
node, CFNode
label, d
_) [Node]
list =
case CFNode
label of
CFNode
CFUnresolvedExit -> Node
nodeNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
list
CFApplyEffects [IdTagged CFEffect]
effects -> [IdTagged CFEffect] -> [Node] -> [Node]
f [IdTagged CFEffect]
effects [Node]
list
CFNode
_ -> [Node]
list
f :: [IdTagged CFEffect] -> [Node] -> [Node]
f [] [Node]
list = [Node]
list
f (IdTagged Id
_ (CFDefineFunction String
_ Id
id Node
start Node
end):[IdTagged CFEffect]
rest) [Node]
list = [IdTagged CFEffect] -> [Node] -> [Node]
f [IdTagged CFEffect]
rest (Node
endNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
list)
f (IdTagged CFEffect
_:[IdTagged CFEffect]
rest) [Node]
list = [IdTagged CFEffect] -> [Node] -> [Node]
f [IdTagged CFEffect]
rest [Node]
list
findPostDominators :: Node -> CFGraph -> Array Node [Node]
findPostDominators :: Node -> CFGraph -> Array Node [Node]
findPostDominators Node
mainexit CFGraph
graph = Array Node [Node]
asArray
where
inlined :: CFGraph
inlined = CFGraph -> CFGraph
inlineSubshells CFGraph
graph
terminals :: [Node]
terminals = CFGraph -> [Node]
findTerminalNodes CFGraph
inlined
(Adj CFEdge
incoming, Node
_, CFNode
label, Adj CFEdge
outgoing) = CFGraph -> Node -> Context CFNode CFEdge
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context CFGraph
graph Node
mainexit
withExitEdges :: CFGraph
withExitEdges = (Adj CFEdge
incoming Adj CFEdge -> Adj CFEdge -> Adj CFEdge
forall a. [a] -> [a] -> [a]
++ (Node -> (CFEdge, Node)) -> [Node] -> Adj CFEdge
forall a b. (a -> b) -> [a] -> [b]
map (\Node
c -> (CFEdge
CFEFlow, Node
c)) [Node]
terminals, Node
mainexit, CFNode
label, Adj CFEdge
outgoing) Context CFNode CFEdge -> CFGraph -> CFGraph
forall {gr :: * -> * -> *} {b} {a}.
DynGraph gr =>
(Adj b, Node, a, Adj b) -> gr a b -> gr a b
`safeUpdate` CFGraph
inlined
reversed :: CFGraph
reversed = CFGraph -> CFGraph
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev CFGraph
withExitEdges
postDoms :: [(Node, [Node])]
postDoms = CFGraph -> Node -> [(Node, [Node])]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [(Node, [Node])]
dom CFGraph
reversed Node
mainexit
(Node
_, Node
maxNode) = CFGraph -> (Node, Node)
forall a b. Gr a b -> (Node, Node)
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> (Node, Node)
nodeRange CFGraph
graph
initializedArray :: Array Node [Node]
initializedArray = (Node, Node) -> [[Node]] -> Array Node [Node]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Node
0, Node
maxNode) ([[Node]] -> Array Node [Node]) -> [[Node]] -> Array Node [Node]
forall a b. (a -> b) -> a -> b
$ [Node] -> [[Node]]
forall a. a -> [a]
repeat []
asArray :: Array Node [Node]
asArray = Array Node [Node]
initializedArray Array Node [Node] -> [(Node, [Node])] -> Array Node [Node]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Node, [Node])]
postDoms
return []
runTests :: IO Bool
runTests = $( [| $(forAllProperties) (quickCheckWithResult (stdArgs { maxSuccess = 1 }) ) |])