implementation module iTasks.Gin.Parser import StdBool import StdArray import StdEnum from StdFunc import o,flip,seq //import StdMisc import StdList import StdOrdList import StdTuple import StdClass, StdInt import Data.Error import GenPrint from iTasks import class iTask from iTasks.Gin.Types import generic gEq, generic JSONDecode, generic JSONEncode, generic gVerify, generic gUpdate, generic gDefault, generic gGridRows, generic gHeaders, generic gVisualizeText, generic gVisualizeEditor from iTasks.Gin.Types import :: JSONNode, :: InteractionMask, :: VerifyMask, :: VerifyOptions, :: ConsPos, :: StaticVisualizationMode, :: VSt, :: VisualizationResult, :: GTypeExpression, :: GTypeDefinition from iTasks.Gin.Types import printGTypeDefinition, typeIsDefined, printGTypeExpression from iTasks.Gin.Printer import class Printer //Clean-platform: import Data.Graph import Data.Map import Data.Void import Text.JSON import Text //Clean-compiler: from general import :: Optional(..) from syntax import ::ArrayKind, ::BasicValue, ::Bind, ::BoundExpr, ::CaseAlt, ::CodeBinding, ::DynamicType, ::ElemAssignment, ::Env, ::FieldAssignment, ::FieldNameOrQualifiedFieldName, ::FieldSymbol, ::Global, ::ModuleIdent(..), ::Ident(..), ::LocalDefs, ::Optional(..), ::OptionalRecordName(..), ::ParsedExpr(..), ::ParsedSelection, ::ParsedSelectorKind, ::Position, ::Ptr, ::Qualifier, ::Sequence, ::SymbolPtr, ::SymbolTableEntry, ::TypeKind from CleanDocParser import parseExpressionUnsafe //GiN: import iTasks.Gin.Monad import iTasks.Gin.Syntax import iTasks.Gin.AbstractSyntax import iTasks.Gin.FlowLibrary import iTasks.Gin.ORYX import iTasks.Gin.Storage //-------------------------------------------------------------------------------------------------- //GParseState monadic combinators derive class iTask GPathNode, GParseResult, GParseState isParseError :: (GParseResult a) -> Bool isParseError (GError _) = True isParseError _ = False getParseSuccess :: (GParseResult a) -> a getParseSuccess (GSuccess a) = a getParseError :: (GParseResult a) -> [(GPath, String)] getParseError (GError b) = b instance Monad GParseState where ret :: a -> GParseState a ret a = GParseState (\path = GSuccess a) (>>>) infixr 5 :: (GParseState a) (a -> GParseState b) -> GParseState b (>>>) (GParseState m) k = GParseState (\path = case m path of GError errors = GError errors GSuccess a = strip (k a) path) where strip (GParseState f) = f instance PathNode GNode where getPathNode :: GNode GPath -> GPath getPathNode { GNode | identifier } _ = [NodePath identifier] instance PathNode GEdge where getPathNode :: GEdge GPath -> GPath getPathNode { GEdge | identifier} _ = [EdgePath identifier] instance PathNode (String,GExpression) where getPathNode :: (String,GExpression) GPath -> GPath getPathNode (s,_) path = [ParamPath s : path] instance PathNode TreeGraph where getPathNode :: TreeGraph GPath -> GPath getPathNode (TreeGraph graph source sink) path = getPathNode (fromJust (getNodeData source graph)) path instance PathNode TreeGraphNode where getPathNode :: TreeGraphNode GPath -> GPath getPathNode (TGNode node) path = getPathNode node path getPathNode (TGSubgraph subgraph) path = getPathNode subgraph path parseChild :: a (GParseState b) -> GParseState b| PathNode a parseChild child (GParseState f) = GParseState (\path = f (getPathNode child path)) parseMap :: (a -> GParseState b) [a] -> GParseState [b] parseMap _ [] = ret [] parseMap f [x:xs] = f x >>> \x` = parseMap f xs >>> \xs` = ret [x`:xs`] parseChildMap :: (a -> GParseState b) [a] -> GParseState [b]| PathNode a parseChildMap f [] = ret [] parseChildMap f [x:xs] = parseChild x (f x) >>> \x` -> parseChildMap f xs >>> \xs` -> ret [x`:xs`] orElse :: (GParseState a) (GParseState a) -> GParseState a orElse (GParseState m) (GParseState k) = GParseState (\p = case (m p) of GSuccess a = GSuccess a GError errors = k p) parseError :: String -> GParseState a parseError message = GParseState (\path = GError [(path,message)]) parseErrorInChild :: a String -> GParseState b| PathNode a parseErrorInChild child message = parseChild child (parseError message) parseErrorInChildren :: [a] String -> GParseState b| PathNode a parseErrorInChildren children message = GParseState (\path = GError [(getPathNode child path, message) \\ child <- children]) getCurrentPath :: GParseState GPath getCurrentPath = GParseState (\path = GSuccess path) runParse :: (GParseState a) -> GParseResult a runParse (GParseState f) = f [] //------------------------------------------------------------------------------------------- //Top-level conversion function gToAModule :: !GModule !GinConfig !*World -> (GParseState AModule, *World) gToAModule gmod =: { moduleKind = GCleanModule _ } config world = (parseError "Module does not have a graphical representation", world) gToAModule gmod =: { moduleKind = GGraphicalModule definitions } config world # (res, world) = importModules config gmod.GModule.imports world | isError res = (parseError (fromError res), world) # imports = fromOk res # bindings = map getDefinitionBinding definitions ++ (flatten o map getModuleBindings) imports = ( parseMap (gToADefinition bindings) definitions >>> \definitions = ret { AModule | name = gmod.GModule.name , types = gmod.GModule.types , imports = gmod.GModule.imports , definitions = definitions } , world) gToADefinition :: !Bindings !GDefinition -> GParseState ADefinition gToADefinition bindings gdef # graph = GGraphExpression (oryxDiagramToGraph bindings gdef.GDefinition.body) = gToAExpression bindings graph >>> \body = ret { ADefinition | name = gdef.GDefinition.declaration.GDeclaration.name , formalParams = gdef.GDefinition.declaration.GDeclaration.formalParams , returnType = gdef.GDefinition.declaration.GDeclaration.returnType , body = body , locals = [] } gToAExpression :: !Bindings !GExpression -> GParseState (AExpression Void) gToAExpression bindings (GUndefinedExpression) = parseError "Undefined expression" gToAExpression bindings (GGraphExpression graph) = graphToAExpression bindings graph gToAExpression bindings (GListExpression gexps) = parseMap (gToAExpression bindings) gexps >>> \aexps = ret (List aexps) gToAExpression bindings (GListComprehensionExpression glc) = gToAListComprehension bindings glc >>> \alc = ret (ListComprehension alc) gToAExpression bindings (GCleanExpression text) | size text == 0 = parseError "Clean expression is empty" gToAExpression bindings (GCleanExpression text) = ret (Unparsed text) putPathContext :: (AExpression Void) -> GParseState (AExpression Void) putPathContext exp = getCurrentPath >>> \path -> ret (PathContext path exp) gToAMaybeExpression :: !Bindings !(Maybe GExpression) -> GParseState (Maybe (AExpression Void)) gToAMaybeExpression bindings (Just exp) = gToAExpression bindings exp >>> \exp` = ret (Just exp`) gToAMaybeExpression bindings Nothing = ret Nothing gToAListComprehension :: !Bindings !GListComprehension -> GParseState (AListComprehension Void) gToAListComprehension bindings glc = gToAExpression bindings glc.GListComprehension.output >>> \output` = gToAExpression bindings glc.GListComprehension.input >>> \input` = ret { output = output` , generators = NestedGeneratorList [Generator glc.GListComprehension.selector input`] , guards = map Unparsed (maybeToList glc.GListComprehension.guard) } //-------------------------------------------------------------------------------------------------------------- //GGraph decomposition graphToAExpression :: !Bindings !GGraph -> GParseState (AExpression Void) graphToAExpression bindings graph = toTreeGraph graph >>> \tg -> ret (decompose bindings (tg)) >>> \tg -> treeGraphToAExpression bindings tg :: TreeGraph = TreeGraph (Graph TreeGraphNode GEdge) NodeIndex NodeIndex :: TreeGraphNode = TGNode GNode | TGSubgraph TreeGraph isNode :: TreeGraphNode -> Bool isNode (TGNode _) = True isNode _ = False isSubgraph :: TreeGraphNode -> Bool isSubgraph (TGSubgraph _) = True isSubgraph _ = False fromNode :: TreeGraphNode -> GNode fromNode (TGNode n) = n fromSubgraph :: TreeGraphNode -> TreeGraph fromSubgraph (TGSubgraph t) = t toTreeGraph :: GGraph -> GParseState TreeGraph toTreeGraph (GGraph graph) # sources = filterNodes (\pred _ _ -> isEmpty pred) graph | isEmpty sources = parseError "No source node found" | (not o isEmpty) (tl sources) = parseErrorInChildren (getNodes sources graph) "Source node is not unique" # sinks = filterNodes (\_ succ _ -> isEmpty succ) graph | isEmpty sinks = parseError "No sink node found" | (not o isEmpty) (tl sinks) = parseErrorInChildren (getNodes sinks graph) "Sink node is not unique" = ret (TreeGraph (mapNodes (\n -> TGNode n) graph) (hd sources) (hd sinks)) edgePairs :: (Graph n e) EdgeIndex -> [(EdgeIndex,EdgeIndex)] edgePairs graph startEdge = (diag2 (successorEdges startEdge graph) (predecessorEdges startEdge graph)) decompose :: Bindings TreeGraph -> TreeGraph decompose bindings tg=:(TreeGraph g source sink) | nodeCount g == 1 = tg //Trivial graph: No decomposition possible # loop = (sink,source) # pairs = edgePairs g loop = decomp (edgePairs g loop) loop (TreeGraph (addEdge emptyEdge loop g) source sink) where decomp :: [(EdgeIndex,EdgeIndex)] EdgeIndex TreeGraph -> TreeGraph decomp [] loop (TreeGraph g source sink) = TreeGraph (removeEdge loop g) source sink decomp [(fromEdge,toEdge):edges] loop tg=:(TreeGraph g source sink) | not ( isParallelBinding (nodeName (fst fromEdge) g) (nodeName (snd toEdge) g) bindings || isParallelBinding (nodeName (snd fromEdge) g) (nodeName (fst toEdge) g) bindings ) = decomp edges loop tg # fromData = fromJust (getEdgeData fromEdge g) toData = fromJust (getEdgeData toEdge g) # comps = components (removeEdge fromEdge (removeEdge toEdge g)) | isEmpty (tl comps) = decomp edges loop tg //try next pair # [g,s:_] = comps # (g,s) = if (nodeExists source g) (g,s) (s,g) | isTrivialGraph s = decomp edges loop tg # g = removeEdge loop g # (newNode,g) = addNode (TGSubgraph(decompose bindings (TreeGraph s (snd fromEdge) (fst toEdge)))) g //decompose subgraph s recursively # g = addEdge fromData (fst fromEdge,newNode) g # g = addEdge toData (newNode, snd toEdge) g # source = if (source == snd fromEdge) newNode source # sink = if (sink == fst toEdge) newNode sink = decompose bindings (TreeGraph g source sink) treeGraphNodeToAExpression :: !Bindings !TreeGraphNode -> GParseState (AExpression Void) treeGraphNodeToAExpression bindings (TGNode node) = nodeToAExpression bindings node treeGraphNodeToAExpression bindings (TGSubgraph graph) = treeGraphToAExpression bindings graph treeGraphToAExpression :: !Bindings !TreeGraph -> GParseState (AExpression Void) treeGraphToAExpression bindings tg=:(TreeGraph graph source sink) | isEmptyGraph graph = parseErrorInChild tg "Empty graph" //Trivial subgraphs | isTrivialGraph graph = treeGraphNodeToAExpression bindings (fromJust (getNodeData (hd (nodeIndices graph)) graph)) //Structured parallel subgraphs # mbParallel = parallelDecompose bindings tg | isJust mbParallel = parallelToAExpression bindings (fromJust mbParallel) //Sequential subgraphs | isSequential tg = sequenceToAExpression bindings tg //Other graphs = parseErrorInChild tg "Mapping not supported" nodeToAExpression :: !Bindings !GNode -> GParseState (AExpression Void) nodeToAExpression bindings node = parseChild node ( ( getNodeBinding node.GNode.name bindings >>> \nb = case nb.NodeBinding.parameterMap of NBBuiltIn = parseError "Node not allowed here" NBPrefixApp = if (isEmpty node.GNode.actualParams) (ret (Var node.GNode.name)) (argsToExpressions nb >>> \exps = ret (App [(Var node.GNode.name) : exps])) NBInfixApp fix prio = argsToExpressions nb >>> \[exp1, exp2: _] -> ret (AppInfix node.GNode.name fix prio exp1 exp2) ) >>> putPathContext ) where argsToExpressions :: NodeBinding -> GParseState [AExpression Void] argsToExpressions nb = parseChildMap (\(_,param) -> gToAExpression bindings param >>> putPathContext) [(fromMaybe formalParam.GFormalParameter.name formalParam.GFormalParameter.title, actualParam) \\ formalParam <- nb.NodeBinding.declaration.GDeclaration.formalParams & actualParam <- node.GNode.actualParams ] //------------------------------------------------------------------------------------------- //Mapping of parallel subgraphs parallelDecompose :: !Bindings !TreeGraph -> Maybe (GNode, GNode, [TreeGraphNode]) parallelDecompose bindings (TreeGraph graph sourceIndex sinkIndex) # branchIndices = directSuccessors sourceIndex graph | sort branchIndices <> sort (directPredecessors sinkIndex graph) = Nothing | not (isParallelBinding (nodeName sourceIndex graph) (nodeName sinkIndex graph) bindings) = Nothing # source = fromNode (fromJust (getNodeData sourceIndex graph)) # sink = fromNode (fromJust (getNodeData sinkIndex graph)) = Just (source, sink, [ fromJust (getNodeData n graph) \\ n <- branchIndices]) parallelToAExpression :: !Bindings (GNode, GNode, [TreeGraphNode]) -> GParseState (AExpression Void) parallelToAExpression bindings (split, merge, branches) = parseChild split ( getParallelBinding split.GNode.name merge.GNode.name bindings >>> \pb = checkNrBranches pb (length branches) >>> \_ = setParallelParams bindings (split,merge) branches pb.ParallelBinding.parameterMap >>> putPathContext ) checkNrBranches :: !ParallelBinding !Int -> GParseState Void checkNrBranches pb i = case pb.fixedNrBranches of Just n | n == i = ret Void Just n = parseError ("(" +++ pb.split.GDeclaration.name +++ "," +++ pb.merge.GDeclaration.name +++ ") must have " +++ fromInt n +++ " branches") Nothing = ret Void setParallelParams :: !Bindings !(GNode, GNode) ![TreeGraphNode] !(AExpression PBParameter) -> GParseState (AExpression Void) setParallelParams _ _ _ (Unparsed s) = ret (Unparsed s) setParallelParams _ _ _ (Lit s) = ret (Lit s) setParallelParams _ _ _ (Var i) = ret (Var i) setParallelParams bindings (split,merge) branches (App exps) = parseMap (setParallelParams bindings (split,merge) branches) exps >>> \exps` = ret (App exps`) setParallelParams bindings (split,merge) branches (AppInfix i fix pred exp1 exp2) = setParallelParams bindings (split,merge) branches exp1 >>> \exp1` = setParallelParams bindings (split,merge) branches exp2 >>> \exp2` = ret (AppInfix i fix pred exp1` exp2`) setParallelParams bindings (split,merge) branches (Case exp casealts) = setParallelParams bindings (split,merge) branches exp >>> \exp` = parseMap (setParallelParamsCase bindings (split,merge) branches) casealts >>> \casealts` = ret (Case exp` casealts`) setParallelParams bindings (split,merge) branches (Lambda pat exp) = setParallelParams bindings (split,merge) branches exp >>> \exp` = ret (Lambda pat exp`) setParallelParams bindings (split,merge) branches (Tuple exps) = parseMap (setParallelParams bindings (split,merge) branches) exps >>> \exps` = ret (Tuple exps`) setParallelParams bindings (split,merge) branches (List exps) = parseMap (setParallelParams bindings (split,merge) branches) exps >>> \exps` = ret (List exps`) setParallelParams bindings (split,merge) branches (Extension ext) = case ext of PBSplitParameter i = gToAExpression bindings (split.GNode.actualParams !! i) PBMergeParameter i = gToAExpression bindings (merge.GNode.actualParams !! i) PBBranch i = case branches of [TGNode node] = if (node.GNode.name == "list comprehension") (parseError "List comprehension not allowed here") (nodeToAExpression bindings node) _ = (treeGraphNodeToAExpression bindings (branches !! i)) PBBranchList = case branches of [TGNode node] = if (node.GNode.name == "list comprehension") (setListComprehension node) setList _ = setList where setListComprehension node = getNodePattern node 0 >>> \generatorPattern -> gToAExpression bindings (node.GNode.actualParams !! 1) >>> \generatorExpression -> getNodePattern node 2 >>> \guard -> gToAExpression bindings (node.GNode.actualParams !! 3) >>> \output -> ret ( ListComprehension { AListComprehension | output = output , generators = NestedGeneratorList [Generator generatorPattern generatorExpression] , guards = if (trim guard == "") [] [Unparsed guard] } ) setList = parseMap (treeGraphNodeToAExpression bindings) branches >>> \branches` -> ret (List branches`) setParallelParamsCase :: !Bindings !(GNode, GNode) ![TreeGraphNode] !(ACaseAlt PBParameter) -> GParseState (ACaseAlt Void) setParallelParamsCase bindings (split,merge) branches (CaseAlt pat exp) = setParallelParams bindings (split,merge) branches exp >>> \exp` = ret (CaseAlt pat exp`) //------------------------------------------------------------------------------------------- //Mapping of sequential subgraphs isSequential :: TreeGraph -> Bool isSequential graph = True //TODO: check if graph does not contain any parallel split or parallel merge node. sequenceToAExpression :: !Bindings !TreeGraph -> GParseState (AExpression Void) sequenceToAExpression bindings tg = parseChild tg (sequenceToAExpression` bindings tg) sequenceToAExpression` :: !Bindings !TreeGraph -> GParseState (AExpression Void) sequenceToAExpression` bindings tg=:(TreeGraph graph source sink) # mergeNodes = filter (\n -> nodeName n graph == "case merge" && not (isPathToMergeSink graph n sink)) (nodeIndices graph) # nvMap = buildNodeVarMap tg mergeNodes = parseMap (\i -> seqNodeToAExpr (hd (directSuccessors i graph)) sink mergeNodes nvMap >>> \iexp -> ret ("f" +++ toString i +++ " " +++ unwords (fromJust (get i nvMap)), iexp)) mergeNodes >>> \letExps -> seqNodeToAExpr source sink mergeNodes nvMap >>> \exp -> ret if (isEmpty letExps) exp (Let letExps exp) where seqNodeToAExpr :: !NodeIndex !NodeIndex ![NodeIndex] !NodeVarMap -> GParseState (AExpression Void) seqNodeToAExpr current sink mergeNodes nvMap # nodeData = (fromJust (getNodeData current graph)) | current == sink = treeGraphNodeToAExpression bindings nodeData //1 | isNode nodeData # node = fromNode nodeData # nodename = node.GNode.name | isMember current mergeNodes = let f = Var ("f" +++ toString current) in ret (case fromMaybe [] (get current nvMap) of [] = f xs = App [f : map Var xs] ) | nodename == "case split" = caseNodeToAExpr current sink mergeNodes nvMap //3 | nodename == "let" = letNodeToAExpr current sink mergeNodes nvMap //4 = seqNode` nodeData = seqNode` nodeData where seqNode` nodeData # successors = directSuccessors current graph | not (isEmpty (tl successors)) = parseErrorInChild nodeData "Node cannot be used as split node" //7 # successor = hd successors | isPathToMergeSink graph successor sink = seqNodeToAExpr current current mergeNodes nvMap # edgePattern = (fromJust (getEdgeData (current, successor) graph)).pattern //5,6 = treeGraphNodeToAExpression bindings nodeData >>> \first` -> seqNodeToAExpr successor sink mergeNodes nvMap >>> \second` -> ret (case edgePattern of Just p = (AppInfix ">>=" Infixl 1 first` (Lambda p second`)) Nothing = (AppInfix ">>|" Infixl 1 first` second`) ) caseNodeToAExpr :: NodeIndex NodeIndex [NodeIndex] NodeVarMap -> GParseState (AExpression Void) caseNodeToAExpr current sink mergeNodes nvMap # nodeData = fromJust (getNodeData current graph) # node = fromNode nodeData # successors = directSuccessors current graph | isEmpty successors = parseErrorInChild node "Missing node(s) after case split" | or [ isPathToMergeSink graph s sink \\ s <- successors ] = parseErrorInChild node "Missing task in branch" //TODO: Highlight branch # caseExpression = node.GNode.actualParams = parseChild node (gToAExpression bindings (node.GNode.actualParams !! 0)) >>> \caseExpr -> parseMap (\n -> seqNodeToAExpr n sink mergeNodes nvMap >>> \exp -> ret (fromJust (getEdgeData (current,n) graph), exp)) successors >>> \caseAlts -> if (length (filter (\{pattern} -> isNothing pattern) (map fst caseAlts)) > 1) (parseErrorInChild node "A case expression can have at most one default case") //"otherwise" alternative is put at the end of the list //TODO: Sort according to diagram layout. (ret (let sortAlts = filter (not o isEmptyEdge o fst) caseAlts ++ filter (isEmptyEdge o fst) caseAlts in Case caseExpr (map mkCaseAlt sortAlts))) where isEmptyEdge :: GEdge -> Bool isEmptyEdge {pattern = Nothing } = True isEmptyEdge {pattern = Just pat } = size (trim pat) == 0 mkCaseAlt :: (GEdge, AExpression Void) -> ACaseAlt Void mkCaseAlt ({pattern = Just pat}, exp) = CaseAlt pat exp mkCaseAlt ({pattern = Nothing }, exp) = CaseAlt "otherwise" exp letNodeToAExpr :: NodeIndex NodeIndex [NodeIndex] NodeVarMap -> GParseState (AExpression Void) letNodeToAExpr current sink mergeNodes nvMap # nodeData = (fromJust (getNodeData current graph)) # node = fromNode nodeData # successors = directSuccessors current graph | isEmpty successors = parseErrorInChild node "Missing node after let" | not (isEmpty (tl successors)) = parseErrorInChild node "Let cannot be used as split node" | isPathToMergeSink graph (hd successors) sink = parseErrorInChild node "Missing task in branch" = getNodePattern node 0 >>> \pat -> gToAExpression bindings (node.GNode.actualParams !! 1) >>> \exp -> seqNodeToAExpr (hd successors) sink mergeNodes nvMap >>> \inExpr -> ret (App [Lambda pat inExpr, exp]) nodeName :: NodeIndex (Graph TreeGraphNode e) -> String nodeName nodeIndex graph = case fromJust (getNodeData nodeIndex graph) of TGNode{ GNode | name } = name _ = "" getNodePattern :: GNode Int -> GParseState String getNodePattern node index = parseChild node (getTextExpr (node.GNode.actualParams !! index)) where getTextExpr :: GExpression -> GParseState String getTextExpr (GCleanExpression exp) | exp == "" = parseError "Pattern is empty" | otherwise = ret exp getTextExpr f = parseError "Expected: textual expression" getNodes :: [NodeIndex] (Graph n e) -> [n] getNodes nodes graph = catMaybes [ getNodeData n graph\\ n <- nodes ] //-------------------------------------------------------------------------------------------------- isPathToMergeSink :: (Graph TreeGraphNode GEdge) NodeIndex NodeIndex -> Bool isPathToMergeSink graph current sink # nodeData = fromJust (getNodeData current graph) | isSubgraph nodeData = False # node = fromNode nodeData | node.GNode.name <> "case merge" = False | current == sink = True = case directSuccessors current graph of [n] = isPathToMergeSink graph n sink _ = False :: NodeVarMap :== Map NodeIndex Vars buildNodeVarMap :: TreeGraph [NodeIndex] -> NodeVarMap buildNodeVarMap (TreeGraph graph source sink) mergeNodes = fromList [(n, getNodeVars n) \\ n <- mergeNodes ] where getNodeVars :: NodeIndex -> Vars getNodeVars node # freeVars = freeVarsAfter graph node # boundVars = mergeVars [boundVarsBefore graph (p,node) \\ p <- directPredecessors node graph] = [ v \\ v <- freeVars | isMember v boundVars ] freeVarsAfter :: (Graph TreeGraphNode GEdge) NodeIndex -> Vars freeVarsAfter graph startNode = freeVarsAfter` [(startNode,emptyScope)] newMap where freeVarsAfter` :: [(NodeIndex, Scope)] (Map NodeIndex Scope) -> Vars freeVarsAfter` [] visitedMap = [] freeVarsAfter` [(n,scope):ns] visitedMap # newVars = [v \\ v <- freeVarsInNode (fromJust (getNodeData n graph)) | not (isMember v scope)] # toVisit = [(n`, addVars (boundVarsInEdge (n,n`) graph) scope) \\ n` <- directSuccessors n graph ] ++ ns = case get n visitedMap of Just visitedScope = if (isEmpty [ v \\ v <- visitedScope | not (isMember v scope) ]) [] (addVars newVars (freeVarsAfter` toVisit visitedMap)) Nothing = addVars newVars (freeVarsAfter` toVisit (put n scope visitedMap)) freeVarsInNode :: TreeGraphNode -> Vars freeVarsInNode (TGNode node) = mergeVars (map freeVarsInExpression node.GNode.actualParams) freeVarsInNode (TGSubgraph (TreeGraph graph source sink)) = freeVarsAfter graph source freeVarsInExpression :: GExpression -> Vars freeVarsInExpression GUndefinedExpression = emptyVars freeVarsInExpression (GGraphExpression graph) # result = runParse (toTreeGraph graph) | isParseError result = emptyVars # (TreeGraph graph` source sink) = getParseSuccess result = freeVarsAfter graph` source freeVarsInExpression (GListExpression items) = mergeVars (map freeVarsInExpression items) freeVarsInExpression (GListComprehensionExpression { GListComprehension | output, input, guard} ) = mergeVars [ freeVarsInExpression output , freeVarsInExpression input , case guard of Just g = freeVarsInCleanExpression g Nothing = emptyVars ] freeVarsInExpression (GCleanExpression clean) = freeVarsInCleanExpression clean boundVarsBefore :: (Graph TreeGraphNode GEdge) EdgeIndex -> Vars boundVarsBefore graph startEdge = boundVarsBefore` [startEdge] [] where boundVarsBefore` :: [EdgeIndex] [EdgeIndex] -> Vars boundVarsBefore` [] visited = [] boundVarsBefore` [e:es] visited | isMember e visited = boundVarsBefore` es visited # preds = directPredecessors (fst e) graph = addVars (boundVarsInEdge e graph) (boundVarsBefore` ([(p,fst e) \\ p <- preds] ++ es) [e:visited]) boundVarsInEdge :: EdgeIndex (Graph TreeGraphNode GEdge) -> Vars boundVarsInEdge edgeIndex graph # edgeData = fromJust (getEdgeData edgeIndex graph) = case edgeData.GEdge.pattern of Just p = freeVarsInCleanExpression p Nothing = //Check for bound vars in preceding let-node case fromJust (getNodeData (fst edgeIndex) graph) of TGNode { GNode | name = "let", actualParams } = freeVarsInExpression (actualParams !! 0) _ = emptyVars freeVarsInCleanExpression :: !String -> Vars freeVarsInCleanExpression input # mExpr = parseExpressionUnsafe input | isNothing mExpr = [] = freeVars emptyScope (fromJust mExpr) where freeVars :: Scope ParsedExpr -> Vars freeVars scope (PE_List exprs) = mergeVars (map (freeVars scope) exprs) freeVars scope (PE_Ident ident) = if (inScope ident.id_name scope) [] [ident.id_name] freeVars scope (PE_Basic _) = [] // freeVars scope (PE_Bound boundExpr) = abort "freeVars PE_Bound" // freeVars scope (PE_Lambda _ pat exp _) = abort "freeVars PE_Lambda" freeVars scope (PE_Tuple exprs) = flatten (map (freeVars scope) exprs) // freeVars scope (PE_Record expr optionalRecordName fieldAssignments) = abort "freeVars PE_Record" // freeVars scope (PE_ArrayPattern elemAssignments) = abort "freeVars PE_UpdateComprehension" // freeVars scope (PE_UpdateComprehension expr1 expr2 expr3 qualifiers) = abort "freeVars PE_ArrayDenot" // freeVars scope (PE_ArrayDenot kind exprs) = abort "freeVars PE_ArrayDenot" freeVars scope (PE_Selection _ expr selections) = freeVars scope expr // freeVars scope (PE_Update expr1 selections expr2) = abort "freeVars PE_Update" // freeVars scope (PE_Case _ e alts) = abort "freeVars PE_Case" freeVars scope (PE_If _ b e1 e2) = mergeVars [freeVars scope e \\ e <- [b,e1,e2]] // freeVars scope (PE_Let b defs expr) = abort "freeVars PE_Let" // freeVars scope (PE_ListCompr /*predef_cons_index:*/ i1 /*predef_nil_index:*/ i2 expr qualifiers) = abort "freeVars PE_ListCompr" // freeVars scope (PE_ArrayCompr arrayKind expr qualifiers) = abort "freeVars PE_ArrayCompr" // freeVars scope (PE_Sequ sequence) = abort "freeVars PE_Sequ" // freeVars scope (PE_WildCard) = abort "freeVars PE_Wildcard" // freeVars scope (PE_Field expr globalFieldSymbol /* Auxiliary, used during checking */) = abort "freeVars PE_Field" // freeVars scope (PE_QualifiedIdent ident string) = abort "freeVars PE_QualifiedIdent" // freeVars scope (PE_ABC_Code abc b) = abort "freeVars PE_ABC_Code" // freeVars scope (PE_Any_Code binding ident strings) = abort "freeVars PE_Any_Code" // freeVars scope (PE_DynamicPattern expr dyntype) = abort "freeVars PE_DynamicPattern" // freeVars scope (PE_Dynamic expr dyntype) = abort "freeVars PE_Dynamic" // freeVars scope (PE_Generic ident kind /* AA: For generics, kind indexed identifier */) = abort "freeVars PE_Generic" // freeVars scope (PE_TypeSignature arrayKind expr) = abort "freeVars PE_TypeSignature" // freeVars scope (PE_Empty) = abort "freeVars PE_Empty" // freeVars scope _ = abort "freeVars: not yet implemented" freeVars scope _ = [] //-------------------------------------------------------------------------------------------------- //Utilities foldl1 :: (a a -> a) [a] -> a foldl1 f [x:xs] = foldl f x xs unwords :: [String] -> String unwords [] = "" unwords [x] = x unwords [x:xs] = x +++ " " +++ unwords xs