(* Copyright (c) 2013, 2016 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* Derived from the original parse-tree Copyright (c) 2000 Cambridge University Technical Services Limited Further development: Copyright (c) 2000-13 David C.J. Matthews Title: Parse Tree Structure and Operations. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1985 *) functor EXPORT_PARSETREE ( structure BASEPARSETREE : BaseParseTreeSig structure PRINTTREE: PrintParsetreeSig structure LEX : LEXSIG structure STRUCTVALS : STRUCTVALSIG structure EXPORTTREE: EXPORTTREESIG structure TYPETREE : TYPETREESIG structure DEBUGGER : DEBUGGERSIG sharing LEX.Sharing = TYPETREE.Sharing = STRUCTVALS.Sharing = EXPORTTREE.Sharing = BASEPARSETREE.Sharing = PRINTTREE.Sharing = DEBUGGER.Sharing ): ExportParsetreeSig = struct open LEX open STRUCTVALS open EXPORTTREE open TYPETREE open BASEPARSETREE open PRINTTREE fun getExportTree(navigation, p: parsetree) = let (* Common properties for navigation and printing. *) val commonProps = exportNavigationProps navigation @ [PTprint(fn d => displayParsetree(p, d))] fun asParent () = getExportTree(navigation, p) (* Put all these into a common list. That simplifies navigation between the various groups in abstypes and datatypes. *) datatype lType = DataT of datatypebind | TypeB of typebind | Decl of parsetree * breakPoint option ref (* Common code for datatypes, abstypes and type bindings. *) fun exportTypeBinding(navigation, this as DataT(DatatypeBind{name, nameLoc, fullLoc, constrs, tcon=ref(TypeConstrSet(tcon, _)), ...})) = let fun asParent () = exportTypeBinding(navigation, this) (* Ignore any type variables before the type name. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getConstrs}, name, nameLoc, definingLocationProps(tcLocations tcon)) and getConstrs () = let fun exportConstrs(navigation, {constrName, idLocn, constrVal=ref(Value{locations, ...}), ... }) = (* TODO: the constructor type. *) getStringAsTree(navigation, constrName, idLocn, definingLocationProps locations) in (fullLoc, (* TODO: We need a separate location for the constrs. *) exportList(exportConstrs, SOME asParent) constrs @ exportNavigationProps {parent=SOME asParent, previous=SOME getName, next=NONE}) end in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end | exportTypeBinding(navigation, this as TypeB(TypeBind{name, nameLoc, decType = SOME decType, fullLoc, tcon=ref(TypeConstrSet(tcon, _)), ...})) = let fun asParent () = exportTypeBinding(navigation, this) (* Ignore any type variables before the type name. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, definingLocationProps(tcLocations tcon)) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, decType) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end (* TypeBind is also used in a signature in which case decType could be NONE. *) | exportTypeBinding(navigation, this as TypeB(TypeBind{name, nameLoc, decType = NONE, fullLoc, tcon=ref(TypeConstrSet(tcon, _)), ...})) = let fun asParent () = exportTypeBinding(navigation, this) (* Ignore any type variables before the type name. *) (* Retain this as a child entry in case we decide to add the type vars later. *) fun getName () = getStringAsTree({parent=SOME asParent, previous=NONE, next=NONE}, name, nameLoc, definingLocationProps(tcLocations tcon)) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end | exportTypeBinding(navigation, Decl dec) = (* Value declarations in an abstype. *) exportTreeWithBpt(navigation, dec) (* In a couple of cases we can have a breakpoint associated with an entry. *) and exportTreeWithBpt(nav, (p, ref NONE)) = getExportTree (nav, p) | exportTreeWithBpt(nav, (p, ref (SOME bpt))) = let val (loc, props) = getExportTree (nav, p) in (loc, PTbreakPoint bpt :: props) end fun exportMatch(navigation, p as MatchTree{location, vars, exp, resType = ref rtype, argType = ref atype, breakPoint = ref bpt, ...}) = let fun asParent () = exportMatch(navigation, p) val debugProp = case bpt of NONE => [] | SOME bpt => [PTbreakPoint bpt] in (location, [PTprint(fn d => displayMatch(p, d)), PTtype (mkFunctionType (atype, rtype))] @ exportList(getExportTree, SOME asParent) [vars, exp] @ exportNavigationProps navigation @ debugProp ) end in case p of Ident{location, expType=ref expType, value, possible, name, ...} => let (* Include the type and declaration properties if these have been set. *) val (decProp, references, possProp) = case value of ref (Value{name = "", ...}) => let (* Generate possible completions. For the moment just consider simple prefixes. *) val completions = List.filter (String.isPrefix name) (! possible ()) in ([], NONE, [PTcompletions completions]) end | ref (Value{locations, references, ...}) => let (* If this is in a pattern it could be the defining location of the id. It's complicated trying to find out exactly which is the defining location so we check to see if this is the DeclaredAt location. *) val locProps = case List.find (fn DeclaredAt l => l = location | _ => false) locations of SOME _ => definingLocationProps locations | NONE => mapLocationProps locations in (locProps, references, []) end val refProp = case references of NONE => [] | SOME {exportedRef=ref exp, localRef=ref locals, recursiveRef=ref recs} => [PTreferences(exp, List.map #1 recs @ locals)] in (location, PTtype expType :: decProp @ commonProps @ refProp @ possProp) end | Literal {location, expType=ref expType, ...} => (location, PTtype expType :: commonProps) (* Infixed application. For the purposes of navigation we treat this as three entries in order. *) | Applic{location, f, arg = TupleTree{fields=[left, right], ...}, isInfix = true, expType=ref expType, ...} => (location, PTtype expType :: exportList(getExportTree, SOME asParent) [left, f, right] @ commonProps) (* Non-infixed application. *) | Applic{location, f, arg, expType=ref expType, ...} => (location, PTtype expType :: exportList(getExportTree, SOME asParent) [f, arg] @ commonProps) | Cond{location, test, thenpt, elsept, thenBreak, elseBreak, ...} => (location, exportList(exportTreeWithBpt, SOME asParent) [(test, ref NONE), (thenpt, thenBreak), (elsept, elseBreak)] @ commonProps) | TupleTree{fields, location, expType=ref expType, ...}=> (location, PTtype expType :: exportList(getExportTree, SOME asParent) fields @ commonProps) | ValDeclaration{location, dec, ...} => let fun exportVB(navigation, vb as ValBind{dec, exp, line, ...}) = let val vbProps = exportNavigationProps navigation (* First child should give the pattern *) (* Second child should give the expression *) fun exportThis () = exportVB(navigation, vb) val asChild = exportList(getExportTree, SOME exportThis) [dec, exp] in (line, asChild @ vbProps) end val expChild = exportList(exportVB, SOME asParent) dec in (* We need a special case for a top-level expression. This has been converted by the parser into val it = exp but the "val it = " takes up no space. We need to go directly to the expression in that case. *) case dec of [ValBind{dec=Ident{name="it", location=itLoc, ...}, exp, ...}] => if #startPosition itLoc = #endPosition itLoc andalso #startLine itLoc = #endLine itLoc then getExportTree(navigation, exp) else (location, expChild @ commonProps) | _ => (location, expChild @ commonProps) end | FunDeclaration{location, dec, ...} => let (* It's easiest to put these all together into a single list. *) datatype funEntry = FunIdent of { name: string, expType: types ref, location: location } * values | FunPtree of parsetree | FunConstraint of typeParsetree | FunInfixed of funEntry list * location fun exportFunEntry(navigation, FunIdent({expType=ref expType, location, ...}, Value{references, locations, ...})) = let val refProp = case references of NONE => [] | SOME {exportedRef=ref exp, localRef=ref locals, recursiveRef=ref recs} => [PTreferences(exp, List.map #1 recs @ locals)] in (location, refProp @ definingLocationProps locations @ (PTtype expType :: exportNavigationProps navigation)) end | exportFunEntry(navigation, FunPtree pt) = getExportTree(navigation, pt) | exportFunEntry(navigation, FunConstraint typ) = typeExportTree(navigation, typ) | exportFunEntry(navigation, this as FunInfixed(inf, location)) = let fun asParent () = exportFunEntry(navigation, this) val expChild = exportList(exportFunEntry, SOME asParent) inf in (location, expChild @ exportNavigationProps navigation) end fun exportAClause( FValClause{dec = {ident, isInfix, args, constraint}, exp, breakPoint = ref bpt, ...}, idVal, exportThis) = let (* The effect of this is to have all the elements of the clause as a single level except that if we have an infixed application of the function (e.g. fun f o g = ...) then this is a subnode. *) val funAndArgs = case (isInfix, args) of (true, TupleTree{fields=[left, right], location, ...} :: otherArgs) => (* Infixed. *) FunInfixed([FunPtree left, FunIdent(ident, idVal), FunPtree right], location) :: map FunPtree otherArgs | (_, args) => (* Normal prefixed form. *) FunIdent(ident, idVal) :: map FunPtree args val constraint = case constraint of NONE => [] |SOME typ => [FunConstraint typ] val debugProp = case bpt of NONE => [] | SOME bpt => [PTbreakPoint bpt] in exportList(exportFunEntry, SOME exportThis) (funAndArgs @ constraint @ [FunPtree exp]) @ debugProp end fun exportFB(navigation, fb as FValBind{clauses=[clause], location, functVar = ref idVal, ...}) = (* If there's just one clause go straight to it. Otherwise we have an unnecessary level of navigation. *) let val fbProps = exportNavigationProps navigation val asChild = exportAClause(clause, idVal, fn () => exportFB(navigation, fb)) in (location, asChild @ fbProps) end | exportFB(navigation, fb as FValBind{clauses, location, functVar = ref idVal, ...}) = let val fbProps = exportNavigationProps navigation (* Each child gives a clause. *) (* First child should give the pattern *) (* Second child should give the expression *) fun exportThis () = exportFB(navigation, fb) fun exportClause(navigation, clause as FValClause{ line, ...}) = let val clProps = exportNavigationProps navigation val asChild = exportAClause(clause, idVal, fn () => exportClause(navigation, clause)) in (line, asChild @ clProps) end val asChild = exportList(exportClause, SOME exportThis) clauses in (location, asChild @ fbProps) end val expChild = exportList(exportFB, SOME asParent) dec in (location, expChild @ commonProps) end | OpenDec{location, decs, ...} => let fun exportStructIdent(navigation, { value, location, ...} ) = let (* Include the declaration properties if it has been set. *) val locProps = case !value of SOME(Struct{locations, ...}) => mapLocationProps locations | NONE => [] val siProps = exportNavigationProps navigation @ locProps in (location, siProps) end val expChild = exportList(exportStructIdent, SOME asParent) decs in (location, expChild @ commonProps) end | Constraint{location, value, given, ...} => let (* The first position is the expression, the second the type *) fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getType}, value) and getType () = typeExportTree({parent=SOME asParent, previous=SOME getExpr, next=NONE}, given) in (location, PTfirstChild getExpr :: commonProps) end | Layered{location, var, pattern, ...} => (location, exportList(getExportTree, SOME asParent) [var, pattern] @ commonProps) | Fn {matches, location, expType = ref expType, ...} => (location, PTtype expType :: exportList(exportMatch, SOME asParent) matches @ commonProps) | Localdec{location, decs, body, ...} => (location, exportList(exportTreeWithBpt, SOME asParent) (decs @ body) @ commonProps) | TypeDeclaration(tbl, location) => let val allItems = List.map TypeB tbl in (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps) end | AbsDatatypeDeclaration { location, typelist, withtypes, declist, ... } => let val allItems = List.map DataT typelist @ List.map TypeB withtypes @ List.map Decl declist in (location, exportList(exportTypeBinding, SOME asParent) allItems @ commonProps) end | DatatypeReplication{location, ...} => (* TODO *) (location, commonProps) | ExpSeq(ptl, location) => (location, exportList(exportTreeWithBpt, SOME asParent) ptl @ commonProps) | Directive{location, ...} => (* No need to process the individual identifiers. *) (location, commonProps) | ExDeclaration(exbinds, location) => let (* There are three possibilities here. exception exc; exception exc of ty; exception exc = exc' *) fun exportExdec(navigation, ExBind{name, previous=EmptyTree, ofType=NONE, nameLoc, value=ref(Value{locations, ...}), ...}) = (* Simple, generative exception with no type. *) getStringAsTree(navigation, name, nameLoc, PTtype exnType :: definingLocationProps locations) | exportExdec(navigation, eb as ExBind{name, previous=EmptyTree, ofType=SOME ofType, nameLoc, fullLoc, value=ref(Value{locations, ...}), ...}) = (* exception exc of type. *) let fun asParent () = exportExdec (navigation, eb) fun getName () = getStringAsTree({parent=SOME asParent, next=SOME getOfType, previous=NONE}, name, nameLoc, (* Type could be in here? *)definingLocationProps locations) and getOfType () = typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, ofType) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end | exportExdec(navigation, eb as ExBind{name, previous, (* ofType=NONE, *) nameLoc, fullLoc, value=ref(Value{locations, ...}), ...}) = let fun asParent () = exportExdec (navigation, eb) fun getName () = getStringAsTree({parent=SOME asParent, next=SOME getPreviousExc, previous=NONE}, name, nameLoc, (* Type could be in here? *)definingLocationProps locations) and getPreviousExc () = getExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, previous) in (fullLoc, PTfirstChild getName :: exportNavigationProps navigation) end val expChild = exportList(exportExdec, SOME asParent) exbinds in (location, expChild @ commonProps) end | Raise(raiseExp, location) => let fun getExp () = getExportTree({parent=SOME asParent, next=NONE, previous=NONE}, raiseExp) in (location, [PTfirstChild getExp] @ commonProps) end | HandleTree{location, exp, hrules, listLocation, ...} => let (* The first position is the expression, the second the matches *) fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getMatches}, exp) and getMatches () = (listLocation, exportList(exportMatch, SOME getMatches) hrules @ exportNavigationProps{parent=SOME asParent, previous=SOME getExpr, next=NONE}) in (location, [PTfirstChild getExpr] @ commonProps) end | While{location, test, body, breakPoint, ...} => (location, exportList(exportTreeWithBpt, SOME asParent) [(test, ref NONE), (body, breakPoint)] @ commonProps) | Case{location, test, match, listLocation, expType=ref expType, ...} => let (* The first position is the expression, the second the matches *) fun getExpr () = getExportTree({parent=SOME asParent, previous=NONE, next=SOME getMatches}, test) and getMatches () = (listLocation, exportList(exportMatch, SOME getMatches) match @ exportNavigationProps{parent=SOME asParent, previous=SOME getExpr, next=NONE}) in (location, [PTfirstChild getExpr, PTtype expType] @ commonProps) end | Andalso {location, first, second, ...} => (location, exportList(getExportTree, SOME asParent) [first, second] @ commonProps) | Orelse{location, first, second, ...} => (location, exportList(getExportTree, SOME asParent) [first, second] @ commonProps) | Labelled{location, expType=ref expType, recList, ...} => let (* It's convenient to be able to click on the label part and get the type of the expression or pattern on the right of the '='. *) fun exportField(navigation, label as {name, nameLoc, valOrPat, expType=ref expType, fullLocation, ...}) = let val patTree as (patLocation, _) = getExportTree(navigation, valOrPat) in if patLocation = fullLocation then (* The parser rewrites { name, ...} as { name=name, ... } (more generally { name: ty as pat, ...} as { name = name: ty as pat). To avoid having nodes that overlap we return only the pattern part here. *) patTree else let (* The first position is the label, the second the type *) fun asParent () = exportField (navigation, label) fun getLab () = getStringAsTree({parent=SOME asParent, next=SOME getExp, previous=NONE}, name, nameLoc, [PTtype expType]) and getExp () = getExportTree({parent=SOME asParent, previous=SOME getLab, next=NONE}, valOrPat) in (fullLocation, PTfirstChild getLab :: exportNavigationProps navigation) end end val expChild = exportList(exportField, SOME asParent) recList in (location, PTtype expType :: (expChild @ commonProps)) end | Selector{location, typeof, ...} => (location, PTtype typeof :: commonProps) | List{elements, location, expType = ref expType, ...} => (location, PTtype expType :: exportList(getExportTree, SOME asParent) elements @ commonProps) | EmptyTree => (nullLocation, commonProps) | WildCard location => (location, commonProps) | Unit location => (location, PTtype unitType :: commonProps) | Parenthesised(p, _) => getExportTree(navigation, p) end fun getLocation c = #1 (getExportTree({parent=NONE, next=NONE, previous=NONE}, c)) (* Extract the declaration location from the location list. *) fun declaredAt [] = LEX.nullLocation | declaredAt (DeclaredAt loc :: _) = loc | declaredAt (_::l) = declaredAt l (* Types that can be shared. *) structure Sharing = struct type lexan = lexan and parsetree = parsetree and matchtree = matchtree and locationProp = locationProp and pretty = pretty and ptProperties = ptProperties end end;