diff --git a/src/fsharp/FSharp.Core/quotations.fs b/src/fsharp/FSharp.Core/quotations.fs index 464f8a6a46e..3c1fea9d34b 100644 --- a/src/fsharp/FSharp.Core/quotations.fs +++ b/src/fsharp/FSharp.Core/quotations.fs @@ -18,6 +18,7 @@ open Microsoft.FSharp.Reflection open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Text.StructuredPrintfImpl open Microsoft.FSharp.Text.StructuredPrintfImpl.LayoutOps +open Microsoft.FSharp.Text.StructuredPrintfImpl.TaggedTextOps #nowarn "52" // The value has been copied to ensure the original is not mutated by this operation @@ -227,22 +228,23 @@ and [] let expr (e:Expr ) = e.GetLayout(long) let exprs (es:Expr list) = es |> List.map expr let parens ls = bracketL (commaListL ls) - let pairL l1 l2 = bracketL (l1 ^^ sepL "," ^^ l2) + let pairL l1 l2 = bracketL (l1 ^^ sepL Literals.comma ^^ l2) let listL ls = squareBracketL (commaListL ls) - let combL nm ls = wordL nm ^^ parens ls - let noneL = wordL "None" - let someL e = combL "Some" [expr e] - let typeL (o: Type) = wordL (if long then o.FullName else o.Name) - let objL (o: 'T) = wordL (sprintf "%A" o) - let varL (v:Var) = wordL v.Name + let combTaggedL nm ls = wordL nm ^^ parens ls + let combL nm ls = combTaggedL (tagKeyword nm) ls + let noneL = wordL (tagProperty "None") + let someL e = combTaggedL (tagMethod "Some") [expr e] + let typeL (o: Type) = wordL (tagClass (if long then o.FullName else o.Name)) + let objL (o: 'T) = wordL (tagText (sprintf "%A" o)) + let varL (v:Var) = wordL (tagLocal v.Name) let (|E|) (e: Expr) = e.Tree let (|Lambda|_|) (E x) = match x with LambdaTerm(a,b) -> Some (a,b) | _ -> None let (|IteratedLambda|_|) (e: Expr) = qOneOrMoreRLinear (|Lambda|_|) e - let ucaseL (unionCase:UnionCaseInfo) = (if long then objL unionCase else wordL unionCase.Name) - let minfoL (minfo: MethodInfo) = if long then objL minfo else wordL minfo.Name - let cinfoL (cinfo: ConstructorInfo) = if long then objL cinfo else wordL cinfo.DeclaringType.Name - let pinfoL (pinfo: PropertyInfo) = if long then objL pinfo else wordL pinfo.Name - let finfoL (finfo: FieldInfo) = if long then objL finfo else wordL finfo.Name + let ucaseL (unionCase:UnionCaseInfo) = (if long then objL unionCase else wordL (tagUnionCase unionCase.Name)) + let minfoL (minfo: MethodInfo) = if long then objL minfo else wordL (tagMethod minfo.Name) + let cinfoL (cinfo: ConstructorInfo) = if long then objL cinfo else wordL (tagMethod cinfo.DeclaringType.Name) + let pinfoL (pinfo: PropertyInfo) = if long then objL pinfo else wordL (tagProperty pinfo.Name) + let finfoL (finfo: FieldInfo) = if long then objL finfo else wordL (tagField finfo.Name) let rec (|NLambdas|_|) n (e:Expr) = match e with | _ when n <= 0 -> Some([],e) @@ -259,7 +261,7 @@ and [] | CombTerm(UnionCaseTestOp(unionCase),args) -> combL "UnionCaseTest" (exprs args@ [ucaseL unionCase]) | CombTerm(NewTupleOp _,args) -> combL "NewTuple" (exprs args) | CombTerm(TupleGetOp (_,i),[arg]) -> combL "TupleGet" ([expr arg] @ [objL i]) - | CombTerm(ValueOp(v,_,Some nm),[]) -> combL "ValueWithName" [objL v; wordL nm] + | CombTerm(ValueOp(v,_,Some nm),[]) -> combL "ValueWithName" [objL v; wordL (tagLocal nm)] | CombTerm(ValueOp(v,_,None),[]) -> combL "Value" [objL v] | CombTerm(WithValueOp(v,_),[defn]) -> combL "WithValue" [objL v; expr defn] | CombTerm(InstanceMethodCallOp(minfo),obj::args) -> combL "Call" [someL obj; minfoL minfo; listL (exprs args)] @@ -291,9 +293,9 @@ and [] | NLambdas n (vs,e) -> combL "NewDelegate" ([typeL ty] @ (vs |> List.map varL) @ [expr e]) | _ -> combL "NewDelegate" [typeL ty; expr e] //| CombTerm(_,args) -> combL "??" (exprs args) - | VarTerm(v) -> wordL v.Name + | VarTerm(v) -> wordL (tagLocal v.Name) | LambdaTerm(v,b) -> combL "Lambda" [varL v; expr b] - | HoleTerm _ -> wordL "_" + | HoleTerm _ -> wordL (tagLocal "_") | CombTerm(QuoteOp _,args) -> combL "Quote" (exprs args) | _ -> failwithf "Unexpected term in layout %A" x.Tree diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 8a3dfb8f773..7c5cfd1eb59 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -597,7 +597,9 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = match arity,args with | (0|1),[] when typeEquiv g (domainOfFunTy g fty) g.unit_ty -> mkUnit g m, (args, rangeOfFunTy g fty) | 0,(arg::argst)-> - warning(InternalError(sprintf "Unexpected zero arity, args = %s" (Layout.showL (Layout.sepListL (Layout.rightL ";") (List.map exprL args))),m)); + + + warning(InternalError(sprintf "Unexpected zero arity, args = %s" (Layout.showL (Layout.sepListL (Layout.rightL (Layout.TaggedTextOps.tagText ";")) (List.map exprL args))),m)); arg, (argst, rangeOfFunTy g fty) | 1,(arg :: argst) -> arg, (argst, rangeOfFunTy g fty) | 1,[] -> error(InternalError("expected additional arguments here",m)) diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 4e3bbe6b1b0..5e317becd4b 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -26,6 +26,7 @@ open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.AttributeChecking open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Core.Printf @@ -35,16 +36,14 @@ open Microsoft.FSharp.Compiler.ExtensionTyping open Microsoft.FSharp.Core.CompilerServices #endif - [] module internal PrintUtilities = let bracketIfL x lyt = if x then bracketL lyt else lyt - let squareAngleL x = leftL "[<" ^^ x ^^ rightL ">]" - let angleL x = sepL "<" ^^ x ^^ rightL ">" - let braceL x = leftL "{" ^^ x ^^ rightL "}" + let squareAngleL x = LeftL.leftBracketAngle ^^ x ^^ RightL.rightBracketAngle + let angleL x = sepL Literals.leftAngle ^^ x ^^ rightL Literals.rightAngle + let braceL x = leftL Literals.leftBrace ^^ x ^^ rightL Literals.rightBrace - let commentL l = wordL "(*" ++ l ++ wordL "*)" - let comment str = str |> wordL |> commentL + let comment str = wordL (tagText (sprintf "(* %s *)" str)) let layoutsL (ls : layout list) : layout = match ls with @@ -58,7 +57,7 @@ module internal PrintUtilities = let applyMaxMembers maxMembers (alldecls : _ list) = match maxMembers with - | Some n when alldecls.Length > n -> (alldecls |> List.truncate n) @ [wordL "..."] + | Some n when alldecls.Length > n -> (alldecls |> List.truncate n) @ [wordL (tagPunctuation "...")] | _ -> alldecls /// fix up a name coming from IL metadata by quoting "funny" names (keywords, otherwise invalid identifiers) @@ -69,7 +68,7 @@ module internal PrintUtilities = let shrinkOverloads layoutFunction resultFunction group = match group with | [x] -> [resultFunction x (layoutFunction x)] - | (x:: rest) -> [ resultFunction x (layoutFunction x -- leftL (match rest.Length with 1 -> FSComp.SR.nicePrintOtherOverloads1() | n -> FSComp.SR.nicePrintOtherOverloadsN(n))) ] + | (x:: rest) -> [ resultFunction x (layoutFunction x -- leftL (tagText (match rest.Length with 1 -> FSComp.SR.nicePrintOtherOverloads1() | n -> FSComp.SR.nicePrintOtherOverloadsN(n)))) ] | _ -> [] let layoutTyconRefImpl isAttribute (denv: DisplayEnv) (tcref:TyconRef) = @@ -84,7 +83,7 @@ module internal PrintUtilities = if isAttribute then defaultArg (String.tryDropSuffix name "Attribute") name else name - let tyconTextL = wordL demangled + let tyconTextL = wordL (tagEntityRefName tcref demangled) if denv.shortTypeNames then tyconTextL else @@ -97,7 +96,7 @@ module internal PrintUtilities = if i <> -1 then s.Substring(0,i)+"<...>" // apparently has static params, shorten else s) let pathText = trimPathByDisplayEnv denv path - if pathText = "" then tyconTextL else leftL pathText ^^ tyconTextL + if pathText = "" then tyconTextL else leftL (tagUnknownEntity pathText) ^^ tyconTextL let layoutBuiltinAttribute (denv: DisplayEnv) (attrib: BuiltinAttribInfo) = let tcref = attrib.TyconRef @@ -133,10 +132,11 @@ module private PrintIL = | [ "System"; "Boolean"] -> ["bool"] | _ -> path let p2,n = List.frontAndBack path + let tagged = if n = "obj" || n = "string" then tagClass n else tagStruct n if denv.shortTypeNames then - wordL n + wordL tagged else - leftL (trimPathByDisplayEnv denv p2) ^^ wordL n + leftL (tagNamespace (trimPathByDisplayEnv denv p2)) ^^ wordL tagged let layoutILTypeRef denv tref = let path = fullySplitILTypeRef tref @@ -156,17 +156,17 @@ module private PrintIL = e.RemoveMethod.CallingSignature.CallingConv.IsStatic let private layoutILArrayShape (ILArrayShape sh) = - sepL "[" ^^ wordL (sh |> List.tail |> List.map (fun _ -> ",") |> String.concat "") ^^ rightL "]" // drop off one "," so that a n-dimensional array has n - 1 ","'s + SepL.leftBracket ^^ wordL (tagPunctuation (sh |> List.tail |> List.map (fun _ -> ",") |> String.concat "")) ^^ RightL.rightBracket // drop off one "," so that a n-dimensional array has n - 1 ","'s let private layoutILGenericParameterDefs (ps: ILGenericParameterDefs) = - ps |> List.map (fun x -> "'" + x.Name |> wordL) + ps |> List.map (fun x -> "'" + x.Name |> (tagTypeParameter >> wordL)) let private paramsL (ps: layout list) : layout = match ps with | [] -> emptyL | _ -> let body = Layout.commaListL ps - sepL "<" ^^ body ^^ rightL ">" + SepL.leftAngle ^^ body ^^ RightL.rightAngle let private pruneParms (className: string) (ilTyparSubst: layout list) = let numParms = @@ -179,7 +179,7 @@ module private PrintIL = let rec layoutILType (denv: DisplayEnv) (ilTyparSubst: layout list) (typ : ILType) : layout = match typ with - | ILType.Void -> wordL "unit" // These are type-theoretically totally different type-theoretically `void` is Fin 0 and `unit` is Fin (S 0) ... but, this looks like as close as we can get. + | ILType.Void -> WordL.structUnit // These are type-theoretically totally different type-theoretically `void` is Fin 0 and `unit` is Fin (S 0) ... but, this looks like as close as we can get. | ILType.Array (sh, t) -> layoutILType denv ilTyparSubst t ^^ layoutILArrayShape sh | ILType.Value t | ILType.Boxed t -> layoutILTypeRef denv t.TypeRef ^^ (t.GenericArgs |> List.map (layoutILType denv ilTyparSubst) |> paramsL) @@ -201,9 +201,9 @@ module private PrintIL = | Some className -> layoutILTypeRefName denv (SplitNamesForILPath (ungenericizeTypeName className)) ^^ (pruneParms className ilTyparSubst |> paramsL) // special case for constructor return-type (viz., the class itself) | None -> signatur.ReturnType |> layoutILType denv ilTyparSubst match args with - | [] -> wordL "unit" ^^ wordL "->" ^^ res - | [x] -> x ^^ wordL "->" ^^ res - | _ -> sepListL (wordL "*") args ^^ wordL "->" ^^ res + | [] -> WordL.structUnit ^^ WordL.arrow ^^ res + | [x] -> x ^^ WordL.arrow ^^ res + | _ -> sepListL WordL.star args ^^ WordL.arrow ^^ res /// Layout a function pointer signature using type-only-F#-style. No argument names are printed. // @@ -213,13 +213,13 @@ module private PrintIL = let isParamArray = TryFindILAttribute denv.g.attrib_ParamArrayAttribute p.CustomAttrs match isParamArray, p.Name, p.IsOptional with // Layout an optional argument - | _, Some nm, true -> leftL ("?" + nm + ":") + | _, Some nm, true -> LeftL.questionMark ^^ sepL (tagParameter nm) ^^ SepL.colon // Layout an unnamed argument - | _, None, _ -> leftL ":" + | _, None, _ -> LeftL.colon // Layout a named argument | true, Some nm,_ -> - layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ leftL (nm + ":") - | false, Some nm,_ -> leftL (nm+":") + layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ wordL (tagParameter nm) ^^ SepL.colon + | false, Some nm,_ -> leftL (tagParameter nm) ^^ SepL.colon preL ^^ (layoutILType denv ilTyparSubst p.Type) @@ -234,9 +234,9 @@ module private PrintIL = | Some className -> layoutILTypeRefName denv (SplitNamesForILPath (ungenericizeTypeName className)) ^^ (pruneParms className ilTyparSubst |> paramsL) // special case for constructor return-type (viz., the class itself) | None -> retType |> layoutILType denv ilTyparSubst match parameters with - | [] -> wordL "unit" ^^ wordL "->" ^^ res - | [x] -> layoutILParameter denv ilTyparSubst x ^^ wordL "->" ^^ res - | args -> sepListL (wordL "*") (List.map (layoutILParameter denv ilTyparSubst) args) ^^ wordL "->" ^^ res + | [] -> WordL.structUnit ^^ WordL.arrow ^^ res + | [x] -> layoutILParameter denv ilTyparSubst x ^^ WordL.arrow ^^ res + | args -> sepListL WordL.star (List.map (layoutILParameter denv ilTyparSubst) args) ^^ WordL.arrow ^^ res /// Layout a method's signature using type-only-F#-style. No argument names are printed. @@ -255,33 +255,33 @@ module private PrintIL = let name = adjustILMethodName m.Name let (nameL, isCons) = match () with - | _ when m.IsConstructor -> (wordL "new", Some className) // we need the unadjusted name here to be able to grab the number of generic parameters - | _ when m.IsStatic -> (wordL "static" ^^ wordL "member" ^^ wordL name ^^ (myParms |> paramsL), None) - | _ -> (wordL "member" ^^ wordL name ^^ (myParms |> paramsL), None) + | _ when m.IsConstructor -> (WordL.keywordNew, Some className) // we need the unadjusted name here to be able to grab the number of generic parameters + | _ when m.IsStatic -> (WordL.keywordStatic ^^ WordL.keywordMember ^^ wordL (tagMethod name) ^^ (myParms |> paramsL), None) + | _ -> (WordL.keywordMember ^^ wordL (tagMethod name) ^^ (myParms |> paramsL), None) let signaturL = (m.Parameters, m.Return.Type) |> layoutILParameters denv ilTyparSubst isCons - nameL ^^ wordL ":" ^^ signaturL + nameL ^^ WordL.colon ^^ signaturL let private layoutILFieldDef (denv: DisplayEnv) (ilTyparSubst: layout list) (f: ILFieldDef) = - let staticL = if f.IsStatic then wordL "static" else emptyL + let staticL = if f.IsStatic then WordL.keywordStatic else emptyL let name = adjustILName f.Name - let nameL = wordL name + let nameL = wordL (tagField name) let typL = layoutILType denv ilTyparSubst f.Type - staticL ^^ wordL "val" ^^ nameL ^^ wordL ":" ^^ typL + staticL ^^ WordL.keywordVal ^^ nameL ^^ WordL.colon ^^ typL let private layoutILEventDef denv ilTyparSubst (e: ILEventDef) = - let staticL = if isStaticILEvent e then wordL "static" else emptyL + let staticL = if isStaticILEvent e then WordL.keywordStatic else emptyL let name = adjustILName e.Name - let nameL = wordL name + let nameL = wordL (tagEvent name) let typL = match e.Type with | Some t -> layoutILType denv ilTyparSubst t | _ -> emptyL - staticL ^^ wordL "event" ^^ nameL ^^ wordL ":" ^^ typL + staticL ^^ WordL.keywordEvent ^^ nameL ^^ WordL.colon ^^ typL let private layoutILPropertyDef denv ilTyparSubst (p : ILPropertyDef) = - let staticL = if p.CallingConv = ILThisConvention.Static then wordL "static" else emptyL + let staticL = if p.CallingConv = ILThisConvention.Static then WordL.keywordStatic else emptyL let name = adjustILName p.Name - let nameL = wordL name + let nameL = wordL (tagProperty name) let layoutGetterType (getterRef:ILMethodRef) = if isNil getterRef.ArgTypes then @@ -295,8 +295,8 @@ module private PrintIL = emptyL // shouldn't happen else let frontArgs, lastArg = List.frontAndBack argTypes - let argsL = frontArgs |> List.map (layoutILType denv ilTyparSubst) |> sepListL (wordL "*") - argsL ^^ wordL "->" ^^ (layoutILType denv ilTyparSubst lastArg) + let argsL = frontArgs |> List.map (layoutILType denv ilTyparSubst) |> sepListL WordL.star + argsL ^^ WordL.arrow ^^ (layoutILType denv ilTyparSubst lastArg) let typL = match p.GetMethod, p.SetMethod with @@ -308,9 +308,9 @@ module private PrintIL = match p.GetMethod, p.SetMethod with | None,None | Some _, None -> emptyL - | None, Some _ -> wordL "with" ^^ wordL " set" - | Some _, Some _ -> wordL "with" ^^ wordL "get," ^^ wordL "set" - staticL ^^ wordL "member" ^^ nameL ^^ wordL ":" ^^ typL ^^ specGetSetL + | None, Some _ -> WordL.keywordWith ^^ WordL.keywordSet + | Some _, Some _ -> WordL.keywordWith ^^ WordL.keywordGet ^^ RightL.comma ^^ WordL.keywordSet + staticL ^^ WordL.keywordMember ^^ nameL ^^ WordL.colon ^^ typL ^^ specGetSetL let layoutILFieldInit x = let textOpt = @@ -319,35 +319,37 @@ module private PrintIL = match init with | ILFieldInit.Bool x -> if x - then Some "true" - else Some "false" - | ILFieldInit.Char c -> Some ("'" + (char c).ToString () + "'") - | ILFieldInit.Int16 x -> Some ((x |> int32 |> string) + "s") - | ILFieldInit.Int32 x -> Some (x |> string) - | ILFieldInit.Int64 x -> Some ((x |> string) + "L") - | ILFieldInit.UInt16 x -> Some ((x |> int32 |> string) + "us") - | ILFieldInit.UInt32 x -> Some ((x |> int64 |> string) + "u") - | ILFieldInit.UInt64 x -> Some ((x |> int64 |> string) + "UL") + then Some Literals.keywordTrue + else Some Literals.keywordFalse + | ILFieldInit.Char c -> ("'" + (char c).ToString () + "'") |> (tagStringLiteral >> Some) + | ILFieldInit.Int16 x -> ((x |> int32 |> string) + "s") |> (tagNumericLiteral >> Some) + | ILFieldInit.Int32 x -> x |> (string >> tagNumericLiteral >> Some) + | ILFieldInit.Int64 x -> ((x |> string) + "L") |> (tagNumericLiteral >> Some) + | ILFieldInit.UInt16 x -> ((x |> int32 |> string) + "us") |> (tagNumericLiteral >> Some) + | ILFieldInit.UInt32 x -> (x |> int64 |> string) + "u" |> (tagNumericLiteral >> Some) + | ILFieldInit.UInt64 x -> ((x |> int64 |> string) + "UL") |> (tagNumericLiteral >> Some) | ILFieldInit.Single d -> let s = d.ToString ("g12", System.Globalization.CultureInfo.InvariantCulture) let s = if String.forall (fun c -> System.Char.IsDigit c || c = '-') s then s + ".0" else s - Some (s + "f") + (s + "f") |> (tagNumericLiteral >> Some) | ILFieldInit.Double d -> let s = d.ToString ("g12", System.Globalization.CultureInfo.InvariantCulture) - if String.forall (fun c -> System.Char.IsDigit c || c = '-') s - then Some (s + ".0") - else Some s + let s = + if String.forall (fun c -> System.Char.IsDigit c || c = '-') s + then (s + ".0") + else s + s |> (tagNumericLiteral >> Some) | _ -> None | None -> None match textOpt with - | None -> wordL "=" ^^ (comment "value unavailable") - | Some s -> wordL "=" ^^ wordL s + | None -> WordL.equals ^^ (comment "value unavailable") + | Some s -> WordL.equals ^^ wordL s let layoutILEnumDefParts nm litVal = - wordL "|" ^^ wordL (adjustILName nm) ^^ layoutILFieldInit litVal + WordL.bar ^^ wordL (tagEnum (adjustILName nm)) ^^ layoutILFieldInit litVal let private layoutILEnumDef (f : ILFieldDef) = layoutILEnumDefParts f.Name f.LiteralValue @@ -424,7 +426,7 @@ module private PrintIL = let pre = match typeDef.tdKind with | ILTypeDefKind.Class -> None - | ILTypeDefKind.ValueType -> Some (wordL "struct") + | ILTypeDefKind.ValueType -> Some WordL.keywordStruct | ILTypeDefKind.Interface -> None | _ -> failwith "unreachable" let baseT = @@ -432,7 +434,7 @@ module private PrintIL = | Some b -> let baseName = layoutILType denv ilTyparSubst b if isShowBase baseName - then [ wordL "inherit" ^^ baseName ] + then [ WordL.keywordInherit ^^ baseName ] else [] | None -> [] @@ -498,7 +500,7 @@ module private PrintIL = |> List.sortBy(fun t -> adjustILName t.Name) |> List.map (layoutILNestedClassDef denv) - let post = wordL "end" + let post = WordL.keywordEnd renderL pre (baseT @ body @ types ) post | ILTypeDefKind.Enum -> @@ -515,19 +517,19 @@ module private PrintIL = match typeDef.Methods.AsList |> List.filter (fun m -> m.Name = "Invoke") with // the delegate delegates to the type of `Invoke` | m :: _ -> layoutILCallingSignature denv ilTyparSubst None m.CallingSignature | _ -> comment "`Invoke` method could not be found" - wordL "delegate" ^^ wordL "of" ^^ rhs + WordL.keywordDelegate ^^ WordL.keywordOf ^^ rhs and layoutILNestedClassDef (denv: DisplayEnv) (typeDef : ILTypeDef) = let name = adjustILName typeDef.Name - let nameL = wordL name + let nameL = wordL (tagClass name) let ilTyparSubst = typeDef.GenericParams |> layoutILGenericParameterDefs let paramsL = pruneParms typeDef.Name ilTyparSubst |> paramsL if denv.suppressNestedTypes then - wordL "nested" ^^ wordL "type" ^^ nameL ^^ paramsL + WordL.keywordNested ^^ WordL.keywordType ^^ nameL ^^ paramsL else - let pre = wordL "nested" ^^ wordL "type" ^^ nameL ^^ paramsL + let pre = WordL.keywordNested ^^ WordL.keywordType ^^ nameL ^^ paramsL let body = layoutILTypeDef denv typeDef - (pre ^^ wordL "=") @@-- body + (pre ^^ WordL.equals) @@-- body module private PrintTypes = @@ -535,33 +537,33 @@ module private PrintTypes = let layoutConst g ty c = let str = match c with - | Const.Bool x -> if x then "true" else "false" - | Const.SByte x -> (x |> string)+"y" - | Const.Byte x -> (x |> string)+"uy" - | Const.Int16 x -> (x |> string)+"s" - | Const.UInt16 x -> (x |> string)+"us" - | Const.Int32 x -> (x |> string) - | Const.UInt32 x -> (x |> string)+"u" - | Const.Int64 x -> (x |> string)+"L" - | Const.UInt64 x -> (x |> string)+"UL" - | Const.IntPtr x -> (x |> string)+"n" - | Const.UIntPtr x -> (x |> string)+"un" + | Const.Bool x -> if x then Literals.keywordTrue else Literals.keywordFalse + | Const.SByte x -> (x |> string)+"y" |> tagNumericLiteral + | Const.Byte x -> (x |> string)+"uy" |> tagNumericLiteral + | Const.Int16 x -> (x |> string)+"s" |> tagNumericLiteral + | Const.UInt16 x -> (x |> string)+"us" |> tagNumericLiteral + | Const.Int32 x -> (x |> string) |> tagNumericLiteral + | Const.UInt32 x -> (x |> string)+"u" |> tagNumericLiteral + | Const.Int64 x -> (x |> string)+"L" |> tagNumericLiteral + | Const.UInt64 x -> (x |> string)+"UL" |> tagNumericLiteral + | Const.IntPtr x -> (x |> string)+"n" |> tagNumericLiteral + | Const.UIntPtr x -> (x |> string)+"un" |> tagNumericLiteral | Const.Single d -> - (let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) + ((let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" - else s) + "f" + else s) + "f") |> tagNumericLiteral | Const.Double d -> let s = d.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) - if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s + (if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" - else s - | Const.Char c -> "'" + c.ToString() + "'" - | Const.String bs -> "\"" + bs + "\"" - | Const.Unit -> "()" - | Const.Decimal bs -> string bs + "M" + else s) |> tagNumericLiteral + | Const.Char c -> "'" + c.ToString() + "'" |> tagStringLiteral + | Const.String bs -> "\"" + bs + "\"" |> tagNumericLiteral + | Const.Unit -> "()" |> tagPunctuation + | Const.Decimal bs -> string bs + "M" |> tagNumericLiteral // either "null" or "the defaut value for a struct" - | Const.Zero -> if isRefTy g ty then "null" else "default" + | Const.Zero -> tagKeyword(if isRefTy g ty then "null" else "default") wordL str let layoutAccessibility (denv:DisplayEnv) accessibility itemL = @@ -575,9 +577,9 @@ module private PrintTypes = | _ when List.forall isInternalCompPath p -> Internal | _ -> Private match denv.contextAccessibility,accessibility with - | Public,Internal -> wordL "internal" ++ itemL // print modifier, since more specific than context - | Public,Private -> wordL "private" ++ itemL // print modifier, since more specific than context - | Internal,Private -> wordL "private" ++ itemL // print modifier, since more specific than context + | Public,Internal -> WordL.keywordInternal ++ itemL // print modifier, since more specific than context + | Public,Private -> WordL.keywordPrivate ++ itemL // print modifier, since more specific than context + | Internal,Private -> WordL.keywordPrivate ++ itemL // print modifier, since more specific than context | _ -> itemL /// Layout a reference to a type @@ -585,9 +587,9 @@ module private PrintTypes = /// Layout the flags of a member let layoutMemberFlags memFlags = - let stat = if memFlags.IsInstance || (memFlags.MemberKind = MemberKind.Constructor) then emptyL else wordL "static" - let stat = if memFlags.IsDispatchSlot then stat ++ wordL "abstract" - elif memFlags.IsOverrideOrExplicitImpl then stat ++ wordL "override" + let stat = if memFlags.IsInstance || (memFlags.MemberKind = MemberKind.Constructor) then emptyL else WordL.keywordStatic + let stat = if memFlags.IsDispatchSlot then stat ++ WordL.keywordAbstract + elif memFlags.IsOverrideOrExplicitImpl then stat ++ WordL.keywordOverride else stat let stat = @@ -599,7 +601,7 @@ module private PrintTypes = | MemberKind.PropertyGetSet -> stat | MemberKind.Member | MemberKind.PropertyGet - | MemberKind.PropertySet -> stat ++ wordL "member" + | MemberKind.PropertySet -> stat ++ WordL.keywordMember // let stat = if memFlags.IsFinal then stat ++ wordL "final" else stat in stat @@ -611,37 +613,37 @@ module private PrintTypes = match arg with | Expr.Const(c,_,ty) -> if isEnumTy denv.g ty then - wordL "enum" ^^ angleL (layoutType denv ty) ^^ bracketL (layoutConst denv.g ty c) + WordL.keywordEnum ^^ angleL (layoutType denv ty) ^^ bracketL (layoutConst denv.g ty c) else layoutConst denv.g ty c | Expr.Op (TOp.Array,[_elemTy],args,_) -> - leftL "[|" ^^ semiListL (List.map (layoutAttribArg denv) args) ^^ rightL "|]" + LeftL.leftBracketBar ^^ semiListL (List.map (layoutAttribArg denv) args) ^^ RightL.rightBracketBar // Detect 'typeof' calls | TypeOfExpr denv.g ty -> - leftL "typeof<" ^^ layoutType denv ty ^^ rightL ">" + LeftL.keywordTypeof ^^ wordL (tagPunctuation "<") ^^ layoutType denv ty ^^ rightL (tagPunctuation ">") // Detect 'typedefof' calls | TypeDefOfExpr denv.g ty -> - leftL "typedefof<" ^^ layoutType denv ty ^^ rightL ">" + LeftL.keywordTypedefof ^^ wordL (tagPunctuation "<") ^^ layoutType denv ty ^^ rightL (tagPunctuation ">") | Expr.Op (TOp.Coerce,[tgTy;_],[arg2],_) -> - leftL "(" ^^ layoutAttribArg denv arg2 ^^ wordL ":>" ^^ layoutType denv tgTy ^^ rightL ")" + leftL (tagPunctuation "(") ^^ layoutAttribArg denv arg2 ^^ wordL (tagPunctuation ":>") ^^ layoutType denv tgTy ^^ rightL (tagPunctuation ")") | AttribBitwiseOrExpr denv.g (arg1, arg2) -> - layoutAttribArg denv arg1 ^^ wordL "|||" ^^ layoutAttribArg denv arg2 + layoutAttribArg denv arg1 ^^ wordL (tagPunctuation "|||") ^^ layoutAttribArg denv arg2 // Detect explicit enum values | EnumExpr denv.g arg1 -> - wordL "enum" ++ bracketL (layoutAttribArg denv arg1) + WordL.keywordEnum ++ bracketL (layoutAttribArg denv arg1) - | _ -> wordL "(* unsupported attribute argument *)" + | _ -> comment "(* unsupported attribute argument *)" /// Layout arguments of an attribute 'arg1, ..., argN' and private layoutAttribArgs denv args = - sepListL (rightL ",") (List.map (fun (AttribExpr(e1,_)) -> layoutAttribArg denv e1) args) + sepListL (rightL (tagPunctuation ",")) (List.map (fun (AttribExpr(e1,_)) -> layoutAttribArg denv e1) args) /// Layout an attribute 'Type(arg1, ..., argN)' // @@ -668,44 +670,44 @@ module private PrintTypes = and layoutILAttribElement denv arg = match arg with - | ILAttribElem.String (Some x) -> wordL ("\"" + x + "\"") - | ILAttribElem.String None -> wordL "" - | ILAttribElem.Bool x -> if x then wordL "true" else wordL "false" - | ILAttribElem.Char x -> wordL ("'" + x.ToString() + "'" ) - | ILAttribElem.SByte x -> wordL ((x |> string)+"y") - | ILAttribElem.Int16 x -> wordL ((x |> string)+"s") - | ILAttribElem.Int32 x -> wordL ((x |> string)) - | ILAttribElem.Int64 x -> wordL ((x |> string)+"L") - | ILAttribElem.Byte x -> wordL ((x |> string)+"uy") - | ILAttribElem.UInt16 x -> wordL ((x |> string)+"us") - | ILAttribElem.UInt32 x -> wordL ((x |> string)+"u") - | ILAttribElem.UInt64 x -> wordL ((x |> string)+"UL") + | ILAttribElem.String (Some x) -> wordL (tagStringLiteral ("\"" + x + "\"")) + | ILAttribElem.String None -> wordL (tagStringLiteral "") + | ILAttribElem.Bool x -> if x then WordL.keywordTrue else WordL.keywordFalse + | ILAttribElem.Char x -> wordL (tagStringLiteral ("'" + x.ToString() + "'" )) + | ILAttribElem.SByte x -> wordL (tagNumericLiteral ((x |> string)+"y")) + | ILAttribElem.Int16 x -> wordL (tagNumericLiteral ((x |> string)+"s")) + | ILAttribElem.Int32 x -> wordL (tagNumericLiteral ((x |> string))) + | ILAttribElem.Int64 x -> wordL (tagNumericLiteral ((x |> string)+"L")) + | ILAttribElem.Byte x -> wordL (tagNumericLiteral ((x |> string)+"uy")) + | ILAttribElem.UInt16 x -> wordL (tagNumericLiteral ((x |> string)+"us")) + | ILAttribElem.UInt32 x -> wordL (tagNumericLiteral ((x |> string)+"u")) + | ILAttribElem.UInt64 x -> wordL (tagNumericLiteral ((x |> string)+"UL")) | ILAttribElem.Single x -> let str = let s = x.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) (if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s) + "f" - wordL str + wordL (tagNumericLiteral str) | ILAttribElem.Double x -> let str = let s = x.ToString("g12",System.Globalization.CultureInfo.InvariantCulture) if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s - wordL str - | ILAttribElem.Null -> wordL "null" + wordL (tagNumericLiteral str) + | ILAttribElem.Null -> wordL (tagKeyword "null") | ILAttribElem.Array (_, xs) -> - leftL "[|" ^^ semiListL (List.map (layoutILAttribElement denv) xs) ^^ rightL "|]" + leftL (tagPunctuation "[|") ^^ semiListL (List.map (layoutILAttribElement denv) xs) ^^ RightL.rightBracketBar | ILAttribElem.Type (Some ty) -> - leftL "typeof<" ^^ PrintIL.layoutILType denv [] ty ^^ rightL ">" - | ILAttribElem.Type None -> wordL "" + LeftL.keywordTypeof ^^ SepL.leftAngle ^^ PrintIL.layoutILType denv [] ty ^^ RightL.rightAngle + | ILAttribElem.Type None -> wordL (tagText "") | ILAttribElem.TypeRef (Some ty) -> - leftL "typedefof<" ^^ PrintIL.layoutILTypeRef denv ty ^^ rightL ">" - | ILAttribElem.TypeRef None -> wordL "" + LeftL.keywordTypedefof ^^ SepL.leftAngle ^^ PrintIL.layoutILTypeRef denv ty ^^ RightL.rightAngle + | ILAttribElem.TypeRef None -> emptyL and layoutILAttrib denv (ty, args) = - let argsL = bracketL (sepListL (rightL ",") (List.map (layoutILAttribElement denv) args)) + let argsL = bracketL (sepListL (rightL (tagPunctuation ",")) (List.map (layoutILAttribElement denv) args)) PrintIL.layoutILType denv [] ty ++ argsL /// Layout '[]' above another block @@ -723,23 +725,23 @@ module private PrintTypes = let attrs = attrs |> List.filter (IsMatchingFSharpAttribute denv.g denv.g.attrib_AutoSerializableAttribute >> not) match attrs with | [] -> restL - | _ -> squareAngleL (sepListL (rightL ";") (List.map (layoutAttrib denv) attrs)) @@ + | _ -> squareAngleL (sepListL (rightL (tagPunctuation ";")) (List.map (layoutAttrib denv) attrs)) @@ restL else match kind with | TyparKind.Type -> restL - | TyparKind.Measure -> squareAngleL (wordL "Measure") @@ restL + | TyparKind.Measure -> squareAngleL (wordL (tagText "Measure")) @@ restL and layoutTyparAttribs denv kind attrs restL = match attrs, kind with | [], TyparKind.Type -> restL - | _, _ -> squareAngleL (sepListL (rightL ";") ((match kind with TyparKind.Type -> [] | TyparKind.Measure -> [wordL "Measure"]) @ List.map (layoutAttrib denv) attrs)) ^^ restL + | _, _ -> squareAngleL (sepListL (rightL (tagPunctuation ";")) ((match kind with TyparKind.Type -> [] | TyparKind.Measure -> [wordL (tagText "Measure")]) @ List.map (layoutAttrib denv) attrs)) ^^ restL and private layoutTyparRef denv (typar:Typar) = - wordL (sprintf "%s%s%s" + wordL (tagTypeParameter (sprintf "%s%s%s" (if denv.showConstraintTyparAnnotations then prefixOfStaticReq typar.StaticReq else "'") (if denv.showImperativeTyparAnnotations then prefixOfRigidTypar typar else "") - typar.DisplayName) + typar.DisplayName)) /// Layout a single type parameter declaration, taking TypeSimplificationInfo into account /// There are several printing-cases for a typar: @@ -757,9 +759,9 @@ module private PrintTypes = match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstrTyp) -> if Zset.contains typar env.singletons then - leftL "#" ^^ layoutTypeWithInfo denv env typarConstrTyp + leftL (tagPunctuation "#") ^^ layoutTypeWithInfo denv env typarConstrTyp else - (varL ^^ sepL ":>" ^^ layoutTypeWithInfo denv env typarConstrTyp) |> bracketL + (varL ^^ sepL (tagPunctuation ":>") ^^ layoutTypeWithInfo denv env typarConstrTyp) |> bracketL | _ -> varL @@ -784,72 +786,77 @@ module private PrintTypes = | [] -> emptyL | _ -> if denv.abbreviateAdditionalConstraints then - wordL "when " + wordL (tagKeyword "when") ^^ wordL(tagText "") elif denv.shortConstraints then - leftL "(" ^^ wordL "requires" ^^ sepListL (wordL "and") cxsL ^^ rightL ")" + leftL (tagPunctuation "(") ^^ wordL (tagKeyword "requires") ^^ sepListL (wordL (tagKeyword "and")) cxsL ^^ rightL (tagPunctuation ")") else - wordL "when" ^^ sepListL (wordL "and") cxsL + wordL (tagKeyword "when") ^^ sepListL (wordL (tagKeyword "and")) cxsL /// Layout constraints, taking TypeSimplificationInfo into account and private layoutConstraintWithInfo denv env (tp,tpc) = - let longConstraintPrefix l = layoutTyparRefWithInfo denv env tp ^^ wordL ":" ^^ l + let longConstraintPrefix l = layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ l match tpc with | TyparConstraint.CoercesTo(tpct,_) -> - [layoutTyparRefWithInfo denv env tp ^^ wordL ":>" --- layoutTypeWithInfo denv env tpct] + [layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tpct] | TyparConstraint.MayResolveMember(traitInfo,_) -> [layoutTraitWithInfo denv env traitInfo] | TyparConstraint.DefaultsTo(_,ty,_) -> - if denv.showTyparDefaultConstraints then [wordL "default" ^^ layoutTyparRefWithInfo denv env tp ^^ wordL " :" ^^ layoutTypeWithInfo denv env ty] + if denv.showTyparDefaultConstraints then [wordL (tagKeyword "default") ^^ layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ layoutTypeWithInfo denv env ty] else [] | TyparConstraint.IsEnum(ty,_) -> if denv.shortConstraints then - [wordL "enum"] + [wordL (tagKeyword "enum")] else - [longConstraintPrefix (layoutTypeAppWithInfoAndPrec denv env (wordL "enum") 2 true [ty])] + [longConstraintPrefix (layoutTypeAppWithInfoAndPrec denv env (wordL (tagKeyword "enum")) 2 true [ty])] | TyparConstraint.SupportsComparison _ -> if denv.shortConstraints then - [wordL "comparison"] + [wordL (tagKeyword "comparison")] else - [wordL "comparison" |> longConstraintPrefix] + [wordL (tagKeyword "comparison") |> longConstraintPrefix] | TyparConstraint.SupportsEquality _ -> if denv.shortConstraints then - [wordL "equality"] + [wordL (tagKeyword "equality")] else - [wordL "equality" |> longConstraintPrefix] + [wordL (tagKeyword "equality") |> longConstraintPrefix] | TyparConstraint.IsDelegate(aty,bty,_) -> if denv.shortConstraints then - [wordL "delegate"] + [WordL.keywordDelegate] else - [layoutTypeAppWithInfoAndPrec denv env (wordL "delegate") 2 true [aty;bty] |> longConstraintPrefix] + [layoutTypeAppWithInfoAndPrec denv env (WordL.keywordDelegate) 2 true [aty;bty] |> longConstraintPrefix] | TyparConstraint.SupportsNull _ -> - [wordL "null" |> longConstraintPrefix] + [wordL (tagKeyword "null") |> longConstraintPrefix] | TyparConstraint.IsNonNullableStruct _ -> if denv.shortConstraints then - [wordL "value type"] + [wordL (tagText "value type")] else - [wordL "struct" |> longConstraintPrefix] + [WordL.keywordStruct |> longConstraintPrefix] | TyparConstraint.IsUnmanaged _ -> if denv.shortConstraints then - [wordL "unmanaged"] + [wordL (tagKeyword "unmanaged")] else - [wordL "unmanaged" |> longConstraintPrefix] + [wordL (tagKeyword "unmanaged") |> longConstraintPrefix] | TyparConstraint.IsReferenceType _ -> if denv.shortConstraints then - [wordL "reference type"] + [wordL (tagText "reference type")] else - [wordL "not struct" |> longConstraintPrefix] + [(wordL (tagKeyword "not") ^^ wordL(tagKeyword "struct")) |> longConstraintPrefix] | TyparConstraint.SimpleChoice(tys,_) -> - [bracketL (sepListL (sepL "|") (List.map (layoutTypeWithInfo denv env) tys)) |> longConstraintPrefix] + [bracketL (sepListL (sepL (tagPunctuation "|")) (List.map (layoutTypeWithInfo denv env) tys)) |> longConstraintPrefix] | TyparConstraint.RequiresDefaultConstructor _ -> if denv.shortConstraints then - [wordL "default constructor"] + [wordL (tagKeyword "default") ^^ wordL (tagKeyword "constructor")] else - [bracketL (wordL "new : unit -> " ^^ (layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix] + [bracketL ( + wordL (tagKeyword "new") ^^ + wordL (tagPunctuation ":") ^^ + WordL.structUnit ^^ + WordL.arrow ^^ + (layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix] and private layoutTraitWithInfo denv env (TTrait(tys,nm,memFlags,argtys,rty,_)) = let nm = DemangleOperatorName nm if denv.shortConstraints then - wordL ("member "^nm) + WordL.keywordMember ^^ wordL (tagMember nm) else let rty = GetFSharpViewOfReturnType denv.g rty let stat = layoutMemberFlags memFlags @@ -857,10 +864,10 @@ module private PrintTypes = let tysL = match tys with | [ty] -> layoutTypeWithInfo denv env ty - | tys -> bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL "or") tys) - tysL ^^ wordL ":" --- - bracketL (stat ++ wordL nm ^^ wordL ":" --- - ((layoutTypesWithInfoAndPrec denv env 2 (wordL "*") argtys --- wordL "->") --- (layoutTypeWithInfo denv env rty))) + | tys -> bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagKeyword "or")) tys) + tysL ^^ wordL (tagPunctuation ":") --- + bracketL (stat ++ wordL (tagMember nm) ^^ wordL (tagPunctuation ":") --- + ((layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argtys --- wordL (tagPunctuation "->")) --- (layoutTypeWithInfo denv env rty))) /// Layout a unit expression @@ -871,28 +878,28 @@ module private PrintTypes = let negcs,poscs = ListMeasureConOccsWithNonZeroExponents denv.g false unt |> sortCons |> List.partition (fun (_,e) -> SignRational e < 0) let unparL uv = layoutTyparRef denv uv let unconL tc = layoutTyconRef denv tc - let rationalL e = wordL (RationalToString e) - let measureToPowerL x e = if e = OneRational then x else x -- wordL "^" -- rationalL e + let rationalL e = wordL (tagNumericLiteral (RationalToString e)) + let measureToPowerL x e = if e = OneRational then x else x -- wordL (tagPunctuation "^") -- rationalL e let prefix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) e) posvs @ List.map (fun (c,e) -> measureToPowerL (unconL c) e) poscs) let postfix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) (NegRational e)) negvs @ List.map (fun (c,e) -> measureToPowerL (unconL c) (NegRational e)) negcs) match (negvs,negcs) with - | [],[] -> (match posvs,poscs with [],[] -> wordL "1" | _ -> prefix) - | _ -> prefix ^^ sepL "/" ^^ (if List.length negvs + List.length negcs > 1 then sepL "(" ^^ postfix ^^ sepL ")" else postfix) + | [],[] -> (match posvs,poscs with [],[] -> wordL (tagNumericLiteral "1") | _ -> prefix) + | _ -> prefix ^^ sepL (tagPunctuation "/") ^^ (if List.length negvs + List.length negcs > 1 then sepL (tagPunctuation "(") ^^ postfix ^^ sepL (tagPunctuation ")") else postfix) /// Layout type arguments, either NAME or (ty,...,ty) NAME *) and private layoutTypeAppWithInfoAndPrec denv env tcL prec prefix args = if prefix then match args with | [] -> tcL - | [arg] -> tcL ^^ sepL "<" ^^ (layoutTypeWithInfoAndPrec denv env 4 arg) ^^ rightL ">" - | args -> bracketIfL (prec <= 1) (tcL ^^ angleL (layoutTypesWithInfoAndPrec denv env 2 (sepL ",") args)) + | [arg] -> tcL ^^ sepL (tagPunctuation "<") ^^ (layoutTypeWithInfoAndPrec denv env 4 arg) ^^ rightL (tagPunctuation">") + | args -> bracketIfL (prec <= 1) (tcL ^^ angleL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) args)) else match args with | [] -> tcL | [arg] -> layoutTypeWithInfoAndPrec denv env 2 arg ^^ tcL - | args -> bracketIfL (prec <= 1) (bracketL (layoutTypesWithInfoAndPrec denv env 2 (sepL ",") args) --- tcL) + | args -> bracketIfL (prec <= 1) (bracketL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) args) --- tcL) /// Layout a type, taking precedence into account to insert brackets where needed *) and layoutTypeWithInfoAndPrec denv env prec typ = @@ -912,23 +919,23 @@ module private PrintTypes = // Layout a tuple type | TType_tuple (tupInfo,t) -> if evalTupInfoIsStruct tupInfo then - wordL "struct" --- bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL "*") t) + WordL.keywordStruct --- bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) t) else - bracketIfL (prec <= 2) (layoutTypesWithInfoAndPrec denv env 2 (wordL "*") t) + bracketIfL (prec <= 2) (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) t) // Layout a first-class generic type. | TType_forall (tps,tau) -> let tauL = layoutTypeWithInfoAndPrec denv env prec tau match tps with | [] -> tauL - | [h] -> layoutTyparRefWithInfo denv env h ^^ rightL "." --- tauL - | (h::t) -> spaceListL (List.map (layoutTyparRefWithInfo denv env) (h::t)) ^^ rightL "." --- tauL + | [h] -> layoutTyparRefWithInfo denv env h ^^ rightL (tagPunctuation ".") --- tauL + | (h::t) -> spaceListL (List.map (layoutTyparRefWithInfo denv env) (h::t)) ^^ rightL (tagPunctuation ".") --- tauL // Layout a function type. | TType_fun _ -> let rec loop soFarL ty = match stripTyparEqns ty with - | TType_fun (dty,rty) -> loop (soFarL --- (layoutTypeWithInfoAndPrec denv env 4 dty ^^ wordL "->")) rty + | TType_fun (dty,rty) -> loop (soFarL --- (layoutTypeWithInfoAndPrec denv env 4 dty ^^ wordL (tagPunctuation "->"))) rty | rty -> soFarL --- layoutTypeWithInfoAndPrec denv env 5 rty bracketIfL (prec <= 4) (loop emptyL typ) @@ -967,7 +974,7 @@ module private PrintTypes = match argInfo.Name, isOptionalArg, isParamArray, tryDestOptionTy denv.g ty with // Layout an optional argument | Some(id), true, _, Some ty -> - leftL ("?"^id.idText) ^^ sepL ":" ^^ layoutTypeWithInfoAndPrec denv env 2 ty + leftL (tagPunctuation "?") ^^ sepL (tagParameter id.idText) ^^ SepL.colon ^^ layoutTypeWithInfoAndPrec denv env 2 ty // Layout an unnamed argument | None, _,_, _ -> layoutTypeWithInfoAndPrec denv env 2 ty @@ -975,17 +982,17 @@ module private PrintTypes = | Some id,_,isParamArray,_ -> let prefix = if isParamArray then - layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ leftL id.idText + layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ leftL (tagParameter id.idText) else - leftL id.idText - prefix ^^ sepL ":" ^^ layoutTypeWithInfoAndPrec denv env 2 ty + leftL (tagParameter id.idText) + prefix ^^ SepL.colon ^^ layoutTypeWithInfoAndPrec denv env 2 ty - let delimitReturnValue = if denv.useColonForReturnType then ":" else "->" + let delimitReturnValue = tagPunctuation (if denv.useColonForReturnType then ":" else "->") let allArgsL = argInfos |> List.mapSquared argL - |> List.map (sepListL (wordL "*")) + |> List.map (sepListL (wordL (tagPunctuation "*"))) |> List.map (fun x -> (x ^^ wordL delimitReturnValue)) (List.foldBack (---) allArgsL rtyL) --- cxsL @@ -1002,7 +1009,7 @@ module private PrintTypes = | _ -> let tpcsL = layoutConstraintsWithInfo denv env tpcs - let coreL = sepListL (sepL ",") (List.map (layoutTyparRefWithInfo denv env) typars) + let coreL = sepListL (sepL (tagPunctuation ",")) (List.map (layoutTyparRefWithInfo denv env) typars) (if prefix || not (isNil tpcs) then nmL ^^ angleL (coreL --- tpcsL) else bracketL coreL --- nmL) @@ -1057,10 +1064,10 @@ module private PrintTypes = let layoutMemberSig denv (memberToParentInst,nm,methTypars,argInfos,retTy) = let niceMethodTypars,tauL = layoutMemberTypeCore denv memberToParentInst (methTypars, argInfos, retTy) let nameL = - let nameL = wordL (DemangleOperatorName nm) + let nameL = DemangleOperatorNameAsLayout tagMember nm let nameL = if denv.showTyparBinding then layoutTyparDecls denv nameL true niceMethodTypars else nameL nameL - nameL ^^ wordL ":" ^^ tauL + nameL ^^ wordL (tagPunctuation ":") ^^ tauL let layoutPrettyType denv typ = @@ -1082,11 +1089,10 @@ module private PrintTastMemberOrVals = let stat = PrintTypes.layoutMemberFlags membInfo.MemberFlags let _tps,argInfos,rty,_ = GetTypeOfMemberInFSharpForm denv.g v let mkNameL niceMethodTypars name = - let name = DemangleOperatorName name - let nameL = wordL name + let nameL = DemangleOperatorNameAsLayout tagMember name let nameL = if denv.showMemberContainers then - layoutTyconRef denv v.MemberApparentParent ^^ sepL "." ^^ nameL + layoutTyconRef denv v.MemberApparentParent ^^ SepL.dot ^^ nameL else nameL let nameL = if denv.showTyparBinding then layoutTyparDecls denv nameL true niceMethodTypars else nameL @@ -1097,18 +1103,18 @@ module private PrintTastMemberOrVals = | MemberKind.Member -> let niceMethodTypars,tauL = layoutMemberType denv v argInfos rty let nameL = mkNameL niceMethodTypars v.LogicalName - stat --- (nameL ^^ wordL ":" ^^ tauL) + stat --- (nameL ^^ WordL.colon ^^ tauL) | MemberKind.ClassConstructor | MemberKind.Constructor -> let _,tauL = layoutMemberType denv v argInfos rty - let newL = layoutAccessibility denv v.Accessibility (wordL "new") - stat ++ newL ^^ wordL ":" ^^ tauL + let newL = layoutAccessibility denv v.Accessibility WordL.keywordNew + stat ++ newL ^^ wordL (tagPunctuation ":") ^^ tauL | MemberKind.PropertyGetSet -> stat | MemberKind.PropertyGet -> if isNil argInfos then // use error recovery because intellisense on an incomplete file will show this errorR(Error(FSComp.SR.tastInvalidFormForPropertyGetter(),v.Id.idRange)); - stat --- wordL v.PropertyName --- wordL "with get" + stat --- wordL (tagProperty v.PropertyName) --- (WordL.keywordWith ^^ WordL.keywordGet) else let argInfos = match argInfos with @@ -1117,32 +1123,32 @@ module private PrintTastMemberOrVals = let niceMethodTypars,tauL = layoutMemberType denv v argInfos rty let nameL = mkNameL niceMethodTypars v.PropertyName - stat --- (nameL ^^ wordL ":" ^^ (if isNil argInfos then tauL else tauL --- wordL "with get")) + stat --- (nameL ^^ WordL.colon ^^ (if isNil argInfos then tauL else tauL --- (WordL.keywordWith ^^ WordL.keywordGet))) | MemberKind.PropertySet -> if argInfos.Length <> 1 || isNil argInfos.Head then // use error recovery because intellisense on an incomplete file will show this errorR(Error(FSComp.SR.tastInvalidFormForPropertySetter(),v.Id.idRange)); - stat --- wordL v.PropertyName --- wordL "with set" + stat --- wordL (tagProperty v.PropertyName) --- (WordL.keywordWith ^^ WordL.keywordSet) else let argInfos,valueInfo = List.frontAndBack argInfos.Head let niceMethodTypars,tauL = layoutMemberType denv v (if isNil argInfos then [] else [argInfos]) (fst valueInfo) let nameL = mkNameL niceMethodTypars v.PropertyName - stat --- (nameL ^^ wordL ":" ^^ (tauL --- wordL "with set")) + stat --- (nameL ^^ wordL (tagPunctuation ":") ^^ (tauL --- (WordL.keywordWith ^^ WordL.keywordSet))) let private layoutNonMemberVal denv (tps,v:Val,tau,cxs) = let env = SimplifyTypes.CollectInfo true [tau] cxs let cxs = env.postfixConstraints let argInfos,rty = GetTopTauTypeInFSharpForm denv.g (arityOfVal v).ArgInfos tau v.Range - let nameL = wordL v.DisplayName + let nameL = wordL ((if v.IsModuleBinding then tagModuleBinding else tagUnknownEntity) v.DisplayName) let nameL = layoutAccessibility denv v.Accessibility nameL let nameL = if v.IsMutable && not denv.suppressMutableKeyword then - wordL "mutable" ++ nameL + wordL (tagKeyword "mutable") ++ nameL else nameL let nameL = if v.MustInline && not denv.suppressInlineKeyword then - wordL "inline" ++ nameL + wordL (tagKeyword "inline") ++ nameL else nameL @@ -1152,10 +1158,10 @@ module private PrintTastMemberOrVals = if isTyFunction || isOverGeneric || denv.showTyparBinding then layoutTyparDecls denv nameL true tps else nameL - let valAndTypeL = (wordL "val" ^^ typarBindingsL --- wordL ":") --- layoutTopType denv env argInfos rty cxs + let valAndTypeL = (WordL.keywordVal ^^ typarBindingsL --- wordL (tagPunctuation ":")) --- layoutTopType denv env argInfos rty cxs match denv.generatedValueLayout v with | None -> valAndTypeL - | Some rhsL -> (valAndTypeL ++ wordL "=") --- rhsL + | Some rhsL -> (valAndTypeL ++ wordL (tagPunctuation"=")) --- rhsL let layoutValOrMember denv (v:Val) = let vL = @@ -1183,8 +1189,10 @@ module private PrintTastMemberOrVals = let layoutMemberSig denv x = x |> PrintTypes.layoutMemberSig denv let layoutTyparConstraint denv x = x |> PrintTypes.layoutTyparConstraint denv let outputTy denv os x = x |> PrintTypes.layoutType denv |> bufferL os +let layoutTy denv x = x |> PrintTypes.layoutType denv let outputTypars denv nm os x = x |> PrintTypes.layoutTyparDecls denv (wordL nm) true |> bufferL os let outputTyconRef denv os x = x |> PrintTypes.layoutTyconRef denv |> bufferL os +let layoutTyconRef denv x = x |> PrintTypes.layoutTyconRef denv let layoutConst g ty c = PrintTypes.layoutConst g ty c let layoutPrettifiedTypeAndConstraints denv argInfos tau = PrintTypes.layoutPrettifiedTypeAndConstraints denv argInfos tau @@ -1196,77 +1204,93 @@ module InfoMemberPrinting = /// Format the arguments of a method to a buffer. /// /// This uses somewhat "old fashioned" printf-style buffer printing. - let formatParamDataToBuffer denv os (ParamData(isParamArray, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty)) = + let layoutParamData denv (ParamData(isParamArray, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty)) = let isOptArg = optArgInfo.IsOptional match isParamArray, nmOpt, isOptArg, tryDestOptionTy denv.g pty with // Layout an optional argument | _, Some nm, true, ptyOpt -> // detect parameter type, if ptyOpt is None - this is .NET style optional argument let pty = defaultArg ptyOpt pty - bprintf os "?%s: " nm.idText - outputTy denv os pty + SepL.questionMark ^^ + wordL (tagParameter nm.idText) ^^ + RightL.colon ^^ + PrintTypes.layoutType denv pty // Layout an unnamed argument | _, None, _,_ -> - outputTy denv os pty; + PrintTypes.layoutType denv pty // Layout a named argument | true, Some nm,_,_ -> - layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute |> bufferL os - bprintf os " %s: " nm.idText - outputTy denv os pty + layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ + wordL (tagParameter nm.idText) ^^ + RightL.colon ^^ + PrintTypes.layoutType denv pty | false, Some nm,_,_ -> - bprintf os "%s: " nm.idText - outputTy denv os pty + wordL (tagParameter nm.idText) ^^ + RightL.colon ^^ + PrintTypes.layoutType denv pty + let formatParamDataToBuffer denv os pd = layoutParamData denv pd |> bufferL os + /// Format a method info using "F# style". // // That is, this style: // new : argName1:argType1 * ... * argNameN:argTypeN -> retType // Method : argName1:argType1 * ... * argNameN:argTypeN -> retType - let private formatMethInfoToBufferFSharpStyle amap m denv os (minfo:MethInfo) minst = - if not minfo.IsConstructor && not minfo.IsInstance then bprintf os "static " - if minfo.IsConstructor then - bprintf os "new : " - else - bprintf os "member " - outputTypars denv minfo.LogicalName os minfo.FormalMethodTypars; - bprintf os " : " + let private layoutMethInfoFSharpStyleCore amap m denv (minfo:MethInfo) minst = + let layout = + if not minfo.IsConstructor && not minfo.IsInstance then WordL.keywordStatic + else emptyL + let layout = + layout ^^ + ( + if minfo.IsConstructor then + wordL (tagKeyword "new") + else + WordL.keywordMember ^^ + PrintTypes.layoutTyparDecls denv (wordL (tagMethod minfo.LogicalName)) true minfo.FormalMethodTypars + ) ^^ + WordL.colon let paramDatas = minfo.GetParamDatas(amap, m, minst) - if (List.concat paramDatas).Length = 0 then - bprintf os "unit" - paramDatas |> List.iteri (fun i datas -> - if i > 0 then bprintf os " -> "; - datas |> List.iteri (fun j arg -> - if j > 0 then bprintf os " * "; - formatParamDataToBuffer denv os arg)) + let layout = + layout ^^ + if (List.concat paramDatas).Length = 0 then + WordL.structUnit + else + sepListL WordL.arrow (List.map ((List.map (layoutParamData denv)) >> sepListL WordL.star) paramDatas) let retTy = minfo.GetFSharpReturnTy(amap, m, minst) - bprintf os " -> " - outputTy denv os retTy + layout ^^ + WordL.arrow ^^ + PrintTypes.layoutType denv retTy /// Format a method info using "half C# style". // // That is, this style: // Container(argName1:argType1, ..., argNameN:argTypeN) : retType // Container.Method(argName1:argType1, ..., argNameN:argTypeN) : retType - let private formatMethInfoToBufferCSharpStyle amap m denv os (minfo:MethInfo) minst = + let private layoutMethInfoCSharpStyle amap m denv (minfo:MethInfo) minst = let retTy = minfo.GetFSharpReturnTy(amap, m, minst) - if minfo.IsExtensionMember then - bprintf os "(%s) " (FSComp.SR.typeInfoExtension()) - if isAppTy amap.g minfo.EnclosingType then - outputTyconRef denv os (tcrefOfAppTy amap.g minfo.EnclosingType) - else - outputTy denv os minfo.EnclosingType - if minfo.IsConstructor then - bprintf os "(" - else - bprintf os "." - outputTypars denv minfo.LogicalName os minfo.FormalMethodTypars - bprintf os "(" + let layout = + if minfo.IsExtensionMember then + LeftL.leftParen ^^ wordL (tagKeyword (FSComp.SR.typeInfoExtension())) ^^ RightL.rightParen + else emptyL + let layout = + layout ^^ + if isAppTy amap.g minfo.EnclosingType then + PrintTypes.layoutTyconRef denv (tcrefOfAppTy amap.g minfo.EnclosingType) + else + PrintTypes.layoutType denv minfo.EnclosingType + let layout = + layout ^^ + if minfo.IsConstructor then + SepL.leftParen + else + SepL.dot ^^ + PrintTypes.layoutTyparDecls denv (wordL (tagMethod minfo.LogicalName)) true minfo.FormalMethodTypars ^^ + SepL.leftParen + let paramDatas = minfo.GetParamDatas (amap, m, minst) - paramDatas |> List.iter (List.iteri (fun i arg -> - if i > 0 then bprintf os ", "; - formatParamDataToBuffer denv os arg)) - bprintf os ") : " - outputTy denv os retTy + let layout = layout ^^ sepListL RightL.comma ((List.concat >> List.map (layoutParamData denv)) paramDatas) + layout ^^ RightL.rightParen ^^ WordL.colon ^^ PrintTypes.layoutType denv retTy // Prettify this baby @@ -1305,24 +1329,27 @@ module InfoMemberPrinting = // // For C# extension members: // ApparentContainer.Method(argName1:argType1, ..., argNameN:argTypeN) : retType - let formatMethInfoToBufferFreeStyle amap m denv os minfo = + let layoutMethInfoToFreeStyle amap m denv minfo = match minfo with | DefaultStructCtor(g,_typ) -> - outputTyconRef denv os (tcrefOfAppTy g minfo.EnclosingType) - bprintf os "()" + PrintTypes.layoutTyconRef denv (tcrefOfAppTy g minfo.EnclosingType) ^^ wordL (tagPunctuation "()") | FSMeth(_,_,vref,_) -> - vref.Deref |> PrintTastMemberOrVals.layoutValOrMember { denv with showMemberContainers=true; } |> bufferL os + vref.Deref |> PrintTastMemberOrVals.layoutValOrMember { denv with showMemberContainers=true; } | ILMeth(_,ilminfo,_) -> let minfo,minst = prettifyILMethInfo amap m minfo ilminfo - formatMethInfoToBufferCSharpStyle amap m denv os minfo minst + layoutMethInfoCSharpStyle amap m denv minfo minst #if EXTENSIONTYPING | ProvidedMeth _ -> - formatMethInfoToBufferCSharpStyle amap m denv os minfo minfo.FormalMethodInst + layoutMethInfoCSharpStyle amap m denv minfo minfo.FormalMethodInst #endif + let formatMethInfoToBufferFreeStyle amap m denv os minfo = + layoutMethInfoToFreeStyle amap m denv minfo |> bufferL os + /// Format a method to a layout (actually just containing a string) using "free style" (aka "standalone"). - let layoutMethInfoFSharpStyle amap m denv (minfo: MethInfo) = - wordL (bufs (fun buf -> formatMethInfoToBufferFSharpStyle amap m denv buf minfo minfo.FormalMethodInst)) + let layoutMethInfoFSharpStyle amap m denv (minfo: MethInfo) = + layoutMethInfoFSharpStyleCore amap m denv minfo minfo.FormalMethodInst + //wordL (bufs (fun buf -> formatMethInfoToBufferFSharpStyle amap m denv buf minfo minfo.FormalMethodInst)) //------------------------------------------------------------------------- @@ -1333,23 +1360,23 @@ module private TastDefinitionPrinting = let layoutExtensionMember denv (v:Val) = let tycon = v.MemberApparentParent.Deref - let nameL = wordL tycon.DisplayName + let nameL = wordL (tagMethod tycon.DisplayName) let nameL = layoutAccessibility denv tycon.Accessibility nameL // "type-accessibility" let tps = match PartitionValTyparsForApparentEnclosingType denv.g v with | Some(_,memberParentTypars,_,_,_) -> memberParentTypars | None -> [] - let lhsL = wordL "type" ^^ layoutTyparDecls denv nameL tycon.IsPrefixDisplay tps - (lhsL ^^ wordL "with") @@-- (PrintTastMemberOrVals.layoutValOrMember denv v) + let lhsL = WordL.keywordType ^^ layoutTyparDecls denv nameL tycon.IsPrefixDisplay tps + (lhsL ^^ WordL.keywordWith) @@-- (PrintTastMemberOrVals.layoutValOrMember denv v) let layoutExtensionMembers denv vs = aboveListL (List.map (layoutExtensionMember denv) vs) let layoutRecdField addAccess denv (fld:RecdField) = - let lhs = wordL fld.Name + let lhs = wordL (tagRecordField fld.Name) let lhs = (if addAccess then layoutAccessibility denv fld.Accessibility lhs else lhs) - let lhs = if fld.IsMutable then wordL "mutable" --- lhs else lhs - (lhs ^^ rightL ":") --- layoutType denv fld.FormalType + let lhs = if fld.IsMutable then wordL (tagKeyword "mutable") --- lhs else lhs + (lhs ^^ RightL.colon) --- layoutType denv fld.FormalType let layoutUnionOrExceptionField denv isGenerated i (fld : RecdField) = if isGenerated i fld then layoutTypeWithInfoAndPrec denv SimplifyTypes.typeSimplificationInfo0 2 fld.FormalType @@ -1367,17 +1394,17 @@ module private TastDefinitionPrinting = | [f] when isUnionCase -> layoutUnionOrExceptionField denv isGeneratedUnionCaseField -1 f | _ -> let isGenerated = if isUnionCase then isGeneratedUnionCaseField else isGeneratedExceptionField - sepListL (wordL "*") (List.mapi (layoutUnionOrExceptionField denv isGenerated) fields) + sepListL (wordL (tagPunctuation "*")) (List.mapi (layoutUnionOrExceptionField denv isGenerated) fields) let layoutUnionCase denv prefixL (ucase:UnionCase) = - let nmL = wordL (DemangleOperatorName ucase.Id.idText) + let nmL = DemangleOperatorNameAsLayout tagUnionCase ucase.Id.idText //let nmL = layoutAccessibility denv ucase.Accessibility nmL match ucase.RecdFields with | [] -> (prefixL ^^ nmL) - | fields -> (prefixL ^^ nmL ^^ wordL "of") --- layoutUnionCaseFields denv true fields + | fields -> (prefixL ^^ nmL ^^ WordL.keywordOf) --- layoutUnionCaseFields denv true fields let layoutUnionCases denv ucases = - let prefixL = wordL "|" // See bug://2964 - always prefix in case preceded by accessibility modifier + let prefixL = WordL.bar // See bug://2964 - always prefix in case preceded by accessibility modifier List.map (layoutUnionCase denv prefixL) ucases /// When to force a break? "type tyname = repn" @@ -1400,30 +1427,30 @@ module private TastDefinitionPrinting = #if EXTENSIONTYPING let private layoutILFieldInfo denv amap m (e: ILFieldInfo) = - let staticL = if e.IsStatic then wordL "static" else emptyL - let nameL = wordL (adjustILName e.FieldName) + let staticL = if e.IsStatic then WordL.keywordStatic else emptyL + let nameL = wordL (tagField (adjustILName e.FieldName)) let typL = layoutType denv (e.FieldType(amap,m)) - staticL ^^ wordL "val" ^^ nameL ^^ wordL ":" ^^ typL + staticL ^^ WordL.keywordVal ^^ nameL ^^ WordL.colon ^^ typL let private layoutEventInfo denv amap m (e: EventInfo) = - let staticL = if e.IsStatic then wordL "static" else emptyL - let nameL = wordL (adjustILName e.EventName) + let staticL = if e.IsStatic then WordL.keywordStatic else emptyL + let nameL = wordL (tagEvent (adjustILName e.EventName)) let typL = layoutType denv (e.GetDelegateType(amap,m)) - staticL ^^ wordL "event" ^^ nameL ^^ wordL ":" ^^ typL + staticL ^^ WordL.keywordEvent ^^ nameL ^^ WordL.colon ^^ typL let private layoutPropInfo denv amap m (p : PropInfo) = - let staticL = if p.IsStatic then wordL "static" else emptyL - let nameL = wordL (adjustILName p.PropertyName) + let staticL = if p.IsStatic then WordL.keywordStatic else emptyL + let nameL = wordL (tagProperty (adjustILName p.PropertyName)) let typL = layoutType denv (p.GetPropertyType(amap,m)) // shouldn't happen let specGetSetL = match p.HasGetter, p.HasSetter with | false,false | true,false -> emptyL - | false, true -> wordL "with" ^^ wordL " set" - | true, true -> wordL "with" ^^ wordL "get," ^^ wordL "set" + | false, true -> WordL.keywordWith ^^ WordL.keywordSet + | true, true -> WordL.keywordWith ^^ WordL.keywordGet^^ SepL.comma ^^ WordL.keywordSet - staticL ^^ wordL "member" ^^ nameL ^^ wordL ":" ^^ typL ^^ specGetSetL + staticL ^^ WordL.keywordMember ^^ nameL ^^ WordL.colon ^^ typL ^^ specGetSetL /// Another re-implementation of type printing, this time based off provided info objects. let layoutProvidedTycon (denv:DisplayEnv) (infoReader:InfoReader) ad m start lhsL ty = @@ -1436,7 +1463,7 @@ module private TastDefinitionPrinting = |> List.filter (fun x -> x.FieldName <> "value__") |> List.map (fun x -> PrintIL.layoutILEnumDefParts x.FieldName x.LiteralValue) |> aboveListL - (lhsL ^^ wordL "=") @@-- fieldLs + (lhsL ^^ WordL.equals) @@-- fieldLs else let amap = infoReader.amap let sortKey (v:MethInfo) = @@ -1465,7 +1492,7 @@ module private TastDefinitionPrinting = if suppressInheritanceAndInterfacesForTyInSimplifiedDisplays g amap m ty then [] else - GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m ty |> List.map (fun ity -> wordL (if isInterfaceTy g ty then "inherit" else "interface") --- layoutType denv ity) + GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m ty |> List.map (fun ity -> wordL (tagKeyword (if isInterfaceTy g ty then "inherit" else "interface")) --- layoutType denv ity) let props = GetIntrinsicPropInfosOfType infoReader (None,ad,AllowMultiIntfInstantiations.Yes) PreferOverrides m ty @@ -1515,10 +1542,10 @@ module private TastDefinitionPrinting = | TProvidedTypeExtensionPoint info -> [ for nestedType in info.ProvidedType.PApplyArray((fun sty -> sty.GetNestedTypes()), "GetNestedTypes", m) do - yield nestedType.PUntaint((fun t -> t.Name), m) + yield nestedType.PUntaint((fun t -> t.IsClass, t.Name), m) ] - |> List.sort - |> List.map (fun t -> wordL "nested" ^^ wordL "type" ^^ wordL t) + |> List.sortBy snd + |> List.map (fun (isClass, t) -> WordL.keywordNested ^^ WordL.keywordType ^^ wordL ((if isClass then tagClass else tagStruct) t)) | _ -> [] @@ -1527,7 +1554,7 @@ module private TastDefinitionPrinting = [] else match GetSuperTypeOfType g amap m ty with - | Some super when not (isObjTy g super) -> [wordL "inherit" ^^ (layoutType denv super)] + | Some super when not (isObjTy g super) -> [wordL (tagKeyword "inherit") ^^ (layoutType denv super)] | _ -> [] let erasedL = @@ -1542,27 +1569,26 @@ module private TastDefinitionPrinting = lhsL else let declsL = (inherits @ iimplsLs @ ctorLs @ membLs @ nestedTypeLs @ erasedL) |> applyMaxMembers denv.maxMembers |> aboveListL - let rhsL = match start with Some s -> (wordL s @@-- declsL) @@ wordL "end" | None -> declsL - (lhsL ^^ wordL "=") @@-- rhsL + let rhsL = match start with Some s -> (wordL s @@-- declsL) @@ WordL.keywordEnd | None -> declsL + (lhsL ^^ WordL.equals) @@-- rhsL #endif let layoutTycon (denv:DisplayEnv) (infoReader:InfoReader) ad m simplified typewordL (tycon:Tycon) = let g = denv.g - let nameL = wordL tycon.DisplayName - let nameL = layoutAccessibility denv tycon.Accessibility nameL + let _,ty = generalizeTyconRef (mkLocalTyconRef tycon) + let start, name = + let n = tycon.DisplayName + if isClassTy g ty then (if simplified then None else Some "class" ), tagClass n + elif isInterfaceTy g ty then Some "interface", tagInterface n + elif isStructTy g ty then Some "struct", tagStruct n + else None, tagUnknownType n + let nameL = layoutAccessibility denv tycon.Accessibility (wordL name) let denv = denv.AddAccessibility tycon.Accessibility let lhsL = let tps = tycon.TyparsNoRange let tpsL = layoutTyparDecls denv nameL tycon.IsPrefixDisplay tps typewordL ^^ tpsL - let _,ty = generalizeTyconRef (mkLocalTyconRef tycon) - let start = - if isClassTy g ty then (if simplified then None else Some "class" ) - elif isInterfaceTy g ty then Some "interface" - elif isStructTy g ty then Some "struct" - else None - - + let start = Option.map tagKeyword start #if EXTENSIONTYPING match tycon.IsProvided with | true -> @@ -1599,7 +1625,7 @@ module private TastDefinitionPrinting = | _ -> tycon.ImmediateInterfacesOfFSharpTycon let iimpls = iimpls |> List.filter (fun (_,compgen,_) -> not compgen) // if TTyconInterface, the iimpls should be printed as inherited interfaces - let iimplsLs = iimpls |> List.map (fun (ty,_,_) -> wordL "interface" --- layoutType denv ty) + let iimplsLs = iimpls |> List.map (fun (ty,_,_) -> wordL (tagKeyword "interface") --- layoutType denv ty) let adhocCtorsLs = adhoc |> List.filter (fun v -> v.IsConstructor) |> List.map (fun vref -> PrintTastMemberOrVals.layoutValOrMember denv vref.Deref) let adhocInstanceLs = adhoc |> List.filter (fun v -> not v.IsConstructor && v.IsInstanceMember) |> List.map (fun vref -> PrintTastMemberOrVals.layoutValOrMember denv vref.Deref) let adhocStaticLs = adhoc |> List.filter (fun v -> not v.IsConstructor && not v.IsInstanceMember) |> List.map (fun vref -> PrintTastMemberOrVals.layoutValOrMember denv vref.Deref) @@ -1607,8 +1633,10 @@ module private TastDefinitionPrinting = let memberLs = memberImplementLs @ memberCtorLs @ memberInstanceLs @ memberStaticLs let addMembersAsWithEnd reprL = if isNil memberLs then reprL - elif simplified then reprL @@ aboveListL memberLs - else reprL @@ (wordL "with" @@-- aboveListL memberLs) @@ wordL "end" + else + let memberLs = applyMaxMembers denv.maxMembers memberLs + if simplified then reprL @@-- aboveListL memberLs + else reprL @@ (WordL.keywordWith @@-- aboveListL memberLs) @@ WordL.keywordEnd let reprL = let repr = tycon.TypeReprInfo @@ -1625,7 +1653,7 @@ module private TastDefinitionPrinting = let denv = denv.AddAccessibility tycon.TypeReprAccessibility match repr with | TRecdRepr _ -> - let recdFieldRefL fld = layoutRecdField false denv fld ^^ rightL ";" + let recdFieldRefL fld = layoutRecdField false denv fld ^^ rightL (tagPunctuation ";") let recdL = tycon.TrueFieldsAsList |> List.map recdFieldRefL |> applyMaxMembers denv.maxMembers |> aboveListL |> braceL Some (addMembersAsWithEnd (addReprAccessL recdL)) @@ -1633,7 +1661,7 @@ module private TastDefinitionPrinting = match r.fsobjmodel_kind with | TTyconDelegate (TSlotSig(_,_, _,_,paraml, rty)) -> let rty = GetFSharpViewOfReturnType denv.g rty - Some (wordL "delegate of" --- layoutTopType denv SimplifyTypes.typeSimplificationInfo0 (paraml |> List.mapSquared (fun sp -> (sp.Type, ValReprInfo.unnamedTopArg1))) rty []) + Some (WordL.keywordDelegate ^^ WordL.keywordOf --- layoutTopType denv SimplifyTypes.typeSimplificationInfo0 (paraml |> List.mapSquared (fun sp -> (sp.Type, ValReprInfo.unnamedTopArg1))) rty []) | _ -> match r.fsobjmodel_kind with | TTyconEnum -> @@ -1641,17 +1669,20 @@ module private TastDefinitionPrinting = |> List.map (fun f -> match f.LiteralValue with | None -> emptyL - | Some c -> wordL "| " ^^ wordL f.Name ^^ wordL " = " ^^ layoutConst denv.g ty c) + | Some c -> WordL.bar ^^ + wordL (tagField f.Name) ^^ + WordL.equals ^^ + layoutConst denv.g ty c) |> aboveListL |> Some | _ -> let inherits = match r.fsobjmodel_kind, tycon.TypeContents.tcaug_super with - | TTyconClass,Some super -> [wordL "inherit" ^^ (layoutType denv super)] + | TTyconClass,Some super -> [wordL (tagKeyword "inherit") ^^ (layoutType denv super)] | TTyconInterface,_ -> tycon.ImmediateInterfacesOfFSharpTycon |> List.filter (fun (_,compgen,_) -> not compgen) - |> List.map (fun (ity,_,_) -> wordL "inherit" ^^ (layoutType denv ity)) + |> List.map (fun (ity,_,_) -> wordL (tagKeyword "inherit") ^^ (layoutType denv ity)) | _ -> [] let vsprs = tycon.MembersOfFSharpTyconSorted @@ -1661,11 +1692,11 @@ module private TastDefinitionPrinting = let staticValsLs = tycon.TrueFieldsAsList |> List.filter (fun f -> f.IsStatic) - |> List.map (fun f -> wordL "static" ^^ wordL "val" ^^ layoutRecdField true denv f) + |> List.map (fun f -> WordL.keywordStatic ^^ WordL.keywordVal ^^ layoutRecdField true denv f) let instanceValsLs = tycon.TrueFieldsAsList |> List.filter (fun f -> not f.IsStatic) - |> List.map (fun f -> wordL "val" ^^ layoutRecdField true denv f) + |> List.map (fun f -> WordL.keywordVal ^^ layoutRecdField true denv f) let alldecls = inherits @ memberImplementLs @ memberCtorLs @ instanceValsLs @ vsprs @ memberInstanceLs @ staticValsLs @ memberStaticLs if isNil alldecls then None @@ -1674,13 +1705,13 @@ module private TastDefinitionPrinting = let emptyMeasure = match tycon.TypeOrMeasureKind with TyparKind.Measure -> isNil alldecls | _ -> false if emptyMeasure then None else let declsL = aboveListL alldecls - let declsL = match start with Some s -> (wordL s @@-- declsL) @@ wordL "end" | None -> declsL + let declsL = match start with Some s -> (wordL s @@-- declsL) @@ wordL (tagKeyword "end") | None -> declsL Some declsL | TUnionRepr _ -> let layoutUnionCases = tycon.UnionCasesAsList |> layoutUnionCases denv |> applyMaxMembers denv.maxMembers |> aboveListL Some (addMembersAsWithEnd (addReprAccessL layoutUnionCases)) | TAsmRepr _ -> - Some (wordL "(# \"\" #)") + Some (wordL (tagText "(# \"\" #)")) | TMeasureableRepr ty -> Some (layoutType denv ty) | TILObjectRepr (_,_,td) -> @@ -1692,33 +1723,33 @@ module private TastDefinitionPrinting = | None -> lhsL | Some rhsL -> if brk then - (lhsL ^^ wordL "=") @@-- rhsL + (lhsL ^^ WordL.equals) @@-- rhsL else - (lhsL ^^ wordL "=") --- rhsL + (lhsL ^^ WordL.equals) --- rhsL | _ -> match tycon.TypeAbbrev with | None -> - addMembersAsWithEnd lhsL + addMembersAsWithEnd (lhsL ^^ WordL.equals) | Some a -> - (lhsL ^^ wordL "=") --- (layoutType { denv with shortTypeNames = false } a) + (lhsL ^^ WordL.equals) --- (layoutType { denv with shortTypeNames = false } a) layoutAttribs denv tycon.TypeOrMeasureKind tycon.Attribs reprL // Layout: exception definition let layoutExnDefn denv (exnc:Entity) = let nm = exnc.LogicalName - let nmL = wordL nm + let nmL = wordL (tagClass nm) let nmL = layoutAccessibility denv exnc.TypeReprAccessibility nmL - let exnL = wordL "exception" ^^ nmL // need to tack on the Exception at the right of the name for goto definition + let exnL = wordL (tagKeyword "exception") ^^ nmL // need to tack on the Exception at the right of the name for goto definition let reprL = match exnc.ExceptionInfo with - | TExnAbbrevRepr ecref -> wordL "=" --- layoutTyconRef denv ecref - | TExnAsmRepr _ -> wordL "=" --- wordL "(# ... #)" + | TExnAbbrevRepr ecref -> WordL.equals --- layoutTyconRef denv ecref + | TExnAsmRepr _ -> WordL.equals --- wordL (tagText "(# ... #)") | TExnNone -> emptyL | TExnFresh r -> match r.TrueFieldsAsList with | [] -> emptyL - | r -> wordL "of" --- layoutUnionCaseFields denv false r + | r -> WordL.keywordOf --- layoutUnionCaseFields denv false r exnL ^^ reprL @@ -1729,8 +1760,8 @@ module private TastDefinitionPrinting = | [] -> emptyL | [h] when h.IsExceptionDecl -> layoutExnDefn denv h | h :: t -> - let x = layoutTycon denv infoReader ad m false (wordL "type") h - let xs = List.map (layoutTycon denv infoReader ad m false (wordL "and")) t + let x = layoutTycon denv infoReader ad m false (WordL.keywordType) h + let xs = List.map (layoutTycon denv infoReader ad m false (wordL (tagKeyword "and"))) t aboveListL (x::xs) @@ -1781,14 +1812,15 @@ module private InferredSigPrinting = // Check if this namespace contains anything interesting if isConcreteNamespace def then // This is a container namespace. We print the header when we get to the first concrete module. - let headerL = wordL ("namespace " ^ (String.concat "." (innerPath |> List.map fst))) + let headerL = + wordL (tagKeyword "namespace") ^^ sepListL SepL.dot (List.map (fst >> tagNamespace >> wordL) innerPath) headerL @@-- basic else // This is a namespace that only contains namespaces. Skipt the header basic else // This is a module - let nmL = layoutAccessibility denv mspec.Accessibility (wordL nm) + let nmL = layoutAccessibility denv mspec.Accessibility (wordL (tagModule nm)) let denv = denv.AddAccessibility mspec.Accessibility let basic = imdefL denv def // Check if its an outer module or a nested module @@ -1799,18 +1831,18 @@ module private InferredSigPrinting = // Check if this is an outer module with no namespace if isNil outerPath then // If so print a "module" declaration - (wordL "module" ^^ nmL) @@ basic + (wordL (tagKeyword "module") ^^ nmL) @@ basic else // Otherwise this is an outer module contained immediately in a namespace // We already printed the namespace declaration earlier. So just print the // module now. - ((wordL "module" ^^ nmL ^^ wordL "=" ^^ wordL "begin") @@-- basic) @@ wordL "end" + ((wordL (tagKeyword"module") ^^ nmL ^^ WordL.equals ^^ wordL (tagKeyword "begin")) @@-- basic) @@ WordL.keywordEnd else // OK, we're in F# Interactive, presumably the implicit module for each interaction. basic else // OK, this is a nested module - ((wordL "module" ^^ nmL ^^ wordL "=" ^^ wordL "begin") @@-- basic) @@ wordL "end" + ((wordL (tagKeyword "module") ^^ nmL ^^ WordL.equals ^^ wordL (tagKeyword"begin")) @@-- basic) @@ WordL.keywordEnd imexprL denv expr //-------------------------------------------------------------------------- @@ -1825,30 +1857,30 @@ module private PrintData = match expr with | Expr.Const (c,_,ty) -> if isEnumTy denv.g ty then - wordL "enum" ^^ angleL (layoutType denv ty) ^^ bracketL (layoutConst denv.g ty c) + wordL (tagKeyword "enum") ^^ angleL (layoutType denv ty) ^^ bracketL (layoutConst denv.g ty c) else layoutConst denv.g ty c - | Expr.Val (v,_,_) -> wordL (v.DisplayName) + | Expr.Val (v,_,_) -> wordL (tagLocal v.DisplayName) | Expr.Link rX -> dataExprWrapL denv isAtomic (!rX) | Expr.Op (TOp.UnionCase(c),_,args,_) -> - if denv.g.unionCaseRefEq c denv.g.nil_ucref then wordL "[]" + if denv.g.unionCaseRefEq c denv.g.nil_ucref then wordL (tagPunctuation "[]") elif denv.g.unionCaseRefEq c denv.g.cons_ucref then let rec strip = function (Expr.Op (TOp.UnionCase _,_,[h;t],_)) -> h::strip t | _ -> [] listL (dataExprL denv) (strip expr) elif isNil args then - wordL c.CaseName + wordL (tagUnionCase c.CaseName) else - (wordL c.CaseName ++ bracketL (commaListL (dataExprsL denv args))) + (wordL (tagUnionCase c.CaseName) ++ bracketL (commaListL (dataExprsL denv args))) - | Expr.Op (TOp.ExnConstr(c),_,args,_) -> (wordL c.LogicalName ++ bracketL (commaListL (dataExprsL denv args))) + | Expr.Op (TOp.ExnConstr(c),_,args,_) -> (wordL (tagMethod c.LogicalName) ++ bracketL (commaListL (dataExprsL denv args))) | Expr.Op (TOp.Tuple _,_,xs,_) -> tupleL (dataExprsL denv xs) | Expr.Op (TOp.Recd (_,tc),_,xs,_) -> let fields = tc.TrueInstanceFieldsAsList - let lay fs x = (wordL fs.rfield_id.idText ^^ sepL "=") --- (dataExprL denv x) - leftL "{" ^^ semiListL (List.map2 lay fields xs) ^^ rightL "}" - | Expr.Op (TOp.Array,[_],xs,_) -> leftL "[|" ^^ semiListL (dataExprsL denv xs) ^^ rightL "|]" - | _ -> wordL "?" + let lay fs x = (wordL (tagRecordField fs.rfield_id.idText) ^^ sepL (tagPunctuation "=")) --- (dataExprL denv x) + leftL (tagPunctuation "{") ^^ semiListL (List.map2 lay fields xs) ^^ rightL (tagPunctuation "}") + | Expr.Op (TOp.Array,[_],xs,_) -> leftL (tagPunctuation "[|") ^^ semiListL (dataExprsL denv xs) ^^ RightL.rightBracketBar + | _ -> wordL (tagPunctuation "?") and private dataExprsL denv xs = List.map (dataExprL denv) xs let dataExprL denv expr = PrintData.dataExprL denv expr @@ -1861,32 +1893,40 @@ let dataExprL denv expr = PrintData.dataExprL denv expr let outputValOrMember denv os x = x |> PrintTastMemberOrVals.layoutValOrMember denv |> bufferL os let stringValOrMember denv x = x |> PrintTastMemberOrVals.layoutValOrMember denv |> showL /// Print members with a qualification showing the type they are contained in +let layoutQualifiedValOrMember denv v = PrintTastMemberOrVals.layoutValOrMember { denv with showMemberContainers=true; } v let outputQualifiedValOrMember denv os v = outputValOrMember { denv with showMemberContainers=true; } os v let outputQualifiedValSpec denv os v = outputQualifiedValOrMember denv os v let stringOfQualifiedValOrMember denv v = PrintTastMemberOrVals.layoutValOrMember { denv with showMemberContainers=true; } v |> showL /// Convert a MethInfo to a string let formatMethInfoToBufferFreeStyle amap m denv buf d = InfoMemberPrinting.formatMethInfoToBufferFreeStyle amap m denv buf d +let layoutMethInfoFreeStyle amap m denv d = InfoMemberPrinting.layoutMethInfoToFreeStyle amap m denv d /// Convert a MethInfo to a string let stringOfMethInfo amap m denv d = bufs (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle amap m denv buf d) /// Convert a ParamData to a string let stringOfParamData denv paramData = bufs (fun buf -> InfoMemberPrinting.formatParamDataToBuffer denv buf paramData) +let layoutOfParamData denv paramData = InfoMemberPrinting.layoutParamData denv paramData let outputILTypeRef denv os x = x |> PrintIL.layoutILTypeRef denv |> bufferL os +let layoutILTypeRef denv x = x |> PrintIL.layoutILTypeRef denv let outputExnDef denv os x = x |> TastDefinitionPrinting.layoutExnDefn denv |> bufferL os +let layoutExnDef denv x = x |> TastDefinitionPrinting.layoutExnDefn denv let stringOfTyparConstraints denv x = x |> PrintTypes.layoutConstraintsWithInfo denv SimplifyTypes.typeSimplificationInfo0 |> showL -let outputTycon denv infoReader ad m (* width *) os x = TastDefinitionPrinting.layoutTycon denv infoReader ad m true (wordL "type") x (* |> Layout.squashTo width *) |> bufferL os +let outputTycon denv infoReader ad m (* width *) os x = TastDefinitionPrinting.layoutTycon denv infoReader ad m true (WordL.keywordType) x (* |> Layout.squashTo width *) |> bufferL os +let layoutTycon denv infoReader ad m (* width *) x = TastDefinitionPrinting.layoutTycon denv infoReader ad m true (wordL (tagKeyword "type")) x (* |> Layout.squashTo width *) +let layoutUnionCases denv x = x |> TastDefinitionPrinting.layoutUnionCaseFields denv true let outputUnionCases denv os x = x |> TastDefinitionPrinting.layoutUnionCaseFields denv true |> bufferL os /// Pass negative number as pos in case of single cased discriminated unions let isGeneratedUnionCaseField pos f = TastDefinitionPrinting.isGeneratedUnionCaseField pos f let isGeneratedExceptionField pos f = TastDefinitionPrinting.isGeneratedExceptionField pos f let stringOfTyparConstraint denv tpc = stringOfTyparConstraints denv [tpc] let stringOfTy denv x = x |> PrintTypes.layoutType denv |> showL +let prettyLayoutOfTy denv x = x |> PrintTypes.layoutPrettyType denv let prettyStringOfTy denv x = x |> PrintTypes.layoutPrettyType denv |> showL let prettyStringOfTyNoCx denv x = x |> PrintTypes.layoutPrettyTypeNoCx denv |> showL let stringOfRecdField denv x = x |> TastDefinitionPrinting.layoutRecdField false denv |> showL -let stringOfUnionCase denv x = x |> TastDefinitionPrinting.layoutUnionCase denv (wordL "|") |> showL +let stringOfUnionCase denv x = x |> TastDefinitionPrinting.layoutUnionCase denv (WordL.bar) |> showL let stringOfExnDef denv x = x |> TastDefinitionPrinting.layoutExnDefn denv |> showL let stringOfFSAttrib denv x = x |> PrintTypes.layoutAttrib denv |> squareAngleL |> showL diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index b3a1d2e5b36..cdcdc4648c7 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -31,6 +31,7 @@ open Microsoft.FSharp.Compiler.Tastops.DebugPrint open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps open Microsoft.FSharp.Compiler.TypeRelations open System.Collections.Generic @@ -148,29 +149,29 @@ type ImplFileOptimizationInfo = LazyModuleInfo type CcuOptimizationInfo = LazyModuleInfo #if DEBUG -let braceL x = leftL "{" ^^ x ^^ rightL "}" +let braceL x = leftL (tagText "{") ^^ x ^^ rightL (tagText "}") let seqL xL xs = Seq.fold (fun z x -> z @@ xL x) emptyL xs let namemapL xL xmap = NameMap.foldBack (fun nm x z -> xL nm x @@ z) xmap emptyL let rec exprValueInfoL g = function | ConstValue (x,ty) -> NicePrint.layoutConst g ty x - | UnknownValue -> wordL "?" + | UnknownValue -> wordL (tagText "?") | SizeValue (_,vinfo) -> exprValueInfoL g vinfo - | ValValue (vr,vinfo) -> bracketL ((valRefL vr ^^ wordL "alias") --- exprValueInfoL g vinfo) + | ValValue (vr,vinfo) -> bracketL ((valRefL vr ^^ wordL (tagText "alias")) --- exprValueInfoL g vinfo) | TupleValue vinfos -> bracketL (exprValueInfosL g vinfos) | RecdValue (_,vinfos) -> braceL (exprValueInfosL g vinfos) | UnionCaseValue (ucr,vinfos) -> unionCaseRefL ucr ^^ bracketL (exprValueInfosL g vinfos) - | CurriedLambdaValue(_lambdaId,_arities,_bsize,expr',_ety) -> wordL "lam" ++ exprL expr' (* (sprintf "lam(size=%d)" bsize) *) + | CurriedLambdaValue(_lambdaId,_arities,_bsize,expr',_ety) -> wordL (tagText "lam") ++ exprL expr' (* (sprintf "lam(size=%d)" bsize) *) | ConstExprValue (_size,x) -> exprL x and exprValueInfosL g vinfos = commaListL (List.map (exprValueInfoL g) (Array.toList vinfos)) and moduleInfoL g (x:LazyModuleInfo) = let x = x.Force() - braceL ((wordL "Modules: " @@ (x.ModuleOrNamespaceInfos |> namemapL (fun nm x -> wordL nm ^^ moduleInfoL g x) ) ) - @@ (wordL "Values:" @@ (x.ValInfos.Entries |> seqL (fun (vref,x) -> valRefL vref ^^ valInfoL g x) ))) + braceL ((wordL (tagText "Modules: ") @@ (x.ModuleOrNamespaceInfos |> namemapL (fun nm x -> wordL (tagText nm) ^^ moduleInfoL g x) ) ) + @@ (wordL (tagText "Values:") @@ (x.ValInfos.Entries |> seqL (fun (vref,x) -> valRefL vref ^^ valInfoL g x) ))) and valInfoL g (x:ValInfo) = - braceL ((wordL "ValExprInfo: " @@ exprValueInfoL g x.ValExprInfo) - @@ (wordL "ValMakesNoCriticalTailcalls:" @@ wordL (if x.ValMakesNoCriticalTailcalls then "true" else "false"))) + braceL ((wordL (tagText "ValExprInfo: ") @@ exprValueInfoL g x.ValExprInfo) + @@ (wordL (tagText "ValMakesNoCriticalTailcalls:") @@ wordL (tagText (if x.ValMakesNoCriticalTailcalls then "true" else "false")))) #endif type Summary<'Info> = diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 8c5dddcf753..b124db11531 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -602,20 +602,20 @@ let rec BuildSwitch inpExprOpt g expr edges dflt m = #if DEBUG let rec layoutPat pat = match pat with - | TPat_query (_,pat,_) -> Layout.(--) (Layout.wordL "query") (layoutPat pat) - | TPat_wild _ -> Layout.wordL "wild" - | TPat_as _ -> Layout.wordL "var" + | TPat_query (_,pat,_) -> Layout.(--) (Layout.wordL (Layout.TaggedTextOps.tagText "query")) (layoutPat pat) + | TPat_wild _ -> Layout.wordL (Layout.TaggedTextOps.tagText "wild") + | TPat_as _ -> Layout.wordL (Layout.TaggedTextOps.tagText "var") | TPat_tuple (_, pats, _, _) | TPat_array (pats, _, _) -> Layout.bracketL (Layout.tupleL (List.map layoutPat pats)) - | _ -> Layout.wordL "?" + | _ -> Layout.wordL (Layout.TaggedTextOps.tagText "?") -let layoutPath _p = Layout.wordL "" +let layoutPath _p = Layout.wordL (Layout.TaggedTextOps.tagText "") let layoutActive (Active (path, _subexpr, pat)) = - Layout.(--) (Layout.wordL "Active") (Layout.tupleL [layoutPath path; layoutPat pat]) + Layout.(--) (Layout.wordL (Layout.TaggedTextOps.tagText "Active")) (Layout.tupleL [layoutPath path; layoutPat pat]) let layoutFrontier (Frontier (i,actives,_)) = - Layout.(--) (Layout.wordL "Frontier") (Layout.tupleL [intL i; Layout.listL layoutActive actives]) + Layout.(--) (Layout.wordL (Layout.TaggedTextOps.tagText "Frontier ")) (Layout.tupleL [intL i; Layout.listL layoutActive actives]) #endif let mkFrontiers investigations i = diff --git a/src/fsharp/PrettyNaming.fs b/src/fsharp/PrettyNaming.fs index 3be1286ed53..3afea2c80f4 100755 --- a/src/fsharp/PrettyNaming.fs +++ b/src/fsharp/PrettyNaming.fs @@ -14,6 +14,9 @@ module internal Microsoft.FSharp.Compiler.PrettyNaming open System.Collections.Generic open System.Collections.Concurrent + module TaggedTextOps = Internal.Utilities.StructuredFormat.TaggedTextOps + module LayoutOps = Internal.Utilities.StructuredFormat.LayoutOps + #if FX_RESHAPED_REFLECTION open Microsoft.FSharp.Core.ReflectionAdapters #endif @@ -288,7 +291,14 @@ module internal Microsoft.FSharp.Compiler.PrettyNaming let nm = DecompileOpName nm if IsOpName nm then "( " + nm + " )" else nm - + + open LayoutOps + + let DemangleOperatorNameAsLayout nonOpTagged nm = + let nm = DecompileOpName nm + if IsOpName nm then wordL (TaggedTextOps.tagPunctuation "(") ^^ wordL (TaggedTextOps.tagOperator nm) ^^ wordL (TaggedTextOps.tagPunctuation ")") + else LayoutOps.wordL (nonOpTagged nm) + let opNameCons = CompileOpName "::" let opNameNil = CompileOpName "[]" let opNameEquals = CompileOpName "=" diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 582338c543d..9f784027f9d 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -20,12 +20,12 @@ open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps open Microsoft.FSharp.Compiler.PrettyNaming #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping #endif - //--------------------------------------------------------------------------- // Basic data structures //--------------------------------------------------------------------------- @@ -2471,17 +2471,30 @@ type DisplayEnv = let (+.+) s1 s2 = (if s1 = "" then s2 else s1+"."+s2) +let layoutOfPath p = + sepListL SepL.dot (List.map (tagNamespace >> wordL) p) + let fullNameOfParentOfPubPath pp = match pp with | PubPath([| _ |]) -> None | pp -> Some(textOfPath (Array.toList pp.EnclosingPath)) +let fullNameOfParentOfPubPathAsLayout pp = + match pp with + | PubPath([| _ |]) -> None + | pp -> Some(layoutOfPath (Array.toList pp.EnclosingPath)) + let fullNameOfPubPath (PubPath(p)) = textOfPath (Array.toList p) +let fullNameOfPubPathAsLayout (PubPath(p)) = layoutOfPath (Array.toList p) let fullNameOfParentOfNonLocalEntityRef (nlr: NonLocalEntityRef) = if nlr.Path.Length = 0 || nlr.Path.Length = 1 then None else Some (textOfArrPath nlr.EnclosingMangledPath) // <--- BAD BAD BAD: this is a mangled path. This is wrong for nested modules +let fullNameOfParentOfNonLocalEntityRefAsLayout (nlr: NonLocalEntityRef) = + if nlr.Path.Length = 0 || nlr.Path.Length = 1 then None + else Some (layoutOfPath (List.ofArray nlr.EnclosingMangledPath)) // <--- BAD BAD BAD: this is a mangled path. This is wrong for nested modules + let fullNameOfParentOfEntityRef eref = match eref with | ERefLocal x -> @@ -2490,11 +2503,37 @@ let fullNameOfParentOfEntityRef eref = | Some ppath -> fullNameOfParentOfPubPath ppath | ERefNonLocal nlr -> fullNameOfParentOfNonLocalEntityRef nlr +let fullNameOfParentOfEntityRefAsLayout eref = + match eref with + | ERefLocal x -> + match x.PublicPath with + | None -> None + | Some ppath -> fullNameOfParentOfPubPathAsLayout ppath + | ERefNonLocal nlr -> fullNameOfParentOfNonLocalEntityRefAsLayout nlr + let fullNameOfEntityRef nmF xref = match fullNameOfParentOfEntityRef xref with | None -> nmF xref | Some pathText -> pathText +.+ nmF xref - + +let tagEntityRefName (xref: EntityRef) name = + if xref.IsNamespace then tagNamespace name + else if xref.IsModule then tagModule name + else if xref.IsTypeAbbrev then tagAlias name + else if xref.IsFSharpDelegateTycon then tagDelegate name + else if xref.IsILEnumTycon || xref.IsFSharpEnumTycon then tagEnum name + else if xref.IsStructOrEnumTycon then tagStruct name + else if xref.IsFSharpInterfaceTycon then tagInterface name + else if xref.IsUnionTycon then tagUnion name + else if xref.IsRecordTycon then tagRecord name + else tagClass name + +let fullNameOfEntityRefAsLayout nmF (xref: EntityRef) = + let n = wordL (tagEntityRefName xref (nmF xref)) + match fullNameOfParentOfEntityRefAsLayout xref with + | None -> n + | Some pathText -> pathText ^^ SepL.dot ^^ n + let fullNameOfParentOfValRef vref = match vref with | VRefLocal x -> @@ -2504,11 +2543,23 @@ let fullNameOfParentOfValRef vref = | VRefNonLocal nlr -> Some (fullNameOfEntityRef (fun (x:EntityRef) -> x.DemangledModuleOrNamespaceName) nlr.EnclosingEntity) +let fullNameOfParentOfValRefAsLayout vref = + match vref with + | VRefLocal x -> + match x.PublicPath with + | None -> None + | Some (ValPubPath(pp,_)) -> Some(fullNameOfPubPathAsLayout pp) + | VRefNonLocal nlr -> + Some (fullNameOfEntityRefAsLayout (fun (x:EntityRef) -> x.DemangledModuleOrNamespaceName) nlr.EnclosingEntity) + + let fullDisplayTextOfParentOfModRef r = fullNameOfParentOfEntityRef r let fullDisplayTextOfModRef r = fullNameOfEntityRef (fun (x:EntityRef) -> x.DemangledModuleOrNamespaceName) r let fullDisplayTextOfTyconRef r = fullNameOfEntityRef (fun (tc:TyconRef) -> tc.DisplayNameWithStaticParametersAndUnderscoreTypars) r +let fullDisplayTextOfTyconRefAsLayout r = fullNameOfEntityRefAsLayout (fun (tc:TyconRef) -> tc.DisplayNameWithStaticParametersAndUnderscoreTypars) r let fullDisplayTextOfExnRef r = fullNameOfEntityRef (fun (tc:TyconRef) -> tc.DisplayNameWithStaticParametersAndUnderscoreTypars) r +let fullDisplayTextOfExnRefAsLayout r = fullNameOfEntityRefAsLayout (fun (tc:TyconRef) -> tc.DisplayNameWithStaticParametersAndUnderscoreTypars) r let fullDisplayTextOfUnionCaseRef (ucref:UnionCaseRef) = fullDisplayTextOfTyconRef ucref.TyconRef +.+ ucref.CaseName let fullDisplayTextOfRecdFieldRef (rfref:RecdFieldRef) = fullDisplayTextOfTyconRef rfref.TyconRef +.+ rfref.FieldName @@ -2518,6 +2569,26 @@ let fullDisplayTextOfValRef (vref:ValRef) = | None -> vref.DisplayName | Some pathText -> pathText +.+ vref.DisplayName +let fullDisplayTextOfValRefAsLayout (vref:ValRef) = + let n = + match vref.MemberInfo with + | None -> + if vref.IsModuleBinding then tagModuleBinding vref.DisplayName + else tagUnknownEntity vref.DisplayName + | Some memberInfo -> + match memberInfo.MemberFlags.MemberKind with + | MemberKind.PropertyGet + | MemberKind.PropertySet + | MemberKind.PropertyGetSet -> tagProperty vref.DisplayName + | MemberKind.ClassConstructor + | MemberKind.Constructor -> tagMethod vref.DisplayName + | MemberKind.Member -> tagMember vref.DisplayName + match fullNameOfParentOfValRefAsLayout vref with + | None -> wordL n + | Some pathText -> + pathText ^^ SepL.dot ^^ wordL n + //pathText +.+ vref.DisplayName + let fullMangledPathToTyconRef (tcref:TyconRef) = match tcref with @@ -2848,13 +2919,13 @@ module DebugPrint = begin open PrettyTypes let layoutRanges = ref false - let squareAngleL x = leftL "[<" ^^ x ^^ rightL ">]" - let angleL x = sepL "<" ^^ x ^^ rightL ">" - let braceL x = leftL "{" ^^ x ^^ rightL "}" - let boolL = function true -> wordL "true" | false -> wordL "false" + let squareAngleL x = LeftL.leftBracketAngle ^^ x ^^ RightL.rightBracketAngle + let angleL x = sepL Literals.leftAngle ^^ x ^^ rightL Literals.rightAngle + let braceL x = leftL Literals.leftBrace ^^ x ^^ rightL Literals.rightBrace + let boolL = function true -> WordL.keywordTrue | false -> WordL.keywordFalse - let intL (n:int) = wordL (string n ) - let int64L (n:int64) = wordL (string n ) + let intL (n:int) = wordL (tagNumericLiteral (string n )) + let int64L (n:int64) = wordL (tagNumericLiteral (string n )) let jlistL xL xmap = QueueList.foldBack (fun x z -> z @@ xL x) xmap emptyL @@ -2862,26 +2933,26 @@ module DebugPrint = begin let lvalopL x = match x with - | LGetAddr -> wordL "LGetAddr" - | LByrefGet -> wordL "LByrefGet" - | LSet -> wordL "LSet" - | LByrefSet -> wordL "LByrefSet" + | LGetAddr -> wordL (tagText "LGetAddr") + | LByrefGet -> wordL (tagText "LByrefGet") + | LSet -> wordL (tagText "LSet") + | LByrefSet -> wordL (tagText "LByrefSet") - let angleBracketL l = leftL "<" ^^ l ^^ rightL ">" - let angleBracketListL l = angleBracketL (sepListL (sepL ",") l) + let angleBracketL l = leftL (tagText "<") ^^ l ^^ rightL (tagText ">") + let angleBracketListL l = angleBracketL (sepListL (sepL (tagText ",")) l) let layoutMemberFlags memFlags = - let stat = if memFlags.IsInstance || (memFlags.MemberKind = MemberKind.Constructor) then emptyL else wordL "static" - let stat = if memFlags.IsDispatchSlot then stat ++ wordL "abstract" - elif memFlags.IsOverrideOrExplicitImpl then stat ++ wordL "override" + let stat = if memFlags.IsInstance || (memFlags.MemberKind = MemberKind.Constructor) then emptyL else wordL (tagText "static") + let stat = if memFlags.IsDispatchSlot then stat ++ wordL (tagText "abstract") + elif memFlags.IsOverrideOrExplicitImpl then stat ++ wordL (tagText "override") else stat stat let stampL _n w = w - let layoutTyconRef (tc:TyconRef) = wordL tc.DisplayNameWithStaticParameters |> stampL tc.Stamp + let layoutTyconRef (tc:TyconRef) = wordL (tagText tc.DisplayNameWithStaticParameters) |> stampL tc.Stamp let rec auxTypeL env typ = auxTypeWrapL env false typ @@ -2906,40 +2977,40 @@ module DebugPrint = begin let wrap x = bracketIfL isAtomic x in // wrap iff require atomic expr match stripTyparEqns typ with | TType_forall (typars,rty) -> - (leftL "!" ^^ layoutTyparDecls typars --- auxTypeL env rty) |> wrap + (leftL (tagText "!") ^^ layoutTyparDecls typars --- auxTypeL env rty) |> wrap | TType_ucase (UCRef(tcref,_),tinst) | TType_app (tcref,tinst) -> let prefix = tcref.IsPrefixDisplay let tcL = layoutTyconRef tcref auxTyparsL env tcL prefix tinst - | TType_tuple (_tupInfo,typs) -> sepListL (wordL "*") (List.map (auxTypeAtomL env) typs) |> wrap - | TType_fun (f,x) -> ((auxTypeAtomL env f ^^ wordL "->") --- auxTypeL env x) |> wrap + | TType_tuple (_tupInfo,typs) -> sepListL (wordL (tagText "*")) (List.map (auxTypeAtomL env) typs) |> wrap + | TType_fun (f,x) -> ((auxTypeAtomL env f ^^ wordL (tagText "->")) --- auxTypeL env x) |> wrap | TType_var typar -> auxTyparWrapL env isAtomic typar | TType_measure unt -> #if DEBUG - leftL "{" ^^ + leftL (tagText "{") ^^ (match !global_g with - | None -> wordL "" + | None -> wordL (tagText "") | Some g -> let sortVars (vs:(Typar * Rational) list) = vs |> List.sortBy (fun (v,_) -> v.DisplayName) let sortCons (cs:(TyconRef * Rational) list) = cs |> List.sortBy (fun (c,_) -> c.DisplayName) let negvs,posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_,e) -> SignRational e < 0) let negcs,poscs = ListMeasureConOccsWithNonZeroExponents g false unt |> sortCons |> List.partition (fun (_,e) -> SignRational e < 0) - let unparL (uv:Typar) = wordL ("'" ^ uv.DisplayName) + let unparL (uv:Typar) = wordL (tagText ("'" ^ uv.DisplayName)) let unconL tc = layoutTyconRef tc - let rationalL e = wordL (RationalToString e) - let measureToPowerL x e = if e = OneRational then x else x -- wordL "^" -- rationalL e + let rationalL e = wordL (tagText(RationalToString e)) + let measureToPowerL x e = if e = OneRational then x else x -- wordL (tagText "^") -- rationalL e let prefix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) e) posvs @ List.map (fun (c,e) -> measureToPowerL (unconL c) e) poscs) let postfix = spaceListL (List.map (fun (v,e) -> measureToPowerL (unparL v) (NegRational e)) negvs @ List.map (fun (c,e) -> measureToPowerL (unconL c) (NegRational e)) negcs) match (negvs,negcs) with | [],[] -> prefix - | _ -> prefix ^^ sepL "/" ^^ postfix) ^^ - rightL "}" + | _ -> prefix ^^ sepL (tagText "/") ^^ postfix) ^^ + rightL (tagText "}") #else unt |> ignore - wordL "" + wordL(tagText "") #endif and auxTyparWrapL (env:SimplifyTypes.TypeSimplificationInfo) isAtomic (typar:Typar) = @@ -2951,17 +3022,17 @@ module DebugPrint = begin // ('a :> Type) - inplace coercion constraint not singleton // ('a.opM : S->T) - inplace operator constraint let tpL = - wordL (prefixOfStaticReq typar.StaticReq + wordL (tagText (prefixOfStaticReq typar.StaticReq + prefixOfRigidTypar typar - + typar.DisplayName) + + typar.DisplayName)) let varL = tpL |> stampL typar.Stamp match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstrTyp) -> if Zset.contains typar env.singletons then - leftL "#" ^^ auxTyparConstraintTypL env typarConstrTyp + leftL (tagText "#") ^^ auxTyparConstraintTypL env typarConstrTyp else - (varL ^^ sepL ":>" ^^ auxTyparConstraintTypL env typarConstrTyp) |> wrap + (varL ^^ sepL (tagText ":>") ^^ auxTyparConstraintTypL env typarConstrTyp) |> wrap | _ -> varL and auxTypar2L env typar = auxTyparWrapL env false typar @@ -2974,53 +3045,53 @@ module DebugPrint = begin #if DEBUG let (TTrait(tys,nm,memFlags,argtys,rty,_)) = ttrait match !global_g with - | None -> wordL "" + | None -> wordL (tagText "") | Some g -> let rty = GetFSharpViewOfReturnType g rty let stat = layoutMemberFlags memFlags - let argsL = sepListL (wordL "*") (List.map (auxTypeAtomL env) argtys) + let argsL = sepListL (wordL (tagText "*")) (List.map (auxTypeAtomL env) argtys) let resL = auxTypeL env rty - let methodTypeL = (argsL ^^ wordL "->") ++ resL - bracketL (stat ++ bracketL (sepListL (wordL "or") (List.map (auxTypeAtomL env) tys)) ++ wordL "member" --- (wordL nm ^^ wordL ":" -- methodTypeL)) + let methodTypeL = (argsL ^^ wordL (tagText "->")) ++ resL + bracketL (stat ++ bracketL (sepListL (wordL (tagText "or")) (List.map (auxTypeAtomL env) tys)) ++ wordL (tagText "member") --- (wordL (tagText nm) ^^ wordL (tagText ":") -- methodTypeL)) #else ignore (env,ttrait) - wordL "trait" + wordL(tagText "trait") #endif and auxTyparConstraintL env (tp,tpc) = - let constraintPrefix l = auxTypar2L env tp ^^ wordL ":" ^^ l + let constraintPrefix l = auxTypar2L env tp ^^ wordL (tagText ":") ^^ l match tpc with | TyparConstraint.CoercesTo(typarConstrTyp,_) -> - auxTypar2L env tp ^^ wordL ":>" --- auxTyparConstraintTypL env typarConstrTyp + auxTypar2L env tp ^^ wordL (tagText ":>") --- auxTyparConstraintTypL env typarConstrTyp | TyparConstraint.MayResolveMember(traitInfo,_) -> - auxTypar2L env tp ^^ wordL ":" --- auxTraitL env traitInfo + auxTypar2L env tp ^^ wordL (tagText ":") --- auxTraitL env traitInfo | TyparConstraint.DefaultsTo(_,ty,_) -> - wordL "default" ^^ auxTypar2L env tp ^^ wordL ":" ^^ auxTypeL env ty + wordL (tagText "default") ^^ auxTypar2L env tp ^^ wordL (tagText ":") ^^ auxTypeL env ty | TyparConstraint.IsEnum(ty,_) -> - auxTyparsL env (wordL "enum") true [ty] |> constraintPrefix + auxTyparsL env (wordL (tagText "enum")) true [ty] |> constraintPrefix | TyparConstraint.IsDelegate(aty,bty,_) -> - auxTyparsL env (wordL "delegate") true [aty; bty] |> constraintPrefix + auxTyparsL env (wordL (tagText "delegate")) true [aty; bty] |> constraintPrefix | TyparConstraint.SupportsNull _ -> - wordL "null" |> constraintPrefix + wordL (tagText "null") |> constraintPrefix | TyparConstraint.SupportsComparison _ -> - wordL "comparison" |> constraintPrefix + wordL (tagText "comparison") |> constraintPrefix | TyparConstraint.SupportsEquality _ -> - wordL "equality" |> constraintPrefix + wordL (tagText "equality") |> constraintPrefix | TyparConstraint.IsNonNullableStruct _ -> - wordL "struct" |> constraintPrefix + wordL (tagText "struct") |> constraintPrefix | TyparConstraint.IsReferenceType _ -> - wordL "not struct" |> constraintPrefix + wordL (tagText "not struct") |> constraintPrefix | TyparConstraint.IsUnmanaged _ -> - wordL "unmanaged" |> constraintPrefix + wordL (tagText "unmanaged") |> constraintPrefix | TyparConstraint.SimpleChoice(tys,_) -> - bracketL (sepListL (sepL "|") (List.map (auxTypeL env) tys)) |> constraintPrefix + bracketL (sepListL (sepL (tagText "|")) (List.map (auxTypeL env) tys)) |> constraintPrefix | TyparConstraint.RequiresDefaultConstructor _ -> - bracketL (wordL "new : unit -> " ^^ (auxTypar2L env tp)) |> constraintPrefix + bracketL (wordL (tagText "new : unit -> ") ^^ (auxTypar2L env tp)) |> constraintPrefix and auxTyparConstraintsL env x = match x with | [] -> emptyL - | cxs -> wordL "when" --- aboveListL (List.map (auxTyparConstraintL env) cxs) + | cxs -> wordL (tagText "when") --- aboveListL (List.map (auxTyparConstraintL env) cxs) and typarL tp = auxTypar2L SimplifyTypes.typeSimplificationInfo0 tp and typarAtomL tp = auxTyparAtomL SimplifyTypes.typeSimplificationInfo0 tp @@ -3051,80 +3122,80 @@ module DebugPrint = begin // DEBUG layout - types //-------------------------------------------------------------------------- - let rangeL m = wordL (stringOfRange m) + let rangeL m = wordL (tagText (stringOfRange m)) let instL tyL tys = match tys with | [] -> emptyL - | tys -> sepL "@[" ^^ commaListL (List.map tyL tys) ^^ rightL "]" + | tys -> sepL (tagText "@[") ^^ commaListL (List.map tyL tys) ^^ rightL (tagText "]") let valRefL (vr:ValRef) = - wordL vr.LogicalName |> stampL vr.Stamp + wordL (tagText vr.LogicalName) |> stampL vr.Stamp let layoutAttrib (Attrib(_,k,_,_,_,_,_)) = - leftL "[<" ^^ + leftL (tagText "[<") ^^ (match k with - | ILAttrib (ilmeth) -> wordL ilmeth.Name + | ILAttrib (ilmeth) -> wordL (tagText ilmeth.Name) | FSAttrib (vref) -> valRefL vref) ^^ - rightL ">]" + rightL (tagText ">]") let layoutAttribs attribs = aboveListL (List.map layoutAttrib attribs) let arityInfoL (ValReprInfo (tpNames,_,_) as tvd) = let ns = tvd.AritiesOfArgs in - leftL "arity<" ^^ intL tpNames.Length ^^ sepL ">[" ^^ commaListL (List.map intL ns) ^^ rightL "]" + leftL (tagText "arity<") ^^ intL tpNames.Length ^^ sepL (tagText ">[") ^^ commaListL (List.map intL ns) ^^ rightL (tagText "]") let valL (vspec:Val) = - let vsL = wordL (DecompileOpName vspec.LogicalName) |> stampL vspec.Stamp + let vsL = wordL (tagText (DecompileOpName vspec.LogicalName)) |> stampL vspec.Stamp let vsL = vsL -- layoutAttribs (vspec.Attribs) vsL let typeOfValL (v:Val) = (valL v - ^^ (if v.MustInline then wordL "inline " else emptyL) - ^^ (if v.IsMutable then wordL "mutable " else emptyL) - ^^ wordL ":") -- typeL v.Type + ^^ (if v.MustInline then wordL (tagText "inline ") else emptyL) + ^^ (if v.IsMutable then wordL(tagText "mutable ") else emptyL) + ^^ wordL (tagText ":")) -- typeL v.Type let tslotparamL(TSlotParam(nmOpt, typ, inFlag, outFlag, _,_)) = - (optionL wordL nmOpt) ^^ wordL ":" ^^ typeL typ ^^ (if inFlag then wordL "[in]" else emptyL) ^^ (if outFlag then wordL "[out]" else emptyL) ^^ (if inFlag then wordL "[opt]" else emptyL) + (optionL (tagText >> wordL) nmOpt) ^^ wordL(tagText ":") ^^ typeL typ ^^ (if inFlag then wordL(tagText "[in]") else emptyL) ^^ (if outFlag then wordL(tagText "[out]") else emptyL) ^^ (if inFlag then wordL(tagText "[opt]") else emptyL) let slotSigL (slotsig:SlotSig) = #if DEBUG let (TSlotSig(nm,typ,tps1,tps2,pms,rty)) = slotsig match !global_g with - | None -> wordL "" + | None -> wordL(tagText "") | Some g -> let rty = GetFSharpViewOfReturnType g rty - (wordL "slot" --- (wordL nm) ^^ wordL "@" ^^ typeL typ) -- - (wordL "LAM" --- spaceListL (List.map typarL tps1) ^^ rightL ".") --- - (wordL "LAM" --- spaceListL (List.map typarL tps2) ^^ rightL ".") --- - (commaListL (List.map (List.map tslotparamL >> tupleL) pms)) ^^ (wordL "-> ") --- (typeL rty) + (wordL(tagText "slot") --- (wordL (tagText nm)) ^^ wordL(tagText "@") ^^ typeL typ) -- + (wordL(tagText "LAM") --- spaceListL (List.map typarL tps1) ^^ rightL(tagText ".")) --- + (wordL(tagText "LAM") --- spaceListL (List.map typarL tps2) ^^ rightL(tagText ".")) --- + (commaListL (List.map (List.map tslotparamL >> tupleL) pms)) ^^ (wordL(tagText "-> ")) --- (typeL rty) #else ignore slotsig - wordL "slotsig" + wordL(tagText "slotsig") #endif let rec MemberL (v:Val) (membInfo:ValMemberInfo) = - (aboveListL [ wordL "compiled_name! = " ^^ wordL v.CompiledName ; - wordL "membInfo-slotsig! = " ^^ listL slotSigL membInfo.ImplementedSlotSigs ]) + (aboveListL [ wordL(tagText "compiled_name! = ") ^^ wordL (tagText v.CompiledName) ; + wordL(tagText "membInfo-slotsig! = ") ^^ listL slotSigL membInfo.ImplementedSlotSigs ]) and vspecAtBindL v = let vL = valL v in - let mutL = (if v.IsMutable then wordL "mutable" ++ vL else vL) - mutL --- (aboveListL (List.concat [[wordL ":" ^^ typeL v.Type]; - (match v.MemberInfo with None -> [] | Some mem_info -> [wordL "!" ^^ MemberL v mem_info]); - (match v.ValReprInfo with None -> [] | Some arity_info -> [wordL "#" ^^ arityInfoL arity_info])])) + let mutL = (if v.IsMutable then wordL(tagText "mutable") ++ vL else vL) + mutL --- (aboveListL (List.concat [[wordL(tagText ":") ^^ typeL v.Type]; + (match v.MemberInfo with None -> [] | Some mem_info -> [wordL(tagText "!") ^^ MemberL v mem_info]); + (match v.ValReprInfo with None -> [] | Some arity_info -> [wordL(tagText "#") ^^ arityInfoL arity_info])])) - let unionCaseRefL (ucr:UnionCaseRef) = wordL ucr.CaseName - let recdFieldRefL (rfref:RecdFieldRef) = wordL rfref.FieldName + let unionCaseRefL (ucr:UnionCaseRef) = wordL (tagText ucr.CaseName) + let recdFieldRefL (rfref:RecdFieldRef) = wordL (tagText rfref.FieldName) //-------------------------------------------------------------------------- // DEBUG layout - bind, expr, dtree etc. //-------------------------------------------------------------------------- - let identL (id:Ident) = wordL id.idText + let identL (id:Ident) = wordL (tagText id.idText) // Note: We need nice printing of constants in order to print literals and attributes let constL c = @@ -3156,12 +3227,12 @@ module DebugPrint = begin | Const.Unit -> "()" | Const.Decimal bs -> string bs + "M" | Const.Zero -> "default" - wordL str + wordL (tagText str) let rec tyconL (tycon:Tycon) = if tycon.IsModuleOrNamespace then entityL tycon else - let lhsL = wordL (match tycon.TypeOrMeasureKind with TyparKind.Measure -> "[] type" | TyparKind.Type -> "type") ^^ wordL tycon.DisplayName ^^ layoutTyparDecls tycon.TyparsNoRange + let lhsL = wordL (tagText (match tycon.TypeOrMeasureKind with TyparKind.Measure -> "[] type" | TyparKind.Type -> "type")) ^^ wordL (tagText tycon.DisplayName) ^^ layoutTyparDecls tycon.TyparsNoRange let lhsL = lhsL --- layoutAttribs tycon.Attribs let memberLs = let adhoc = @@ -3179,35 +3250,35 @@ module DebugPrint = begin if isNil adhoc && isNil iimpls then emptyL else - let iimplsLs = iimpls |> List.map (fun (ty,_,_) -> wordL "interface" --- typeL ty) + let iimplsLs = iimpls |> List.map (fun (ty,_,_) -> wordL(tagText "interface") --- typeL ty) let adhocLs = adhoc |> List.map (fun vref -> vspecAtBindL vref.Deref) - (wordL "with" @@-- aboveListL (iimplsLs @ adhocLs)) @@ wordL "end" + (wordL(tagText "with") @@-- aboveListL (iimplsLs @ adhocLs)) @@ wordL(tagText "end") - let layoutUnionCaseArgTypes argtys = sepListL (wordL "*") (List.map typeL argtys) + let layoutUnionCaseArgTypes argtys = sepListL (wordL(tagText "*")) (List.map typeL argtys) let ucaseL prefixL (ucase: UnionCase) = - let nmL = wordL (DemangleOperatorName ucase.Id.idText) + let nmL = wordL (tagText (DemangleOperatorName ucase.Id.idText)) match ucase.RecdFields |> List.map (fun rfld -> rfld.FormalType) with | [] -> (prefixL ^^ nmL) - | argtys -> (prefixL ^^ nmL ^^ wordL "of") --- layoutUnionCaseArgTypes argtys + | argtys -> (prefixL ^^ nmL ^^ wordL(tagText "of")) --- layoutUnionCaseArgTypes argtys let layoutUnionCases ucases = - let prefixL = if List.length ucases > 1 then wordL "|" else emptyL + let prefixL = if List.length ucases > 1 then wordL(tagText "|") else emptyL List.map (ucaseL prefixL) ucases let layoutRecdField (fld:RecdField) = - let lhs = wordL fld.Name - let lhs = if fld.IsMutable then wordL "mutable" --- lhs else lhs - (lhs ^^ rightL ":") --- typeL fld.FormalType + let lhs = wordL (tagText fld.Name) + let lhs = if fld.IsMutable then wordL(tagText "mutable") --- lhs else lhs + (lhs ^^ rightL(tagText ":")) --- typeL fld.FormalType let tyconReprL (repr,tycon:Tycon) = match repr with | TRecdRepr _ -> - tycon.TrueFieldsAsList |> List.map (fun fld -> layoutRecdField fld ^^ rightL ";") |> aboveListL + tycon.TrueFieldsAsList |> List.map (fun fld -> layoutRecdField fld ^^ rightL(tagText ";")) |> aboveListL | TFSharpObjectRepr r -> match r.fsobjmodel_kind with | TTyconDelegate _ -> - wordL "delegate ..." + wordL(tagText "delegate ...") | _ -> let start = match r.fsobjmodel_kind with @@ -3218,24 +3289,24 @@ module DebugPrint = begin | _ -> failwith "???" let inherits = match r.fsobjmodel_kind, tycon.TypeContents.tcaug_super with - | TTyconClass,Some super -> [wordL "inherit" ^^ (typeL super)] + | TTyconClass,Some super -> [wordL(tagText "inherit") ^^ (typeL super)] | TTyconInterface,_ -> tycon.ImmediateInterfacesOfFSharpTycon |> List.filter (fun (_,compgen,_) -> not compgen) - |> List.map (fun (ity,_,_) -> wordL "inherit" ^^ (typeL ity)) + |> List.map (fun (ity,_,_) -> wordL(tagText "inherit") ^^ (typeL ity)) | _ -> [] let vsprs = tycon.MembersOfFSharpTyconSorted |> List.filter (fun v -> v.IsDispatchSlot) |> List.map (fun vref -> vspecAtBindL vref.Deref) - let vals = tycon.TrueFieldsAsList |> List.map (fun f -> (if f.IsStatic then wordL "static" else emptyL) ^^ wordL "val" ^^ layoutRecdField f) + let vals = tycon.TrueFieldsAsList |> List.map (fun f -> (if f.IsStatic then wordL(tagText "static") else emptyL) ^^ wordL(tagText "val") ^^ layoutRecdField f) let alldecls = inherits @ vsprs @ vals let emptyMeasure = match tycon.TypeOrMeasureKind with TyparKind.Measure -> isNil alldecls | _ -> false - if emptyMeasure then emptyL else (wordL start @@-- aboveListL alldecls) @@ wordL "end" + if emptyMeasure then emptyL else (wordL (tagText start) @@-- aboveListL alldecls) @@ wordL(tagText "end") | TUnionRepr _ -> tycon.UnionCasesAsList |> layoutUnionCases |> aboveListL - | TAsmRepr _ -> wordL "(# ... #)" + | TAsmRepr _ -> wordL(tagText "(# ... #)") | TMeasureableRepr ty -> typeL ty - | TILObjectRepr (_,_,td) -> wordL td.Name + | TILObjectRepr (_,_,td) -> wordL (tagText td.Name) | _ -> failwith "unreachable" let reprL = match tycon.TypeReprInfo with @@ -3246,10 +3317,10 @@ module DebugPrint = begin | TNoRepr -> match tycon.TypeAbbrev with | None -> lhsL @@-- memberLs - | Some a -> (lhsL ^^ wordL "=") --- (typeL a @@ memberLs) + | Some a -> (lhsL ^^ wordL(tagText "=")) --- (typeL a @@ memberLs) | a -> let rhsL = tyconReprL (a,tycon) @@ memberLs - (lhsL ^^ wordL "=") @@-- rhsL + (lhsL ^^ wordL(tagText "=")) @@-- rhsL reprL @@ -3258,7 +3329,7 @@ module DebugPrint = begin //-------------------------------------------------------------------------- and bindingL (TBind(v,repr,_)) = - vspecAtBindL v --- (wordL "=" ^^ exprL repr) + vspecAtBindL v --- (wordL(tagText "=") ^^ exprL repr) and exprL expr = exprWrapL false expr and atomL expr = exprWrapL true expr // true means bracket if needed to be atomic expr @@ -3266,12 +3337,12 @@ module DebugPrint = begin and letRecL binds bodyL = let eqnsL = binds - |> List.mapHeadTail (fun bind -> wordL "rec" ^^ bindingL bind ^^ wordL "in") - (fun bind -> wordL "and" ^^ bindingL bind ^^ wordL "in") + |> List.mapHeadTail (fun bind -> wordL(tagText "rec") ^^ bindingL bind ^^ wordL(tagText "in")) + (fun bind -> wordL(tagText "and") ^^ bindingL bind ^^ wordL(tagText "in")) (aboveListL eqnsL @@ bodyL) and letL bind bodyL = - let eqnL = wordL "let" ^^ bindingL bind ^^ wordL "in" + let eqnL = wordL(tagText "let") ^^ bindingL bind ^^ wordL(tagText "in") (eqnL @@ bodyL) and exprWrapL isAtomic expr = @@ -3283,10 +3354,10 @@ module DebugPrint = begin let xL = valL v.Deref let xL = match flags with - | PossibleConstrainedCall _ -> xL ^^ rightL "" - | CtorValUsedAsSelfInit -> xL ^^ rightL "" - | CtorValUsedAsSuperInit -> xL ^^ rightL "" - | VSlotDirectCall -> xL ^^ rightL "" + | PossibleConstrainedCall _ -> xL ^^ rightL(tagText "") + | CtorValUsedAsSelfInit -> xL ^^ rightL(tagText "") + | CtorValUsedAsSuperInit -> xL ^^ rightL(tagText "") + | VSlotDirectCall -> xL ^^ rightL(tagText "") | NormalValUse -> xL xL | Expr.Sequential (x0,x1,flag,_,_) -> @@ -3294,18 +3365,18 @@ module DebugPrint = begin match flag with | NormalSeq -> "; (*Seq*)" | ThenDoSeq -> "; (*ThenDo*)" - ((exprL x0 ^^ rightL flag) @@ exprL x1) |> wrap + ((exprL x0 ^^ rightL (tagText flag)) @@ exprL x1) |> wrap | Expr.Lambda(_, _, baseValOpt,argvs,body,_,_) -> let formalsL = spaceListL (List.map vspecAtBindL argvs) in let bindingL = match baseValOpt with - | None -> wordL "lam" ^^ formalsL ^^ rightL "." - | Some basev -> wordL "lam" ^^ (leftL "base=" ^^ vspecAtBindL basev) --- formalsL ^^ rightL "." in + | None -> wordL(tagText "lam") ^^ formalsL ^^ rightL(tagText ".") + | Some basev -> wordL(tagText "lam") ^^ (leftL(tagText "base=") ^^ vspecAtBindL basev) --- formalsL ^^ rightL(tagText ".") in (bindingL ++ exprL body) |> wrap | Expr.TyLambda(_,argtyvs,body,_,_) -> - ((wordL "LAM" ^^ spaceListL (List.map typarL argtyvs) ^^ rightL ".") ++ exprL body) |> wrap + ((wordL(tagText "LAM") ^^ spaceListL (List.map typarL argtyvs) ^^ rightL(tagText ".")) ++ exprL body) |> wrap | Expr.TyChoose(argtyvs,body,_) -> - ((wordL "CHOOSE" ^^ spaceListL (List.map typarL argtyvs) ^^ rightL ".") ++ exprL body) |> wrap + ((wordL(tagText "CHOOSE") ^^ spaceListL (List.map typarL argtyvs) ^^ rightL(tagText ".")) ++ exprL body) |> wrap | Expr.App (f,_,tys,argtys,_) -> let flayout = atomL f appL flayout tys argtys |> wrap @@ -3314,98 +3385,98 @@ module DebugPrint = begin | Expr.Let (bind,body,_,_) -> letL bind (exprL body) |> wrap | Expr.Link rX -> - (wordL "RecLink" --- atomL (!rX)) |> wrap + (wordL(tagText "RecLink") --- atomL (!rX)) |> wrap | Expr.Match (_,_,dtree,targets,_,_) -> - leftL "[" ^^ (decisionTreeL dtree @@ aboveListL (List.mapi targetL (targets |> Array.toList)) ^^ rightL "]") + leftL(tagText "[") ^^ (decisionTreeL dtree @@ aboveListL (List.mapi targetL (targets |> Array.toList)) ^^ rightL(tagText "]")) | Expr.Op (TOp.UnionCase (c),_,args,_) -> (unionCaseRefL c ++ spaceListL (List.map atomL args)) |> wrap | Expr.Op (TOp.ExnConstr (ecref),_,args,_) -> - wordL ecref.LogicalName ^^ bracketL (commaListL (List.map atomL args)) + wordL (tagText ecref.LogicalName) ^^ bracketL (commaListL (List.map atomL args)) | Expr.Op (TOp.Tuple _,_,xs,_) -> tupleL (List.map exprL xs) | Expr.Op (TOp.Recd (ctor,tc),_,xs,_) -> let fields = tc.TrueInstanceFieldsAsList - let lay fs x = (wordL fs.rfield_id.idText ^^ sepL "=") --- (exprL x) + let lay fs x = (wordL (tagText fs.rfield_id.idText) ^^ sepL(tagText "=")) --- (exprL x) let ctorL = match ctor with | RecdExpr -> emptyL - | RecdExprIsObjInit-> wordL "(new)" - leftL "{" ^^ semiListL (List.map2 lay fields xs) ^^ rightL "}" ^^ ctorL + | RecdExprIsObjInit-> wordL(tagText "(new)") + leftL(tagText "{") ^^ semiListL (List.map2 lay fields xs) ^^ rightL(tagText "}") ^^ ctorL | Expr.Op (TOp.ValFieldSet rf,_,[rx;x],_) -> - (atomL rx --- wordL ".") ^^ (recdFieldRefL rf ^^ wordL "<-" --- exprL x) + (atomL rx --- wordL(tagText ".")) ^^ (recdFieldRefL rf ^^ wordL(tagText "<-") --- exprL x) | Expr.Op (TOp.ValFieldSet rf,_,[x],_) -> - (recdFieldRefL rf ^^ wordL "<-" --- exprL x) + (recdFieldRefL rf ^^ wordL(tagText "<-") --- exprL x) | Expr.Op (TOp.ValFieldGet rf,_,[rx],_) -> - (atomL rx ^^ rightL ".#" ^^ recdFieldRefL rf) + (atomL rx ^^ rightL(tagText ".#") ^^ recdFieldRefL rf) | Expr.Op (TOp.ValFieldGet rf,_,[],_) -> recdFieldRefL rf | Expr.Op (TOp.ValFieldGetAddr rf,_,[rx],_) -> - leftL "&" ^^ bracketL (atomL rx ^^ rightL ".!" ^^ recdFieldRefL rf) + leftL(tagText "&") ^^ bracketL (atomL rx ^^ rightL(tagText ".!") ^^ recdFieldRefL rf) | Expr.Op (TOp.ValFieldGetAddr rf,_,[],_) -> - leftL "&" ^^ (recdFieldRefL rf) + leftL(tagText "&") ^^ (recdFieldRefL rf) | Expr.Op (TOp.UnionCaseTagGet tycr,_,[x],_) -> - wordL ("#" ^ tycr.LogicalName ^ ".tag") ^^ atomL x + wordL (tagText ("#" ^ tycr.LogicalName ^ ".tag")) ^^ atomL x | Expr.Op (TOp.UnionCaseProof c,_,[x],_) -> - wordL ("#" ^ c.CaseName^ ".cast") ^^ atomL x + wordL (tagText ("#" ^ c.CaseName^ ".cast")) ^^ atomL x | Expr.Op (TOp.UnionCaseFieldGet (c,i),_,[x],_) -> - wordL ("#" ^ c.CaseName ^ "." ^ string i) --- atomL x + wordL (tagText ("#" ^ c.CaseName ^ "." ^ string i)) --- atomL x | Expr.Op (TOp.UnionCaseFieldSet (c,i),_,[x;y],_) -> - ((atomL x --- (rightL ("#" ^ c.CaseName ^ "." ^ string i))) ^^ wordL ":=") --- exprL y + ((atomL x --- (rightL (tagText ("#" ^ c.CaseName ^ "." ^ string i)))) ^^ wordL(tagText ":=")) --- exprL y | Expr.Op (TOp.TupleFieldGet (_,i),_,[x],_) -> - wordL ("#" ^ string i) --- atomL x + wordL (tagText ("#" ^ string i)) --- atomL x | Expr.Op (TOp.Coerce,[typ;_],[x],_) -> - atomL x --- (wordL ":>" ^^ typeL typ) + atomL x --- (wordL(tagText ":>") ^^ typeL typ) | Expr.Op (TOp.Reraise,[_],[],_) -> - wordL "Rethrow!" + wordL(tagText "Rethrow!") | Expr.Op (TOp.ILAsm (a,tys),tyargs,args,_) -> - let instrs = a |> List.map (sprintf "%+A" >> wordL) |> spaceListL // %+A has + since instrs are from an "internal" type - let instrs = leftL "(#" ^^ instrs ^^ rightL "#)" + let instrs = a |> List.map (sprintf "%+A" >> tagText >> wordL) |> spaceListL // %+A has + since instrs are from an "internal" type + let instrs = leftL(tagText "(#") ^^ instrs ^^ rightL(tagText "#)") (appL instrs tyargs args --- - wordL ":" ^^ spaceListL (List.map typeAtomL tys)) |> wrap + wordL(tagText ":") ^^ spaceListL (List.map typeAtomL tys)) |> wrap | Expr.Op (TOp.LValueOp (lvop,vr),_,args,_) -> (lvalopL lvop ^^ valRefL vr --- bracketL (commaListL (List.map atomL args))) |> wrap | Expr.Op (TOp.ILCall (_isVirtCall,_isProtectedCall,_valu,_isNewObjCall,_valUseFlags,_isProperty,_noTailCall,ilMethRef,tinst,minst,_tys),tyargs,args,_) -> let meth = ilMethRef.Name - wordL "ILCall" ^^ aboveListL [wordL "meth " --- wordL ilMethRef.EnclosingTypeRef.FullName ^^ sepL "." ^^ wordL meth; - wordL "tinst " --- listL typeL tinst; - wordL "minst " --- listL typeL minst; - wordL "tyargs" --- listL typeL tyargs; - wordL "args " --- listL exprL args] |> wrap + wordL(tagText "ILCall") ^^ aboveListL [wordL(tagText "meth ") --- wordL (tagText ilMethRef.EnclosingTypeRef.FullName) ^^ sepL(tagText ".") ^^ wordL (tagText meth); + wordL(tagText "tinst ") --- listL typeL tinst; + wordL(tagText "minst ") --- listL typeL minst; + wordL(tagText "tyargs") --- listL typeL tyargs; + wordL(tagText "args ") --- listL exprL args] |> wrap | Expr.Op (TOp.Array,[_],xs,_) -> - leftL "[|" ^^ commaListL (List.map exprL xs) ^^ rightL "|]" + leftL(tagText "[|") ^^ commaListL (List.map exprL xs) ^^ rightL(tagText "|]") | Expr.Op (TOp.While _,[],[x1;x2],_) -> - wordL "while" ^^ exprL x1 ^^ wordL "do" ^^ exprL x2 ^^ rightL "}" + wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do") ^^ exprL x2 ^^ rightL(tagText "}") | Expr.Op (TOp.For _,[],[x1;x2;x3],_) -> - wordL "for" ^^ aboveListL [(exprL x1 ^^ wordL "to" ^^ exprL x2 ^^ wordL "do"); exprL x3 ] ^^ rightL "done" + wordL(tagText "for") ^^ aboveListL [(exprL x1 ^^ wordL(tagText "to") ^^ exprL x2 ^^ wordL(tagText "do")); exprL x3 ] ^^ rightL(tagText "done") | Expr.Op (TOp.TryCatch _,[_],[x1;x2],_) -> - wordL "try" ^^ exprL x1 ^^ wordL "with" ^^ exprL x2 ^^ rightL "}" + wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "with") ^^ exprL x2 ^^ rightL(tagText "}") | Expr.Op (TOp.TryFinally _,[_],[x1;x2],_) -> - wordL "try" ^^ exprL x1 ^^ wordL "finally" ^^ exprL x2 ^^ rightL "}" + wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "finally") ^^ exprL x2 ^^ rightL(tagText "}") | Expr.Op (TOp.Bytes _,_ ,_ ,_) -> - wordL "bytes++" - | Expr.Op (TOp.UInt16s _,_ ,_ ,_) -> wordL "uint16++" - | Expr.Op (TOp.RefAddrGet,_tyargs,_args,_) -> wordL "GetRefLVal..." - | Expr.Op (TOp.TraitCall _,_tyargs,_args,_) -> wordL "traitcall..." - | Expr.Op (TOp.ExnFieldGet _,_tyargs,_args,_) -> wordL "TOp.ExnFieldGet..." - | Expr.Op (TOp.ExnFieldSet _,_tyargs,_args,_) -> wordL "TOp.ExnFieldSet..." - | Expr.Op (TOp.TryFinally _,_tyargs,_args,_) -> wordL "TOp.TryFinally..." - | Expr.Op (TOp.TryCatch _,_tyargs,_args,_) -> wordL "TOp.TryCatch..." - | Expr.Op (_,_tys,args,_) -> wordL "Expr.Op ..." ^^ bracketL (commaListL (List.map atomL args)) - | Expr.Quote (a,_,_,_,_) -> leftL "<@" ^^ atomL a ^^ rightL "@>" + wordL(tagText "bytes++") + | Expr.Op (TOp.UInt16s _,_ ,_ ,_) -> wordL(tagText "uint16++") + | Expr.Op (TOp.RefAddrGet,_tyargs,_args,_) -> wordL(tagText "GetRefLVal...") + | Expr.Op (TOp.TraitCall _,_tyargs,_args,_) -> wordL(tagText "traitcall...") + | Expr.Op (TOp.ExnFieldGet _,_tyargs,_args,_) -> wordL(tagText "TOp.ExnFieldGet...") + | Expr.Op (TOp.ExnFieldSet _,_tyargs,_args,_) -> wordL(tagText "TOp.ExnFieldSet...") + | Expr.Op (TOp.TryFinally _,_tyargs,_args,_) -> wordL(tagText "TOp.TryFinally...") + | Expr.Op (TOp.TryCatch _,_tyargs,_args,_) -> wordL(tagText "TOp.TryCatch...") + | Expr.Op (_,_tys,args,_) -> wordL(tagText "Expr.Op ...") ^^ bracketL (commaListL (List.map atomL args)) + | Expr.Quote (a,_,_,_,_) -> leftL(tagText "<@") ^^ atomL a ^^ rightL(tagText "@>") | Expr.Obj (_lambdaId,typ,basev,ccall,overrides,iimpls,_) -> - wordL "OBJ:" ^^ aboveListL [typeL typ; + wordL(tagText "OBJ:") ^^ aboveListL [typeL typ; exprL ccall; optionL vspecAtBindL basev; aboveListL (List.map overrideL overrides); aboveListL (List.map iimplL iimpls)] | Expr.StaticOptimization (_tcs,csx,x,_) -> - (wordL "opt" @@- (exprL x)) @@-- - (wordL "|" ^^ exprL csx --- (wordL "when..." )) + (wordL(tagText "opt") @@- (exprL x)) @@-- + (wordL(tagText "|") ^^ exprL csx --- (wordL(tagText "when...") )) // For tracking ranges through expr rewrites if !layoutRanges - then leftL "{" ^^ (rangeL expr.Range ^^ rightL ":") ++ lay ^^ rightL "}" + then leftL(tagText "{") ^^ (rangeL expr.Range ^^ rightL(tagText ":")) ++ lay ^^ rightL(tagText "}") else lay and implFilesL implFiles = @@ -3414,16 +3485,16 @@ module DebugPrint = begin and appL flayout tys args = let z = flayout let z = z ^^ instL typeL tys - let z = z --- sepL "`" --- (spaceListL (List.map atomL args)) + let z = z --- sepL(tagText "`") --- (spaceListL (List.map atomL args)) z and implFileL (TImplFile(_,_,e,_,_)) = - aboveListL [(wordL "top implementation ") @@-- mexprL e] + aboveListL [(wordL(tagText "top implementation ")) @@-- mexprL e] and mexprL x = match x with - | ModuleOrNamespaceExprWithSig(mtyp,defs,_) -> mdefL defs @@- (wordL ":" @@- entityTypeL mtyp) - and mdefsL defs = wordL "Module Defs" @@-- aboveListL(List.map mdefL defs) + | ModuleOrNamespaceExprWithSig(mtyp,defs,_) -> mdefL defs @@- (wordL(tagText ":") @@- entityTypeL mtyp) + and mdefsL defs = wordL(tagText "Module Defs") @@-- aboveListL(List.map mdefL defs) and mdefL x = match x with | TMDefRec(_,tycons ,mbinds,_) -> aboveListL ((tycons |> List.map tyconL) @ List.map mbindL mbinds) @@ -3435,15 +3506,15 @@ module DebugPrint = begin match x with | ModuleOrNamespaceBinding.Binding bind -> letL bind emptyL | ModuleOrNamespaceBinding.Module(mspec, rhs) -> - (wordL (if mspec.IsNamespace then "namespace" else "module") ^^ (wordL mspec.DemangledModuleOrNamespaceName |> stampL mspec.Stamp)) @@-- mdefL rhs + (wordL (tagText (if mspec.IsNamespace then "namespace" else "module")) ^^ (wordL (tagText mspec.DemangledModuleOrNamespaceName) |> stampL mspec.Stamp)) @@-- mdefL rhs and entityTypeL (mtyp:ModuleOrNamespaceType) = aboveListL [jlistL typeOfValL mtyp.AllValsAndMembers; jlistL tyconL mtyp.AllEntities;] and entityL (ms:ModuleOrNamespace) = - let header = wordL "module" ^^ (wordL ms.DemangledModuleOrNamespaceName |> stampL ms.Stamp) ^^ wordL ":" - let footer = wordL "end" + let header = wordL(tagText "module") ^^ (wordL (tagText ms.DemangledModuleOrNamespaceName) |> stampL ms.Stamp) ^^ wordL(tagText ":") + let footer = wordL(tagText "end") let body = entityTypeL ms.ModuleOrNamespaceType (header @@-- body) @@ footer @@ -3451,35 +3522,35 @@ module DebugPrint = begin and decisionTreeL x = match x with - | TDBind (bind,body) -> let bind = wordL "let" ^^ bindingL bind ^^ wordL "in" in (bind @@ decisionTreeL body) - | TDSuccess (args,n) -> wordL "Success" ^^ leftL "T" ^^ intL n ^^ tupleL (args |> List.map exprL) - | TDSwitch (test,dcases,dflt,_) -> (wordL "Switch" --- exprL test) @@-- + | TDBind (bind,body) -> let bind = wordL(tagText "let") ^^ bindingL bind ^^ wordL(tagText "in") in (bind @@ decisionTreeL body) + | TDSuccess (args,n) -> wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map exprL) + | TDSwitch (test,dcases,dflt,_) -> (wordL(tagText "Switch") --- exprL test) @@-- (aboveListL (List.map dcaseL dcases) @@ match dflt with None -> emptyL - | Some dtree -> wordL "dflt:" --- decisionTreeL dtree) + | Some dtree -> wordL(tagText "dflt:") --- decisionTreeL dtree) - and dcaseL (TCase (test,dtree)) = (dtestL test ^^ wordL "//") --- decisionTreeL dtree + and dcaseL (TCase (test,dtree)) = (dtestL test ^^ wordL(tagText "//")) --- decisionTreeL dtree and dtestL x = match x with - | (Test.UnionCase (c,tinst)) -> wordL "is" ^^ unionCaseRefL c ^^ instL typeL tinst - | (Test.ArrayLength (n,ty)) -> wordL "length" ^^ intL n ^^ typeL ty - | (Test.Const c ) -> wordL "is" ^^ constL c - | (Test.IsNull ) -> wordL "isnull" - | (Test.IsInst (_,typ) ) -> wordL "isinst" ^^ typeL typ - | (Test.ActivePatternCase (exp,_,_,_,_)) -> wordL "query" ^^ exprL exp + | (Test.UnionCase (c,tinst)) -> wordL(tagText "is") ^^ unionCaseRefL c ^^ instL typeL tinst + | (Test.ArrayLength (n,ty)) -> wordL(tagText "length") ^^ intL n ^^ typeL ty + | (Test.Const c ) -> wordL(tagText "is") ^^ constL c + | (Test.IsNull ) -> wordL(tagText "isnull") + | (Test.IsInst (_,typ) ) -> wordL(tagText "isinst") ^^ typeL typ + | (Test.ActivePatternCase (exp,_,_,_,_)) -> wordL(tagText "query") ^^ exprL exp - and targetL i (TTarget (argvs,body,_)) = leftL "T" ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL ":" --- exprL body + and targetL i (TTarget (argvs,body,_)) = leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL body and flatValsL vs = vs |> List.map valL and tmethodL (TObjExprMethod(TSlotSig(nm,_,_,_,_,_), _, tps, vs, e, _)) = - (wordL "TObjExprMethod" --- (wordL nm) ^^ wordL "=") -- - (wordL "METH-LAM" --- angleBracketListL (List.map typarL tps) ^^ rightL ".") --- - (wordL "meth-lam" --- tupleL (List.map (List.map vspecAtBindL >> tupleL) vs) ^^ rightL ".") --- + (wordL(tagText "TObjExprMethod") --- (wordL (tagText nm)) ^^ wordL(tagText "=")) -- + (wordL(tagText "METH-LAM") --- angleBracketListL (List.map typarL tps) ^^ rightL(tagText ".")) --- + (wordL(tagText "meth-lam") --- tupleL (List.map (List.map vspecAtBindL >> tupleL) vs) ^^ rightL(tagText ".")) --- (atomL e) - and overrideL tmeth = wordL "with" ^^ tmethodL tmeth - and iimplL (typ,tmeths) = wordL "impl" ^^ aboveListL (typeL typ :: List.map tmethodL tmeths) + and overrideL tmeth = wordL(tagText "with") ^^ tmethodL tmeth + and iimplL (typ,tmeths) = wordL(tagText "impl") ^^ aboveListL (typeL typ :: List.map tmethodL tmeths) let showType x = Layout.showL (typeL x) let showExpr x = Layout.showL (exprL x) diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index d90a61c5ce6..4ce0aab7a1d 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -650,13 +650,17 @@ type DisplayEnv = member AddOpenPath : string list -> DisplayEnv member AddOpenModuleOrNamespace : ModuleOrNamespaceRef -> DisplayEnv +val tagEntityRefName: xref: EntityRef -> name: string -> StructuredFormat.TaggedText /// Return the full text for an item as we want it displayed to the user as a fully qualified entity val fullDisplayTextOfModRef : ModuleOrNamespaceRef -> string val fullDisplayTextOfParentOfModRef : ModuleOrNamespaceRef -> string option val fullDisplayTextOfValRef : ValRef -> string +val fullDisplayTextOfValRefAsLayout : ValRef -> StructuredFormat.Layout val fullDisplayTextOfTyconRef : TyconRef -> string +val fullDisplayTextOfTyconRefAsLayout : TyconRef -> StructuredFormat.Layout val fullDisplayTextOfExnRef : TyconRef -> string +val fullDisplayTextOfExnRefAsLayout : TyconRef -> StructuredFormat.Layout val fullDisplayTextOfUnionCaseRef : UnionCaseRef -> string val fullDisplayTextOfRecdFieldRef : RecdFieldRef -> string diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index 15fc5a4152a..877f2b5caf2 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -55,7 +55,8 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals open Internal.Utilities.Collections -open Internal.Utilities.StructuredFormat + +type FormatOptions = Internal.Utilities.StructuredFormat.FormatOptions //---------------------------------------------------------------------------- // Hardbinding dependencies should we NGEN fsi.exe @@ -256,10 +257,10 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, // the maximum length (1+fsi.PrintLength/3) let makeListL itemLs = - (leftL "[") ^^ - sepListL (rightL ";") itemLs ^^ - (rightL "]") - Some(wordL "dict" --- makeListL itemLs) + (leftL (TaggedTextOps.tagText "[")) ^^ + sepListL (rightL (TaggedTextOps.tagText ";")) itemLs ^^ + (rightL (TaggedTextOps.tagText "]")) + Some(wordL (TaggedTextOps.tagText "dict") --- makeListL itemLs) finally match it with | :? System.IDisposable as d -> d.Dispose() @@ -285,7 +286,7 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, | _ when aty.IsAssignableFrom(obj.GetType()) -> match printer obj with | null -> None - | s -> Some (wordL s) + | s -> Some (wordL (TaggedTextOps.tagText s)) | _ -> None) | Choice2Of2 (aty: System.Type, converter) -> @@ -340,14 +341,14 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, anyToLayoutCall.AnyToLayout(opts, x, ty) with #if !FX_REDUCED_EXCEPTIONS - | :? ThreadAbortException -> Layout.wordL "" + | :? ThreadAbortException -> Layout.wordL (TaggedTextOps.tagText "") #endif | e -> #if DEBUG printf "\n\nPrintValue: x = %+A and ty=%s\n" x (ty.FullName) #endif printf "%s" (FSIstrings.SR.fsiExceptionDuringPrettyPrinting(e.ToString())); - Layout.wordL "" + Layout.wordL (TaggedTextOps.tagText "") /// Display the signature of an F# value declaration, along with its actual value. member valuePrinter.InvokeDeclLayout (emEnv, ilxGenerator: IlxAssemblyGenerator, v:Val) = @@ -403,7 +404,7 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, let fullL = if Option.isNone rhsL || isEmptyL rhsL.Value then NicePrint.layoutValOrMember denv vref (* the rhs was suppressed by the printer, so no value to print *) else - (NicePrint.layoutValOrMember denv vref ++ wordL "=") --- rhsL.Value + (NicePrint.layoutValOrMember denv vref ++ wordL (TaggedTextOps.tagText "=")) --- rhsL.Value Internal.Utilities.StructuredFormat.Display.output_layout opts outWriter fullL; outWriter.WriteLine() diff --git a/src/fsharp/layout.fs b/src/fsharp/layout.fs index 187211fb77c..263d15d114e 100644 --- a/src/fsharp/layout.fs +++ b/src/fsharp/layout.fs @@ -3,6 +3,7 @@ module internal Microsoft.FSharp.Compiler.Layout open System +open System.Collections.Generic open System.IO open Internal.Utilities.StructuredFormat open Microsoft.FSharp.Core.Printf @@ -10,6 +11,8 @@ open Microsoft.FSharp.Core.Printf #nowarn "62" // This construct is for ML compatibility. type layout = Internal.Utilities.StructuredFormat.Layout +type TaggedText = Internal.Utilities.StructuredFormat.TaggedText + let spaces n = new String(' ',n) @@ -18,18 +21,20 @@ let spaces n = new String(' ',n) //-------------------------------------------------------------------------- let rec juxtLeft = function + | ObjLeaf (jl,_text,_jr) -> jl | Leaf (jl,_text,_jr) -> jl | Node (jl,_l,_jm,_r,_jr,_joint) -> jl | Attr (_tag,_attrs,l) -> juxtLeft l let rec juxtRight = function + | ObjLeaf (_jl,_text,jr) -> jr | Leaf (_jl,_text,jr) -> jr | Node (_jl,_l,_jm,_r,jr,_joint) -> jr | Attr (_tag,_attrs,l) -> juxtRight l // NOTE: emptyL might be better represented as a constructor, so then (Sep"") would have true meaning -let emptyL = Leaf (true,box "",true) -let isEmptyL = function Leaf(true,tag,true) when unbox tag = "" -> true | _ -> false +let emptyL = Leaf (true,TaggedText.Text "",true) +let isEmptyL = function Leaf(true,tag,true) when tag.Value = "" -> true | _ -> false let mkNode l r joint = if isEmptyL l then r else @@ -44,10 +49,160 @@ let mkNode l r joint = //INDEX: constructors //-------------------------------------------------------------------------- -let wordL (str:string) = Leaf (false,box str,false) -let sepL (str:string) = Leaf (true ,box str,true) -let rightL (str:string) = Leaf (true ,box str,false) -let leftL (str:string) = Leaf (false,box str,true) +let wordL (str:TaggedText) = Leaf (false,str,false) +let sepL (str:TaggedText) = Leaf (true ,str,true) +let rightL (str:TaggedText) = Leaf (true ,str,false) +let leftL (str:TaggedText) = Leaf (false,str,true) + +module TaggedTextOps = + let tagActivePatternCase = Internal.Utilities.StructuredFormat.TaggedText.ActivePatternCase + let tagActivePatternResult = Internal.Utilities.StructuredFormat.TaggedText.ActivePatternResult + let tagAlias = Internal.Utilities.StructuredFormat.TaggedTextOps.tagAlias + let tagClass = Internal.Utilities.StructuredFormat.TaggedTextOps.tagClass + let tagUnion = Internal.Utilities.StructuredFormat.TaggedText.Union + let tagUnionCase = Internal.Utilities.StructuredFormat.TaggedTextOps.tagUnionCase + let tagDelegate = Internal.Utilities.StructuredFormat.TaggedTextOps.tagDelegate + let tagEnum = Internal.Utilities.StructuredFormat.TaggedTextOps.tagEnum + let tagEvent = Internal.Utilities.StructuredFormat.TaggedTextOps.tagEvent + let tagField = Internal.Utilities.StructuredFormat.TaggedTextOps.tagField + let tagInterface = Internal.Utilities.StructuredFormat.TaggedTextOps.tagInterface + let tagKeyword = Internal.Utilities.StructuredFormat.TaggedTextOps.tagKeyword + let tagLineBreak = Internal.Utilities.StructuredFormat.TaggedTextOps.tagLineBreak + let tagLocal = Internal.Utilities.StructuredFormat.TaggedTextOps.tagLocal + let tagRecord = Internal.Utilities.StructuredFormat.TaggedTextOps.tagRecord + let tagRecordField = Internal.Utilities.StructuredFormat.TaggedTextOps.tagRecordField + let tagMethod = Internal.Utilities.StructuredFormat.TaggedTextOps.tagMethod + let tagMember = Internal.Utilities.StructuredFormat.TaggedText.Member + let tagModule = Internal.Utilities.StructuredFormat.TaggedTextOps.tagModule + let tagModuleBinding = Internal.Utilities.StructuredFormat.TaggedTextOps.tagModuleBinding + let tagNamespace = Internal.Utilities.StructuredFormat.TaggedTextOps.tagNamespace + let tagNumericLiteral = Internal.Utilities.StructuredFormat.TaggedTextOps.tagNumericLiteral + let tagOperator = Internal.Utilities.StructuredFormat.TaggedTextOps.tagOperator + let tagParameter = Internal.Utilities.StructuredFormat.TaggedTextOps.tagParameter + let tagProperty = Internal.Utilities.StructuredFormat.TaggedTextOps.tagProperty + let tagSpace = Internal.Utilities.StructuredFormat.TaggedTextOps.tagSpace + let tagStringLiteral = Internal.Utilities.StructuredFormat.TaggedTextOps.tagStringLiteral + let tagStruct = Internal.Utilities.StructuredFormat.TaggedTextOps.tagStruct + let tagTypeParameter = Internal.Utilities.StructuredFormat.TaggedTextOps.tagTypeParameter + let tagText = Internal.Utilities.StructuredFormat.TaggedTextOps.tagText + let tagPunctuation = Internal.Utilities.StructuredFormat.TaggedTextOps.tagPunctuation + let tagUnknownEntity = Internal.Utilities.StructuredFormat.TaggedText.UnknownEntity + let tagUnknownType = Internal.Utilities.StructuredFormat.TaggedText.UnknownType + + module Literals = + // common tagged literals + let lineBreak = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.lineBreak + let space = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.space + let comma = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.comma + let semicolon = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.semicolon + let leftParen = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.leftParen + let rightParen = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.rightParen + let leftBracket = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.leftBracket + let rightBracket = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.rightBracket + let leftBrace = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.leftBrace + let rightBrace = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.rightBrace + let equals = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.equals + let arrow = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.arrow + let questionMark = Internal.Utilities.StructuredFormat.TaggedTextOps.Literals.questionMark + let dot = tagPunctuation "." + let leftAngle = tagPunctuation "<" + let rightAngle = tagPunctuation ">" + let star = tagOperator "*" + let colon = tagPunctuation ":" + let minus = tagPunctuation "-" + let keywordNew = tagKeyword "new" + let leftBracketAngle = tagPunctuation "[<" + let rightBracketAngle = tagPunctuation ">]" + let structUnit = tagStruct "unit" + let keywordStatic = tagKeyword "static" + let keywordMember = tagKeyword "member" + let keywordVal = tagKeyword "val" + let keywordEvent = tagKeyword "event" + let keywordWith = tagKeyword "with" + let keywordSet = tagKeyword "set" + let keywordGet = tagKeyword "get" + let keywordTrue = tagKeyword "true" + let keywordFalse = tagKeyword "false" + let bar = tagPunctuation "|" + let keywordStruct = tagKeyword "struct" + let keywordInherit = tagKeyword "inherit" + let keywordEnd = tagKeyword "end" + let keywordNested = tagKeyword "nested" + let keywordType = tagKeyword "type" + let keywordDelegate = tagKeyword "delegate" + let keywordOf = tagKeyword "of" + let keywordInternal = tagKeyword "internal" + let keywordPrivate = tagKeyword "private" + let keywordAbstract = tagKeyword "abstract" + let keywordOverride = tagKeyword "override" + let keywordEnum = tagKeyword "enum" + let leftBracketBar = tagPunctuation "[|" + let rightBracketBar = tagPunctuation "|]" + let keywordTypeof = tagKeyword "typeof" + let keywordTypedefof = tagKeyword "typedefof" + +open TaggedTextOps + +module SepL = + let dot = sepL Literals.dot + let star = sepL Literals.star + let colon = sepL Literals.colon + let questionMark = sepL Literals.questionMark + let leftParen = sepL Literals.leftParen + let comma = sepL Literals.comma + let space = sepL Literals.space + let leftBracket = sepL Literals.leftBracket + let leftAngle = sepL Literals.leftAngle + let lineBreak = sepL Literals.lineBreak + let rightParen = sepL Literals.rightParen + +module WordL = + let arrow = wordL Literals.arrow + let star = wordL Literals.star + let colon = wordL Literals.colon + let equals = wordL Literals.equals + let keywordNew = wordL Literals.keywordNew + let structUnit = wordL Literals.structUnit + let keywordStatic = wordL Literals.keywordStatic + let keywordMember = wordL Literals.keywordMember + let keywordVal = wordL Literals.keywordVal + let keywordEvent = wordL Literals.keywordEvent + let keywordWith = wordL Literals.keywordWith + let keywordSet = wordL Literals.keywordSet + let keywordGet = wordL Literals.keywordGet + let keywordTrue = wordL Literals.keywordTrue + let keywordFalse = wordL Literals.keywordFalse + let bar = wordL Literals.bar + let keywordStruct = wordL Literals.keywordStruct + let keywordInherit = wordL Literals.keywordInherit + let keywordEnd = wordL Literals.keywordEnd + let keywordNested = wordL Literals.keywordNested + let keywordType = wordL Literals.keywordType + let keywordDelegate = wordL Literals.keywordDelegate + let keywordOf = wordL Literals.keywordOf + let keywordInternal = wordL Literals.keywordInternal + let keywordPrivate = wordL Literals.keywordPrivate + let keywordAbstract = wordL Literals.keywordAbstract + let keywordOverride = wordL Literals.keywordOverride + let keywordEnum = wordL Literals.keywordEnum + +module LeftL = + let leftParen = leftL Literals.leftParen + let questionMark = leftL Literals.questionMark + let colon = leftL Literals.colon + let leftBracketAngle = leftL Literals.leftBracketAngle + let leftBracketBar = leftL Literals.leftBracketBar + let keywordTypeof = leftL Literals.keywordTypeof + let keywordTypedefof = leftL Literals.keywordTypedefof + +module RightL = + let comma = rightL Literals.comma + let rightParen = rightL Literals.rightParen + let colon = rightL Literals.colon + let rightBracket = rightL Literals.rightBracket + let rightAngle = rightL Literals.rightAngle + let rightBracketAngle = rightL Literals.rightBracketAngle + let rightBracketBar = rightL Literals.rightBracketBar let aboveL l r = mkNode l r (Broken 0) @@ -78,24 +233,24 @@ let tagListL tagger = function | [] -> prefixL | y::ys -> process' ((tagger prefixL) ++ y) ys in process' x xs - -let commaListL x = tagListL (fun prefixL -> prefixL ^^ rightL ",") x -let semiListL x = tagListL (fun prefixL -> prefixL ^^ rightL ";") x + +let commaListL x = tagListL (fun prefixL -> prefixL ^^ rightL Literals.comma) x +let semiListL x = tagListL (fun prefixL -> prefixL ^^ rightL Literals.semicolon) x let spaceListL x = tagListL (fun prefixL -> prefixL) x let sepListL x y = tagListL (fun prefixL -> prefixL ^^ x) y -let bracketL l = leftL "(" ^^ l ^^ rightL ")" -let tupleL xs = bracketL (sepListL (sepL ",") xs) +let bracketL l = leftL Literals.leftParen ^^ l ^^ rightL Literals.rightParen +let tupleL xs = bracketL (sepListL (sepL Literals.comma) xs) let aboveListL = function | [] -> emptyL | [x] -> x | x::ys -> List.fold (fun pre y -> pre @@ y) x ys let optionL xL = function - | None -> wordL "None" - | Some x -> wordL "Some" -- (xL x) + | None -> wordL (tagUnionCase "None") + | Some x -> wordL (tagUnionCase "Some") -- (xL x) -let listL xL xs = leftL "[" ^^ sepListL (sepL ";") (List.map xL xs) ^^ rightL "]" +let listL xL xs = leftL Literals.leftBracket ^^ sepListL (sepL Literals.semicolon) (List.map xL xs) ^^ rightL Literals.rightBracket //-------------------------------------------------------------------------- @@ -157,12 +312,13 @@ let squashTo maxWidth layout = (*printf "\n\nCalling pos=%d layout=[%s]\n" pos (showL layout)*) let breaks,layout,pos,offset = match layout with + | ObjLeaf _ -> failwith "ObjLeaf should not appear here" | Attr (tag,attrs,l) -> let breaks,layout,pos,offset = fit breaks (pos,l) let layout = Attr (tag,attrs,layout) breaks,layout,pos,offset | Leaf (_jl,text,_jr) -> - let textWidth = (unbox text).Length + let textWidth = text.Length let rec fitLeaf breaks pos = if pos + textWidth <= maxWidth then breaks,layout,pos + textWidth,textWidth (* great, it fits *) @@ -215,7 +371,7 @@ let squashTo maxWidth layout = type LayoutRenderer<'a,'b> = abstract Start : unit -> 'b - abstract AddText : 'b -> string -> 'b + abstract AddText : 'b -> TaggedText -> 'b abstract AddBreak : 'b -> int -> 'b abstract AddTag : 'b -> string * (string * string) list * bool -> 'b abstract Finish : 'b -> 'a @@ -223,9 +379,10 @@ type LayoutRenderer<'a,'b> = let renderL (rr: LayoutRenderer<_,_>) layout = let rec addL z pos i layout k = match layout with + | ObjLeaf _ -> failwith "ObjLeaf should never apper here" (* pos is tab level *) | Leaf (_,text,_) -> - k(rr.AddText z (unbox text),i + (unbox text).Length) + k(rr.AddText z text,i + text.Length) | Node (_,l,_,r,_,Broken indent) -> addL z pos i l <| fun (z,_i) -> @@ -234,7 +391,7 @@ let renderL (rr: LayoutRenderer<_,_>) layout = | Node (_,l,jm,r,_,_) -> addL z pos i l <| fun (z, i) -> - let z,i = if jm then z,i else rr.AddText z " ",i+1 + let z,i = if jm then z,i else rr.AddText z Literals.space, i+1 let pos = i addL z pos i r k | Attr (tag,attrs,l) -> @@ -252,7 +409,7 @@ let renderL (rr: LayoutRenderer<_,_>) layout = let stringR = { new LayoutRenderer with member x.Start () = [] - member x.AddText rstrs text = text::rstrs + member x.AddText rstrs text = text.Value::rstrs member x.AddBreak rstrs n = (spaces n) :: "\n" :: rstrs member x.AddTag z (_,_,_) = z member x.Finish rstrs = String.Join("",Array.ofList (List.rev rstrs)) } @@ -260,11 +417,21 @@ let stringR = type NoState = NoState type NoResult = NoResult +/// string render +let taggedTextListR collector = + { new LayoutRenderer with + member x.Start () = NoState + member x.AddText z text = collector text; z + member x.AddBreak rstrs n = collector Literals.lineBreak; collector (tagSpace(spaces n)); rstrs + member x.AddTag z (_,_,_) = z + member x.Finish rstrs = NoResult } + + /// channel LayoutRenderer let channelR (chan:TextWriter) = { new LayoutRenderer with member r.Start () = NoState - member r.AddText z s = chan.Write s; z + member r.AddText z s = chan.Write s.Value; z member r.AddBreak z n = chan.WriteLine(); chan.Write (spaces n); z member r.AddTag z (tag,attrs,start) = z member r.Finish z = NoResult } @@ -273,7 +440,7 @@ let channelR (chan:TextWriter) = let bufferR os = { new LayoutRenderer with member r.Start () = NoState - member r.AddText z s = bprintf os "%s" s; z + member r.AddText z s = bprintf os "%s" s.Value; z member r.AddBreak z n = bprintf os "\n"; bprintf os "%s" (spaces n); z member r.AddTag z (tag,attrs,start) = z member r.Finish z = NoResult } @@ -284,4 +451,4 @@ let bufferR os = let showL layout = renderL stringR layout let outL (chan:TextWriter) layout = renderL (channelR chan) layout |> ignore -let bufferL os layout = renderL (bufferR os) layout |> ignore +let bufferL os layout = renderL (bufferR os) layout |> ignore \ No newline at end of file diff --git a/src/fsharp/layout.fsi b/src/fsharp/layout.fsi index 8d8ec6c589b..44ba9e0fefb 100644 --- a/src/fsharp/layout.fsi +++ b/src/fsharp/layout.fsi @@ -3,19 +3,22 @@ module internal Microsoft.FSharp.Compiler.Layout open System.Text +open System.Collections.Generic open System.IO open Internal.Utilities.StructuredFormat +open Internal.Utilities.StructuredFormat.TaggedTextOps type layout = Internal.Utilities.StructuredFormat.Layout +type TaggedText = Internal.Utilities.StructuredFormat.TaggedText +module TaggedTextOps = Internal.Utilities.StructuredFormat.TaggedTextOps val emptyL : Layout val isEmptyL : Layout -> bool -val wordL : string -> Layout -val sepL : string -> Layout -val rightL : string -> Layout -val leftL : string -> Layout - +val wordL : TaggedText -> Layout +val sepL : TaggedText -> Layout +val rightL : TaggedText -> Layout +val leftL : TaggedText -> Layout val ( ^^ ) : Layout -> Layout -> Layout (* never break "glue" *) val ( ++ ) : Layout -> Layout -> Layout (* if break, indent=0 *) val ( -- ) : Layout -> Layout -> Layout (* if break, indent=1 *) @@ -45,10 +48,129 @@ val showL : Layout -> string val outL : TextWriter -> Layout -> unit val bufferL : StringBuilder -> Layout -> unit +module TaggedTextOps = + val tagActivePatternCase : (string -> TaggedText) + val tagActivePatternResult : (string -> TaggedText) + val tagAlias : (string -> TaggedText) + val tagClass : (string -> TaggedText) + val tagUnion : (string -> TaggedText) + val tagUnionCase : (string -> TaggedText) + val tagDelegate : (string -> TaggedText) + val tagEnum : (string -> TaggedText) + val tagEvent : (string -> TaggedText) + val tagField : (string -> TaggedText) + val tagInterface : (string -> TaggedText) + val tagKeyword : (string -> TaggedText) + val tagLineBreak : (string -> TaggedText) + val tagMethod : (string -> TaggedText) + val tagLocal : (string -> TaggedText) + val tagRecord : (string -> TaggedText) + val tagRecordField : (string -> TaggedText) + val tagModule : (string -> TaggedText) + val tagModuleBinding : (string -> TaggedText) + val tagMember : (string -> TaggedText) + val tagNamespace : (string -> TaggedText) + val tagNumericLiteral : (string -> TaggedText) + val tagOperator : (string -> TaggedText) + val tagParameter : (string -> TaggedText) + val tagProperty : (string -> TaggedText) + val tagSpace : (string -> TaggedText) + val tagStringLiteral : (string -> TaggedText) + val tagStruct : (string -> TaggedText) + val tagTypeParameter : (string -> TaggedText) + val tagText : (string -> TaggedText) + val tagPunctuation : (string -> TaggedText) + val tagUnknownEntity : (string -> TaggedText) + val tagUnknownType : (string -> TaggedText) + + module Literals = + // common tagged literals + val lineBreak : TaggedText + val space : TaggedText + val comma : TaggedText + val dot : TaggedText + val semicolon : TaggedText + val leftParen : TaggedText + val rightParen : TaggedText + val leftBracket : TaggedText + val rightBracket : TaggedText + val leftBrace: TaggedText + val rightBrace : TaggedText + val leftAngle: TaggedText + val rightAngle: TaggedText + val equals : TaggedText + val arrow : TaggedText + val questionMark : TaggedText + val colon: TaggedText + val minus: TaggedText + val keywordTrue: TaggedText + val keywordFalse: TaggedText + +module SepL = + val dot: Layout + val star: Layout + val colon: Layout + val questionMark: Layout + val leftParen: Layout + val comma: Layout + val space: Layout + val leftBracket: Layout + val leftAngle: Layout + val lineBreak: Layout + val rightParen: Layout + +module WordL = + val arrow: Layout + val star: Layout + val colon: Layout + val equals: Layout + val keywordNew: Layout + val structUnit: Layout + val keywordStatic: Layout + val keywordMember: Layout + val keywordVal: Layout + val keywordEvent: Layout + val keywordWith: Layout + val keywordSet: Layout + val keywordGet: Layout + val keywordTrue: Layout + val keywordFalse: Layout + val bar: Layout + val keywordStruct: Layout + val keywordInherit: Layout + val keywordEnd: Layout + val keywordNested: Layout + val keywordType: Layout + val keywordDelegate: Layout + val keywordOf: Layout + val keywordInternal: Layout + val keywordPrivate: Layout + val keywordAbstract: Layout + val keywordOverride: Layout + val keywordEnum: Layout + +module LeftL = + val leftParen: Layout + val questionMark: Layout + val colon: Layout + val leftBracketAngle: Layout + val leftBracketBar: Layout + val keywordTypeof: Layout + val keywordTypedefof: Layout + +module RightL = + val comma: Layout + val rightParen: Layout + val colon: Layout + val rightBracket: Layout + val rightAngle: Layout + val rightBracketAngle: Layout + val rightBracketBar: Layout + /// render a Layout yielding an 'a using a 'b (hidden state) type type LayoutRenderer<'a,'b> = abstract Start : unit -> 'b - abstract AddText : 'b -> string -> 'b + abstract AddText : 'b -> TaggedText -> 'b abstract AddBreak : 'b -> int -> 'b abstract AddTag : 'b -> string * (string * string) list * bool -> 'b abstract Finish : 'b -> 'a @@ -63,4 +185,5 @@ val renderL : LayoutRenderer<'b,'a> -> Layout -> 'b val stringR : LayoutRenderer val channelR : TextWriter -> LayoutRenderer val bufferR : StringBuilder -> LayoutRenderer +val taggedTextListR : collector: (TaggedText -> unit) -> LayoutRenderer diff --git a/src/fsharp/vs/ServiceDeclarations.fs b/src/fsharp/vs/ServiceDeclarations.fs index b614ea53f46..cc5b79330df 100644 --- a/src/fsharp/vs/ServiceDeclarations.fs +++ b/src/fsharp/vs/ServiceDeclarations.fs @@ -22,6 +22,7 @@ open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler.Range @@ -33,6 +34,8 @@ open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionIcons +type internal Layout = layout + module EnvMisc2 = let maxMembers = GetEnvInteger "FCS_MaxMembersInQuickInfo" 10 @@ -59,24 +62,48 @@ type FSharpXmlDoc = /// A single data tip display element [] -type FSharpToolTipElement = +type FSharpToolTipElement<'T> = | None /// A single type, method, etc with comment. - | Single of (* text *) string * FSharpXmlDoc + | Single of (* text *) 'T * FSharpXmlDoc /// A single parameter, with the parameter name. - | SingleParameter of (* text *) string * FSharpXmlDoc * string + | SingleParameter of (* text *) 'T * FSharpXmlDoc * string /// For example, a method overload group. - | Group of ((* text *) string * FSharpXmlDoc) list + | Group of ((* text *) 'T * FSharpXmlDoc) list /// An error occurred formatting this element | CompositionError of string +/// A single data tip display element with where text is expressed as string +type FSharpToolTipElement = FSharpToolTipElement + +/// A single data tip display element with where text is expressed as +type internal FSharpStructuredToolTipElement = FSharpToolTipElement + /// Information for building a data tip box. // // Note: this type does not hold any handles to compiler data structure. -type FSharpToolTipText = +type FSharpToolTipText<'T> = /// A list of data tip elements to display. - | FSharpToolTipText of FSharpToolTipElement list - + | FSharpToolTipText of FSharpToolTipElement<'T> list + +// specialization that stores data as strings +type FSharpToolTipText = FSharpToolTipText +// specialization that stores data as +type internal FSharpStructuredToolTipText = FSharpToolTipText + +module internal Tooltips = + let ToFSharpToolTipElement tooltip = + match tooltip with + | FSharpStructuredToolTipElement.None -> FSharpToolTipElement.None + | FSharpStructuredToolTipElement.Single(text, doc) -> FSharpToolTipElement.Single(showL text, doc) + | FSharpStructuredToolTipElement.SingleParameter(t, doc, name) -> FSharpToolTipElement.SingleParameter(showL t, doc, name) + | FSharpStructuredToolTipElement.Group(l) -> FSharpToolTipElement.Group(l |> List.map(fun (text, doc) -> showL text, doc)) + | FSharpStructuredToolTipElement.CompositionError(text) -> FSharpToolTipElement.CompositionError(text) + + let ToFSharpToolTipText (FSharpStructuredToolTipText.FSharpToolTipText(text)) = + FSharpToolTipText(List.map ToFSharpToolTipElement text) + + let Map f a = async.Bind(a, f >> async.Return) [] module internal ItemDescriptionsImpl = @@ -85,14 +112,14 @@ module internal ItemDescriptionsImpl = let _,tau = tryDestForallTy g typ isFunTy g tau - - let OutputFullName isDecl ppF fnF os r = + let OutputFullName isDecl ppF fnF r = // Only display full names in quick info, not declaration text if not isDecl then match ppF r with - | None -> () + | None -> emptyL | Some _ -> - bprintf os "\n\n%s: %s" (FSComp.SR.typeInfoFullName()) (fnF r) + sepL (tagLineBreak "\n\n") ^^ wordL (tagText (FSComp.SR.typeInfoFullName())) ^^ RightL.colon ^^ (fnF r) + else emptyL let rangeOfValRef preferFlag (vref:ValRef) = match preferFlag with @@ -427,18 +454,19 @@ module internal ItemDescriptionsImpl = GetXmlCommentForItemAux (if minfo.HasDirectXmlComment then Some minfo.XmlDoc else None) infoReader m d /// Output a method info - let FormatOverloadsToList (infoReader:InfoReader) m denv d minfos : FSharpToolTipElement = - let formatOne minfo = - let text = bufs (fun os -> NicePrint.formatMethInfoToBufferFreeStyle infoReader.amap m denv os minfo) + let FormatOverloadsToList (infoReader:InfoReader) m denv d minfos : FSharpStructuredToolTipElement = + let layoutOne minfo = + let layout = NicePrint.layoutMethInfoFreeStyle infoReader.amap m denv minfo + //let text = bufs (fun os -> NicePrint.formatMethInfoToBufferFreeStyle infoReader.amap m denv os minfo) let xml = GetXmlCommentForMethInfoItem infoReader m d minfo - text,xml + layout,xml ToolTipFault |> Option.iter (fun msg -> let exn = Error((0,msg),range.Zero) let ph = PhasedDiagnostic.Create(exn, BuildPhase.TypeCheck) simulateError ph) - FSharpToolTipElement.Group(minfos |> List.map formatOne) + FSharpStructuredToolTipElement.Group(minfos |> List.map layoutOne) let pubpath_of_vref (v:ValRef) = v.PublicPath @@ -727,38 +755,36 @@ module internal ItemDescriptionsImpl = // operator with solution FormatItemDescriptionToToolTipElement isDecl infoReader m denv (Item.Value vref) | Item.Value vref | Item.CustomBuilder (_,vref) -> - let text = - bufs (fun os -> - NicePrint.outputQualifiedValOrMember denv os vref.Deref - OutputFullName isDecl pubpath_of_vref fullDisplayTextOfValRef os vref) + let layout = + NicePrint.layoutQualifiedValOrMember denv vref.Deref ^^ + OutputFullName isDecl pubpath_of_vref fullDisplayTextOfValRefAsLayout vref - FSharpToolTipElement.Single(text, xml) + FSharpStructuredToolTipElement.Single(layout, xml) // Union tags (constructors) | Item.UnionCase(ucinfo,_) -> let uc = ucinfo.UnionCase let rty = generalizedTyconRef ucinfo.TyconRef let recd = uc.RecdFields - let text = - bufs (fun os -> - bprintf os "%s " (FSComp.SR.typeInfoUnionCase()) - NicePrint.outputTyconRef denv os ucinfo.TyconRef - bprintf os ".%s: " - (DecompileOpName uc.Id.idText) - if not (List.isEmpty recd) then - NicePrint.outputUnionCases denv os recd - os.Append (" -> ") |> ignore - NicePrint.outputTy denv os rty ) - - FSharpToolTipElement.Single(text, xml) + let layout = + wordL (tagText (FSComp.SR.typeInfoUnionCase())) ^^ + NicePrint.layoutTyconRef denv ucinfo.TyconRef ^^ + sepL (tagPunctuation ".") ^^ + wordL (tagUnionCase (DecompileOpName uc.Id.idText)) ^^ + RightL.colon ^^ + (if List.isEmpty recd then emptyL else NicePrint.layoutUnionCases denv recd ^^ WordL.arrow) ^^ + NicePrint.layoutTy denv rty + FSharpStructuredToolTipElement.Single(layout, xml) // Active pattern tag inside the declaration (result) | Item.ActivePatternResult(apinfo, ty, idx, _) -> let items = apinfo.ActiveTags - let text = bufs (fun os -> - bprintf os "%s %s: " (FSComp.SR.typeInfoActivePatternResult()) (List.item idx items) - NicePrint.outputTy denv os ty) - FSharpToolTipElement.Single(text, xml) + let layout = + wordL (tagText ((FSComp.SR.typeInfoActivePatternResult()))) ^^ + wordL (tagActivePatternResult (List.item idx items)) ^^ + RightL.colon ^^ + NicePrint.layoutTy denv ty + FSharpStructuredToolTipElement.Single(layout, xml) // Active pattern tags | Item.ActivePatternCase apref -> @@ -767,68 +793,73 @@ module internal ItemDescriptionsImpl = let _,tau = v.TypeScheme // REVIEW: use _cxs here let _, ptau, _cxs = PrettyTypes.PrettifyTypes1 denv.g tau - let text = - bufs (fun os -> - bprintf os "%s %s: " (FSComp.SR.typeInfoActiveRecognizer()) - apref.Name - NicePrint.outputTy denv os ptau - OutputFullName isDecl pubpath_of_vref fullDisplayTextOfValRef os v) - FSharpToolTipElement.Single(text, xml) + let layout = + wordL (tagText (FSComp.SR.typeInfoActiveRecognizer())) ^^ + wordL (tagActivePatternCase apref.Name) ^^ + RightL.colon ^^ + NicePrint.layoutTy denv ptau ^^ + OutputFullName isDecl pubpath_of_vref fullDisplayTextOfValRefAsLayout v + FSharpStructuredToolTipElement.Single(layout, xml) // F# exception names | Item.ExnCase ecref -> - let text = bufs (fun os -> - NicePrint.outputExnDef denv os ecref.Deref - OutputFullName isDecl pubpath_of_tcref fullDisplayTextOfExnRef os ecref) - FSharpToolTipElement.Single(text, xml) + let layout = + NicePrint.layoutExnDef denv ecref.Deref ^^ + OutputFullName isDecl pubpath_of_tcref fullDisplayTextOfExnRefAsLayout ecref + FSharpStructuredToolTipElement.Single(layout, xml) // F# record field names | Item.RecdField rfinfo -> let rfield = rfinfo.RecdField let _, ty, _cxs = PrettyTypes.PrettifyTypes1 g rfinfo.FieldType - let text = - bufs (fun os -> - NicePrint.outputTyconRef denv os rfinfo.TyconRef - bprintf os ".%s: " - (DecompileOpName rfield.Name) - NicePrint.outputTy denv os ty; - match rfinfo.LiteralValue with - | None -> () - | Some lit -> - try bprintf os " = %s" (Layout.showL ( NicePrint.layoutConst denv.g ty lit )) with _ -> ()) - FSharpToolTipElement.Single(text, xml) + let layout = + NicePrint.layoutTyconRef denv rfinfo.TyconRef ^^ + SepL.dot ^^ + wordL (tagRecordField (DecompileOpName rfield.Name)) ^^ + RightL.colon ^^ + NicePrint.layoutTy denv ty ^^ + ( + match rfinfo.LiteralValue with + | None -> emptyL + | Some lit -> try WordL.equals ^^ NicePrint.layoutConst denv.g ty lit with _ -> emptyL + ) + FSharpStructuredToolTipElement.Single(layout, xml) // Not used | Item.NewDef id -> - let dataTip = bufs (fun os -> bprintf os "%s %s" (FSComp.SR.typeInfoPatternVariable()) id.idText) - FSharpToolTipElement.Single(dataTip, xml) + let layout = + wordL (tagText (FSComp.SR.typeInfoPatternVariable())) ^^ + wordL (tagUnknownEntity id.idText) + FSharpStructuredToolTipElement.Single(layout, xml) // .NET fields | Item.ILField finfo -> - let dataTip = bufs (fun os -> - bprintf os "%s " (FSComp.SR.typeInfoField()) - NicePrint.outputILTypeRef denv os finfo.ILTypeRef - bprintf os ".%s" finfo.FieldName; - match finfo.LiteralValue with - | None -> () - | Some v -> - try bprintf os " = %s" (Layout.showL ( NicePrint.layoutConst denv.g (finfo.FieldType(infoReader.amap, m)) (TypeChecker.TcFieldInit m v) )) - with _ -> ()) - FSharpToolTipElement.Single(dataTip, xml) + let layout = + wordL (tagText (FSComp.SR.typeInfoField())) ^^ + NicePrint.layoutILTypeRef denv finfo.ILTypeRef ^^ + SepL.dot ^^ + wordL (tagField finfo.FieldName) ^^ + ( + match finfo.LiteralValue with + | None -> emptyL + | Some v -> + WordL.equals ^^ + try NicePrint.layoutConst denv.g (finfo.FieldType(infoReader.amap, m)) (TypeChecker.TcFieldInit m v) with _ -> emptyL + ) + FSharpStructuredToolTipElement.Single(layout, xml) // .NET events | Item.Event einfo -> let rty = PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo let _,rty, _cxs = PrettyTypes.PrettifyTypes1 g rty - let text = - bufs (fun os -> - // REVIEW: use _cxs here - bprintf os "%s " (FSComp.SR.typeInfoEvent()) - NicePrint.outputTyconRef denv os (tcrefOfAppTy g einfo.EnclosingType) - bprintf os ".%s: " einfo.EventName - NicePrint.outputTy denv os rty) - - FSharpToolTipElement.Single(text, xml) + let layout = + wordL (tagText (FSComp.SR.typeInfoEvent())) ^^ + NicePrint.layoutTyconRef denv (tcrefOfAppTy g einfo.EnclosingType) ^^ + SepL.dot ^^ + wordL (tagEvent einfo.EventName) ^^ + RightL.colon ^^ + NicePrint.layoutTy denv rty + FSharpStructuredToolTipElement.Single(layout, xml) // F# and .NET properties | Item.Property(_,pinfos) -> @@ -836,14 +867,15 @@ module internal ItemDescriptionsImpl = let rty = pinfo.GetPropertyType(amap,m) let rty = if pinfo.IsIndexer then mkRefTupledTy g (pinfo.GetParamTypes(amap, m)) --> rty else rty let _, rty, _ = PrettyTypes.PrettifyTypes1 g rty - let text = - bufs (fun os -> - bprintf os "%s " (FSComp.SR.typeInfoProperty()) - NicePrint.outputTyconRef denv os (tcrefOfAppTy g pinfo.EnclosingType) - bprintf os ".%s: " pinfo.PropertyName - NicePrint.outputTy denv os rty) + let layout = + wordL (tagText (FSComp.SR.typeInfoProperty())) ^^ + NicePrint.layoutTyconRef denv (tcrefOfAppTy g pinfo.EnclosingType) ^^ + SepL.dot ^^ + wordL (tagProperty pinfo.PropertyName) ^^ + RightL.colon ^^ + NicePrint.layoutTy denv rty - FSharpToolTipElement.Single(text, xml) + FSharpStructuredToolTipElement.Single(layout, xml) // Custom operations in queries | Item.CustomOperation (customOpName,usageText,Some minfo) -> @@ -851,28 +883,24 @@ module internal ItemDescriptionsImpl = // Build 'custom operation: where (bool) // // Calls QueryBuilder.Where' - let text = - bufs (fun os -> - bprintf os "%s: " (FSComp.SR.typeInfoCustomOperation()) - match usageText() with - | Some t -> - bprintf os "%s" t - | None -> + let layout = + wordL (tagText (FSComp.SR.typeInfoCustomOperation())) ^^ + RightL.colon ^^ + ( + match usageText() with + | Some t -> wordL (tagText t) + | None -> let argTys = ParamNameAndTypesOfUnaryCustomOperation g minfo |> List.map (fun (ParamNameAndType(_,ty)) -> ty) let _, argTys, _ = PrettyTypes.PrettifyTypesN g argTys + wordL (tagMethod customOpName) ^^ sepListL SepL.space (List.map (fun ty -> LeftL.leftParen ^^ NicePrint.layoutTy denv ty ^^ SepL.rightParen) argTys) + ) ^^ + SepL.lineBreak ^^ SepL.lineBreak ^^ + wordL (tagText (FSComp.SR.typeInfoCallsWord())) ^^ + NicePrint.layoutTyconRef denv (tcrefOfAppTy g minfo.EnclosingType) ^^ + SepL.dot ^^ + wordL (tagMethod minfo.DisplayName) - bprintf os "%s" customOpName - for argTy in argTys do - bprintf os " (" - NicePrint.outputTy denv os argTy - bprintf os ")" - bprintf os "\n\n%s " - (FSComp.SR.typeInfoCallsWord()) - NicePrint.outputTyconRef denv os (tcrefOfAppTy g minfo.EnclosingType) - bprintf os ".%s " - minfo.DisplayName) - - FSharpToolTipElement.Single(text, xml) + FSharpStructuredToolTipElement.Single(layout, xml) // F# constructors and methods | Item.CtorGroup(_,minfos) @@ -886,39 +914,41 @@ module internal ItemDescriptionsImpl = // and in that case we'll just show the interface type name. | Item.FakeInterfaceCtor typ -> let _, typ, _ = PrettyTypes.PrettifyTypes1 g typ - let text = bufs (fun os -> NicePrint.outputTyconRef denv os (tcrefOfAppTy g typ)) - FSharpToolTipElement.Single(text, xml) + let layout = NicePrint.layoutTyconRef denv (tcrefOfAppTy g typ) + FSharpStructuredToolTipElement.Single(layout, xml) // The 'fake' representation of constructors of .NET delegate types | Item.DelegateCtor delty -> let _, delty, _cxs = PrettyTypes.PrettifyTypes1 g delty let (SigOfFunctionForDelegate(_, _, _, fty)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere - let text = bufs (fun os -> - NicePrint.outputTyconRef denv os (tcrefOfAppTy g delty) - bprintf os "(" - NicePrint.outputTy denv os fty - bprintf os ")") - FSharpToolTipElement.Single(text, xml) + let layout = + NicePrint.layoutTyconRef denv (tcrefOfAppTy g delty) ^^ + LeftL.leftParen ^^ + NicePrint.layoutTy denv fty ^^ + RightL.rightParen + FSharpStructuredToolTipElement.Single(layout, xml) // Types. | Item.Types(_,((TType_app(tcref,_)):: _)) -> - let text = - bufs (fun os -> - let denv = { denv with shortTypeNames = true } - NicePrint.outputTycon denv infoReader AccessibleFromSomewhere m (* width *) os tcref.Deref - OutputFullName isDecl pubpath_of_tcref fullDisplayTextOfTyconRef os tcref) - FSharpToolTipElement.Single(text, xml) + let denv = { denv with shortTypeNames = true } + let layout = + NicePrint.layoutTycon denv infoReader AccessibleFromSomewhere m (* width *) tcref.Deref ^^ + OutputFullName isDecl pubpath_of_tcref fullDisplayTextOfTyconRefAsLayout tcref + FSharpStructuredToolTipElement.Single(layout, xml) // F# Modules and namespaces | Item.ModuleOrNamespaces((modref :: _) as modrefs) -> - let os = StringBuilder() + //let os = StringBuilder() let modrefs = modrefs |> RemoveDuplicateModuleRefs let definiteNamespace = modrefs |> List.forall (fun modref -> modref.IsNamespace) let kind = if definiteNamespace then FSComp.SR.typeInfoNamespace() elif modrefs |> List.forall (fun modref -> modref.IsModule) then FSComp.SR.typeInfoModule() else FSComp.SR.typeInfoNamespaceOrModule() - bprintf os "%s %s" kind (if definiteNamespace then fullDisplayTextOfModRef modref else modref.DemangledModuleOrNamespaceName) + + let layout = + wordL (tagKeyword kind) ^^ + wordL (if definiteNamespace then tagNamespace (fullDisplayTextOfModRef modref) else (tagModule modref.DemangledModuleOrNamespaceName)) if not definiteNamespace then let namesToAdd = ([],modrefs) @@ -928,30 +958,41 @@ module internal ItemDescriptionsImpl = | _ -> st) |> Seq.mapi (fun i x -> i,x) |> Seq.toList - if not (List.isEmpty namesToAdd) then - bprintf os "\n" - for i, txt in namesToAdd do - bprintf os "\n%s" ((if i = 0 then FSComp.SR.typeInfoFromFirst else FSComp.SR.typeInfoFromNext) txt) - FSharpToolTipElement.Single(os.ToString(), xml) + let layout = + layout ^^ + ( + if not (List.isEmpty namesToAdd) then + SepL.lineBreak ^^ + List.fold ( fun s (i, txt) -> + s ^^ + SepL.lineBreak ^^ + wordL (tagText ((if i = 0 then FSComp.SR.typeInfoFromFirst else FSComp.SR.typeInfoFromNext) txt)) + ) emptyL namesToAdd + else + emptyL + ) + FSharpStructuredToolTipElement.Single(layout, xml) else - FSharpToolTipElement.Single(os.ToString(), xml) + FSharpStructuredToolTipElement.Single(layout, xml) // Named parameters | Item.ArgName (id, argTy, _) -> let _, argTy, _ = PrettyTypes.PrettifyTypes1 g argTy - let text = bufs (fun os -> - bprintf os "%s %s : " (FSComp.SR.typeInfoArgument()) id.idText - NicePrint.outputTy denv os argTy) - FSharpToolTipElement.SingleParameter(text, xml, id.idText) + let layout = + wordL (tagText (FSComp.SR.typeInfoArgument())) ^^ + wordL (tagParameter id.idText) ^^ + RightL.colon ^^ + NicePrint.layoutTy denv argTy + FSharpStructuredToolTipElement.SingleParameter(layout, xml, id.idText) | Item.SetterArg (_, item) -> FormatItemDescriptionToToolTipElement isDecl infoReader m denv item | _ -> - FSharpToolTipElement.None + FSharpStructuredToolTipElement.None // Format the return type of an item - let rec FormatItemReturnTypeToBuffer (infoReader:InfoReader) m denv os d = + let rec FormatItemReturnTypeAsLayout (infoReader:InfoReader) m denv d = let isDecl = false let g = infoReader.g let amap = infoReader.amap @@ -964,15 +1005,12 @@ module internal ItemDescriptionsImpl = let dtau,rtau = destFunTy g tau let ptausL,tpcsL = NicePrint.layoutPrettifiedTypes denv [dtau;rtau] let _,prtauL = List.frontAndBack ptausL - bprintf os ": " - bufferL os prtauL - bprintf os " " - bufferL os tpcsL + RightL.colon ^^ prtauL ^^ SepL.space ^^ tpcsL else - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] tau) + NicePrint.layoutPrettifiedTypeAndConstraints denv [] tau | Item.UnionCase(ucinfo,_) -> let rty = generalizedTyconRef ucinfo.TyconRef - NicePrint.outputTy denv os rty + NicePrint.layoutTy denv rty | Item.ActivePatternCase(apref) -> let v = apref.ActivePatternVal let _, tau = v.TypeScheme @@ -982,31 +1020,30 @@ module internal ItemDescriptionsImpl = let aparity = apnames.Length let rty = if aparity <= 1 then res else List.item apref.CaseIndex (argsOfAppTy g res) - NicePrint.outputTy denv os rty + NicePrint.layoutTy denv rty | Item.ExnCase _ -> - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] g.exn_ty) + NicePrint.layoutPrettifiedTypeAndConstraints denv [] g.exn_ty | Item.RecdField(rfinfo) -> - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] rfinfo.FieldType); + NicePrint.layoutPrettifiedTypeAndConstraints denv [] rfinfo.FieldType | Item.ILField(finfo) -> - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] (finfo.FieldType(amap,m))) + NicePrint.layoutPrettifiedTypeAndConstraints denv [] (finfo.FieldType(amap,m)) | Item.Event(einfo) -> - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo)) + NicePrint.layoutPrettifiedTypeAndConstraints denv [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo) | Item.Property(_,pinfos) -> let pinfo = List.head pinfos let rty = pinfo.GetPropertyType(amap,m) - let layout = (NicePrint.layoutPrettifiedTypeAndConstraints denv [] rty) - bufferL os layout + NicePrint.layoutPrettifiedTypeAndConstraints denv [] rty | Item.CustomOperation (_,_,Some minfo) | Item.MethodGroup(_,(minfo :: _),_) | Item.CtorGroup(_,(minfo :: _)) -> let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] rty) + NicePrint.layoutPrettifiedTypeAndConstraints denv [] rty | Item.FakeInterfaceCtor typ | Item.DelegateCtor typ -> - bufferL os (NicePrint.layoutPrettifiedTypeAndConstraints denv [] typ) - | Item.TypeVar _ -> () + NicePrint.layoutPrettifiedTypeAndConstraints denv [] typ + | Item.TypeVar _ -> emptyL - | _ -> () + | _ -> emptyL let rec GetF1Keyword d : string option = let rec unwindTypeAbbrev (tcref : TyconRef) = @@ -1169,13 +1206,21 @@ module internal ItemDescriptionsImpl = | Item.ActivePatternResult _ // "let (|Foo|Bar|) = .. Fo$o ..." - no keyword -> None - let FormatDescriptionOfItem isDecl (infoReader:InfoReader) m denv d : FSharpToolTipElement = + let FormatStructuredDescriptionOfItem isDecl (infoReader:InfoReader) m denv d : FSharpStructuredToolTipElement = ErrorScope.Protect m (fun () -> FormatItemDescriptionToToolTipElement isDecl infoReader m denv d) - (fun err -> FSharpToolTipElement.CompositionError(err)) + (fun err -> FSharpStructuredToolTipElement.CompositionError(err)) + + let FormatDescriptionOfItem isDecl infoReader m denv d = + FormatStructuredDescriptionOfItem isDecl infoReader m denv d + |> Tooltips.ToFSharpToolTipElement + let FormatStructuredReturnTypeOfItem (infoReader:InfoReader) m denv d = + ErrorScope.Protect m (fun () -> FormatItemReturnTypeAsLayout infoReader m denv d) (fun err -> wordL (tagText err)) + let FormatReturnTypeOfItem (infoReader:InfoReader) m denv d = - ErrorScope.Protect m (fun () -> bufs (fun buf -> FormatItemReturnTypeToBuffer infoReader m denv buf d)) (fun err -> err) + FormatStructuredReturnTypeOfItem infoReader m denv d + |> showL // Compute the index of the VS glyph shown with an item in the Intellisense menu let GlyphOfItem(denv,d) = @@ -1266,12 +1311,12 @@ module internal ItemDescriptionsImpl = /// An intellisense declaration [] type FSharpDeclarationListItem(name: string, glyphMajor: GlyphMajor, glyphMinor: GlyphMinor, info, isAttribute: bool) = - let mutable descriptionTextHolder:FSharpToolTipText option = None + let mutable descriptionTextHolder:FSharpToolTipText<_> option = None let mutable task = null member decl.Name = name - member decl.DescriptionTextAsync = + member decl.StructuredDescriptionTextAsync = match info with | Choice1Of2 (items, infoReader, m, denv, reactor:IReactorOperations, checkAlive) -> // reactor causes the lambda to execute on the background compiler thread, through the Reactor @@ -1280,12 +1325,16 @@ type FSharpDeclarationListItem(name: string, glyphMajor: GlyphMajor, glyphMinor: // It is written to be robust to a disposal of an IncrementalBuilder, in which case it will just return the empty string. // It is best to think of this as a "weak reference" to the IncrementalBuilder, i.e. this code is written to be robust to its // disposal. Yes, you are right to scratch your head here, but this is ok. - if checkAlive() then FSharpToolTipText(items |> Seq.toList |> List.map (FormatDescriptionOfItem true infoReader m denv)) - else FSharpToolTipText [ FSharpToolTipElement.Single(FSComp.SR.descriptionUnavailable(), FSharpXmlDoc.None) ]) + if checkAlive() then FSharpToolTipText(items |> Seq.toList |> List.map (FormatStructuredDescriptionOfItem true infoReader m denv)) + else FSharpToolTipText [ FSharpStructuredToolTipElement.Single(wordL (tagText (FSComp.SR.descriptionUnavailable())), FSharpXmlDoc.None) ]) | Choice2Of2 result -> async.Return result - member decl.DescriptionText = + member decl.DescriptionTextAsync = + decl.StructuredDescriptionTextAsync + |> Tooltips.Map Tooltips.ToFSharpToolTipText + + member decl.StructuredDescriptionText = match descriptionTextHolder with | Some descriptionText -> descriptionText | None -> @@ -1297,7 +1346,7 @@ type FSharpDeclarationListItem(name: string, glyphMajor: GlyphMajor, glyphMinor: if isNull task then // kick off the actual (non-cooperative) work task <- System.Threading.Tasks.Task.Factory.StartNew(fun() -> - let text = decl.DescriptionTextAsync |> Async.RunSynchronously + let text = decl.StructuredDescriptionTextAsync |> Async.RunSynchronously descriptionTextHolder <- Some text) // The dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. @@ -1305,11 +1354,13 @@ type FSharpDeclarationListItem(name: string, glyphMajor: GlyphMajor, glyphMinor: task.Wait EnvMisc2.dataTipSpinWaitTime |> ignore match descriptionTextHolder with | Some text -> text - | None -> FSharpToolTipText [ FSharpToolTipElement.Single(FSComp.SR.loadingDescription(), FSharpXmlDoc.None) ] + | None -> FSharpToolTipText [ FSharpStructuredToolTipElement.Single(wordL (tagText (FSComp.SR.loadingDescription())), FSharpXmlDoc.None) ] | Choice2Of2 result -> result + member decl.DescriptionText = decl.StructuredDescriptionText |> Tooltips.ToFSharpToolTipText + member decl.Glyph = 6 * int glyphMajor + int glyphMinor member decl.GlyphMajor = glyphMajor member decl.GlyphMinor = glyphMinor @@ -1378,5 +1429,5 @@ type FSharpDeclarationListInfo(declarations: FSharpDeclarationListItem[]) = static member Error msg = new FSharpDeclarationListInfo( - [| new FSharpDeclarationListItem("", GlyphMajor.Error, GlyphMinor.Normal, Choice2Of2 (FSharpToolTipText [FSharpToolTipElement.CompositionError msg]), false) |] ) - static member Empty = FSharpDeclarationListInfo([| |]) \ No newline at end of file + [| new FSharpDeclarationListItem("", GlyphMajor.Error, GlyphMinor.Normal, Choice2Of2 (FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError msg]), false) |] ) + static member Empty = new FSharpDeclarationListInfo([| |]) diff --git a/src/fsharp/vs/ServiceDeclarations.fsi b/src/fsharp/vs/ServiceDeclarations.fsi index d32cad3d241..24e5fd378b2 100755 --- a/src/fsharp/vs/ServiceDeclarations.fsi +++ b/src/fsharp/vs/ServiceDeclarations.fsi @@ -28,28 +28,44 @@ type internal FSharpXmlDoc = /// Indicates that the text for the documentation can be found in a .xml documentation file, using the given signature key | XmlDocFileSignature of (*File:*) string * (*Signature:*)string +type internal Layout = Internal.Utilities.StructuredFormat.Layout + /// A single tool tip display element // // Note: instances of this type do not hold any references to any compiler resources. [] -type internal FSharpToolTipElement = +type internal FSharpToolTipElement<'T> = | None /// A single type, method, etc with comment. - | Single of (* text *) string * FSharpXmlDoc + | Single of (* text *) 'T * FSharpXmlDoc /// A single parameter, with the parameter name. - | SingleParameter of (* text *) string * FSharpXmlDoc * string + | SingleParameter of (* text *) 'T * FSharpXmlDoc * string /// For example, a method overload group. - | Group of ((* text *) string * FSharpXmlDoc) list + | Group of ((* text *) 'T * FSharpXmlDoc) list /// An error occurred formatting this element | CompositionError of string +/// A single data tip display element with where text is expressed as string +type FSharpToolTipElement = FSharpToolTipElement + +/// A single data tip display element with where text is expressed as +type internal FSharpStructuredToolTipElement = FSharpToolTipElement + /// Information for building a tool tip box. // // Note: instances of this type do not hold any references to any compiler resources. -type internal FSharpToolTipText = +type internal FSharpToolTipText<'T> = /// A list of data tip elements to display. - | FSharpToolTipText of FSharpToolTipElement list - + | FSharpToolTipText of FSharpToolTipElement<'T> list + +type FSharpToolTipText = FSharpToolTipText +type internal FSharpStructuredToolTipText = FSharpToolTipText + +module internal Tooltips = + val ToFSharpToolTipElement: FSharpStructuredToolTipElement -> FSharpToolTipElement + val ToFSharpToolTipText: FSharpStructuredToolTipText -> FSharpToolTipText + val Map: f: ('T1 -> 'T2) -> a: Async<'T1> -> Async<'T2> + [] /// Represents a declaration in F# source code, with information attached ready for display by an editor. /// Returned by GetDeclarations. @@ -62,8 +78,11 @@ type internal FSharpDeclarationListItem = /// resources and may trigger execution of a type provider method to retrieve documentation. /// /// May return "Loading..." if timeout occurs + member StructuredDescriptionText : FSharpStructuredToolTipText member DescriptionText : FSharpToolTipText + /// Get the description text, asynchronously. Never returns "Loading...". + member StructuredDescriptionTextAsync : Async member DescriptionTextAsync : Async /// Get the glyph integer for the declaration as used by Visual Studio. member Glyph : int @@ -100,7 +119,9 @@ module internal ItemDescriptionsImpl = val GetXmlDocSigOfProp : InfoReader -> range -> PropInfo -> (string option * string) option val GetXmlDocSigOfEvent : InfoReader -> range -> EventInfo -> (string option * string) option val GetXmlCommentForItem : InfoReader -> range -> Item -> FSharpXmlDoc - val FormatDescriptionOfItem : bool -> InfoReader -> range -> DisplayEnv -> Item -> FSharpToolTipElement + val FormatStructuredDescriptionOfItem : bool -> InfoReader -> range -> DisplayEnv -> Item -> FSharpToolTipElement + val FormatDescriptionOfItem : bool -> InfoReader -> range -> DisplayEnv -> Item -> FSharpToolTipElement + val FormatStructuredReturnTypeOfItem : InfoReader -> range -> DisplayEnv -> Item -> Layout val FormatReturnTypeOfItem : InfoReader -> range -> DisplayEnv -> Item -> string val RemoveDuplicateItems : TcGlobals -> Item list -> Item list val RemoveExplicitlySuppressed : TcGlobals -> Item list -> Item list diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs old mode 100755 new mode 100644 index eb1c28e434b..1cd94deac9e --- a/src/fsharp/vs/service.fs +++ b/src/fsharp/vs/service.fs @@ -44,6 +44,7 @@ open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionsImpl open Internal.Utilities open Internal.Utilities.Collections +type internal Layout = Internal.Utilities.StructuredFormat.Layout [] module EnvMisc = @@ -63,10 +64,11 @@ module EnvMisc = //-------------------------------------------------------------------------- [] -type FSharpMethodGroupItemParameter(name: string, canonicalTypeTextForSorting: string, display: string, isOptional: bool) = +type FSharpMethodGroupItemParameter(name: string, canonicalTypeTextForSorting: string, display: Layout, isOptional: bool) = member __.ParameterName = name member __.CanonicalTypeTextForSorting = canonicalTypeTextForSorting - member __.Display = display + member __.StructuredDisplay = display + member __.Display = showL display member __.IsOptional = isOptional /// Format parameters for Intellisense completion @@ -83,12 +85,12 @@ module internal Params = FSharpMethodGroupItemParameter( name = f.rfield_id.idText, canonicalTypeTextForSorting = printCanonicalizedTypeName g denv f.rfield_type, - display = NicePrint.prettyStringOfTy denv f.rfield_type, + display = NicePrint.prettyLayoutOfTy denv f.rfield_type, isOptional=false) let ParamOfUnionCaseField g denv isGenerated (i : int) f = let initial = ParamOfRecdField g denv f - let display = if isGenerated i f then initial.Display else NicePrint.stringOfParamData denv (ParamData(false, false, NotOptional, NoCallerInfo, Some f.rfield_id, ReflectedArgInfo.None, f.rfield_type)) + let display = if isGenerated i f then initial.StructuredDisplay else NicePrint.layoutOfParamData denv (ParamData(false, false, NotOptional, NoCallerInfo, Some f.rfield_id, ReflectedArgInfo.None, f.rfield_type)) FSharpMethodGroupItemParameter( name=initial.ParameterName, canonicalTypeTextForSorting=initial.CanonicalTypeTextForSorting, @@ -99,7 +101,7 @@ module internal Params = FSharpMethodGroupItemParameter( name = (match nmOpt with None -> "" | Some pn -> pn.idText), canonicalTypeTextForSorting = printCanonicalizedTypeName g denv pty, - display = NicePrint.stringOfParamData denv paramData, + display = NicePrint.layoutOfParamData denv paramData, isOptional=optArgInfo.IsOptional) // TODO this code is similar to NicePrint.fs:formatParamDataToBuffer, refactor or figure out why different? @@ -114,18 +116,23 @@ module internal Params = let nm = id.idText // detect parameter type, if ptyOpt is None - this is .NET style optional argument let pty = defaultArg ptyOpt pty - (nm, isOptArg, sprintf "?%s:" nm), pty + (nm, isOptArg, SepL.questionMark ^^ (wordL (TaggedTextOps.tagParameter nm))), pty // Layout an unnamed argument | None, _,_ -> - ("", isOptArg, ""), pty + ("", isOptArg, emptyL), pty // Layout a named argument | Some id,_,_ -> let nm = id.idText let prefix = - if isParamArrayArg then - sprintf "%s %s: " (NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute |> showL) nm + if isParamArrayArg then + NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ + wordL (TaggedTextOps.tagParameter nm) ^^ + RightL.colon + //sprintf "%s %s: " (NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute |> showL) nm else - sprintf "%s: " nm + wordL (TaggedTextOps.tagParameter nm) ^^ + RightL.colon + //sprintf "%s: " nm (nm,isOptArg, prefix),pty) |> List.unzip let paramTypeAndRetLs,_ = NicePrint.layoutPrettifiedTypes denv (paramTypes@[rty]) @@ -134,7 +141,7 @@ module internal Params = FSharpMethodGroupItemParameter( name = nm, canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tau, - display = paramPrefix+(showL tyL), + display = paramPrefix ^^ tyL, isOptional=isOptArg )) @@ -145,7 +152,7 @@ module internal Params = FSharpMethodGroupItemParameter( name = "", canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tau, - display = Layout.showL tyL, + display = tyL, isOptional=false ) (args,argsL) ||> List.zip |> List.map mkParam @@ -212,13 +219,14 @@ module internal Params = staticParameters |> Array.map (fun sp -> let typ = Import.ImportProvidedType amap m (sp.PApply((fun x -> x.ParameterType),m)) - let spKind = NicePrint.stringOfTy denv typ + let spKind = NicePrint.prettyLayoutOfTy denv typ let spName = sp.PUntaint((fun sp -> sp.Name), m) let spOpt = sp.PUntaint((fun sp -> sp.IsOptional), m) FSharpMethodGroupItemParameter( name = spName, - canonicalTypeTextForSorting = spKind, - display = sprintf "%s%s: %s" (if spOpt then "?" else "") spName spKind, + canonicalTypeTextForSorting = showL spKind, + display = (if spOpt then SepL.questionMark else emptyL) ^^ wordL (TaggedTextOps.tagParameter spName) ^^ RightL.colon ^^ spKind, + //display = sprintf "%s%s: %s" (if spOpt then "?" else "") spName spKind, isOptional=spOpt)) #endif | _ -> [| |] @@ -302,10 +310,12 @@ module internal Params = /// A single method for Intellisense completion [] // Note: instances of this type do not hold any references to any compiler resources. -type FSharpMethodGroupItem(description: FSharpToolTipText, xmlDoc: FSharpXmlDoc, typeText: string, parameters: FSharpMethodGroupItemParameter[], hasParameters: bool, hasParamArrayArg: bool, staticParameters: FSharpMethodGroupItemParameter[]) = - member __.Description = description +type FSharpMethodGroupItem(description: FSharpToolTipText, xmlDoc: FSharpXmlDoc, typeText: Layout, parameters: FSharpMethodGroupItemParameter[], hasParameters: bool, hasParamArrayArg: bool, staticParameters: FSharpMethodGroupItemParameter[]) = + member __.StructuredDescription = description + member __.Description = Tooltips.ToFSharpToolTipText description member __.XmlDoc = xmlDoc - member __.TypeText = typeText + member __.StructuredTypeText = typeText + member __.TypeText = showL typeText member __.Parameters = parameters member __.HasParameters = hasParameters member __.HasParamArrayArg = hasParamArrayArg @@ -331,7 +341,7 @@ type FSharpMethodGroup( name: string, unsortedMethods: FSharpMethodGroupItem[] ) |> Array.map (fun meth -> let parms = meth.Parameters if parms.Length = 1 && parms.[0].CanonicalTypeTextForSorting="Microsoft.FSharp.Core.Unit" then - FSharpMethodGroupItem(meth.Description, meth.XmlDoc, meth.TypeText, [||], true, meth.HasParamArrayArg, meth.StaticParameters) + FSharpMethodGroupItem(meth.StructuredDescription, meth.XmlDoc, meth.StructuredTypeText, [||], true, meth.HasParamArrayArg, meth.StaticParameters) else meth) // Fix the order of methods, to be stable for unit testing. @@ -382,8 +392,8 @@ type FSharpMethodGroup( name: string, unsortedMethods: FSharpMethodGroupItem[] ) let methods = items |> Array.ofList |> Array.map (fun item -> FSharpMethodGroupItem( - description = FSharpToolTipText [FormatDescriptionOfItem true infoReader m denv item], - typeText = FormatReturnTypeOfItem infoReader m denv item, + description = FSharpToolTipText [FormatStructuredDescriptionOfItem true infoReader m denv item], + typeText = FormatStructuredReturnTypeOfItem infoReader m denv item, xmlDoc = GetXmlCommentForItem infoReader m item, parameters = (Params.ParamsOfItem infoReader m denv item |> Array.ofList), hasParameters = (match item with Params.ItemIsProvidedTypeWithStaticArguments m g _ -> false | _ -> true), @@ -501,7 +511,7 @@ type TypeCheckInfo // Is not keyed on 'Names' collection because this is invariant for the current position in // this unchanged file. Keyed on lineStr though to prevent a change to the currently line // being available against a stale scope. - let getToolTipTextCache = AgedLookup(getToolTipTextSize,areSame=(fun (x,y) -> x = y)) + let getToolTipTextCache = AgedLookup>(getToolTipTextSize,areSame=(fun (x,y) -> x = y)) let amap = tcImports.GetImportMap() let infoReader = new InfoReader(g,amap) @@ -1217,7 +1227,7 @@ type TypeCheckInfo (fun _msg -> []) /// Get the "reference resolution" tooltip for at a location - member scope.GetReferenceResolutionToolTipText(line,col) = + member scope.GetReferenceResolutionStructuredToolTipText(line,col) = let pos = mkPos line col let isPosMatch(pos, ar:AssemblyReference) : bool = let isRangeMatch = (Range.rangeContainsPos ar.Range pos) @@ -1238,28 +1248,27 @@ type TypeCheckInfo match matches with | resolved::_ // Take the first seen | [resolved] -> - let tip = resolved.prepareToolTip () - FSharpToolTipText [FSharpToolTipElement.Single(tip.TrimEnd([|'\n'|]) ,FSharpXmlDoc.None)] + let tip = wordL (TaggedTextOps.tagStringLiteral((resolved.prepareToolTip ()).TrimEnd([|'\n'|]))) + FSharpStructuredToolTipText.FSharpToolTipText [FSharpStructuredToolTipElement.Single(tip ,FSharpXmlDoc.None)] - | [] -> FSharpToolTipText [] + | [] -> FSharpStructuredToolTipText.FSharpToolTipText [] ErrorScope.Protect Range.range0 dataTipOfReferences - (fun err -> FSharpToolTipText [FSharpToolTipElement.CompositionError err]) + (fun err -> FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) // GetToolTipText: return the "pop up" (or "Quick Info") text given a certain context. - member x.GetToolTipText line lineStr colAtEndOfNames names = - + member x.GetStructuredToolTipText line lineStr colAtEndOfNames names = let Compute() = ErrorScope.Protect Range.range0 (fun () -> match GetDeclItemsForNamesAtPosition(None,Some(names),None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.Yes,fun _ -> false) with | None -> FSharpToolTipText [] - | Some (items, denv, m) -> - FSharpToolTipText(items |> List.map (FormatDescriptionOfItem false infoReader m denv ))) - (fun err -> FSharpToolTipText [FSharpToolTipElement.CompositionError err]) + | Some(items, denv, m) -> + FSharpToolTipText(items |> List.map (FormatStructuredDescriptionOfItem false infoReader m denv ))) + (fun err -> FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) // See devdiv bug 646520 for rationale behind truncating and caching these quick infos (they can be big!) let key = line,colAtEndOfNames,lineStr @@ -1270,6 +1279,11 @@ type TypeCheckInfo getToolTipTextCache.Put(key,res) res + // GetToolTipText: return the "pop up" (or "Quick Info") text given a certain context. + member x.GetToolTipText line lineStr colAtEndOfNames names = + x.GetStructuredToolTipText line lineStr colAtEndOfNames names + |> Tooltips.ToFSharpToolTipText + member x.GetF1Keyword (line, lineStr, colAtEndOfNames, names) : string option = ErrorScope.Protect Range.range0 @@ -1966,16 +1980,20 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo reactorOp "GetDeclarationListSymbols" List.empty (fun scope -> scope.GetDeclarationListSymbols(parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck)) /// Resolve the names at the given location to give a data tip - member info.GetToolTipTextAlternate(line, colAtEndOfNames, lineStr, names, tokenTag) = + member info.GetStructuredToolTipTextAlternate(line, colAtEndOfNames, lineStr, names, tokenTag) = let dflt = FSharpToolTipText [] match tokenTagToTokenId tokenTag with | TOKEN_IDENT -> - reactorOp "GetToolTipText" dflt (fun scope -> scope.GetToolTipText line lineStr colAtEndOfNames names) + reactorOp "GetToolTipText" dflt (fun scope -> scope.GetStructuredToolTipText line lineStr colAtEndOfNames names) | TOKEN_STRING | TOKEN_STRING_TEXT -> - reactorOp "GetReferenceResolutionToolTipText" dflt (fun scope -> scope.GetReferenceResolutionToolTipText(line, colAtEndOfNames) ) + reactorOp "GetReferenceResolutionToolTipText" dflt (fun scope -> scope.GetReferenceResolutionStructuredToolTipText(line, colAtEndOfNames) ) | _ -> async.Return dflt + member info.GetToolTipTextAlternate(line, colAtEndOfNames, lineStr, names, tokenTag) = + info.GetStructuredToolTipTextAlternate(line, colAtEndOfNames, lineStr, names, tokenTag) + |> Tooltips.Map Tooltips.ToFSharpToolTipText + member info.GetF1KeywordAlternate (line, colAtEndOfNames, lineStr, names) = reactorOp "GetF1Keyword" None (fun scope -> scope.GetF1Keyword (line, lineStr, colAtEndOfNames, names)) diff --git a/src/fsharp/vs/service.fsi b/src/fsharp/vs/service.fsi index 9d780d065f5..8b972ef4f98 100755 --- a/src/fsharp/vs/service.fsi +++ b/src/fsharp/vs/service.fsi @@ -25,6 +25,10 @@ type internal FSharpMethodGroupItemParameter = /// A key that can be used for sorting the parameters, used to help sort overloads. member CanonicalTypeTextForSorting: string + /// The structured representation for the parameter including its name, its type and visual indicators of other + /// information such as whether it is optional. + member StructuredDisplay: Layout + /// The text to display for the parameter including its name, its type and visual indicators of other /// information such as whether it is optional. member Display: string @@ -40,9 +44,15 @@ type internal FSharpMethodGroupItem = /// The documentation for the item member XmlDoc : FSharpXmlDoc + /// The structured description representation for the method (or other item) + member StructuredDescription : FSharpStructuredToolTipText + /// The formatted description text for the method (or other item) member Description : FSharpToolTipText + /// The The structured description representation for the method (or other item) + member StructuredTypeText: Layout + /// The formatted type text for the method (or other item) member TypeText: string @@ -201,6 +211,15 @@ type internal FSharpCheckFileResults = member GetDeclarationListSymbols : ParsedFileResultsOpt:FSharpParseFileResults option * line: int * colAtEndOfPartialName: int * lineText:string * qualifyingNames: string list * partialName: string * ?hasTextChangedSinceLastTypecheck: (obj * range -> bool) -> Async + /// Compute a formatted tooltip for the given location + /// + /// The line number where the information is being requested. + /// The column number at the end of the identifiers where the information is being requested. + /// The text of the line where the information is being requested. + /// The identifiers at the location where the information is being requested. + /// Used to discriminate between 'identifiers', 'strings' and others. For strings, an attempt is made to give a tooltip for a #r "..." location. Use a value from FSharpTokenInfo.Tag, or FSharpTokenTag.Identifier, unless you have other information available. + member GetStructuredToolTipTextAlternate : line:int * colAtEndOfNames:int * lineText:string * names:string list * tokenTag:int -> Async + /// Compute a formatted tooltip for the given location /// /// The line number where the information is being requested. diff --git a/src/utils/sformat.fs b/src/utils/sformat.fs index 0cb94ac8c40..5b3fec15df3 100644 --- a/src/utils/sformat.fs +++ b/src/utils/sformat.fs @@ -52,6 +52,92 @@ namespace Microsoft.FSharp.Text.StructuredFormat open ReflectionAdapters #endif + [] +#if COMPILER + type internal TaggedText = +#else + type TaggedText = +#endif + | ActivePatternCase of string + | ActivePatternResult of string + | Alias of string + | Class of string + | Union of string + | UnionCase of string + | Delegate of string + | Enum of string + | Event of string + | Field of string + | Interface of string + | Keyword of string + | LineBreak of string + | Local of string + | Record of string + | RecordField of string + | Method of string + | Member of string + | ModuleBinding of string + | Module of string + | Namespace of string + | NumericLiteral of string + | Operator of string + | Parameter of string + | Property of string + | Space of string + | StringLiteral of string + | Struct of string + | TypeParameter of string + | Text of string + | Punctuation of string + | UnknownType of string + | UnknownEntity of string + with + member this.Value = + match this with + | ActivePatternCase t + | ActivePatternResult t + | Alias t + | Class t + | Union t + | UnionCase t + | Delegate t + | Enum t + | Event t + | Field t + | Interface t + | Keyword t + | LineBreak t + | Local t + | Record t + | RecordField t + | Method t + | Member t + | Module t + | ModuleBinding t + | Namespace t + | NumericLiteral t + | Operator t + | Parameter t + | Property t + | Space t + | StringLiteral t + | Struct t + | TypeParameter t + | Text t + | Punctuation t + | UnknownType t + | UnknownEntity t -> t + member this.Length = this.Value.Length + static member GetText(t: TaggedText) = t.Value + +#if COMPILER + type internal TaggedTextWriter = +#else + type TaggedTextWriter = +#endif + abstract Write: t: TaggedText -> unit + abstract WriteLine: unit -> unit + /// A joint, between 2 layouts, is either: /// - unbreakable, or /// - breakable, and if broken the second block has a given indentation. @@ -75,7 +161,8 @@ namespace Microsoft.FSharp.Text.StructuredFormat #else type Layout = #endif - | Leaf of bool * obj * bool + | ObjLeaf of bool * obj * bool + | Leaf of bool * TaggedText * bool | Node of bool * layout * bool * layout * bool * joint | Attr of string * (string * string) list * layout @@ -100,18 +187,71 @@ namespace Microsoft.FSharp.Text.StructuredFormat abstract GetLayout : obj -> layout abstract MaxColumns : int abstract MaxRows : int + +#if COMPILER + module internal TaggedTextOps = +#else + module TaggedTextOps = +#endif + let tagAlias = TaggedText.Alias + let tagClass = TaggedText.Class + let tagUnionCase = TaggedText.UnionCase + let tagDelegate = TaggedText.Delegate + let tagEnum = TaggedText.Enum + let tagEvent = TaggedText.Event + let tagField = TaggedText.Field + let tagInterface = TaggedText.Interface + let tagKeyword = TaggedText.Keyword + let tagLineBreak = TaggedText.LineBreak + let tagLocal = TaggedText.Local + let tagRecord = TaggedText.Record + let tagRecordField = TaggedText.RecordField + let tagMethod = TaggedText.Method + let tagModule = TaggedText.Module + let tagModuleBinding = TaggedText.ModuleBinding + let tagNamespace = TaggedText.Namespace + let tagNumericLiteral = TaggedText.NumericLiteral + let tagOperator = TaggedText.Operator + let tagParameter = TaggedText.Parameter + let tagProperty = TaggedText.Property + let tagSpace = TaggedText.Space + let tagStringLiteral = TaggedText.StringLiteral + let tagStruct = TaggedText.Struct + let tagTypeParameter = TaggedText.TypeParameter + let tagText = TaggedText.Text + let tagPunctuation = TaggedText.Punctuation + + module Literals = + // common tagged literals + let lineBreak = tagLineBreak "\n" + let space = tagSpace " " + let comma = tagPunctuation "," + let semicolon = tagPunctuation ";" + let leftParen = tagPunctuation "(" + let rightParen = tagPunctuation ")" + let leftBracket = tagPunctuation "[" + let rightBracket = tagPunctuation "]" + let leftBrace= tagPunctuation "{" + let rightBrace = tagPunctuation "}" + let equals = tagOperator "=" + let arrow = tagPunctuation "->" + let questionMark = tagPunctuation "?" #if COMPILER module internal LayoutOps = #else module LayoutOps = #endif + open TaggedTextOps + let rec juxtLeft = function + | ObjLeaf (jl,_,_) -> jl | Leaf (jl,_,_) -> jl | Node (jl,_,_,_,_,_) -> jl | Attr (_,_,l) -> juxtLeft l let rec juxtRight = function + | ObjLeaf (_,_,jr) -> jr | Leaf (_,_,jr) -> jr | Node (_,_,_,_,jr,_) -> jr | Attr (_,_,l) -> juxtRight l @@ -126,20 +266,19 @@ namespace Microsoft.FSharp.Text.StructuredFormat // constructors - let objL (obj:obj) = Leaf (false,obj,false) - let sLeaf (l,(str:string),r) = Leaf (l,(str:>obj),r) + let objL (obj:obj) = + match obj with + | :? string as s -> Leaf (false, TaggedText.Text s, false) + | o -> ObjLeaf (false, o, false) + let sLeaf (l, t, r) = Leaf (l, t, r) let wordL str = sLeaf (false,str,false) let sepL str = sLeaf (true ,str,true) let rightL str = sLeaf (true ,str,false) let leftL str = sLeaf (false,str,true) - let emptyL = sLeaf (true,"",true) + let emptyL = sLeaf (true, TaggedText.Text "",true) let isEmptyL = function - | Leaf(true,s,true) -> - match s with - | :? string as s -> s = "" + | Leaf(true, s, true) -> s.Value = "" | _ -> false - | _ -> false - let aboveL l r = mkNode l r (Broken 0) @@ -164,26 +303,26 @@ namespace Microsoft.FSharp.Text.StructuredFormat | y::ys -> process' ((tagger prefixL) ++ y) ys process' x xs - let commaListL x = tagListL (fun prefixL -> prefixL ^^ rightL ",") x - let semiListL x = tagListL (fun prefixL -> prefixL ^^ rightL ";") x + let commaListL x = tagListL (fun prefixL -> prefixL ^^ rightL (Literals.comma)) x + let semiListL x = tagListL (fun prefixL -> prefixL ^^ rightL (Literals.semicolon)) x let spaceListL x = tagListL (fun prefixL -> prefixL) x let sepListL x y = tagListL (fun prefixL -> prefixL ^^ x) y - let bracketL l = leftL "(" ^^ l ^^ rightL ")" - let tupleL xs = bracketL (sepListL (sepL ",") xs) + let bracketL l = leftL Literals.leftParen ^^ l ^^ rightL Literals.rightParen + let tupleL xs = bracketL (sepListL (sepL Literals.comma) xs) let aboveListL = function | [] -> emptyL | [x] -> x | x::ys -> List.fold (fun pre y -> pre @@ y) x ys let optionL xL = function - | None -> wordL "None" - | Some x -> wordL "Some" -- (xL x) + | None -> wordL (tagUnionCase "None") + | Some x -> wordL (tagUnionCase "Some") -- (xL x) - let listL xL xs = leftL "[" ^^ sepListL (sepL ";") (List.map xL xs) ^^ rightL "]" + let listL xL xs = leftL Literals.leftBracket ^^ sepListL (sepL Literals.semicolon) (List.map xL xs) ^^ rightL Literals.rightBracket - let squareBracketL x = leftL "[" ^^ x ^^ rightL "]" + let squareBracketL x = leftL Literals.leftBracket ^^ x ^^ rightL Literals.rightBracket - let braceL x = leftL "{" ^^ x ^^ rightL "}" + let braceL x = leftL Literals.leftBrace ^^ x ^^ rightL Literals.rightBrace let boundedUnfoldL (itemL : 'a -> layout) @@ -192,10 +331,10 @@ namespace Microsoft.FSharp.Text.StructuredFormat (z : 'z) maxLength = let rec consume n z = - if stopShort z then [wordL "..."] else + if stopShort z then [wordL (tagPunctuation "...")] else match project z with | None -> [] // exhaused input - | Some (x,z) -> if n<=0 then [wordL "..."] // hit print_length limit + | Some (x,z) -> if n<=0 then [wordL (tagPunctuation "...")] // hit print_length limit else itemL x :: consume (n-1) z // cons recursive... consume maxLength z @@ -204,9 +343,9 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// These are a typical set of options used to control structured formatting. [] #if COMPILER - type internal FormatOptions = + type internal FormatOptions = #else - type FormatOptions = + type FormatOptions = #endif { FloatingPointFormat: string; AttributeProcessor: (string -> (string * string) list -> bool -> unit); @@ -394,6 +533,8 @@ namespace Microsoft.FSharp.Text.StructuredFormat open ReflectUtils open LayoutOps + open TaggedTextOps + let string_of_int (i:int) = i.ToString() let typeUsesSystemObjectToString (typ:System.Type) = @@ -481,7 +622,8 @@ namespace Microsoft.FSharp.Text.StructuredFormat // fitting // ------------------------------------------------------------------------ - let squashTo (maxWidth,leafFormatter) layout = + let squashTo (maxWidth,leafFormatter : _ -> TaggedText) layout = + let (|ObjToTaggedText|) = leafFormatter if maxWidth <= 0 then layout else let rec fit breaks (pos,layout) = // breaks = break context, can force to get indentation savings. @@ -501,10 +643,10 @@ namespace Microsoft.FSharp.Text.StructuredFormat let breaks,layout,pos,offset = fit breaks (pos,l) let layout = Attr (tag,attrs,layout) breaks,layout,pos,offset - | Leaf (jl,obj,jr) -> - let text:string = leafFormatter obj + | Leaf (jl, text, jr) + | ObjLeaf (jl, ObjToTaggedText text, jr) -> // save the formatted text from the squash - let layout = Leaf(jl,(text :> obj),jr) + let layout = Leaf(jl, text, jr) let textWidth = text.Length let rec fitLeaf breaks pos = if pos + textWidth <= maxWidth then @@ -577,9 +719,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat // addL: pos is tab level let rec addL z pos layout = match layout with + | ObjLeaf (_,obj,_) -> + let text = leafFormatter obj + addText z text | Leaf (_,obj,_) -> - let text = leafFormatter obj - addText z text + addText z obj.Value | Node (_,l,_,r,_,Broken indent) // Print width = 0 implies 1D layout, no squash when not (opts.PrintWidth = 0) -> @@ -604,9 +748,9 @@ namespace Microsoft.FSharp.Text.StructuredFormat // outL // ------------------------------------------------------------------------ - let outL outAttribute leafFormatter (chan : TextWriter) layout = + let outL outAttribute leafFormatter (chan : TaggedTextWriter) layout = // write layout to output chan directly - let write (s:string) = chan.Write(s) + let write s = chan.Write(s) // z is just current indent let z0 = 0 let index i = i @@ -614,15 +758,17 @@ namespace Microsoft.FSharp.Text.StructuredFormat let newLine _ n = // \n then spaces... let indent = new System.String(' ',n) chan.WriteLine(); - write indent; + write (tagText indent); n // addL: pos is tab level let rec addL z pos layout = match layout with - | Leaf (_,obj,_) -> + | ObjLeaf (_,obj,_) -> let text = leafFormatter obj addText z text + | Leaf (_,obj,_) -> + addText z obj | Node (_,l,_,r,_,Broken indent) -> let z = addL z pos l let z = newLine z (pos+indent) @@ -630,7 +776,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat z | Node (_,l,jm,r,_,_) -> let z = addL z pos l - let z = if jm then z else addText z " " + let z = if jm then z else addText z Literals.space let pos = index z let z = addL z pos r z @@ -663,49 +809,49 @@ namespace Microsoft.FSharp.Text.StructuredFormat | ConstructorValue ("Empty",[]) -> None | _ -> failwith "List value had unexpected ValueInfo" - let compactCommaListL xs = sepListL (sepL ",") xs // compact, no spaces around "," - let nullL = wordL "null" - let measureL = wordL "()" + let compactCommaListL xs = sepListL (sepL Literals.comma) xs // compact, no spaces around "," + let nullL = wordL (tagKeyword "null") + let measureL = wordL (tagPunctuation "()") // -------------------------------------------------------------------- // pprinter: attributes // -------------------------------------------------------------------- let makeRecordVerticalL nameXs = - let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL "=")) -- (xL ^^ (rightL ";")) - let braceL xs = (leftL "{") ^^ xs ^^ (rightL "}") + let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL Literals.equals)) -- (xL ^^ (rightL Literals.semicolon)) + let braceL xs = (leftL Literals.leftBrace) ^^ xs ^^ (rightL Literals.rightBrace) braceL (aboveListL (List.map itemL nameXs)) // This is a more compact rendering of records - and is more like tuples let makeRecordHorizontalL nameXs = - let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL "=")) -- xL - let braceL xs = (leftL "{") ^^ xs ^^ (rightL "}") - braceL (sepListL (rightL ";") (List.map itemL nameXs)) + let itemL (name,xL) = let labelL = wordL name in ((labelL ^^ wordL Literals.equals)) -- xL + let braceL xs = (leftL Literals.leftBrace) ^^ xs ^^ (rightL Literals.rightBrace) + braceL (sepListL (rightL Literals.semicolon) (List.map itemL nameXs)) let makeRecordL nameXs = makeRecordVerticalL nameXs let makePropertiesL nameXs = let itemL (name,v) = let labelL = wordL name - (labelL ^^ wordL "=") + (labelL ^^ wordL Literals.equals) ^^ (match v with - | None -> wordL "?" + | None -> wordL Literals.questionMark | Some xL -> xL) - ^^ (rightL ";") - let braceL xs = (leftL "{") ^^ xs ^^ (rightL "}") + ^^ (rightL Literals.semicolon) + let braceL xs = (leftL Literals.leftBrace) ^^ xs ^^ (rightL Literals.rightBrace) braceL (aboveListL (List.map itemL nameXs)) let makeListL itemLs = - (leftL "[") - ^^ sepListL (rightL ";") itemLs - ^^ (rightL "]") + (leftL Literals.leftBracket) + ^^ sepListL (rightL Literals.semicolon) itemLs + ^^ (rightL Literals.rightBracket) let makeArrayL xs = - (leftL "[|") - ^^ sepListL (rightL ";") xs - ^^ (rightL "|]") + (leftL (tagPunctuation "[|")) + ^^ sepListL (rightL Literals.semicolon) xs + ^^ (rightL (tagPunctuation "|]")) - let makeArray2L xs = leftL "[" ^^ aboveListL xs ^^ rightL "]" + let makeArray2L xs = leftL Literals.leftBracket ^^ aboveListL xs ^^ rightL Literals.rightBracket // -------------------------------------------------------------------- // pprinter: anyL - support functions @@ -815,20 +961,20 @@ namespace Microsoft.FSharp.Text.StructuredFormat and objWithReprL showMode depthLim prec (info:ValueInfo) (x:obj) (* x could be null *) = try - if depthLim<=0 || exceededPrintSize() then wordL "..." else + if depthLim<=0 || exceededPrintSize() then wordL (tagPunctuation "...") else match x with | null -> reprL showMode (depthLim-1) prec info x | _ -> if (path.ContainsKey(x)) then - wordL "..." + wordL (tagPunctuation "...") else path.Add(x,0); let res = // Lazy values. VS2008 used StructuredFormatDisplayAttribute to show via ToString. Dev10 (no attr) needs a special case. let ty = x.GetType() if ty.IsGenericType && ty.GetGenericTypeDefinition() = typedefof> then - Some (wordL (x.ToString())) + Some (wordL (tagText(x.ToString()))) else // Try the StructuredFormatDisplayAttribute extensibility attribute match ty.GetCustomAttributes (typeof, true) with @@ -858,8 +1004,8 @@ namespace Microsoft.FSharp.Text.StructuredFormat let illFormedMatch = System.Text.RegularExpressions.Regex.IsMatch(txt, illFormedBracketPattern) match illFormedMatch with | true -> None // there are mismatched brackets, bail out - | false when layouts.Length > 1 -> Some (spaceListL (List.rev ((wordL (replaceEscapedBrackets(txt))::layouts)))) - | false -> Some (wordL (replaceEscapedBrackets(txt))) + | false when layouts.Length > 1 -> Some (spaceListL (List.rev ((wordL (tagText(replaceEscapedBrackets(txt)))::layouts)))) + | false -> Some (wordL (tagText(replaceEscapedBrackets(txt)))) | true -> // we have a hit on a property reference let preText = replaceEscapedBrackets(m.Groups.["pre"].Value) // everything before the first opening bracket @@ -867,7 +1013,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat let prop = replaceEscapedBrackets(m.Groups.["prop"].Value) // Unescape everything between the opening and closing brackets match catchExn (fun () -> getProperty ty x prop) with - | Choice2Of2 e -> Some (wordL ("")) + | Choice2Of2 e -> Some (wordL (tagText(""))) | Choice1Of2 alternativeObj -> try let alternativeObjL = @@ -882,7 +1028,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat // type BigInt(signInt:int, v : BigNat) = // member x.StructuredDisplayString = x.ToString() // - | :? string as s -> sepL s + | :? string as s -> sepL (tagText s) | _ -> // recursing like this can be expensive, so let's throttle it severely sameObjL (depthLim/10) Precedence.BracketIfTuple (alternativeObj, alternativeObj.GetType()) @@ -895,7 +1041,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat | false -> postText | true -> postTextMatch.Groups.["pre"].Value - let newLayouts = (sepL preText ^^ alternativeObjL ^^ sepL currentPostText)::layouts + let newLayouts = (sepL (tagText preText) ^^ alternativeObjL ^^ sepL (tagText currentPostText))::layouts match postText with | "" -> //We are done, build a space-delimited layout from the collection of layouts we've accumulated @@ -918,11 +1064,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat | false -> // We are done, there's more text but it doesn't contain any more properties, we need to remove escaped brackets now though // since that wasn't done when creating currentPostText - Some (spaceListL (List.rev ((sepL preText ^^ alternativeObjL ^^ sepL (replaceEscapedBrackets(remaingPropertyText)))::layouts))) + Some (spaceListL (List.rev ((sepL (tagText preText) ^^ alternativeObjL ^^ sepL (tagText(replaceEscapedBrackets(remaingPropertyText))))::layouts))) with _ -> None // Seed with an empty layout with a space to the left for formatting purposes - buildObjMessageL txt [leftL ""] + buildObjMessageL txt [leftL (tagText "")] #if RUNTIME #else #if COMPILER // FSharp.Compiler.dll: This is the PrintIntercepts extensibility point currently revealed by fsi.exe's AddPrinter @@ -946,28 +1092,28 @@ namespace Microsoft.FSharp.Text.StructuredFormat with e -> countNodes 1 - wordL ("Error: " + e.Message) + wordL (tagText("Error: " + e.Message)) and recdAtomicTupleL depthLim recd = // tuples up args to UnionConstruction or ExceptionConstructor. no node count. match recd with | [(_,x)] -> objL depthLim Precedence.BracketIfTupleOrNotAtomic x - | txs -> leftL "(" ^^ compactCommaListL (List.map (snd >> objL depthLim Precedence.BracketIfTuple) txs) ^^ rightL ")" + | txs -> leftL Literals.leftParen ^^ compactCommaListL (List.map (snd >> objL depthLim Precedence.BracketIfTuple) txs) ^^ rightL Literals.rightParen and bracketIfL b basicL = - if b then (leftL "(") ^^ basicL ^^ (rightL ")") else basicL + if b then (leftL Literals.leftParen) ^^ basicL ^^ (rightL Literals.rightParen) else basicL and reprL showMode depthLim prec repr x (* x could be null *) = let showModeFilter lay = match showMode with ShowAll -> lay | ShowTopLevelBinding -> emptyL match repr with | TupleValue vals -> - let basicL = sepListL (rightL ",") (List.map (objL depthLim Precedence.BracketIfTuple ) vals) + let basicL = sepListL (rightL Literals.comma) (List.map (objL depthLim Precedence.BracketIfTuple ) vals) bracketIfL (prec <= Precedence.BracketIfTuple) basicL | RecordValue items -> let itemL (name,x,typ) = countNodes 1 // record labels are counted as nodes. [REVIEW: discussion under 4090]. - (name,objL depthLim Precedence.BracketIfTuple (x, typ)) + (tagRecordField name,objL depthLim Precedence.BracketIfTuple (x, typ)) makeRecordL (List.map itemL items) | ConstructorValue (constr,recd) when // x is List. Note: "null" is never a valid list value. @@ -980,27 +1126,27 @@ namespace Microsoft.FSharp.Text.StructuredFormat makeListL itemLs | _ -> countNodes 1 - wordL "[]" + wordL (tagPunctuation "[]") | ConstructorValue(nm,[]) -> countNodes 1 - (wordL nm) + (wordL (tagMethod nm)) | ConstructorValue(nm,recd) -> countNodes 1 // e.g. Some (Some (Some (Some 2))) should count for 5 - (wordL nm --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) + (wordL (tagMethod nm) --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) | ExceptionValue(ty,recd) -> countNodes 1 let name = ty.Name match recd with - | [] -> (wordL name) - | recd -> (wordL name --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) + | [] -> (wordL (tagClass name)) + | recd -> (wordL (tagClass name) --- recdAtomicTupleL depthLim recd) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) | FunctionClosureValue ty -> // Q: should function printing include the ty.Name? It does not convey much useful info to most users, e.g. "clo@0_123". countNodes 1 - wordL ("") |> showModeFilter + wordL (tagText("")) |> showModeFilter | ObjectValue(obj) -> match obj with @@ -1013,15 +1159,15 @@ namespace Microsoft.FSharp.Text.StructuredFormat #if COMPILER if s.Length + 2(*quotes*) <= opts.StringLimit then // With the quotes, it fits within the limit. - wordL (formatString s) + wordL (tagStringLiteral(formatString s)) else // When a string is considered too long to print, there is a choice: what to print? // a) -- follows // b) -- follows and gives just the length // c) "abcdefg"+[n chars] -- gives a prefix and the remaining chars - wordL (formatStringInWidth opts.StringLimit s) + wordL (tagStringLiteral(formatStringInWidth opts.StringLimit s)) #else - wordL (formatString s) + wordL (tagStringLiteral (formatString s)) #endif | :? Array as arr -> let ty = arr.GetType().GetElementType() @@ -1031,7 +1177,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat let b1 = arr.GetLowerBound(0) let project depthLim = if depthLim=(b1+n) then None else Some ((box (arr.GetValue(depthLim)), ty),depthLim+1) let itemLs = boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) project stopShort b1 opts.PrintLength - makeArrayL (if b1 = 0 then itemLs else wordL("bound1="+string_of_int b1)::itemLs) + makeArrayL (if b1 = 0 then itemLs else wordL (tagText("bound1="+string_of_int b1))::itemLs) | 2 -> let n1 = arr.GetLength(0) let n2 = arr.GetLength(1) @@ -1043,9 +1189,9 @@ namespace Microsoft.FSharp.Text.StructuredFormat let rowL x = boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) (project2 x) stopShort b2 opts.PrintLength |> makeListL let project1 x = if x>=(b1+n1) then None else Some (x,x+1) let rowsL = boundedUnfoldL rowL project1 stopShort b1 opts.PrintLength - makeArray2L (if b1=0 && b2 = 0 then rowsL else wordL("bound1=" + string_of_int b1)::wordL("bound2=" + string_of_int b2)::rowsL) + makeArray2L (if b1=0 && b2 = 0 then rowsL else wordL (tagText("bound1=" + string_of_int b1))::wordL(tagText("bound2=" + string_of_int b2))::rowsL) | n -> - makeArrayL [wordL("rank=" + string_of_int n)] + makeArrayL [wordL (tagText("rank=" + string_of_int n))] // Format 'set' and 'map' nicely | _ when @@ -1065,7 +1211,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat let it = (obj :?> System.Collections.IEnumerable).GetEnumerator() try let itemLs = boundedUnfoldL possibleKeyValueL (fun () -> if it.MoveNext() then Some(it.Current,()) else None) stopShort () (1+opts.PrintLength/12) - (wordL word --- makeListL itemLs) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) + (wordL (tagClass word) --- makeListL itemLs) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) finally match it with | :? System.IDisposable as e -> e.Dispose() @@ -1083,7 +1229,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat let ty = Option.map (fun (typ:Type) -> typ.GetGenericArguments().[0]) ty try let itemLs = boundedUnfoldL (objL depthLim Precedence.BracketIfTuple) (fun () -> if it.MoveNext() then Some((it.Current, match ty with | None -> it.Current.GetType() | Some ty -> ty),()) else None) stopShort () (1+opts.PrintLength/30) - (wordL word --- makeListL itemLs) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) + (wordL (tagClass word) --- makeListL itemLs) |> bracketIfL (prec <= Precedence.BracketIfTupleOrNotAtomic) finally match it with | :? System.IDisposable as e -> e.Dispose() @@ -1093,7 +1239,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat // Sequence printing is turned off for declared-values, and maybe be disabled to users. // There is choice here, what to print? or ... or ? // Also, in the declared values case, if the sequence is actually a known non-lazy type (list, array etc etc) we could print it. - wordL "" |> showModeFilter + wordL (tagText "") |> showModeFilter | _ -> if showMode = ShowTopLevelBinding && typeUsesSystemObjectToString ty then emptyL @@ -1133,7 +1279,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat (propsAndFields |> Array.map (fun m -> - (m.Name, + ((if m :? FieldInfo then tagField m.Name else tagProperty m.Name), (try Some (objL nDepth Precedence.BracketIfTuple ((getProperty ty obj m.Name), ty)) with _ -> try Some (objL nDepth Precedence.BracketIfTuple ((getField obj (m :?> FieldInfo)), ty)) with _ -> None))) @@ -1150,47 +1296,54 @@ namespace Microsoft.FSharp.Text.StructuredFormat let leafFormatter (opts:FormatOptions) (obj :obj) = match obj with - | null -> "null" + | null -> tagKeyword "null" | :? double as d -> let s = d.ToString(opts.FloatingPointFormat,opts.FormatProvider) - if System.Double.IsNaN(d) then "nan" - elif System.Double.IsNegativeInfinity(d) then "-infinity" - elif System.Double.IsPositiveInfinity(d) then "infinity" - elif opts.FloatingPointFormat.[0] = 'g' && String.forall(fun c -> System.Char.IsDigit(c) || c = '-') s - then s + ".0" - else s + let t = + if System.Double.IsNaN(d) then "nan" + elif System.Double.IsNegativeInfinity(d) then "-infinity" + elif System.Double.IsPositiveInfinity(d) then "infinity" + elif opts.FloatingPointFormat.[0] = 'g' && String.forall(fun c -> System.Char.IsDigit(c) || c = '-') s + then s + ".0" + else s + tagNumericLiteral t | :? single as d -> - (if System.Single.IsNaN(d) then "nan" - elif System.Single.IsNegativeInfinity(d) then "-infinity" - elif System.Single.IsPositiveInfinity(d) then "infinity" - elif opts.FloatingPointFormat.Length >= 1 && opts.FloatingPointFormat.[0] = 'g' - && float32(System.Int32.MinValue) < d && d < float32(System.Int32.MaxValue) - && float32(int32(d)) = d - then (System.Convert.ToInt32 d).ToString(opts.FormatProvider) + ".0" - else d.ToString(opts.FloatingPointFormat,opts.FormatProvider)) - + "f" - | :? System.Decimal as d -> d.ToString("g",opts.FormatProvider) + "M" - | :? uint64 as d -> d.ToString(opts.FormatProvider) + "UL" - | :? int64 as d -> d.ToString(opts.FormatProvider) + "L" - | :? int32 as d -> d.ToString(opts.FormatProvider) - | :? uint32 as d -> d.ToString(opts.FormatProvider) + "u" - | :? int16 as d -> d.ToString(opts.FormatProvider) + "s" - | :? uint16 as d -> d.ToString(opts.FormatProvider) + "us" - | :? sbyte as d -> d.ToString(opts.FormatProvider) + "y" - | :? byte as d -> d.ToString(opts.FormatProvider) + "uy" - | :? nativeint as d -> d.ToString() + "n" - | :? unativeint as d -> d.ToString() + "un" - | :? bool as b -> (if b then "true" else "false") - | :? char as c -> "\'" + formatChar true c + "\'" - | _ -> try + let t = + (if System.Single.IsNaN(d) then "nan" + elif System.Single.IsNegativeInfinity(d) then "-infinity" + elif System.Single.IsPositiveInfinity(d) then "infinity" + elif opts.FloatingPointFormat.Length >= 1 && opts.FloatingPointFormat.[0] = 'g' + && float32(System.Int32.MinValue) < d && d < float32(System.Int32.MaxValue) + && float32(int32(d)) = d + then (System.Convert.ToInt32 d).ToString(opts.FormatProvider) + ".0" + else d.ToString(opts.FloatingPointFormat,opts.FormatProvider)) + + "f" + tagNumericLiteral t + | :? System.Decimal as d -> d.ToString("g",opts.FormatProvider) + "M" |> tagNumericLiteral + | :? uint64 as d -> d.ToString(opts.FormatProvider) + "UL" |> tagNumericLiteral + | :? int64 as d -> d.ToString(opts.FormatProvider) + "L" |> tagNumericLiteral + | :? int32 as d -> d.ToString(opts.FormatProvider) |> tagNumericLiteral + | :? uint32 as d -> d.ToString(opts.FormatProvider) + "u" |> tagNumericLiteral + | :? int16 as d -> d.ToString(opts.FormatProvider) + "s" |> tagNumericLiteral + | :? uint16 as d -> d.ToString(opts.FormatProvider) + "us" |> tagNumericLiteral + | :? sbyte as d -> d.ToString(opts.FormatProvider) + "y" |> tagNumericLiteral + | :? byte as d -> d.ToString(opts.FormatProvider) + "uy" |> tagNumericLiteral + | :? nativeint as d -> d.ToString() + "n" |> tagNumericLiteral + | :? unativeint as d -> d.ToString() + "un" |> tagNumericLiteral + | :? bool as b -> (if b then "true" else "false") |> tagKeyword + | :? char as c -> "\'" + formatChar true c + "\'" |> tagStringLiteral + | _ -> + let t = + try let text = obj.ToString() match text with | null -> "" | _ -> text - with e -> + with e -> // If a .ToString() call throws an exception, catch it and use the message as the result. // This may be informative, e.g. division by zero etc... "" + tagText t let any_to_layout opts x = anyL ShowAll BindingFlags.Public opts x @@ -1201,13 +1354,21 @@ namespace Microsoft.FSharp.Text.StructuredFormat else l |> squashTo (opts.PrintWidth,leafFormatter opts) - let output_layout opts oc l = + let asTaggedTextWriter (tw: TextWriter) = + { new TaggedTextWriter with + member __.Write(t) = tw.Write t.Value + member __.WriteLine() = tw.WriteLine() } + + let output_layout_tagged opts oc l = l |> squash_layout opts |> outL opts.AttributeProcessor (leafFormatter opts) oc + let output_layout opts oc l = + output_layout_tagged opts (asTaggedTextWriter oc) l + let layout_to_string opts l = l |> squash_layout opts - |> showL opts (leafFormatter opts) + |> showL opts ((leafFormatter opts) >> TaggedText.GetText) let output_any_ex opts oc x = x |> any_to_layout opts |> output_layout opts oc diff --git a/src/utils/sformat.fsi b/src/utils/sformat.fsi index 9d2115d72b3..789c98aedc8 100644 --- a/src/utils/sformat.fsi +++ b/src/utils/sformat.fsi @@ -37,6 +37,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// Data representing structured layouts of terms. #if RUNTIME // FSharp.Core.dll makes things internal and hides representations type internal Layout + type internal TaggedText #else // FSharp.Compiler.dll, FSharp.Compiler-proto.dll, FSharp.PowerPack.dll // FSharp.PowerPack.dll: reveals representations // FSharp.Compiler-proto.dll, FSharp.Compiler.dll: the F# compiler likes to see these representations @@ -52,6 +53,58 @@ namespace Microsoft.FSharp.Text.StructuredFormat | Unbreakable | Breakable of int | Broken of int + + [] +#if COMPILER + type internal TaggedText = +#else + type TaggedText = +#endif + | ActivePatternCase of string + | ActivePatternResult of string + | Alias of string + | Class of string + | Union of string + | UnionCase of string + | Delegate of string + | Enum of string + | Event of string + | Field of string + | Interface of string + | Keyword of string + | LineBreak of string + | Local of string + | Record of string + | RecordField of string + | Method of string + | Member of string + | ModuleBinding of string + | Module of string + | Namespace of string + | NumericLiteral of string + | Operator of string + | Parameter of string + | Property of string + | Space of string + | StringLiteral of string + | Struct of string + | TypeParameter of string + | Text of string + | Punctuation of string + | UnknownType of string + | UnknownEntity of string + with + member Value: string + member Length: int + static member GetText: t: TaggedText -> string + +#if COMPILER + type internal TaggedTextWriter = +#else + type TaggedTextWriter = +#endif + abstract Write: t: TaggedText -> unit + abstract WriteLine: unit -> unit /// Data representing structured layouts of terms. The representation /// of this data type is only for the consumption of formatting engines. @@ -61,11 +114,61 @@ namespace Microsoft.FSharp.Text.StructuredFormat #else type Layout = #endif - | Leaf of bool * obj * bool + | ObjLeaf of bool * obj * bool + | Leaf of bool * TaggedText * bool | Node of bool * Layout * bool * Layout * bool * Joint | Attr of string * (string * string) list * Layout #endif + module +#if RUNTIME || COMPILER + internal +#else +#endif + TaggedTextOps = + val tagAlias : string -> TaggedText + val tagClass : string -> TaggedText + val tagUnionCase : string -> TaggedText + val tagDelegate : string -> TaggedText + val tagEnum : string -> TaggedText + val tagEvent : string -> TaggedText + val tagField : string -> TaggedText + val tagInterface : string -> TaggedText + val tagKeyword : string -> TaggedText + val tagLineBreak : string -> TaggedText + val tagMethod : string -> TaggedText + val tagModuleBinding : string -> TaggedText + val tagLocal : string -> TaggedText + val tagRecord : string -> TaggedText + val tagRecordField : string -> TaggedText + val tagModule : string -> TaggedText + val tagNamespace : string -> TaggedText + val tagNumericLiteral : string -> TaggedText + val tagOperator : string -> TaggedText + val tagParameter : string -> TaggedText + val tagProperty : string -> TaggedText + val tagSpace : string -> TaggedText + val tagStringLiteral : string -> TaggedText + val tagStruct : string -> TaggedText + val tagTypeParameter : string -> TaggedText + val tagText : string -> TaggedText + val tagPunctuation : string -> TaggedText + + module Literals = + // common tagged literals + val lineBreak : TaggedText + val space : TaggedText + val comma : TaggedText + val semicolon : TaggedText + val leftParen : TaggedText + val rightParen : TaggedText + val leftBracket : TaggedText + val rightBracket : TaggedText + val leftBrace: TaggedText + val rightBrace : TaggedText + val equals : TaggedText + val arrow : TaggedText + val questionMark : TaggedText #if RUNTIME // FSharp.Core.dll doesn't use PrintIntercepts #else // FSharp.Compiler.dll, FSharp.Compiler-proto.dll, FSharp.PowerPack.dll @@ -106,20 +209,20 @@ namespace Microsoft.FSharp.Text.StructuredFormat val emptyL : Layout /// Is it the empty layout? val isEmptyL : layout:Layout -> bool - + /// An uninterpreted leaf, to be interpreted into a string /// by the layout engine. This allows leaf layouts for numbers, strings and /// other atoms to be customized according to culture. val objL : value:obj -> Layout /// An string leaf - val wordL : text:string -> Layout + val wordL : text:TaggedText -> Layout /// An string which requires no spaces either side. - val sepL : text:string -> Layout + val sepL : text:TaggedText -> Layout /// An string which is right parenthesis (no space on the left). - val rightL : text:string -> Layout + val rightL : text:TaggedText -> Layout /// An string which is left parenthesis (no space on the right). - val leftL : text:string -> Layout + val leftL : text:TaggedText -> Layout /// Join, unbreakable. val ( ^^ ) : layout1:Layout -> layout2:Layout -> Layout @@ -265,8 +368,10 @@ namespace Microsoft.FSharp.Text.StructuredFormat val anyToStringForPrintf: options:FormatOptions -> bindingFlags:System.Reflection.BindingFlags -> value:'T * Type -> string #endif #else + val asTaggedTextWriter: writer: TextWriter -> TaggedTextWriter val any_to_layout : options:FormatOptions -> value:'T * Type -> Layout val squash_layout : options:FormatOptions -> layout:Layout -> Layout + val output_layout_tagged : options:FormatOptions -> writer:TaggedTextWriter -> layout:Layout -> unit val output_layout : options:FormatOptions -> writer:TextWriter -> layout:Layout -> unit val layout_as_string: options:FormatOptions -> value:'T * Type -> string #endif diff --git a/tests/fsharp/typecheck/sigs/neg06.bsl b/tests/fsharp/typecheck/sigs/neg06.bsl index ad317eb7b8d..3500973de47 100644 --- a/tests/fsharp/typecheck/sigs/neg06.bsl +++ b/tests/fsharp/typecheck/sigs/neg06.bsl @@ -89,7 +89,7 @@ neg06.fs(124,9,124,10): typecheck error FS0953: This type definition involves an neg06.fs(128,19,128,46): typecheck error FS0700: 'new' constraints must take one argument of type 'unit' and return the constructed type -neg06.fs(128,53,128,61): typecheck error FS0043: A type parameter is missing a constraint 'when 'a : (new : unit -> 'a)' +neg06.fs(128,53,128,61): typecheck error FS0043: A type parameter is missing a constraint 'when 'a : (new : unit -> 'a)' neg06.fs(141,10,141,18): typecheck error FS0954: This type definition involves an immediate cyclic reference through a struct field or inheritance relation diff --git a/vsintegration/src/FSharp.Editor/Common/CommonRoslynHelpers.fs b/vsintegration/src/FSharp.Editor/Common/CommonRoslynHelpers.fs index 367ac018ccf..3f64bf1ea75 100644 --- a/vsintegration/src/FSharp.Editor/Common/CommonRoslynHelpers.fs +++ b/vsintegration/src/FSharp.Editor/Common/CommonRoslynHelpers.fs @@ -4,10 +4,12 @@ namespace Microsoft.VisualStudio.FSharp.Editor open System open System.Collections.Immutable +open System.Collections.Generic open System.Threading.Tasks open Microsoft.CodeAnalysis open Microsoft.CodeAnalysis.Text open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Layout open Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionIcons open Microsoft.FSharp.Compiler.Range @@ -34,6 +36,44 @@ module internal CommonRoslynHelpers = Assert.Exception(task.Exception.GetBaseException()) raise(task.Exception.GetBaseException()) + let TaggedTextToRoslyn t = + match t with + | TaggedText.ActivePatternCase t + | TaggedText.ActivePatternResult t -> TaggedText(TextTags.Enum, t) + | TaggedText.Alias t -> TaggedText(TextTags.Class, t) + | TaggedText.Class t -> TaggedText(TextTags.Class, t) + | TaggedText.Delegate t -> TaggedText(TextTags.Delegate, t) + | TaggedText.Enum t -> TaggedText(TextTags.Enum, t) + | TaggedText.Event t -> TaggedText(TextTags.Event, t) + | TaggedText.Field t -> TaggedText(TextTags.Field, t) + | TaggedText.Interface t -> TaggedText(TextTags.Interface, t) + | TaggedText.Keyword t -> TaggedText(TextTags.Keyword, t) + | TaggedText.LineBreak t -> TaggedText(TextTags.LineBreak, t) + | TaggedText.Local t -> TaggedText(TextTags.Local, t) + | TaggedText.Member t -> TaggedText(TextTags.Property, t) + | TaggedText.Method t -> TaggedText(TextTags.Method, t) + | TaggedText.Module t -> TaggedText(TextTags.Module, t) + | TaggedText.ModuleBinding t -> TaggedText(TextTags.Property, t) + | TaggedText.Namespace t -> TaggedText(TextTags.Namespace, t) + | TaggedText.NumericLiteral t -> TaggedText(TextTags.NumericLiteral, t) + | TaggedText.Operator t -> TaggedText(TextTags.Operator, t) + | TaggedText.Parameter t -> TaggedText(TextTags.Parameter, t) + | TaggedText.Property t -> TaggedText(TextTags.Property, t) + | TaggedText.Punctuation t -> TaggedText(TextTags.Punctuation, t) + | TaggedText.Record t -> TaggedText(TextTags.Class, t) + | TaggedText.RecordField t -> TaggedText(TextTags.Property, t) + | TaggedText.Space t -> TaggedText(TextTags.Space, t) + | TaggedText.StringLiteral t -> TaggedText(TextTags.StringLiteral, t) + | TaggedText.Struct t -> TaggedText(TextTags.Struct, t) + | TaggedText.Text t -> TaggedText(TextTags.Text, t) + | TaggedText.TypeParameter t -> TaggedText(TextTags.TypeParameter, t) + | TaggedText.Union t -> TaggedText(TextTags.Class, t) + | TaggedText.UnionCase t -> TaggedText(TextTags.Property, t) + | TaggedText.UnknownEntity t -> TaggedText(TextTags.Property, t) + | TaggedText.UnknownType t -> TaggedText(TextTags.Class, t) + + let CollectTaggedText (list: List<_>) t = list.Add(TaggedTextToRoslyn t) + let StartAsyncAsTask cancellationToken computation = let computation = async { diff --git a/vsintegration/src/FSharp.Editor/Completion/CompletionProvider.fs b/vsintegration/src/FSharp.Editor/Completion/CompletionProvider.fs index fed30170ca9..2149bfb41d1 100644 --- a/vsintegration/src/FSharp.Editor/Completion/CompletionProvider.fs +++ b/vsintegration/src/FSharp.Editor/Completion/CompletionProvider.fs @@ -149,9 +149,12 @@ type internal FSharpCompletionProvider async { let exists, declarationItem = declarationItemsCache.TryGetValue(completionItem.DisplayText) if exists then - let! description = declarationItem.DescriptionTextAsync - let datatipText = XmlDocumentation.BuildDataTipText(documentationBuilder, description) - return CompletionDescription.FromText(datatipText) + let! description = declarationItem.StructuredDescriptionTextAsync + let documentation = List() + let collector = CommonRoslynHelpers.CollectTaggedText documentation + // mix main description and xmldoc by using one collector + XmlDocumentation.BuildDataTipText(documentationBuilder, collector, collector, description) + return CompletionDescription.Create(documentation.ToImmutableArray()) else return CompletionDescription.Empty } |> CommonRoslynHelpers.StartAsyncAsTask cancellationToken diff --git a/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs b/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs index 9bdc8208f87..ecb5cd6b53d 100644 --- a/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs +++ b/vsintegration/src/FSharp.Editor/Completion/SignatureHelp.fs @@ -22,6 +22,7 @@ open Microsoft.VisualStudio.Text.Tagging open Microsoft.VisualStudio.Shell open Microsoft.VisualStudio.Shell.Interop +open Microsoft.FSharp.Compiler.Layout open Microsoft.FSharp.Compiler.Parser open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.SourceCodeServices @@ -165,60 +166,28 @@ type internal FSharpSignatureHelpProvider for method in methods do // Create the documentation. Note, do this on the background thread, since doing it in the documentationBuild fails to build the XML index - let summaryDoc = XmlDocumentation.BuildMethodOverloadTipText(documentationBuilder, method.Description, false) + let mainDescription = List() + let documentation = List() + XmlDocumentation.BuildMethodOverloadTipText(documentationBuilder, CommonRoslynHelpers.CollectTaggedText mainDescription, CommonRoslynHelpers.CollectTaggedText documentation, method.StructuredDescription, false) let parameters = let parameters = if isStaticArgTip then method.StaticParameters else method.Parameters [| for p in parameters do + let doc = List() // FSROSLYNTODO: compute the proper help text for parameters, c.f. AppendParameter in XmlDocumentation.fs - let paramDoc = XmlDocumentation.BuildMethodParamText(documentationBuilder, method.XmlDoc, p.ParameterName) - let doc = if String.IsNullOrWhiteSpace(paramDoc) then [||] - else [| TaggedText(TextTags.Text, paramDoc) |] - let parameterParts = - if isStaticArgTip then - [| TaggedText(TextTags.Class, p.Display) |] - else - let str = p.Display - match str.IndexOf(':') with - | -1 -> [| TaggedText(TextTags.Parameter, str) |] - | 0 -> - [| TaggedText(TextTags.Punctuation, ":"); - TaggedText(TextTags.Class, str.[1..]) |] - | i -> - [| TaggedText(TextTags.Parameter, str.[..i-1]); - TaggedText(TextTags.Punctuation, ":"); - TaggedText(TextTags.Class, str.[i+1..]) |] - yield (p.ParameterName, p.IsOptional, doc, parameterParts) + XmlDocumentation.BuildMethodParamText(documentationBuilder, CommonRoslynHelpers.CollectTaggedText doc, method.XmlDoc, p.ParameterName) + let parts = List() + renderL (taggedTextListR (CommonRoslynHelpers.CollectTaggedText parts)) p.StructuredDisplay |> ignore + yield (p.ParameterName, p.IsOptional, doc, parts) |] - let hasParamComments (pcs: (string*bool*TaggedText[]*TaggedText[])[]) = - pcs |> Array.exists (fun (_, _, doc, _) -> doc.Length > 0) - - let summaryText = - let doc = - if String.IsNullOrWhiteSpace summaryDoc then - String.Empty - elif hasParamComments parameters then - summaryDoc + "\n" - else - summaryDoc - [| TaggedText(TextTags.Text, doc) |] - - // Prepare the text to display - let descriptionParts = - let str = method.TypeText - if str.StartsWith(":", StringComparison.OrdinalIgnoreCase) then - [| TaggedText(TextTags.Punctuation, ":"); - TaggedText(TextTags.Class, str.[1..]) |] - else - [| TaggedText(TextTags.Text, str) |] let prefixParts = [| TaggedText(TextTags.Method, methodGroup.MethodName); TaggedText(TextTags.Punctuation, (if isStaticArgTip then "<" else "(")) |] - let separatorParts = [| TaggedText(TextTags.Punctuation, ", ") |] + let separatorParts = [| TaggedText(TextTags.Punctuation, ","); TaggedText(TextTags.Space, " ") |] let suffixParts = [| TaggedText(TextTags.Punctuation, (if isStaticArgTip then ">" else ")")) |] - let completionItem = (method.HasParamArrayArg, summaryText, prefixParts, separatorParts, suffixParts, parameters, descriptionParts) + let completionItem = (method.HasParamArrayArg, documentation, prefixParts, separatorParts, suffixParts, parameters, mainDescription) // FSROSLYNTODO: Do we need a cache like for completion? //declarationItemsCache.Remove(completionItem.DisplayText) |> ignore // clear out stale entries if they exist //declarationItemsCache.Add(completionItem.DisplayText, declarationItem) @@ -251,9 +220,9 @@ type internal FSharpSignatureHelpProvider results |> Array.map (fun (hasParamArrayArg, doc, prefixParts, separatorParts, suffixParts, parameters, descriptionParts) -> let parameters = parameters - |> Array.map (fun (paramName, isOptional, paramDoc, displayParts) -> + |> Array.map (fun (paramName, isOptional, paramDoc, displayParts) -> SignatureHelpParameter(paramName,isOptional,documentationFactory=(fun _ -> paramDoc :> seq<_>),displayParts=displayParts)) - SignatureHelpItem(isVariadic=hasParamArrayArg ,documentationFactory=(fun _ -> doc :> seq<_>),prefixParts=prefixParts,separatorParts=separatorParts,suffixParts=suffixParts,parameters=parameters,descriptionParts=descriptionParts)) + SignatureHelpItem(isVariadic=hasParamArrayArg, documentationFactory=(fun _ -> doc :> seq<_>),prefixParts=prefixParts,separatorParts=separatorParts,suffixParts=suffixParts,parameters=parameters,descriptionParts=descriptionParts)) return SignatureHelpItems(items,applicableSpan,argumentIndex,argumentCount,Option.toObj argumentName) with ex -> diff --git a/vsintegration/src/FSharp.Editor/QuickInfo/QuickInfoProvider.fs b/vsintegration/src/FSharp.Editor/QuickInfo/QuickInfoProvider.fs index c5182389264..20420d7345a 100644 --- a/vsintegration/src/FSharp.Editor/QuickInfo/QuickInfoProvider.fs +++ b/vsintegration/src/FSharp.Editor/QuickInfo/QuickInfoProvider.fs @@ -62,9 +62,10 @@ type internal FSharpQuickInfoProvider [] ( [)>] serviceProvider: IServiceProvider, - classificationFormatMapService: IClassificationFormatMapService, + _classificationFormatMapService: IClassificationFormatMapService, checkerProvider: FSharpCheckerProvider, - projectInfoManager: ProjectInfoManager + projectInfoManager: ProjectInfoManager, + typeMap: Shared.Utilities.ClassificationTypeMap ) = let xmlMemberIndexService = serviceProvider.GetService(typeof) :?> IVsXMLMemberIndexService @@ -78,11 +79,11 @@ type internal FSharpQuickInfoProvider //let qualifyingNames, partialName = QuickParse.GetPartialLongNameEx(textLine.ToString(), textLineColumn - 1) let defines = CompilerEnvironment.GetCompilationDefinesForEditing(filePath, options.OtherOptions |> Seq.toList) let! symbol = CommonHelpers.getSymbolAtPosition(documentId, sourceText, position, filePath, defines, SymbolLookupKind.Fuzzy) - let! res = checkFileResults.GetToolTipTextAlternate(textLineNumber, symbol.RightColumn, textLine.ToString(), [symbol.Text], FSharpTokenTag.IDENT) |> liftAsync + let! res = checkFileResults.GetStructuredToolTipTextAlternate(textLineNumber, symbol.RightColumn, textLine.ToString(), [symbol.Text], FSharpTokenTag.IDENT) |> liftAsync return! match res with | FSharpToolTipText [] - | FSharpToolTipText [FSharpToolTipElement.None] -> None + | FSharpToolTipText [FSharpStructuredToolTipElement.None] -> None | _ -> Some(res, CommonRoslynHelpers.FSharpRangeToTextSpan(sourceText, symbol.Range)) } @@ -95,9 +96,27 @@ type internal FSharpQuickInfoProvider let! options = projectInfoManager.TryGetOptionsForEditingDocumentOrProject(document) let! textVersion = document.GetTextVersionAsync(cancellationToken) let! toolTipElement, textSpan = FSharpQuickInfoProvider.ProvideQuickInfo(checkerProvider.Checker, document.Id, sourceText, document.FilePath, position, options, textVersion.GetHashCode()) - let dataTipText = XmlDocumentation.BuildDataTipText(documentationBuilder, toolTipElement) - let textProperties = classificationFormatMapService.GetClassificationFormatMap("tooltip").DefaultTextProperties - return QuickInfoItem(textSpan, FSharpDeferredQuickInfoContent(dataTipText, textProperties)) + let mainDescription = Collections.Generic.List() + let documentation = Collections.Generic.List() + XmlDocumentation.BuildDataTipText( + documentationBuilder, + CommonRoslynHelpers.CollectTaggedText mainDescription, + CommonRoslynHelpers.CollectTaggedText documentation, + toolTipElement) + let empty = ClassifiableDeferredContent(Array.Empty(), typeMap); + let content = + QuickInfoDisplayDeferredContent + ( + symbolGlyph = null,//SymbolGlyphDeferredContent(), + warningGlyph = null, + mainDescription = ClassifiableDeferredContent(mainDescription, typeMap), + documentation = ClassifiableDeferredContent(documentation, typeMap), + typeParameterMap = empty, + anonymousTypes = empty, + usageText = empty, + exceptionText = empty + ) + return QuickInfoItem(textSpan, content) } |> Async.map Option.toObj - |> CommonRoslynHelpers.StartAsyncAsTask(cancellationToken) \ No newline at end of file + |> CommonRoslynHelpers.StartAsyncAsTask(cancellationToken) diff --git a/vsintegration/src/FSharp.LanguageService/Intellisense.fs b/vsintegration/src/FSharp.LanguageService/Intellisense.fs index a8d5d99d2b9..a1446f20c79 100644 --- a/vsintegration/src/FSharp.LanguageService/Intellisense.fs +++ b/vsintegration/src/FSharp.LanguageService/Intellisense.fs @@ -13,6 +13,9 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.SourceCodeServices + +module internal TaggedText = + let appendTo (sb: System.Text.StringBuilder) (t: Layout.TaggedText) = sb.Append t.Value |> ignore /// Represents all the information necessary to display and navigate /// within a method tip (e.g. param info, overloads, ability to move thru overloads and params) @@ -62,14 +65,18 @@ type internal FSharpMethodListForAMethodTip(documentationBuilder: IDocumentation override x.GetCount() = methods.Length - override x.GetDescription(methodIndex) = safe methodIndex "" (fun m -> XmlDocumentation.BuildMethodOverloadTipText(documentationBuilder, m.Description, true)) + override x.GetDescription(methodIndex) = safe methodIndex "" (fun m -> + let buf = Text.StringBuilder() + XmlDocumentation.BuildMethodOverloadTipText(documentationBuilder, TaggedText.appendTo buf, TaggedText.appendTo buf, m.StructuredDescription, true) + buf.ToString() + ) override x.GetType(methodIndex) = safe methodIndex "" (fun m -> m.TypeText) override x.GetParameterCount(methodIndex) = safe methodIndex 0 (fun m -> getParameters(m).Length) override x.GetParameterInfo(methodIndex, parameterIndex, nameOut, displayOut, descriptionOut) = - let name,display = safe methodIndex ("","") (fun m -> let p = getParameters(m).[parameterIndex] in p.ParameterName,p.Display ) + let name,display = safe methodIndex ("","") (fun m -> let p = getParameters(m).[parameterIndex] in p.ParameterName, p.Display ) nameOut <- name displayOut <- display @@ -141,7 +148,9 @@ type internal FSharpDeclarations(documentationBuilder, declarations: FSharpDecla override decl.GetDescription(filterText, index) = let decls = trimmedDeclarations filterText if (index >= 0 && index < decls.Length) then - XmlDocumentation.BuildDataTipText(documentationBuilder,decls.[index].DescriptionText) + let buf = Text.StringBuilder() + XmlDocumentation.BuildDataTipText(documentationBuilder, TaggedText.appendTo buf, TaggedText.appendTo buf, decls.[index].StructuredDescriptionText) + buf.ToString() else "" override decl.GetGlyph(filterText, index) = @@ -384,12 +393,13 @@ type internal FSharpIntellisenseInfo // Correct the identifier (e.g. to correctly handle active pattern names that end with "BAR" token) let tokenTag = QuickParse.CorrectIdentifierToken s tokenTag - let dataTip = typedResults.GetToolTipTextAlternate(Range.Line.fromZ line, colAtEndOfNames, lineText, qualId, tokenTag) |> Async.RunSynchronously + let dataTip = typedResults.GetStructuredToolTipTextAlternate(Range.Line.fromZ line, colAtEndOfNames, lineText, qualId, tokenTag) |> Async.RunSynchronously match dataTip with - | FSharpToolTipText.FSharpToolTipText [] when makeSecondAttempt -> getDataTip true + | FSharpStructuredToolTipText.FSharpToolTipText [] when makeSecondAttempt -> getDataTip true | _ -> - let dataTipText = XmlDocumentation.BuildDataTipText(documentationBuilder, dataTip) + let buf = Text.StringBuilder() + XmlDocumentation.BuildDataTipText(documentationBuilder, TaggedText.appendTo buf, TaggedText.appendTo buf, dataTip) // The data tip is located w.r.t. the start of the last identifier let sizeFixup = if isQuotedIdentifier then 4 else 0 @@ -398,7 +408,7 @@ type internal FSharpIntellisenseInfo // This is the span of text over which the data tip is active. If the mouse moves away from it then the // data tip goes away let dataTipSpan = TextSpan(iStartLine=line, iEndLine=line, iStartIndex=max 0 (colAtEndOfNames-lastStringLength), iEndIndex=colAtEndOfNames) - (dataTipText, dataTipSpan) + (buf.ToString(), dataTipSpan) else "Bug: TypeCheckInfo option was None", diagnosticTipSpan with e -> diff --git a/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs b/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs index 5b253c23e92..c5ce537bd99 100644 --- a/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs +++ b/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs @@ -4,21 +4,88 @@ namespace Microsoft.VisualStudio.FSharp.LanguageService open System open System.Text +open System.Collections.Generic open Internal.Utilities.Collections open EnvDTE open EnvDTE80 open Microsoft.VisualStudio.Shell.Interop open Microsoft.FSharp.Compiler.SourceCodeServices +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps + +type internal ITaggedTextCollector = + abstract Add: text: TaggedText -> unit + abstract EndsWithLineBreak: bool + abstract IsEmpty: bool + +type internal TextSanitizingCollector(collector, ?lineLimit: int) = + let mutable isEmpty = true + let mutable endsWithLineBreak = false + let mutable count = 0 + + let buf = StringBuilder() + + let addTaggedTextEntry t = + if lineLimit.IsNone || count < lineLimit.Value then + isEmpty <- false + endsWithLineBreak <- match t with TaggedText.LineBreak _ -> true | _ -> false + if endsWithLineBreak then count <- count + 1 + collector t + if lineLimit.IsSome && lineLimit.Value = count then + // add ... when line limit is reached + collector (tagText "...") + count <- count + 1 + + let isCROrLF c = c = '\r' || c = '\n' + + let reportTextLines (s: string) = + let mutable pos = 0 + // skip newlines at the beginning + while pos < s.Length && isCROrLF s.[pos] do + pos <- pos + 1 + + // skip newlines whitespaces at the end + let mutable endPos = s.Length - 1 + while endPos >= pos && (Char.IsWhiteSpace s.[endPos] || isCROrLF s.[endPos])do + endPos <- endPos - 1 + + if pos < endPos then + buf.Clear() |> ignore + while (pos < s.Length) do + match s.[pos] with + | '\r' -> () + | '\n' -> + if buf.Length > 0 then + addTaggedTextEntry (tagText (buf.ToString())) + addTaggedTextEntry Literals.lineBreak + buf.Clear() |> ignore + | c -> buf.Append(c) |> ignore + pos <- pos + 1 + // flush the rest + if buf.Length > 0 then + addTaggedTextEntry (tagText (buf.ToString())) + + buf.Clear() |> ignore + + interface ITaggedTextCollector with + member this.Add text = + // TODO: bail out early if line limit is already hit + match text with + | TaggedText.Text t -> reportTextLines t + | t -> addTaggedTextEntry t + + member this.IsEmpty = isEmpty + member this.EndsWithLineBreak = isEmpty || endsWithLineBreak /// XmlDocumentation builder, using the VS interfaces to build documentation. An interface is used /// to allow unit testing to give an alternative implementation which captures the documentation. type internal IDocumentationBuilder = /// Append the given raw XML formatted into the string builder - abstract AppendDocumentationFromProcessedXML : appendTo:StringBuilder * processedXml:string * showExceptions:bool * showParameters:bool * paramName:string option-> unit + abstract AppendDocumentationFromProcessedXML : collector: ITaggedTextCollector * processedXml:string * showExceptions:bool * showParameters:bool * paramName:string option-> unit /// Appends text for the given filename and signature into the StringBuilder - abstract AppendDocumentation : appendTo: StringBuilder * filename: string * signature: string * showExceptions: bool * showParameters: bool * paramName: string option-> unit + abstract AppendDocumentation : collector: ITaggedTextCollector * filename: string * signature: string * showExceptions: bool * showParameters: bool * paramName: string option-> unit /// Documentation helpers. module internal XmlDocumentation = @@ -29,7 +96,7 @@ module internal XmlDocumentation = if String.IsNullOrEmpty(xml) then xml else let trimmedXml = xml.TrimStart([|' ';'\r';'\n'|]) - if trimmedXml.Length>0 then + if trimmedXml.Length > 0 then if trimmedXml.[0] <> '<' then // This code runs for local/within-project xmldoc tooltips, but not for cross-project or .XML - for that see ast.fs in the compiler let escapedXml = System.Security.SecurityElement.Escape(xml) @@ -38,98 +105,151 @@ module internal XmlDocumentation = "" + xml + "" else xml + let AppendHardLine(collector: ITaggedTextCollector) = + collector.Add Literals.lineBreak + + let EnsureHardLine(collector: ITaggedTextCollector) = + if not collector.EndsWithLineBreak then AppendHardLine collector + + let AppendOnNewLine (collector: ITaggedTextCollector) (line:string) = + if line.Length > 0 then + EnsureHardLine collector + collector.Add(TaggedTextOps.tagText line) + + open System.Xml + open System.Xml.Linq + + let rec private WriteElement (collector: ITaggedTextCollector) (n: XNode) = + match n.NodeType with + | XmlNodeType.Text -> + WriteText collector (n :?> XText) + | XmlNodeType.Element -> + let el = n :?> XElement + match el.Name.LocalName with + | "see" | "seealso" -> + for attr in el.Attributes() do + WriteAttribute collector attr "cref" (WriteTypeName collector) + | "paramref" | "typeref" -> + for attr in el.Attributes() do + WriteAttribute collector attr "name" (tagParameter >> collector.Add) + | _ -> + WriteNodes collector (el.Nodes()) + | _ -> () + + and WriteNodes (collector: ITaggedTextCollector) (nodes: seq) = + for n in nodes do + WriteElement collector n + + and WriteText (collector: ITaggedTextCollector) (n: XText) = + collector.Add(tagText n.Value) + + and WriteAttribute (collector: ITaggedTextCollector) (attr: XAttribute) (taggedName: string) tagger = + if attr.Name.LocalName = taggedName then + tagger attr.Value + else + collector.Add(tagText attr.Value) + + and WriteTypeName (collector: ITaggedTextCollector) (typeName: string) = + let typeName = if typeName.StartsWith("T:") then typeName.Substring(2) else typeName + let parts = typeName.Split([|'.'|]) + for i = 0 to parts.Length - 2 do + collector.Add(tagNamespace parts.[i]) + collector.Add(Literals.dot) + collector.Add(tagClass parts.[parts.Length - 1]) + + type XmlDocReader(s: string) = + let doc = XElement.Parse(ProcessXml(s)) + let tryFindParameter name = + doc.Descendants (XName.op_Implicit "param") + |> Seq.tryFind (fun el -> + match el.Attribute(XName.op_Implicit "name") with + | null -> false + | attr -> attr.Value = name) + + member __.CollectSummary(collector: ITaggedTextCollector) = + match Seq.tryHead (doc.Descendants(XName.op_Implicit "summary")) with + | None -> () + | Some el -> + EnsureHardLine collector + WriteElement collector el + + member this.CollectParameter(collector: ITaggedTextCollector, paramName: string) = + match tryFindParameter paramName with + | None -> () + | Some el -> + EnsureHardLine collector + WriteNodes collector (el.Nodes()) + + member this.CollectParameters(collector: ITaggedTextCollector) = + for p in doc.Descendants(XName.op_Implicit "param") do + match p.Attribute(XName.op_Implicit "name") with + | null -> () + | name -> + EnsureHardLine collector + collector.Add(tagParameter name.Value) + collector.Add(Literals.colon) + collector.Add(Literals.space) + WriteNodes collector (p.Nodes()) + + member this.CollectExceptions(collector: ITaggedTextCollector) = + let mutable started = false; + for p in doc.Descendants(XName.op_Implicit "exception") do + match p.Attribute(XName.op_Implicit "cref") with + | null -> () + | exnType -> + if not started then + started <- true + AppendHardLine collector + AppendHardLine collector + AppendOnNewLine collector Strings.ExceptionsHeader + EnsureHardLine collector + collector.Add(tagSpace " ") + WriteTypeName collector exnType.Value + if not (Seq.isEmpty (p.Nodes())) then + collector.Add Literals.space + collector.Add Literals.minus + collector.Add Literals.space + WriteNodes collector (p.Nodes()) + /// Provide Xml Documentation type Provider(xmlIndexService:IVsXMLMemberIndexService, dte: DTE) = /// Index of assembly name to xml member index. let mutable xmlCache = new AgedLookup(10,areSame=(fun (x,y) -> x = y)) let events = dte.Events :?> Events2 - let solutionEvents = events.SolutionEvents + let solutionEvents = events.SolutionEvents do solutionEvents.add_AfterClosing(fun () -> xmlCache.Clear()) - let HasTrailingEndOfLine(sb:StringBuilder) = - if sb.Length = 0 then true - else - let c = sb.[sb.Length-1] - c = '\r' || c = '\n' - - let AppendHardLine(sb:StringBuilder) = - sb.AppendLine() |> ignore - - let AppendOnNewLine (sb:StringBuilder) (line:string) = - if line.Length>0 then - if not(HasTrailingEndOfLine(sb)) then - sb.AppendLine("")|>ignore - sb.Append(line.TrimEnd([|' '|]))|>ignore - - let AppendSummary (sb:StringBuilder) (memberData:IVsXMLMemberData3) = - let ok,summary = memberData.GetSummaryText() - if Com.Succeeded(ok) then - AppendOnNewLine sb summary - else - // Failed, but still show the summary because it may contain an error message. - if summary<>null then AppendOnNewLine sb summary - #if DEBUG // Keep under DEBUG so that it can keep building. - let _AppendTypeParameters (sb:StringBuilder) (memberData:IVsXMLMemberData3) = + let _AppendTypeParameters (collector: ITaggedTextCollector) (memberData:IVsXMLMemberData3) = let ok,count = memberData.GetTypeParamCount() - if Com.Succeeded(ok) && count>0 then - if not(HasTrailingEndOfLine(sb)) then - AppendHardLine(sb) + if Com.Succeeded(ok) && count > 0 then for param in 0..count do let ok,name,text = memberData.GetTypeParamTextAt(param) - if Com.Succeeded(ok) then - AppendOnNewLine sb (sprintf "%s - %s" name text) - - let _AppendRemarks (sb:StringBuilder) (memberData:IVsXMLMemberData3) = + if Com.Succeeded(ok) then + EnsureHardLine collector + collector.Add(tagTypeParameter name) + collector.Add(Literals.space) + collector.Add(tagPunctuation "-") + collector.Add(Literals.space) + collector.Add(tagText text) + + let _AppendRemarks (collector: ITaggedTextCollector) (memberData:IVsXMLMemberData3) = let ok,remarksText = memberData.GetRemarksText() if Com.Succeeded(ok) then - AppendOnNewLine sb remarksText + AppendOnNewLine collector remarksText #endif - let AppendParameters (sb:StringBuilder) (memberData:IVsXMLMemberData3) = - let ok,count = memberData.GetParamCount() - if Com.Succeeded(ok) && count > 0 then - if not(HasTrailingEndOfLine(sb)) then - AppendHardLine(sb) - AppendHardLine(sb) - for param in 0..(count-1) do - let ok,name,text = memberData.GetParamTextAt(param) - if Com.Succeeded(ok) then - AppendOnNewLine sb (sprintf "%s: %s" name text) - - let AppendParameter (sb:StringBuilder, memberData:IVsXMLMemberData3, paramName:string) = - let ok,count = memberData.GetParamCount() - if Com.Succeeded(ok) && count > 0 then - if not(HasTrailingEndOfLine(sb)) then - AppendHardLine(sb) - for param in 0..(count-1) do - let ok,name,text = memberData.GetParamTextAt(param) - if Com.Succeeded(ok) && name = paramName then - AppendOnNewLine sb text - - let _AppendReturns (sb:StringBuilder) (memberData:IVsXMLMemberData3) = + let _AppendReturns (collector: ITaggedTextCollector) (memberData:IVsXMLMemberData3) = let ok,returnsText = memberData.GetReturnsText() if Com.Succeeded(ok) then - if not(HasTrailingEndOfLine(sb)) then - AppendHardLine(sb) - AppendHardLine(sb) - AppendOnNewLine sb returnsText - - let AppendExceptions (sb:StringBuilder) (memberData:IVsXMLMemberData3) = - let ok,count = memberData.GetExceptionCount() - if Com.Succeeded(ok) && count > 0 then - if count > 0 then - AppendHardLine sb - AppendHardLine sb - AppendOnNewLine sb Strings.ExceptionsHeader - for exc in 0..count do - let ok,typ,_text = memberData.GetExceptionTextAt(exc) - if Com.Succeeded(ok) then - AppendOnNewLine sb (sprintf " %s" typ ) - + if not collector.EndsWithLineBreak then + AppendHardLine(collector) + AppendHardLine(collector) + AppendOnNewLine collector returnsText + /// Retrieve the pre-existing xml index or None let GetMemberIndexOfAssembly(assemblyName) = match xmlCache.TryGet(assemblyName) with @@ -144,32 +264,32 @@ module internal XmlDocumentation = else None else None - let AppendMemberData(appendTo:StringBuilder,memberData:IVsXMLMemberData3,showExceptions:bool,showParameters:bool) = - AppendHardLine appendTo - AppendSummary appendTo memberData + let AppendMemberData(collector: ITaggedTextCollector, xmlDocReader: XmlDocReader,showExceptions:bool,showParameters:bool) = + AppendHardLine collector + xmlDocReader.CollectSummary(collector) // AppendParameters appendTo memberData // AppendTypeParameters appendTo memberData - if (showParameters) then - AppendParameters appendTo memberData + if (showParameters) then + xmlDocReader.CollectParameters collector // Not showing returns because there's no resource localization in language service to place the "returns:" text // AppendReturns appendTo memberData - if (showExceptions) then AppendExceptions appendTo memberData + if (showExceptions) then + xmlDocReader.CollectExceptions collector // AppendRemarks appendTo memberData interface IDocumentationBuilder with /// Append the given processed XML formatted into the string builder override this.AppendDocumentationFromProcessedXML(appendTo, processedXml, showExceptions, showParameters, paramName) = - let ok,xml = xmlIndexService.GetMemberDataFromXML(processedXml) - if Com.Succeeded(ok) then - if paramName.IsSome then - AppendParameter(appendTo, xml:?>IVsXMLMemberData3, paramName.Value) - else - AppendMemberData(appendTo,xml:?>IVsXMLMemberData3,showExceptions,showParameters) + let xmlDocReader = XmlDocReader(processedXml) + if paramName.IsSome then + xmlDocReader.CollectParameter(appendTo, paramName.Value) + else + AppendMemberData(appendTo, xmlDocReader, showExceptions,showParameters) /// Append Xml documentation contents into the StringBuilder override this.AppendDocumentation - ( /// StringBuilder to append to - appendTo:StringBuilder, + ( /// ITaggedTextCollector to add to + sink: ITaggedTextCollector, /// Name of the library file filename:string, /// Signature of the comment @@ -187,98 +307,95 @@ module internal XmlDocumentation = let _,idx = index.ParseMemberSignature(signature) if idx <> 0u then let ok,xml = index.GetMemberXML(idx) - let processedXml = ProcessXml(xml) if Com.Succeeded(ok) then - (this:>IDocumentationBuilder).AppendDocumentationFromProcessedXML(appendTo,processedXml,showExceptions,showParameters, paramName) + (this:>IDocumentationBuilder).AppendDocumentationFromProcessedXML(sink, xml, showExceptions, showParameters, paramName) | None -> () with e-> Assert.Exception(e) reraise() /// Append an XmlCommnet to the segment. - let AppendXmlComment(documentationProvider:IDocumentationBuilder, segment:StringBuilder, xml, showExceptions, showParameters, paramName) = + let AppendXmlComment(documentationProvider:IDocumentationBuilder, sink: ITaggedTextCollector, xml, showExceptions, showParameters, paramName) = match xml with | FSharpXmlDoc.None -> () | FSharpXmlDoc.XmlDocFileSignature(filename,signature) -> - documentationProvider.AppendDocumentation(segment,filename,signature,showExceptions,showParameters, paramName) + documentationProvider.AppendDocumentation(sink, filename, signature, showExceptions, showParameters, paramName) | FSharpXmlDoc.Text(rawXml) -> let processedXml = ProcessXml(rawXml) - documentationProvider.AppendDocumentationFromProcessedXML(segment,processedXml,showExceptions,showParameters, paramName) + documentationProvider.AppendDocumentationFromProcessedXML(sink, processedXml, showExceptions, showParameters, paramName) - /// Common sanitation for data tip segment - let CleanDataTipSegment(segment:StringBuilder) = - segment.Replace("\r", "") - .Replace("\n\n\n","\n\n") - .Replace("\n\n\n","\n\n") - .ToString() - .Trim([|'\n'|]) + let private AddSeparator (collector: ITaggedTextCollector) = + if not collector.IsEmpty then + EnsureHardLine collector + collector.Add (tagText "-------------") + AppendHardLine collector /// Build a data tip text string with xml comments injected. - let BuildTipText(documentationProvider:IDocumentationBuilder, dataTipText:FSharpToolTipElement list, showText, showExceptions, showParameters, showOverloadText) = - let maxLinesInText = 45 - let Format(dataTipElement:FSharpToolTipElement) = - let segment = - match dataTipElement with - | FSharpToolTipElement.None ->StringBuilder() - | FSharpToolTipElement.Single (text,xml) -> - let segment = StringBuilder() - if showText then - segment.Append(text) |> ignore - - AppendXmlComment(documentationProvider, segment, xml, showExceptions, showParameters, None) - segment - | FSharpToolTipElement.SingleParameter(text, xml, paramName) -> - let segment = StringBuilder() - if showText then - segment.Append(text) |> ignore - - AppendXmlComment(documentationProvider, segment, xml, showExceptions, showParameters, Some paramName) - segment - | FSharpToolTipElement.Group (overloads) -> - let segment = StringBuilder() - let overloads = Array.ofList overloads - let len = Array.length overloads - if len >= 1 then - if showOverloadText then - let AppendOverload(text,_) = - if not(String.IsNullOrEmpty(text)) then - segment.Append("\n").Append(text) |> ignore - - AppendOverload(overloads.[0]) - if len >= 2 then AppendOverload(overloads.[1]) - if len >= 3 then AppendOverload(overloads.[2]) - if len >= 4 then AppendOverload(overloads.[3]) - if len >= 5 then AppendOverload(overloads.[4]) - if len >= 6 then segment.Append("\n").Append(PrettyNaming.FormatAndOtherOverloadsString(len-5)) |> ignore - - let _,xml = overloads.[0] - AppendXmlComment(documentationProvider, segment, xml, showExceptions, showParameters, None) - segment - | FSharpToolTipElement.CompositionError(errText) -> StringBuilder(errText) - CleanDataTipSegment(segment) - - let segments = dataTipText |> List.map Format |> List.filter (fun d->d<>null) |> Array.ofList - let text = System.String.Join("\n-------------\n", segments) - - let lines = text.Split([|'\n'|],maxLinesInText+1) // Need one more than max to determine whether there is truncation. - let truncate = lines.Length>maxLinesInText - let lines = lines |> Seq.truncate maxLinesInText - let lines = if truncate then Seq.append lines ["..."] else lines - let lines = lines |> Seq.toArray - let join = String.Join("\n",lines) - - join - - let BuildDataTipText(documentationProvider, FSharpToolTipText(dataTipText)) = - BuildTipText(documentationProvider,dataTipText,true, true, false, true) - - let BuildMethodOverloadTipText(documentationProvider, FSharpToolTipText(dataTipText), showParams) = - BuildTipText(documentationProvider,dataTipText,false, false, showParams, false) - - let BuildMethodParamText(documentationProvider, xml, paramName) = - let sb = StringBuilder() - AppendXmlComment(documentationProvider, sb, xml, false, true, Some paramName) - sb.ToString() + let BuildTipText(documentationProvider:IDocumentationBuilder, dataTipText: FSharpStructuredToolTipElement list, textCollector, xmlCollector, showText, showExceptions, showParameters, showOverloadText) = + let textCollector: ITaggedTextCollector = TextSanitizingCollector(textCollector, lineLimit = 45) :> _ + let xmlCollector: ITaggedTextCollector = TextSanitizingCollector(xmlCollector, lineLimit = 45) :> _ + + let addSeparatorIfNecessary add = + if add then + AddSeparator textCollector + AddSeparator xmlCollector + + let Process add (dataTipElement: FSharpStructuredToolTipElement) = + match dataTipElement with + | FSharpStructuredToolTipElement.None -> false + | FSharpStructuredToolTipElement.Single (text, xml) -> + addSeparatorIfNecessary add + if showText then + renderL (taggedTextListR textCollector.Add) text |> ignore + AppendXmlComment(documentationProvider, xmlCollector, xml, showExceptions, showParameters, None) + true + | FSharpStructuredToolTipElement.SingleParameter(text, xml, paramName) -> + addSeparatorIfNecessary add + if showText then + renderL (taggedTextListR textCollector.Add) text |> ignore + AppendXmlComment(documentationProvider, xmlCollector, xml, showExceptions, showParameters, Some paramName) + true + | FSharpStructuredToolTipElement.Group (overloads) -> + let overloads = Array.ofList overloads + let len = Array.length overloads + if len >= 1 then + addSeparatorIfNecessary add + if showOverloadText then + let AppendOverload(text,_) = + if not(Microsoft.FSharp.Compiler.Layout.isEmptyL text) then + if not textCollector.IsEmpty then textCollector.Add Literals.lineBreak + renderL (taggedTextListR textCollector.Add) text |> ignore + + AppendOverload(overloads.[0]) + if len >= 2 then AppendOverload(overloads.[1]) + if len >= 3 then AppendOverload(overloads.[2]) + if len >= 4 then AppendOverload(overloads.[3]) + if len >= 5 then AppendOverload(overloads.[4]) + if len >= 6 then + textCollector.Add Literals.lineBreak + textCollector.Add (tagText(PrettyNaming.FormatAndOtherOverloadsString(len-5))) + + let _,xml = overloads.[0] + AppendXmlComment(documentationProvider, textCollector, xml, showExceptions, showParameters, None) + true + else + false + + | FSharpStructuredToolTipElement.CompositionError(errText) -> + textCollector.Add(tagText errText) + true + + List.fold Process false dataTipText + |> ignore + + let BuildDataTipText(documentationProvider, textCollector, xmlCollector, FSharpToolTipText(dataTipText)) = + BuildTipText(documentationProvider, dataTipText, textCollector, xmlCollector, true, true, false, true) + + let BuildMethodOverloadTipText(documentationProvider, textCollector, xmlCollector, FSharpToolTipText(dataTipText), showParams) = + BuildTipText(documentationProvider, dataTipText, textCollector, xmlCollector, false, false, showParams, false) + + let BuildMethodParamText(documentationProvider, xmlCollector, xml, paramName) = + AppendXmlComment(documentationProvider, TextSanitizingCollector(xmlCollector), xml, false, true, Some paramName) let documentationBuilderCache = System.Runtime.CompilerServices.ConditionalWeakTable() let CreateDocumentationBuilder(xmlIndexService: IVsXMLMemberIndexService, dte: DTE) = diff --git a/vsintegration/tests/Salsa/salsa.fs b/vsintegration/tests/Salsa/salsa.fs index 8138933cb9d..98273c0d0d0 100644 --- a/vsintegration/tests/Salsa/salsa.fs +++ b/vsintegration/tests/Salsa/salsa.fs @@ -1487,13 +1487,18 @@ module internal Salsa = let tm = box (VsMocks.createTextManager()) let documentationProvider = { new IDocumentationBuilder with - override doc.AppendDocumentationFromProcessedXML(appendTo:StringBuilder,processedXml:string,showExceptions, showReturns, paramName) = - appendTo.AppendLine(processedXml)|> ignore - override doc.AppendDocumentation(appendTo:StringBuilder,filename:string,signature:string, showExceptions, showReturns, paramName) = - appendTo.AppendLine(sprintf "[Filename:%s]" filename).AppendLine(sprintf "[Signature:%s]" signature) |> ignore - if paramName.IsSome then appendTo.AppendLine(sprintf "[ParamName: %s]" paramName.Value) |> ignore + override doc.AppendDocumentationFromProcessedXML(appendTo,processedXml:string,showExceptions, showReturns, paramName) = + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.tagText processedXml) + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.Literals.lineBreak) + override doc.AppendDocumentation(appendTo,filename:string,signature:string, showExceptions, showReturns, paramName) = + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.tagText (sprintf "[Filename:%s]" filename)) + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.Literals.lineBreak) + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.tagText (sprintf "[Signature:%s]" signature)) + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.Literals.lineBreak) + if paramName.IsSome then + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.tagText (sprintf "[ParamName: %s]" paramName.Value)) + appendTo.Add(Microsoft.FSharp.Compiler.Layout.TaggedTextOps.Literals.lineBreak) } - let sp2 = { new System.IServiceProvider with diff --git a/vsintegration/tests/unittests/QuickInfoProviderTests.fs b/vsintegration/tests/unittests/QuickInfoProviderTests.fs index 7e1817d2ad1..108e7ad6c1a 100644 --- a/vsintegration/tests/unittests/QuickInfoProviderTests.fs +++ b/vsintegration/tests/unittests/QuickInfoProviderTests.fs @@ -53,14 +53,14 @@ let internal options = { let private normalizeLineEnds (s: string) = s.Replace("\r\n", "\n").Replace("\n\n", "\n") -let private getQuickInfoText (FSharpToolTipText elements) : string = +let private getQuickInfoText (FSharpStructuredToolTipText.FSharpToolTipText elements) : string = let rec parseElement = function | FSharpToolTipElement.None -> "" | FSharpToolTipElement.Single(text, _) -> text | FSharpToolTipElement.SingleParameter(text, _, _) -> text | FSharpToolTipElement.Group(xs) -> xs |> List.map fst |> String.concat "\n" | FSharpToolTipElement.CompositionError(error) -> error - elements |> List.map parseElement |> String.concat "\n" |> normalizeLineEnds + elements |> List.map (Tooltips.ToFSharpToolTipElement >> parseElement) |> String.concat "\n" |> normalizeLineEnds [] let ShouldShowQuickInfoAtCorrectPositions() = diff --git a/vsintegration/tests/unittests/Tests.LanguageService.QuickInfo.fs b/vsintegration/tests/unittests/Tests.LanguageService.QuickInfo.fs index e09374cb11f..ad9b21385d1 100644 --- a/vsintegration/tests/unittests/Tests.LanguageService.QuickInfo.fs +++ b/vsintegration/tests/unittests/Tests.LanguageService.QuickInfo.fs @@ -265,6 +265,30 @@ type UsingMSBuild() = """ this.CheckTooltip(source, "x``|>", true, checkTooltip "x") + [] + member public this.QuickInfoForTypesWithHiddenRepresentation() = + let source = """ + let x = Async.AsBeginEnd + 1 + """ + let expectedTooltip = """ +type Async = + static member AsBeginEnd : computation:('Arg -> Async<'T>) -> ('Arg * AsyncCallback * obj -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit) + static member AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate) + static member AwaitIAsyncResult : iar:IAsyncResult * ?millisecondsTimeout:int -> Async + static member AwaitTask : task:Task -> Async + static member AwaitTask : task:Task<'T> -> Async<'T> + static member AwaitWaitHandle : waitHandle:WaitHandle * ?millisecondsTimeout:int -> Async + static member CancelDefaultToken : unit -> unit + static member Catch : computation:Async<'T> -> Async> + static member Choice : computations:seq> -> Async<'T option> + static member FromBeginEnd : beginAction:(AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T> + ... + +Full name: Microsoft.FSharp.Control.Async""".TrimStart().Replace("\r\n", "\n") + + this.CheckTooltip(source, "Asyn", false, checkTooltip expectedTooltip) + [] [] member public this.``TypeProviders.NestedTypesOrder``() = @@ -1094,7 +1118,7 @@ let f (tp:ITypeProvider(*$$$*)) = tp.Invalidate // The arises because the xml doc mechanism places these before handing them to VS for processing. this.AssertQuickInfoContainsAtEndOfMarker(fileContent,"XX","module XXX") this.AssertQuickInfoContainsAtEndOfMarker(fileContent,"YY","module YYY\n\nfrom XXX") - this.AssertQuickInfoContainsAtEndOfMarker(fileContent,"ZZ","module ZZZ\n\nfrom XXX\n\nDoc") + this.AssertQuickInfoContainsAtEndOfMarker(fileContent,"ZZ","module ZZZ\n\nfrom XXX\nDoc") [] member public this.``IdentifierWithTick``() =