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