implementation module GinParser import StdBool import StdArray import StdEnum from StdFunc import o,flip,seq //import StdMisc import StdList import StdOrdList import StdTuple import GenPrint //Clean-platform: import Graph import Map import Void import 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, ::Ident(..), ::LocalDefs, ::OptionalRecordName, ::ParsedExpr(..), ::ParsedSelection, ::ParsedSelectorKind, ::Position, ::Ptr, ::Qualifier, ::Sequence, ::SymbolPtr, ::SymbolTableEntry, ::TypeKind import CleanDocParser //GiN: import Monad import GinSyntax import GinAbstractSyntax import GinFlowLibrary import GinORYX import GinStorage //-------------------------------------------------------------------------------------------------- //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