/* * Copyright (c) 2003-2008 The University of Wroclaw. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. The name of the University may not be used to endorse or promote * products derived from this software without specific prior * written permission. * * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY ``AS IS'' AND ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN * NO EVENT SHALL THE UNIVERSITY BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* Transformations of quoted expressions into syntax trees */ using Nemerle.Collections; using Nemerle.Utility; using Nemerle.IO; using Nemerle.Compiler.Parsetree; using TT = Nemerle.Compiler.Typedtree; using System.Text; namespace Nemerle.Compiler { [ManagerAccess] public module Macros { /// PUBLIC API FOR USAGE IN MACROS this () { Manager = ManagerClass.Instance; } /** generates new unique symbol, which can be safely used as name of quoted variables, functions, etc. */ public NewSymbol () : Name { NewSymbol ("") } /** generates new unique symbol, which can be safely used as name of quoted variables, functions, etc. The [root] parameter can be used to specify a string to be part of the name, mostly for debugging purposes. */ public NewSymbol (root : string) : Name { // passing global context here makes little sense, but as name is unique here, // we can pass any to do not introduce nulls into Name def ctx = if (Manager.MacroColors.UseContext == null) Manager.CoreEnv else Manager.MacroColors.UseContext; Name (Util.tmpname (root), Manager.MacroColors.Color, ctx) } /** controlled hygiene breaking - generates symbol, which placed in generated code would bind to variables at macro-use site */ public UseSiteSymbol (id : string) : Name { Name (id, Manager.MacroColors.UseColor, Manager.MacroColors.UseContext) } /** Checks if given expression describes name of a type, like [System.Console] (it is a class) */ public IsTypeName (e : PExpr) : bool { def collect_member (obj : PExpr, acc) { match (obj) { // name in expressions has always one element in name | <[ $(n : name) ]> => def env = n.context; match (env.LookupType (n.Id :: acc)) { | Some => true | _ => false } | <[ $head.$(id : dyn) ]> => collect_member (head, id :: acc) | _ => false } }; collect_member (e, []) } /** Checks if given expression describes name of a type, like [System.Console] (it is a class) */ public GetIfIsType (env : GlobalEnv, e : PExpr) : option [TypeInfo] { def collect_member (obj : PExpr, acc) { match (obj) { // name in expressions has always one element in name | <[ $(n : name) ]> => def env = n.GetEnv (env); env.LookupType (n.Id :: acc) | <[ $head.$(id : dyn) ]> => collect_member (head, id :: acc) | _ => None () } }; collect_member (e, []) } public DefaultValueOfType (ty : MType) : PExpr { <[ $(Typedtree.TExpr.DefaultValue (ty) : typed) ]> } /** Lifts given list of expressions to syntax tree of list containing elements, whose syntax trees are defined by those expressions. (expressions on the list are not lifted) */ internal Lift (l : list[PExpr]) : PExpr { | x :: xs => <[ $x :: $(Lift (xs)) ]> | [] => <[ list.Nil () ]> } /** Lifts given list to syntax tree of this list, applying supplied function to each of its elements. The function is used here to lift elements of list, so we can build entire syntax trees from them. */ public Lift['a] (l : list['a], f : 'a -> PExpr) : PExpr { <[ [.. $(List.Map (l, f)) ] ]> } public Lift['a] (o : option ['a], f : 'a -> PExpr) : PExpr { match (o) { | Some (v) => <[ Some ($(f (v))) ]> | _ => <[ None () ]> } } /** Creates syntax tree of given number (expression building it) */ public Lift (x : int) : PExpr { <[ $(x : int) ]> } public Lift (x : string) : PExpr { <[ $(x : string) ]> } // QUOTATION HANDLING SECTION public TypedChoose (e : Typedtree.TExpr) : PExpr { PExpr.Typed (e) } public TypedChoose (e : MType) : PExpr { PExpr.TypedType (e) } public TypedChoose (e : TyVar) : PExpr { PExpr.TypedType (e) } /** Lifts up [Splicable]. [Splicable.Expression] is substituted by its content and appropriate [Splicable.Name] expression is created. */ quoted_sstring (st : Splicable) : PExpr { match (st) { | Splicable.Name (name) => assert (name.context != null); <[ Splicable.Name ($(quoted_name (name))) ]> | Splicable.Expression (PExpr.TypeEnforcement (e, <[ $(ty : name) ]> )) => match (ty.Id) { | "name" => <[ Splicable.Name ($e) ]> | "global" => <[ Splicable.Name (Name.Global (Macros.Manager(), $e)) ]> | "dyn" => <[ Splicable.Name (Name ($e, -1, ManagerClass.Instance.MacroColors.UseContext)) ]> | "usesite" => <[ Splicable.Name (Name ($e, ManagerClass.Instance.MacroColors.UseColor, ManagerClass.Instance.MacroColors.UseContext)) ]> | x => Message.FatalError ("unsupported splicing type `" + x + "' in splicable expression") } | Splicable.Expression (e) => e | Splicable.HalfId => Util.ice ("completion not supported here") | null => <[ null ]> } } /** Lifts up [Name] giving it supplied context number. */ quoted_name (n : Name, context : int) : PExpr { <[ Name.NameInCurrentColor ($(n.Id : string), $("_N_MacroContexts" : dyn).Get ($(context : int), ManagerClass.Instance)) ]> } quoted_name (n : Name) : PExpr { quoted_name (n, n.context.GetMacroContext()) } public QuotedMatchCase (cas : MatchCase) : PExpr { def guards = cas.patterns; def expr = cas.body; match (guards) { | [PExpr.Ellipsis (args)] => <[ MatchCase ($(quoted_expr (args)), $(quoted_expr (expr))) ]> | _ => <[ MatchCase ($(Lift (guards, quoted_expr)), $(quoted_expr (expr))) ]> } } public quoted_fparam (p : Fun_parm) : PExpr { match (p) { | <[ parameter: $name : $ty ]> => <[ Fun_parm (name = $(quoted_sstring (name)), ty = $(quoted_expr (ty)), modifiers = Modifiers (mods = NemerleAttributes.None, custom_attrs = [])) ]> | <[ parameter: params $name : $ty ]> => def qattr = quoted_expr (<[ System.ParamArrayAttribute ]>); <[ Fun_parm (name = $(quoted_sstring (name)), ty = $(quoted_expr (ty)), modifiers = Modifiers (mods = NemerleAttributes.None, custom_attrs = [$qattr])) ]> | <[ parameter: $name : $ty = $expr ]> => def e = quoted_expr (expr); def qattr = quoted_expr (<[ System.ComponentModel.DefaultValueAttribute ($e) ]>); <[ Fun_parm (name = $(quoted_sstring (name)), ty = $(quoted_expr (ty)), modifiers = Modifiers (mods = NemerleAttributes.None, custom_attrs = [$qattr])) ]> | <[ parameter: ..$attrs $name : $ty ]> => <[ Fun_parm (name = $(quoted_sstring (name)), ty = $(quoted_expr (ty)), modifiers = $(quoted_attributes (attrs))) ]> } } quoted_tparms (tyvars : list [Splicable], constraints : list [Constraint]) : PExpr { def quoted_constr (c : Constraint) { <[ Constraint ($(quoted_sstring (c.tyvar)), $(quoted_expr (c.ty))) ]> } match (constraints) { | [Constraint where (null, PExpr.Tuple ([PExpr.Wildcard, PExpr.Ellipsis (PExpr.Spliced (e))]))] => <[ Typarms ($(Lift (tyvars, quoted_sstring)), $e) ]> | [Constraint where (null, PExpr.Tuple ([PExpr.Ellipsis (PExpr.Spliced (e1)), PExpr.Ellipsis (PExpr.Spliced (e2))]))] => <[ Typarms ($e1, $e2) ]> | Constraint where (null, PExpr.Tuple ([PExpr.Ellipsis (PExpr.Spliced (e)), PExpr.Void])) :: where_cts => <[ Typarms ($e, $(Lift (where_cts, quoted_constr))) ]> | _ => <[ Typarms ($(Lift (tyvars, quoted_sstring)), $(Lift (constraints, quoted_constr))) ]> } } make_quoted_funheader (parms : list[Fun_parm], qtparms : PExpr, ty : PExpr, qname : PExpr) : PExpr { def qparms = match (parms) { | [Fun_parm where (name = Splicable.Name, ty = PExpr.Void, modifiers = Modifiers where (custom_attrs = [PExpr.Ellipsis (e)]))] => quoted_expr (e) | _ => Lift (parms, quoted_fparam) }; def qtype = quoted_expr (ty); <[ Fun_header ($qtparms, $qname, $qtype, $qparms) ]> } make_quoted_fundecl (parms : list[Fun_parm], qtparms : PExpr, ty : PExpr, qname : PExpr, body : PExpr) : PExpr { def qheader = make_quoted_funheader (parms, qtparms, ty, qname); def qbody = quoted_expr (body); <[ Function_decl ($qheader, $qbody) ]> } quoted_attributes (attrs : Modifiers) : PExpr { | null => <[ null ]> | Modifiers where (custom_attrs = [PExpr.Ellipsis (e)]) => quoted_expr (e) | _ => <[ Modifiers (($((attrs.mods :> int) : int) :> NemerleAttributes), $(Lift (attrs.custom_attrs, quoted_expr))) ]> } internal quoted_member (mem : ClassMember) : PExpr { def qnm = quoted_sstring (mem.name); def qattrs = quoted_attributes (mem.modifiers); match (mem) { | ClassMember.TypeDeclaration (td) => <[ ClassMember.TypeDeclaration (name = $qnm, modifiers = $qattrs, td = $(quoted_tydecl (td))) ]> | ClassMember.Field (t) => // | <[ decl: ..$_ $_ : $t; ]> => // field <[ ClassMember.Field (name = $qnm, modifiers = $qattrs, ty = $(quoted_expr (t))) ]> // Example // <[ decl: ..$attrs $n < ..$tparms> (..$fparms) : $t where ..$cts // implements ..$impl $body ]> | ClassMember.Function ( header = Fun_header where ( typarms = Typarms where (tparms, cts), ret_type = t, parms = fparms), implemented = implemented, body = bd) => def qtparms = quoted_tparms (tparms, cts); def qhd = make_quoted_funheader (fparms, qtparms, t, qnm); <[ ClassMember.Function (name = $qnm, modifiers = $qattrs, header = $qhd, implemented = $(lift_with_ellipsis (implemented)), body = $(quoted_funbody (bd))) ]> | ClassMember.EnumOption (val) => def qval = Lift (val, quoted_expr); <[ ClassMember.EnumOption (name = $qnm, modifiers = $qattrs, value = $qval) ]> | ClassMember.Event ( ty = t, add = a, remove = r, field = f) => <[ ClassMember.Event (name = $qnm, modifiers = $qattrs, ty = $(quoted_expr (t)), add = $(quoted_member (a)), remove = $(quoted_member (r)), field = $(if (f != null) quoted_member (f) else <[ null ]>)) ]> | ClassMember.Property (ty = t, prop_ty = p, dims = fps, set = s, get = g) => def qfps = Lift (fps, quoted_fparam); <[ ClassMember.Property (name = $qnm, modifiers = $qattrs, ty = $(quoted_expr (t)), prop_ty = $(quoted_expr (p)), set = $(Lift (s, quoted_member)), get = $(Lift (g, quoted_member)), dims = $qfps) ]> } } private lift_members (members : list [ClassMember]) : PExpr { | [Field (Ellipsis (e)) as f] when f.name == null && f.modifiers == null => quoted_expr (e) | _ => Lift (members, quoted_member); } private lift_with_ellipsis (exprs : list [PExpr]) : PExpr { | [Ellipsis (e)] => quoted_expr (e) | _ => Lift (exprs, quoted_expr); } internal quoted_tydecl (td : TopDeclaration) : PExpr { def qn = quoted_sstring (td.name); def qattr = quoted_attributes (td.modifiers); def qtparms = if (td.typarms != null) quoted_tparms (td.typarms.tyvars, td.typarms.constraints) else <[ null ]>; match (td) { | TopDeclaration.Class ( t_extends = extend, decls = members) => def qexten = lift_with_ellipsis (extend); def qmems = lift_members (members); <[ TopDeclaration.Class (name = $qn, modifiers = $qattr, t_extends = $qexten, typarms = $qtparms, decls = $qmems) ]> | TopDeclaration.Alias ( ty = t) => <[ TopDeclaration.Alias (name = $qn, modifiers = $qattr, typarms = $qtparms, ty = $(quoted_expr (t))) ]> | TopDeclaration.Interface (t_extends = extend, methods = members) => def qexten = lift_with_ellipsis (extend); def qmems = lift_members (members); <[ TopDeclaration.Interface (name = $qn, modifiers = $qattr, t_extends = $qexten, typarms = $qtparms, methods = $qmems) ]> | TopDeclaration.Variant (t_extends = extend, decls = members) => def qexten = lift_with_ellipsis (extend); def qmems = lift_members (members); <[ TopDeclaration.Variant (name = $qn, modifiers = $qattr, t_extends = $qexten, typarms = $qtparms, decls = $qmems) ]> | TopDeclaration.VariantOption (decls = members) => def qmems = lift_members (members); <[ TopDeclaration.VariantOption (name = $qn, modifiers = $qattr, typarms = $qtparms, decls = $qmems) ]> | TopDeclaration.Enum (t_extends = extend, decls = members) => def qexten = lift_with_ellipsis (extend); def qmems = lift_members (members); <[ TopDeclaration.Enum (name = $qn, modifiers = $qattr, t_extends = $qexten, typarms = $qtparms, decls = $qmems) ]> | TopDeclaration.Delegate (hea) => def qhtparms = quoted_tparms (hea.typarms.tyvars, hea.typarms.constraints); def qhd = make_quoted_funheader (hea.parms, qhtparms, hea.ret_type, quoted_sstring (hea.name)); <[ TopDeclaration.Delegate (name = $qn, modifiers = $qattr, typarms = $qtparms, header = $qhd) ]> | TopDeclaration.Macro => Message.FatalError ("quoting macro is not supported - macros should not create macros, it is Bad(TM)"); } } quoted_funbody (x : FunBody) : PExpr { match (x) { | FunBody.Parsed (expr) => <[ FunBody.Parsed ($(quoted_expr (expr))) ]> | FunBody.Typed (expr) => <[ FunBody.Parsed ($(expr : typed)) ]> | null // this is for parsed events without accessors | FunBody.Abstract => <[ FunBody.Abstract () ]> | FunBody.ILed => <[ FunBody.ILed () ]> } } quoted_literal (lit : Literal) : PExpr { | Literal.Void => <[ Literal.Void () ]> | Literal.Null => <[ Literal.Null () ]> | Literal.String (val) => <[ Literal.String ($(val : string)) ]> | Literal.Float (val) => <[ Literal.Float ($(val : float)) ]> | Literal.Double (val) => <[ Literal.Double ($(val : double)) ]> | Literal.Decimal (val) => <[ Literal.Decimal ($(val : decimal)) ]> | Literal.Integer (val, is_negative, _) => <[ Literal.Integer ($(val : ulong), $(is_negative : bool), null).WithProperType () ]> | Literal.Bool (val) => <[ Literal.Bool ($(val : bool)) ]> | Literal.Char (val) => <[ Literal.Char ($(val : char)) ]> | Literal.Enum (l, _, _) => <[ Literal.Enum ($(quoted_literal (l)), null, null) ]> } public quoted_fundecl (d : Function_decl) : PExpr { def <[ fundecl: $name [ ..$typarms] (..$args) : $ty where ..$tyconstrs $body ]> = d; def qtparms = quoted_tparms (typarms, tyconstrs); def qname = quoted_sstring (name); make_quoted_fundecl (args, qtparms, ty, qname, body) } /** Creates parse tree of (expression which builds) given typed type. */ public quoted_ttype (t : PExpr) : PExpr { def constructor (tycon, args) { def tyco = match (Util.QidOfExpr (tycon)) { | Some ((s, _)) => Lift (s, Lift) | _ => Message.FatalError ("type constructor must be qualified id"); } def findtyco = <[ match (Macros.ImplicitCTX ().Env.LookupType ($tyco)) { | Some (x) => x | None => Message.FatalError ("unbound type " + $tyco.ToString (".")) } ]>; match (args) { | [PExpr.Ellipsis(ar)] => <[ MType.Class ($findtyco, $(quoted_ttype (ar))) ]> | _ => <[ MType.Class ($findtyco, $(Lift (args, quoted_ttype))) ]> } } match (t) { | <[ $tycon [ .. $args ] ]> => constructor (tycon, args) | <[ $(_ : name) ]> | <[ $_.$_ ]> => constructor (t, []) | <[ ref $ty ]> => <[ MType.Ref ($(quoted_ttype (ty))) ]> | <[ out $ty ]> => <[ MType.Out ($(quoted_ttype (ty))) ]> | <[ $from -> $to ]> => <[ MType.Fun ($(quoted_ttype (from)), $(quoted_ttype (to))) ]> | <[ void ]> => <[ InternalType.Void ]> | <[ @* (..$args) ]> => def x = Lift (args, quoted_ttype); <[ MType.Tuple ($x) ]> | <[ array [ $r, $ty] ]> => <[ MType.Array ($(quoted_ttype (ty)), $(quoted_expr (r))) ]> // rest of constructs must be in not quoted form, because they define // internal data structures | PExpr.Spliced (PExpr.TypeEnforcement (val, <[ $(ty : name) ]>)) => match (ty.Id) { | "name" => <[ MType.TyVarRef ($val) ]> // it doesn't make much sense here, as it is the same as <[ $v ]>, // but we put it here for consistency | "typed" => val | x => Message.FatalError ("unsupported type of spliced special token `" + x + "' in typed type") } | PExpr.Spliced (e) => e | PExpr.Wildcard => <[ Manager.Solver.FreshTyVar () ]> | PExpr.Ellipsis (ar) => <[ MType.Tuple ($(quoted_ttype (ar))) ]> | PExpr.Typed => Util.ice ("You've got beer from me for generating such a code..."); | _ => Util.ice ("quoted code not supported: " + PrettyPrint.SprintExpr (None (), t)); } } public quoted_expr (expr : PExpr) : PExpr { match (expr) { | null => <[ null ]> | <[ $(id : name) ]> => assert (id.context != null, id.Id); <[ PExpr.Ref ($(quoted_name (id, id.context.GetMacroContext ()))) ]> | <[ $obj . $mem ]> => <[ PExpr.Member ($(quoted_expr (obj)), $(quoted_sstring (mem))) ]> | <[ $func (.. $parms) ]> => <[ PExpr.Call ($(quoted_expr (func)), $(lift_with_ellipsis (parms))) ]> | <[ $func .[..$parms] ]> => <[ PExpr.GenericSpecifier ($(quoted_expr (func)), $(lift_with_ellipsis (parms))) ]> | <[ $target = $source ]> => <[ PExpr.Assign ($(quoted_expr (target)), $(quoted_expr (source))) ]> | <[ def $name = $val ]> => <[ PExpr.Define ($(quoted_expr (name)), $(quoted_expr (val))) ]> | <[ mutable $name = $val ]> => <[ PExpr.DefMutable ($(quoted_expr (name)), $(quoted_expr (val))) ]> | <[ def .. $funs ]> => match (funs) { | [Function_decl where (_, PExpr.Ellipsis (args))] => <[ PExpr.DefFunctions ($(quoted_expr (args))) ]> | _ => <[ PExpr.DefFunctions ($(Lift (funs, quoted_fundecl))) ]> }; | <[ fun [ ..$typarms] (..$args) : $ty where .. $tyconstrs $body ]> => def qtparms = quoted_tparms (typarms, tyconstrs); def qname = <[ Splicable.Name (Name ("")) ]>; // lift function declaration from lambda expression def fdecl = make_quoted_fundecl (args, qtparms, ty, qname, body); // return syntax tree of lifted lambda <[ PExpr.Lambda ($fdecl) ]> | <[ match ($expr) {.. $cases } ]> => match (cases) { | [cas] when cas.patterns is [] => match (cas.body) { | PExpr.Ellipsis (e) => <[ PExpr.Match ($(quoted_expr (expr)), $(quoted_expr (e))) ]> | _ => Util.ice ("parser generated strange match_case") } | _ => <[ PExpr.Match ($(quoted_expr (expr)), $(Lift (cases, QuotedMatchCase))) ]> } | <[ throw $exc ]> => <[ PExpr.Throw ($(quoted_expr (exc))) ]> | <[ ref $e ]> => <[ PExpr.ParmByRef ($(quoted_expr (e))) ]> | <[ out $e ]> => <[ PExpr.ParmOut ($(quoted_expr (e))) ]> | <[ try $body finally $handler ]> => assert (body != null); assert (handler != null); <[ PExpr.TryFinally ($(quoted_expr (body)), $(quoted_expr (handler))) ]> | <[ try $body catch { ..$cases } ]> => def quoted_case (case) { | TryCase.Catch (exn, exn_ty, handler) => <[ TryCase.Catch ($(quoted_sstring (exn)), $(quoted_expr (exn_ty)), $(quoted_expr (handler))) ]> | TryCase.Filter (exn, exn_ty, filter, handler) => <[ TryCase.Filter ($(quoted_sstring (exn)), $(quoted_expr (exn_ty)), $(quoted_expr (filter)), $(quoted_expr (handler))) ]> | TryCase.Ellipsis => Util.ice ("you can have either none or only TryCase.Ellipsis") } def qbody = quoted_expr (body); match (cases) { | [TryCase.Ellipsis (e)] => match (e) { | PExpr.Ellipsis (e) => <[ PExpr.Try ($qbody, $(quoted_expr (e))) ]> | _ => Util.ice ("parser generated strange try_case") } | _ => <[ PExpr.Try ($qbody, [.. $(cases.Map (quoted_case))]) ]> } | PExpr.Literal (lit) => <[ PExpr.Literal ($(quoted_literal (lit))) ]> | <[ this ]> => <[ PExpr.This () ]> | <[ base ]> => <[ PExpr.Base () ]> | <[ typeof ($t) ]> => <[ PExpr.Typeof ($(quoted_expr (t))) ]> | <[ $expr : $ty ]> => <[ PExpr.TypeEnforcement ($(quoted_expr (expr)), $(quoted_expr (ty))) ]> | <[ $expr :> $ty ]> => <[ PExpr.TypeConversion ($(quoted_expr (expr)), $(quoted_expr (ty))) ]> | <[ {.. $seq } ]> => <[ PExpr.Sequence ($(lift_with_ellipsis (seq))) ]> | <[ (.. $args) ]> => <[ PExpr.Tuple ($(lift_with_ellipsis (args))) ]> | <[ array .[ $rank ] $value ]> => <[ PExpr.Array ($(quoted_expr (rank)), $(quoted_expr (value))) ]> | <[ array (.. $sizes) ]> => <[ PExpr.EmptyArray ($(lift_with_ellipsis (sizes))) ]> | <[ $obj [.. $args] ]> => <[ PExpr.Indexer ($(quoted_expr (obj)), $(lift_with_ellipsis (args))) ]> | <[ _ ]> => <[ PExpr.Wildcard () ]> | <[ void ]> => <[ PExpr.Void () ]> | <[ $pat as $name ]> => <[ PExpr.As ($(quoted_expr (pat)), $(quoted_sstring (name))) ]> | <[ $e1 is $e2 ]> => <[ PExpr.Is ($(quoted_expr (e1)), $(quoted_expr (e2))) ]> | <[ $e1 where $e2 ]> => <[ PExpr.Where ($(quoted_expr (e1)), $(quoted_expr (e2))) ]> | PExpr.ListLiteral (elems) => <[ PExpr.ListLiteral ($(lift_with_ellipsis (elems))) ]> // rest of constructs must be in not quoted form, because they define // internal data structures | PExpr.MacroCall (name, namespc, parms) => def quoted_syntax (s) { | SyntaxElement.Expression (body) => <[ SyntaxElement.Expression ($(quoted_expr (body))) ]> | SyntaxElement.MatchCase (body) => <[ SyntaxElement.MatchCase ($(QuotedMatchCase (body))) ]> | SyntaxElement.Function (body) => <[ SyntaxElement.Function ($(quoted_fundecl (body))) ]> | SyntaxElement.Parameter (body) => <[ SyntaxElement.Parameter ($(quoted_fparam (body))) ]> | SyntaxElement.ClassMember (body) => <[ SyntaxElement.ClassMember ($(quoted_member (body))) ]> | SyntaxElement.TType (body) => <[ SyntaxElement.TType ($(quoted_ttype (body))) ]> | SyntaxElement.RawToken | SyntaxElement.TypeBuilder | SyntaxElement.MethodBuilder | SyntaxElement.FieldBuilder | SyntaxElement.PropertyBuilder | SyntaxElement.EventBuilder | SyntaxElement.ParameterBuilder => Util.ice ("syntax elements shouldn't appear in quotations") }; assert (name.context != null); <[ PExpr.MacroCall ($(quoted_name (name, name.context.GetMacroContext ())), ManagerClass.Instance.NameTree.ExactPath ($(Lift (namespc.FullName, Lift))), $(Lift (parms, quoted_syntax))) ]> | PExpr.Error => <[ PExpr.Error () ]> | PExpr.ToComplete => Util.ice ("completion not supported here") | PExpr.Spliced (PExpr.TypeEnforcement (val, <[ $(ty : name) ]>)) => match (ty.Id) { | "name" => <[ PExpr.Ref ($val) ]> | "usesite" => <[ PExpr.Ref (Name ($val, ManagerClass.Instance.MacroColors.UseColor, ManagerClass.Instance.MacroColors.UseContext)) ]> | "dyn" => <[ PExpr.Ref (Name ($val, -1, null)) ]> | "global" => <[ PExpr.Ref (Name.Global (Macros.Manager(), $val)) ]> | "byte" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromByte ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "sbyte" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromSByte ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "short" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromShort ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "ushort" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromUShort ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "int" => <[ PExpr.Literal (Literal.FromInt ($val)) ]> | "uint" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromUInt ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "long" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromLong ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "ulong" => <[ PExpr.TypeEnforcement (PExpr.Literal (Literal.FromULong ($val)), PExpr.Ref ($(quoted_name (ty)))) ]> | "string" => <[ PExpr.Literal (Literal.String ($val)) ]> | "bool" => <[ PExpr.Literal (Literal.Bool ($val)) ]> | "char" => <[ PExpr.Literal (Literal.Char ($val)) ]> | "float" => <[ PExpr.Literal (Literal.Float ($val)) ]> | "double" => <[ PExpr.Literal (Literal.Double ($val)) ]> | "decimal" => <[ PExpr.Literal (Literal.Decimal ($val)) ]> | "enum" => <[ PExpr.Literal (Literal.FromObject ($val)) ]> | "typed" => <[ Macros.TypedChoose ($val) ]> | x => Message.FatalError ("unsupported type `" + x + "' of spliced literal in expression") } | PExpr.Spliced (e) when !Manager.Macros_in_pattern => e | PExpr.Spliced => expr | PExpr.Lambda => Util.ice ("this kind of quoted fun () ... is not supported") | PExpr.Quoted => Message.FatalError ("compound of several <[ ... ]> macro scopes is" " not allowed"); | PExpr.Typed | PExpr.TypedPattern | PExpr.TypedType => Util.ice ("You've got beer from me for generating such a code (and me to)..."); | PExpr.Ellipsis => Message.FatalError (expr.Location, "List of expression parameters outside of quoted sequence:" " use <[ { .. $x } ]> pattern") } } // end quoted_expr /** transforms given expression (which is supposed to be generated from quoted expression) into pattern */ public patternize_quotation (exp : PExpr) : PExpr { | PExpr.Ref => exp | <[ $obj . $mem ]> => <[ $(patternize_quotation (obj)) . $mem ]> // Literal.Integer (2, true, null).WithProperType () // (it is created only when quoting plain numeric literals | <[ Literal.$_ ($v, $n, $_) . $_ () ]> => <[ Literal.Integer ($v, $n, _) ]> | <[ $constr (.. $pars) ]> => def (con, name) = Option.UnSome (Util.QidOfExpr (constr)); def last = con.Last; match (name.context.LookupType (con)) { | Some (tcon) => def convert_params (pars : list [PExpr], mems : list[IField], acc) { match ((pars, mems)) { | ([], []) => List.Rev (acc) | (<[ $(n : name) = $expr ]> :: xs, ms) => convert_params (xs, ms, <[ $(n : name) = $(patternize_quotation (expr)) ]> :: acc) | (expr :: xs, m :: ms) => convert_params (xs, ms, <[ $(m.Name : dyn) = $(patternize_quotation (expr)) ]> :: acc) | ([], _ :: _) => convert_params ([], [], acc) | (_ :: _, []) => Message.Error ("number of supplied parameters is too large"); [] } }; def unalias (tcon : TypeInfo) { def flds = tcon.GetFields (BindingFlags.DeclaredOnly %| BindingFlags.Public %| BindingFlags.NonPublic %| BindingFlags.Instance); match (tcon.GetTydecl ()) { | Typedtree.TypeDeclaration.VariantOption => def pars = if (last.EndsWith ("ClassMember.Function")) List.Tail (pars) else pars; PExpr.Call (constr, convert_params (pars, flds, [])) | Typedtree.TypeDeclaration.Class => // we lose informations about constructor here, but as it's // compiler internal computation we can ignore it def name_expr = Util.ExprOfQid (tcon.FullName); if (last.EndsWith ("Name")) <[ $name_expr where ( idl = $(patternize_quotation (List.Head (pars))) ) ]> else PExpr.Where (name_expr, PExpr.Tuple (convert_params (pars, flds, []))) | Typedtree.TypeDeclaration.Alias (MType.Class (tc, _)) => unalias (tc) | _ => Util.ice ("expression generated from quotation has neither variant" " nor class constructor") } } unalias (tcon) | None when last.EndsWith ("NameInCurrentColor") => <[ Name where ( idl = $(patternize_quotation (List.Head (pars))) ) ]> | None when last.EndsWith ("ExactPath") => PExpr.Wildcard () | None when last.EndsWith ("TypedChoose") => Message.Error ("typed tree cannot be used in pattern matching"); <[ () ]> | None when last.StartsWith ("From") => <[ Literal.Integer ($(last.Replace ("From", "As") : dyn) = Some ($(patternize_quotation (List.Head (pars))))) ]> | None => //Util.ice ($ "expression generated from quotation has broken constructor $exp") DebugStop(); Message.Error ($"expression generated from quotation has broken constructor $exp"); <[ () ]> } | PExpr.ListLiteral (elems) => PExpr.ListLiteral (List.Map (elems, patternize_quotation)) | <[ (..$elems) ]> => <[ (..$(List.Map (elems, patternize_quotation))) ]> | PExpr.Literal | PExpr.Wildcard => exp | PExpr.Spliced (e) => e | _ => Message.Debug (exp.ToString ()); Util.ice ("Bad constructed quoted expression in pattern matching") } DebugStop() : void { } /** * Allows recursive analysing and rewriting given parse tree expression easily. It calls supplied function on every * node of tree returning its result as new node. * * [ctx] - when specified, then expression is first macro-expanded and expansion result is then further analyzed * [expr] - expression to be processed * [in_pattern] - context boolean used to provide information if we are currently in match case pattern * [call] - function called for each node of tree, first parameter hold the [in_pattern] semantics; second denotes if we are calling the * function before processing of subnodes (==false) and after (==true) - the function is always called twice for each node; * third passes the current node to operate on; return value (used only from second/postprocess call) is used as new node value */ public TraverseExpr (ctx : option[Typer], expr : PExpr, in_pattern : bool, call : bool * bool * PExpr -> PExpr) : PExpr { if (expr == null) null else Util.locate (expr.Location, { def expr = match (ctx) { | Some (c) => MacroRegistry.expand_macro (c, expr) [0] | _ => expr }; def trav_funparms (fps) { def go_funparm (p : Fun_parm) { | <[ parameter: $n : $t = $_e ]> => <[ parameter: $n : $t = $(traverse (_e)) ]> | _ => p }; List.Map (fps, go_funparm) }; def traverse (x) { TraverseExpr (ctx, x, in_pattern, call) }; def traversep (x) { TraverseExpr (ctx, x, true, call) }; _ = call (in_pattern, false, expr); def recursed = match (expr) { | <[ $(_ : name) ]> => expr | <[ $obj . $mem ]> => <[ $(traverse (obj)) . $mem ]> | <[ $func (.. $parms) ]> => <[ $(traverse (func)) (..$(parms.Map (traverse))) ]> | <[ $func .[.. $parms] ]> => <[ $(traverse (func)) .[..$(parms.Map (traverse))] ]> | <[ $target = $source ]> => <[ $(traverse (target)) = $(traverse (source)) ]> | <[ def $n = $val ]> => <[ def $(traversep (n)) = $(traverse (val)) ]> | <[ mutable $n = $val ]> => <[ mutable $(traversep (n)) = $(traverse (val)) ]> | <[ match ($mexpr) {.. $cases } ]> => def go_case (c : MatchCase) { def go_guard (g : PExpr) { | <[ $pat when $e ]> => <[ $(traversep (pat)) when $(traverse (e)) ]> | _ => traversep (g) }; def <[ case: | ..$guards => $exp ]> = c; def guards = List.Map (guards, go_guard); <[ case: | ..$guards => $(traverse (exp)) ]> }; def cases = List.Map (cases, go_case); <[ match ($(traverse (mexpr))) {.. $cases } ]> | <[ throw $exc ]> => <[ throw $(traverse (exc)) ]> | PExpr.TryFinally (body, handler) => PExpr.TryFinally (traverse (body), traverse (handler)) | PExpr.Try (body, cases) => def walk_case (case) { | TryCase.Catch (exn, exn_ty, handler) => TryCase.Catch (exn, exn_ty, traverse (handler)) | TryCase.Filter (exn, exn_ty, filter, handler) => TryCase.Filter (exn, exn_ty, traverse (filter), traverse (handler)) | TryCase.Ellipsis (e) => TryCase.Ellipsis (traverse (e)) } PExpr.Try (traverse (body), cases.Map (walk_case)) | PExpr.Literal => expr | <[ this ]> => expr | <[ base ]> => expr | <[ typeof ($_) ]> => expr | <[ $expr :> $ty ]> => <[ $(traverse (expr)) :> $ty ]> | <[ $expr : $ty ]> => <[ $(traverse (expr)) : $ty ]> | <[ {.. $seq } ]> => <[ { ..$(List.Map (seq, traverse)) } ]> | <[ (.. $args) ]> => <[ ( ..$(List.Map (args, traverse)) ) ]> | <[ ref $e ]> => <[ ref $(traverse (e)) ]> | <[ out $e ]> => <[ out $(traverse (e)) ]> | <[ array (..$args) ]> => <[ array ( ..$(List.Map (args, traverse)) ) ]> | <[ array $args ]> => <[ array $(traverse (args)) ]> | <[ array .[ $rank ] $args ]> => <[ array .[ $(traverse (rank))] $(traverse (args)) ]> | <[ $obj [.. $args] ]> => <[ $(traverse (obj)) [ ..$(List.Map (args, traverse)) ] ]> | <[ fun [ ..$tparms] (..$args) where ..$tconstrs $body ]> => def args = trav_funparms (args); <[ fun [ ..$tparms] (..$args) where ..$tconstrs $(traverse (body)) ]> | <[ def ..$funs ]> => def go_fun (f : Function_decl) { | <[ fundecl: $n [ ..$tparms] (..$args) where .. $tconstrs $body ]> => def args = trav_funparms (args); <[ fundecl: $n [ ..$tparms] (..$args) where .. $tconstrs $(traverse (body)) ]> | _ => f }; <[ def ..$(List.Map (funs, go_fun)) ]> | <[ $pat as $nm ]> => PExpr.As (traverse (pat), nm) | <[ $nm where $pat ]> => PExpr.Where (traverse (nm), traverse (pat)) | <[ $e1 is $e2 ]> => PExpr.Is (traverse (e1), traverse (e2)) | PExpr.ListLiteral (elems) => PExpr.ListLiteral (List.Map (elems, traverse)) | PExpr.ToComplete | PExpr.Error | PExpr.Wildcard | PExpr.Void => expr | PExpr.MacroCall (x, namespc, parms) => def go_parm (y) { | SyntaxElement.Expression (e) => SyntaxElement.Expression (traverse (e)) | _ => y }; PExpr.MacroCall (x, namespc, List.Map (parms, go_parm)) | PExpr.Spliced (e) => PExpr.Spliced (traverse (e)) | PExpr.Ellipsis (e) => PExpr.Ellipsis (traverse (e)) | PExpr.Quoted (quot) => def inner = match (quot) { | SyntaxElement.Expression (body) => SyntaxElement.Expression (traverse (body)) | SyntaxElement.MatchCase | SyntaxElement.Function | SyntaxElement.Parameter | SyntaxElement.TType | SyntaxElement.ClassMember | SyntaxElement.TypeBuilder | SyntaxElement.FieldBuilder | SyntaxElement.MethodBuilder | SyntaxElement.PropertyBuilder | SyntaxElement.EventBuilder | SyntaxElement.RawToken | SyntaxElement.ParameterBuilder => quot } PExpr.Quoted (inner) | PExpr.Typed | PExpr.TypedPattern | PExpr.TypedType => expr | PExpr.Lambda => Util.ice ("Bad construction of PExpr.Lambda") }; call (in_pattern, true, recursed) }) } public RecursiveRename (tc : TypeBuilder, expr : PExpr, from : Name, to : Name) : PExpr { def rename_expr (_, is_post, e) { if (is_post) match (e) { | <[ $(n : name) ]> when n.Equals (from) => <[ $(to : name) ]> | <[ mutable $(n : name) = $val ]> when n.Equals (from) => <[ mutable $(to : name) = $val ]> | <[ this.$(n : name) ]> when n.Equals (from) => <[ this.$(to : name) ]> | <[ $obj.$(n : name) ]> when n.Equals (from) => match (GetIfIsType (tc.GlobalEnv, obj)) { | Some (t) when t.Equals (tc) => <[ $obj.$(to : name) ]> | _ => e } | <[ try $body catch { ..$cases } ]> => mutable changed = false; def walk_case (case) { | TryCase.Catch (Splicable.Name (exn), exn_ty, handler) when exn.Equals (from) => changed = true; TryCase.Catch (Splicable.Name (to), exn_ty, handler) | TryCase.Filter (Splicable.Name (exn), exn_ty, filter, handler) when exn.Equals (from) => changed = true; TryCase.Filter (Splicable.Name (to), exn_ty, filter, handler) | TryCase.Catch | TryCase.Filter | TryCase.Ellipsis => case } def cases = cases.Map (walk_case); if (changed) PExpr.Try (body, cases) else e | _ => e } else e } Util.locate (expr.Location, { TraverseExpr (None (), expr, false, rename_expr) }); } } } // end ns