csharpfftfsharpintegrationinterpolationlinear-algebramathdifferentiationmatrixnumericsrandomregressionstatisticsmathnet
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
4240 lines
217 KiB
4240 lines
217 KiB
// (c) Microsoft Corporation. All rights reserved
|
|
//----------------------------------------------------------------------------
|
|
// Open up the compiler as an incremental service for lexing, parsing,
|
|
// type checking and intellisense-like environment-reporting.
|
|
//--------------------------------------------------------------------------
|
|
|
|
#light
|
|
|
|
namespace Microsoft.FSharp.Compiler.SourceCodeServices
|
|
|
|
open Internal.Utilities
|
|
open System
|
|
open System.IO
|
|
open System.Text
|
|
open System.Threading
|
|
open System.Collections.Generic
|
|
|
|
open Microsoft.FSharp.Text.Printf
|
|
open Microsoft.FSharp.Compiler.AbstractIL
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Internal
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
|
|
open Microsoft.FSharp.Compiler
|
|
open Microsoft.FSharp.Compiler.MSBuildResolver
|
|
open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics
|
|
open Microsoft.FSharp.Compiler.PrettyNaming
|
|
open Internal.Utilities.Collections
|
|
open Internal.Utilities.Debug
|
|
open System.Security.Permissions
|
|
|
|
open Microsoft.FSharp.Compiler.Env
|
|
open Microsoft.FSharp.Compiler.Parser
|
|
open Microsoft.FSharp.Compiler.Range
|
|
open Microsoft.FSharp.Compiler.Ast
|
|
open Microsoft.FSharp.Compiler.ErrorLogger
|
|
open Microsoft.FSharp.Compiler.Lexhelp
|
|
open Microsoft.FSharp.Compiler.Build
|
|
open Microsoft.FSharp.Compiler.Tast
|
|
open Microsoft.FSharp.Compiler.Tastops
|
|
open Microsoft.FSharp.Compiler.Lib
|
|
open Microsoft.FSharp.Compiler.AbstractIL.IL
|
|
open Microsoft.FSharp.Compiler.Layout
|
|
open Microsoft.FSharp.Compiler.TypeChecker
|
|
open Microsoft.FSharp.Compiler.Infos
|
|
open Microsoft.FSharp.Compiler.Nameres
|
|
|
|
/// Methods for dealing with F# sources files.
|
|
module SourceFile =
|
|
/// Source file extensions
|
|
let private compilableExtensions = Build.sigSuffixes @ Build.implSuffixes @ Build.scriptSuffixes
|
|
/// Single file projects extensions
|
|
let private singleFileProjectExtensions = Build.scriptSuffixes
|
|
/// Whether or not this file is compilable
|
|
let IsCompilable file =
|
|
let ext = Path.GetExtension(file)
|
|
compilableExtensions |> List.exists(fun e->0 = String.Compare(e,ext,StringComparison.OrdinalIgnoreCase))
|
|
/// Whether or not this file should be a single-file project
|
|
let MustBeSingleFileProject file =
|
|
let ext = Path.GetExtension(file)
|
|
singleFileProjectExtensions |> List.exists(fun e-> 0 = String.Compare(e,ext,StringComparison.OrdinalIgnoreCase))
|
|
/// Whether or not this is an fsi generated by goto metadata.
|
|
let IsFSharpLanguageServiceGenerated s =
|
|
let genExtns = [ ".fsi" ] // REVIEW: decide if we like the extension check or if we ought to skip it
|
|
let extn = Path.GetExtension s
|
|
if List.mem extn genExtns then
|
|
let dirName = Path.GetDirectoryName s
|
|
dirName = FsiGeneration.PathForGeneratedVisualStudioFSharpTempFiles
|
|
else false
|
|
/// Additonal #defines that should be in place when editing a file in a file editor
|
|
/// such as VS.
|
|
let AdditionalDefinesForUseInEditor(filename) =
|
|
if Build.IsScript(filename) then ["INTERACTIVE";"EDITING"]
|
|
else ["COMPILED";"EDITING"]
|
|
|
|
|
|
|
|
/// Test hooks for tweaking internals
|
|
module TestHooks =
|
|
/// Function used to construct memebr info text in data tips.
|
|
let ConstructMemberInfoText: ((unit->unit)->unit) option ref = ref None
|
|
|
|
let HookScope(command:string,hook:(unit->unit)->unit) : System.IDisposable =
|
|
match command with
|
|
| "HookConstructMemberInfoText" ->
|
|
ConstructMemberInfoText := Some(hook)
|
|
{new IDisposable with
|
|
member d.Dispose() =
|
|
ConstructMemberInfoText := None}
|
|
| _ -> failwith "Unknown test hook"
|
|
|
|
|
|
/// Enable/disable generation of interface file in the 'Find Declaration'
|
|
/// By default, the feature is turned off in the current version
|
|
let enableFsiGenerationHook = ref false
|
|
|
|
/// Turns the generation on and returns IDisposable that disables it again
|
|
let EnableFsiGenerationHook () =
|
|
let oldFsiGenerationHook = !enableFsiGenerationHook
|
|
enableFsiGenerationHook := true
|
|
{ new IDisposable with
|
|
member x.Dispose() =
|
|
enableFsiGenerationHook := oldFsiGenerationHook }
|
|
|
|
/// This corresponds to a token categorization originally used in Visual Studio 2003.
|
|
///
|
|
/// NOTE: This corresponds to a token categorization originally used in Visual Studio 2003 and the original Babel source code.
|
|
/// It is not clear it is a primary logical classification that should be being used in the
|
|
/// more recent language service work.
|
|
type TokenColorKind =
|
|
Default = 0
|
|
| Text = 0
|
|
| Keyword = 1
|
|
| Comment = 2
|
|
| Identifier = 3
|
|
| String = 4
|
|
| UpperIdentifier = 5
|
|
| InactiveCode = 7
|
|
| PreprocessorKeyword = 8
|
|
| Number = 9
|
|
|
|
/// Categorize an action the editor should take in respons to a token, e.g. brace matching
|
|
///
|
|
/// NOTE: This corresponds to a token categorization originally used in Visual Studio 2003 and the original Babel source code.
|
|
/// It is not clear it is a primary logical classification that should be being used in the
|
|
/// more recent language service work.
|
|
type TriggerClass =
|
|
None = 0x00000000
|
|
| MemberSelect = 0x00000001
|
|
| MatchBraces = 0x00000002
|
|
| ChoiceSelect = 0x00000004
|
|
| MethodTip = 0x000000F0
|
|
| ParamStart = 0x00000010
|
|
| ParamNext = 0x00000020
|
|
| ParamEnd = 0x00000040
|
|
|
|
|
|
/// This corresponds to a token categorization originally used in Visual Studio 2003.
|
|
///
|
|
/// NOTE: This corresponds to a token categorization originally used in Visual Studio 2003 and the original Babel source code.
|
|
/// It is not clear it is a primary logical classification that should be being used in the
|
|
/// more recent language service work.
|
|
type TokenCharKind =
|
|
Default = 0x00000000
|
|
| Text = 0x00000000
|
|
| Keyword = 0x00000001
|
|
| Identifier = 0x00000002
|
|
| String = 0x00000003
|
|
| Literal = 0x00000004
|
|
| Operator = 0x00000005
|
|
| Delimiter = 0x00000006
|
|
| WhiteSpace = 0x00000008
|
|
| LineComment = 0x00000009
|
|
| Comment = 0x0000000A
|
|
|
|
|
|
/// Information about a particular token from the tokenizer
|
|
type TokenInformation = {
|
|
LeftColumn:int;
|
|
RightColumn:int;
|
|
ColorClass:TokenColorKind;
|
|
CharClass:TokenCharKind;
|
|
TriggerClass:TriggerClass;
|
|
Tag:int
|
|
TokenName:string }
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Flags
|
|
//--------------------------------------------------------------------------
|
|
|
|
module Flags =
|
|
#if DEBUG
|
|
let loggingTypes = System.Environment.GetEnvironmentVariable("mFSharp_Logging")
|
|
let logging = not (String.IsNullOrEmpty(loggingTypes))
|
|
let initialLoggingGUITypes = loggingTypes
|
|
let loggingGUI = not (String.IsNullOrEmpty(System.Environment.GetEnvironmentVariable("mFSharp_LogToWinForm")))
|
|
let loggingStdOut = not (String.IsNullOrEmpty(System.Environment.GetEnvironmentVariable("mFSharp_LogToStdOut")))
|
|
#else
|
|
let loggingTypes = ""
|
|
let logging = false
|
|
let initialLoggingGUITypes = ""
|
|
let loggingGUI = false
|
|
let loggingStdOut = false
|
|
#endif
|
|
let _ =
|
|
if logging && not loggingGUI && not loggingStdOut then
|
|
let logFile = ("c:\\fsharp\\log-m"^System.AppDomain.CurrentDomain.FriendlyName^".log")
|
|
let traceFile = ("c:\\fsharp\\trace-m"^System.AppDomain.CurrentDomain.FriendlyName^".txt")
|
|
try
|
|
let log = (File.CreateText logFile :> TextWriter)
|
|
setDiagnosticsChannel(Some(log));
|
|
progress := true;
|
|
with e->
|
|
// Don't kill the language service just because we couldn't log.
|
|
()
|
|
if logging then
|
|
dprintf "Opened log file %s for ML, config follows\n" logFile
|
|
dprintf "logging types = %s\n" loggingTypes
|
|
Trace.Log <- loggingTypes
|
|
Trace.Out <- new StreamWriter(traceFile,append=false,encoding=System.Text.Encoding.UTF8)
|
|
elif loggingStdOut then
|
|
Trace.Log <- initialLoggingGUITypes
|
|
Trace.Out <- System.Console.Out
|
|
elif loggingGUI then
|
|
let f = new System.Windows.Forms.Form(Visible=true,TopMost=true,Width=600,Height=600)
|
|
let rb = new System.Windows.Forms.RichTextBox(Dock=System.Windows.Forms.DockStyle.Fill, Font=new System.Drawing.Font("courier new",8.0f))
|
|
f.Controls.Add(rb)
|
|
rb.DoubleClick.Add(fun _ -> rb.Clear())
|
|
let lab = new System.Windows.Forms.Label(Dock=System.Windows.Forms.DockStyle.Top, Font=new System.Drawing.Font("courier new",8.0f))
|
|
f.Controls.Add(lab)
|
|
let tb = new System.Windows.Forms.TextBox(Text=initialLoggingGUITypes,Height=10,Multiline=false,Dock=System.Windows.Forms.DockStyle.Top, Font=new System.Drawing.Font("courier new",8.0f))
|
|
f.Controls.Add(tb)
|
|
tb.TextChanged.Add (fun ev -> Trace.Log <- tb.Text)
|
|
|
|
let log =
|
|
let addTextOnGuiThread text =
|
|
if not rb.IsDisposed then
|
|
rb.AppendText(text);
|
|
if text.Contains "\n" then
|
|
rb.ScrollToCaret();
|
|
if rb.TextLength > 20000 then
|
|
let s = rb.Text
|
|
rb.Text <- s.[s.Length - 15000..s.Length-1]
|
|
let addText text =
|
|
if f.InvokeRequired then
|
|
f.BeginInvoke(new System.Windows.Forms.MethodInvoker(fun () -> addTextOnGuiThread text)) |> ignore
|
|
else
|
|
addTextOnGuiThread text
|
|
|
|
{ new System.IO.TextWriter() with
|
|
member x.Write(c:char) = addText (string c)
|
|
member x.Write(s:string) = addText s
|
|
member x.Encoding = System.Text.Encoding.Unicode }
|
|
setDiagnosticsChannel(Some(log));
|
|
Trace.Log <- initialLoggingGUITypes
|
|
Trace.Out <- log
|
|
else
|
|
// Would be nice to leave this at whatever channel was originally assigned.
|
|
// This currently defeats NUnit's ability to capture logging output.
|
|
setDiagnosticsChannel(None) (* VS does not support stderr! *)
|
|
|
|
/// Reads the flag specifying whether interface generation is enabled in the 'Go To Definition' feature
|
|
let enableInterfaceGeneration() = !TestHooks.enableFsiGenerationHook
|
|
//let stripFSharpCoreReferences = not (String.IsNullOrEmpty(System.Environment.GetEnvironmentVariable("mFSharp_StripFSharpCoreReferences")))
|
|
let GetEnvInteger e dflt = match System.Environment.GetEnvironmentVariable(e) with null -> dflt | t -> try int t with _ -> dflt
|
|
let definesCacheSize = GetEnvInteger "mFSharp_DefinesCacheSize" 5
|
|
let buildCacheSize = GetEnvInteger "mFSharp_BuildCacheSize" 3
|
|
let recentForgroundTypeCheckLookupSize = GetEnvInteger "mFSharp_RecentForegroundTypeCheckCacheSize" 5
|
|
let braceMatchCacheSize = GetEnvInteger "mFSharp_BraceMatchCacheSize" 5
|
|
let getDataTipTextCache = GetEnvInteger "mFSharp_GetDataTipTextCache" 20
|
|
let maxErrorsOutOfProjectContext = GetEnvInteger "mFSharp_MaxErrorsOutOfProjectContext" 3
|
|
|
|
open Flags
|
|
|
|
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Babel flags
|
|
//--------------------------------------------------------------------------
|
|
|
|
module TokenClassifications =
|
|
|
|
//----------------------------------------------------------------------------
|
|
//From tokens to flags
|
|
//--------------------------------------------------------------------------
|
|
|
|
let tokenInfo token =
|
|
match token with
|
|
| IDENT s
|
|
->
|
|
if System.Char.ToUpperInvariant s.[0] = s.[0] then
|
|
(TokenColorKind.UpperIdentifier,TokenCharKind.Identifier,TriggerClass.None)
|
|
else
|
|
(TokenColorKind.Identifier,TokenCharKind.Identifier,TriggerClass.None)
|
|
|
|
| DECIMAL _
|
|
| BIGNUM _ | INT8 _ | UINT8 _ | INT16 _ | UINT16 _ | INT32 _ | UINT32 _ | INT64 _ | UINT64 _
|
|
| UNATIVEINT _ | NATIVEINT _ | IEEE32 _ | IEEE64 _
|
|
-> (TokenColorKind.Number,TokenCharKind.Literal,TriggerClass.None)
|
|
|
|
| INT32_DOT_DOT _
|
|
// This will color the whole "1.." expression in a 'number' color
|
|
// (this isn't entirely correct, but it'll work for now - see bug 3727)
|
|
-> (TokenColorKind.Number,TokenCharKind.Operator,TriggerClass.None)
|
|
|
|
| INFIX_STAR_DIV_MOD_OP ("mod" | "land" | "lor" | "lxor")
|
|
| INFIX_STAR_STAR_OP ("lsl" | "lsr" | "asr")
|
|
-> (TokenColorKind.Keyword,TokenCharKind.Keyword,TriggerClass.None)
|
|
|
|
| LPAREN_STAR_RPAREN
|
|
| DOLLAR | INFIX_STAR_STAR_OP _ | INFIX_COMPARE_OP _ | COLON_GREATER | COLON_COLON
|
|
| PERCENT_OP _ | INFIX_AT_HAT_OP _ | INFIX_BAR_OP _ | PLUS_MINUS_OP _ | PREFIX_OP _ | COLON_QMARK_GREATER
|
|
| INFIX_STAR_DIV_MOD_OP _ | INFIX_AMP_OP _ | AMP | AMP_AMP | BAR_BAR | LESS | GREATER | QMARK | QMARK_QMARK | COLON_QMARK
|
|
| DOT_DOT | QUOTE | STAR | HIGH_PRECEDENCE_TYAPP
|
|
| COLON | COLON_EQUALS | LARROW | EQUALS | GREATER_DOT | RQUOTE_DOT _
|
|
| MINUS | ADJACENT_PREFIX_PLUS_MINUS_OP _ | FUNKY_OPERATOR_NAME _
|
|
|
|
-> (TokenColorKind.Text,TokenCharKind.Operator,TriggerClass.None)
|
|
|
|
| COMMA
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.None)
|
|
|
|
| DOT
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.MemberSelect)
|
|
|
|
| BAR
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.None (* TriggerClass.ChoiceSelect *))
|
|
|
|
| HASH | UNDERSCORE
|
|
| SEMICOLON | SEMICOLON_SEMICOLON
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.None)
|
|
|
|
| LPAREN
|
|
// We need 'ParamStart' to trigger the 'GetDeclarations' method to show param info automatically
|
|
// this is needed even if we don't use MPF for determining information about params
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter, TriggerClass.ParamStart ||| TriggerClass.MatchBraces)
|
|
|
|
| RPAREN
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,(* TriggerClass.ParamEnd; ||| *) TriggerClass.MatchBraces )
|
|
|
|
| SPLICE_SYMBOL _ | LBRACK_LESS | LBRACE_LESS
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.None )
|
|
|
|
| LQUOTE _ | LBRACK | LBRACE | LBRACK_BAR
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.MatchBraces )
|
|
|
|
| GREATER_RBRACE | GREATER_RBRACK | GREATER_BAR_RBRACK
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.None )
|
|
|
|
| RQUOTE _ | RBRACK | RBRACE | BAR_RBRACK
|
|
-> (TokenColorKind.Text,TokenCharKind.Delimiter,TriggerClass.MatchBraces )
|
|
|
|
| PUBLIC | PRIVATE | INTERNAL | BASE
|
|
| CONSTRAINT | INSTANCE | DELEGATE | INHERIT|CONSTRUCTOR|DEFAULT|OVERRIDE|ABSTRACT|VIRTUAL|CLASS
|
|
| MEMBER | STATIC | NAMESPACE
|
|
| ODECLEND | OBLOCKSEP | OEND | OBLOCKBEGIN | ORIGHT_BLOCK_END | OBLOCKEND | OTHEN | OELSE | OLET(_) | OBINDER _ | BINDER _ | ODO | OWITH | OFUNCTION | OFUN | ORESET | ODUMMY _ | DO_BANG | ODO_BANG | YIELD _ | YIELD_BANG _ | OINTERFACE_MEMBER
|
|
| ELIF | RARROW | RARROW2 | SIG | STRUCT
|
|
| UPCAST | DOWNCAST | NULL | RESERVED | MODULE | AND | AS | ASSERT | ASR
|
|
| DOWNTO | EXCEPTION | FALSE | FOR | FUN | FUNCTION
|
|
| FINALLY | LAZY | MATCH | METHOD | MUTABLE | NEW | OF | OPEN | OR | VOID | EXTERN
|
|
| INTERFACE | REC | TO | TRUE | TRY | TYPE | VAL | INLINE | WHEN | WHILE | WITH
|
|
| IF | THEN | ELSE | DO | DONE | LET(_) | IN (*| NAMESPACE*)
|
|
| HIGH_PRECEDENCE_APP
|
|
-> (TokenColorKind.Keyword,TokenCharKind.Keyword,TriggerClass.None)
|
|
|
|
| BEGIN
|
|
-> (TokenColorKind.Keyword,TokenCharKind.Keyword,TriggerClass.None)
|
|
|
|
| END
|
|
-> (TokenColorKind.Keyword,TokenCharKind.Keyword,TriggerClass.None)
|
|
| HASH_LIGHT _
|
|
| HASH_LINE _
|
|
| HASH_IF _
|
|
| HASH_ELSE _
|
|
| HASH_ENDIF _ ->
|
|
(TokenColorKind.PreprocessorKeyword,TokenCharKind.WhiteSpace,TriggerClass.None)
|
|
| INACTIVECODE _ ->
|
|
(TokenColorKind.InactiveCode,TokenCharKind.WhiteSpace,TriggerClass.None)
|
|
|
|
|
|
| LEX_FAILURE _
|
|
| WHITESPACE _ ->
|
|
(TokenColorKind.Default,TokenCharKind.WhiteSpace,TriggerClass.None)
|
|
| COMMENT _ ->
|
|
(TokenColorKind.Comment,TokenCharKind.Comment,TriggerClass.None)
|
|
| LINE_COMMENT _ ->
|
|
(TokenColorKind.Comment,TokenCharKind.LineComment,TriggerClass.None)
|
|
| STRING_TEXT _ ->
|
|
(TokenColorKind.String,TokenCharKind.String,TriggerClass.None)
|
|
| BYTEARRAY _ | STRING _
|
|
| CHAR _ (* bug://2863 asks to color 'char' as "string" *)
|
|
-> (TokenColorKind.String,TokenCharKind.String,TriggerClass.None)
|
|
| EOF _ -> failwith "tokenInfo"
|
|
|
|
module TestExpose =
|
|
let TokenInfo tok = TokenClassifications.tokenInfo tok
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Lexer states encoded to/from integers
|
|
//--------------------------------------------------------------------------
|
|
type LexState = int64
|
|
|
|
type ColorState =
|
|
| Token = 1
|
|
| IfDefSkip = 3
|
|
| String = 4
|
|
| Comment = 5
|
|
| CommentString = 6
|
|
| CommentVString = 7
|
|
| CamlOnly = 8
|
|
| VString = 9
|
|
| TokenizedComment = 10
|
|
| EndLineThenSkip = 11
|
|
| EndLineThenToken = 12
|
|
|
|
| InitialState = 0
|
|
|
|
|
|
module LexerStateEncoding =
|
|
|
|
let computeNextLexState token (prevLexcont:lexcont) =
|
|
match token with
|
|
| HASH_LINE s
|
|
| HASH_LIGHT s
|
|
| HASH_IF(_, _, s)
|
|
| HASH_ELSE(_, _, s)
|
|
| HASH_ENDIF(_, _, s)
|
|
| INACTIVECODE s
|
|
| WHITESPACE s
|
|
| COMMENT s
|
|
| LINE_COMMENT s
|
|
| STRING_TEXT s
|
|
| EOF s -> s
|
|
| BYTEARRAY _ | STRING _ -> AT_token(prevLexcont.IfdefStack)
|
|
| _ -> prevLexcont
|
|
|
|
// Note that this will discard all lexcont state, including the ifdefStack.
|
|
let revert_to_default_lexcont = AT_token []
|
|
|
|
let resize32 (i:int32) : LexState = ((int64)i)
|
|
|
|
let lexstate_nbits = 4
|
|
let ncomments_nbits = 2
|
|
let start_pos_nbits = Range.pos_nbits
|
|
let hardwhite_nbits = 1
|
|
let ifdefstack_count_nbits = 4
|
|
let ifdefstack_nbits = 16 // 0 means if, 1 means else
|
|
let _ = assert (lexstate_nbits
|
|
+ ncomments_nbits
|
|
+ start_pos_nbits
|
|
+ hardwhite_nbits
|
|
+ ifdefstack_count_nbits
|
|
+ ifdefstack_nbits <= 64)
|
|
|
|
let lexstate_start = 0
|
|
let ncomments_start = lexstate_nbits
|
|
let start_pos_start = lexstate_nbits+ncomments_nbits
|
|
let hardwhite_pos_start = lexstate_nbits+ncomments_nbits+start_pos_nbits
|
|
let ifdefstack_count_start = lexstate_nbits+ncomments_nbits+start_pos_nbits+hardwhite_nbits
|
|
let ifdefstack_start = lexstate_nbits+ncomments_nbits+start_pos_nbits+hardwhite_nbits+ifdefstack_count_nbits
|
|
|
|
let lexstate_mask = Bits.mask64 lexstate_start lexstate_nbits
|
|
let ncomments_mask = Bits.mask64 ncomments_start ncomments_nbits
|
|
let start_pos_mask = Bits.mask64 start_pos_start start_pos_nbits
|
|
let hardwhite_pos_mask = Bits.mask64 hardwhite_pos_start hardwhite_nbits
|
|
let ifdefstack_count_mask = Bits.mask64 ifdefstack_count_start ifdefstack_count_nbits
|
|
let ifdefstack_mask = Bits.mask64 ifdefstack_start ifdefstack_nbits
|
|
|
|
let bits_of_bool b = if b then 1 else 0
|
|
let bool_of_bits n = (n = 1L)
|
|
|
|
let encode_lexcont (colorState:ColorState) ncomments (b:pos) ifdefStack light =
|
|
let mutable ifdefStackCount = 0
|
|
let mutable ifdefStackBits = 0
|
|
for ifOrElse in ifdefStack do
|
|
match ifOrElse with
|
|
| (IfDefIf,_) -> ()
|
|
| (IfDefElse,_) ->
|
|
ifdefStackBits <- (ifdefStackBits ||| (1 <<< ifdefStackCount))
|
|
ifdefStackCount <- ifdefStackCount + 1
|
|
|
|
let lexstate = int64 colorState
|
|
((lexstate <<< lexstate_start) &&& lexstate_mask)
|
|
||| ((ncomments <<< ncomments_start) &&& ncomments_mask)
|
|
||| ((resize32 (bits_of_pos b) <<< start_pos_start) &&& start_pos_mask)
|
|
||| ((resize32 (bits_of_bool light) <<< hardwhite_pos_start) &&& hardwhite_pos_mask)
|
|
||| ((resize32 ifdefStackCount <<< ifdefstack_count_start) &&& ifdefstack_count_mask)
|
|
||| ((resize32 ifdefStackBits <<< ifdefstack_start) &&& ifdefstack_mask)
|
|
|
|
let decode_lexcont (state:LexState) =
|
|
let mutable ifDefs = []
|
|
let ifdefStackCount = (int32) ((state &&& ifdefstack_count_mask) >>> ifdefstack_count_start)
|
|
if ifdefStackCount>0 then
|
|
let ifdefStack = (int32) ((state &&& ifdefstack_mask) >>> ifdefstack_start)
|
|
for i in 1..ifdefStackCount do
|
|
let bit = ifdefStackCount-i
|
|
let mask = 1 <<< bit
|
|
let ifDef = (if ifdefStack &&& mask = 0 then IfDefIf else IfDefElse)
|
|
ifDefs<-(ifDef,range0)::ifDefs
|
|
enum<ColorState> (int32 ((state &&& lexstate_mask) >>> lexstate_start)),
|
|
(int32) ((state &&& ncomments_mask) >>> ncomments_start),
|
|
pos_of_bits ((int32)((state &&& start_pos_mask) >>> start_pos_start)),
|
|
ifDefs,
|
|
bool_of_bits ((state &&& hardwhite_pos_mask) >>> hardwhite_pos_start)
|
|
|
|
let encode_lexint lightSyntaxStatus (lexcont:lexcont) =
|
|
let tag,n1,p1,ifd =
|
|
match lexcont with
|
|
| AT_token ifd -> ColorState.Token,0L,pos0,ifd
|
|
| AT_ifdef_skip (ifd,n,m) -> ColorState.IfDefSkip,resize32 n,start_of_range m,ifd
|
|
| AT_endline(ENDL_skip(ifd,n,m)) -> ColorState.EndLineThenSkip,resize32 n,start_of_range m,ifd
|
|
| AT_endline(ENDL_token(ifd)) -> ColorState.EndLineThenToken,0L,pos0,ifd
|
|
| AT_string (ifd,m) -> ColorState.String,0L,start_of_range m,ifd
|
|
| AT_comment (ifd,n,m) -> ColorState.Comment,resize32 n,start_of_range m,ifd
|
|
| AT_tokenized_comment (ifd,n,m) -> ColorState.TokenizedComment,resize32 n,start_of_range m,ifd
|
|
| AT_comment_string (ifd,n,m) -> ColorState.CommentString,resize32 n,start_of_range m,ifd
|
|
| AT_comment_vstring (ifd,n,m) -> ColorState.CommentVString,resize32 n,start_of_range m,ifd
|
|
| AT_camlonly (ifd,m) -> ColorState.CamlOnly,0L,start_of_range m,ifd
|
|
| AT_vstring (ifd,m) -> ColorState.VString,0L,start_of_range m,ifd
|
|
encode_lexcont tag n1 p1 ifd lightSyntaxStatus
|
|
|
|
|
|
let decode_lexint (state:LexState) =
|
|
let tag,n1,p1,ifd,lightSyntaxStatusInital = decode_lexcont state
|
|
let lexcont =
|
|
match tag with
|
|
| ColorState.Token -> AT_token ifd
|
|
| ColorState.IfDefSkip -> AT_ifdef_skip (ifd,n1,mk_range "file" p1 p1)
|
|
| ColorState.String -> AT_string (ifd,mk_range "file" p1 p1)
|
|
| ColorState.Comment -> AT_comment (ifd,n1,mk_range "file" p1 p1)
|
|
| ColorState.TokenizedComment -> AT_tokenized_comment (ifd,n1,mk_range "file" p1 p1)
|
|
| ColorState.CommentString -> AT_comment_string (ifd,n1,mk_range "file" p1 p1)
|
|
| ColorState.CommentVString -> AT_comment_vstring (ifd,n1,mk_range "file" p1 p1)
|
|
| ColorState.CamlOnly -> AT_camlonly (ifd,mk_range "file" p1 p1)
|
|
| ColorState.VString -> AT_vstring (ifd,mk_range "file" p1 p1)
|
|
| ColorState.EndLineThenSkip -> AT_endline(ENDL_skip(ifd,n1,mk_range "file" p1 p1))
|
|
| ColorState.EndLineThenToken -> AT_endline(ENDL_token(ifd))
|
|
| _ -> AT_token []
|
|
lightSyntaxStatusInital,lexcont
|
|
|
|
let call_lexcont lexcont args skip lexbuf =
|
|
let argsWithIfDefs ifd = {args with ifdefStack = ref ifd}
|
|
match lexcont with
|
|
| AT_endline(cont) -> Lexer.endline cont args skip lexbuf
|
|
| AT_token ifd -> Lexer.token (argsWithIfDefs ifd) skip lexbuf
|
|
| AT_ifdef_skip (ifd,n,m) -> Lexer.ifdef_skip n m (argsWithIfDefs ifd) skip lexbuf
|
|
//v-- What's this magic number for?
|
|
// answer: it's just an initial buffer size.
|
|
| AT_string (ifd,m) -> Lexer.string (Bytes.Bytebuf.create 100,default_string_finish,m,(argsWithIfDefs ifd)) skip lexbuf
|
|
| AT_comment (ifd,n,m) -> Lexer.comment(n,m,(argsWithIfDefs ifd)) skip lexbuf
|
|
| AT_tokenized_comment (ifd,n,m)->
|
|
// The first argument is 'None' because we don't need XML comments when called from VS
|
|
Lexer.tokenized_comment(None,n,m,(argsWithIfDefs ifd)) skip lexbuf
|
|
| AT_comment_string (ifd,n,m) -> Lexer.comment_string n m (argsWithIfDefs ifd) skip lexbuf
|
|
| AT_comment_vstring (ifd,n,m) -> Lexer.comment_vstring n m (argsWithIfDefs ifd) skip lexbuf
|
|
| AT_camlonly (ifd,m) -> Lexer.camlonly m (argsWithIfDefs ifd) skip lexbuf
|
|
| AT_vstring (ifd,m) -> Lexer.vstring (Bytes.Bytebuf.create 100,default_string_finish,m,(argsWithIfDefs ifd)) skip lexbuf
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Colorization
|
|
//----------------------------------------------------------------------------
|
|
|
|
// Information beyond just tokens that can be derived by looking at just a single line.
|
|
// For example metacommands like #load.
|
|
type SingleLineTokenState =
|
|
| BeforeHash = 0
|
|
| NoFurtherMatchPossible = 1
|
|
|
|
/// Split a line into tokens and attach information about the tokens. This information is used by Visual Studio.
|
|
[<Sealed>]
|
|
type Tokenizer(text:string, defineConstants : string list, filename : string) =
|
|
|
|
let skip = false // don't skip whitespace in the lexer
|
|
let concreteSyntaxSink = None
|
|
let lexResourceManager = new Lexhelp.LexResourceManager()
|
|
let lexbuf = UnicodeLexing.StringAsLexbuf text
|
|
|
|
let mutable singleLineTokenState = SingleLineTokenState.BeforeHash
|
|
let fsx = Build.IsScript(filename)
|
|
|
|
// ----------------------------------------------------------------------------------
|
|
// This implements post-processing of #directive tokens - not very elegant, but it works...
|
|
// We get the whole " #if IDENT // .. .. " thing as a single token from the lexer,
|
|
// so we need to split it into tokens that are used by VS for colorization
|
|
|
|
// Stack for tokens that are split during postrpocessing
|
|
let mutable tokenStack = new Stack<_>()
|
|
let delayToken tok = tokenStack.Push(tok)
|
|
|
|
// Process: anywhite* #<directive>
|
|
let processDirective (str:string) directiveLength delay cont =
|
|
let hashIdx = str.IndexOf("#")
|
|
if (hashIdx <> 0) then delay(WHITESPACE cont, 0, hashIdx - 1)
|
|
delay(HASH_IF(range0, "", cont), hashIdx, hashIdx + directiveLength)
|
|
hashIdx + directiveLength + 1
|
|
|
|
// Process: anywhite* ("//" [^'\n''\r']*)?
|
|
let processWhiteAndComment (str:string) offset delay cont =
|
|
let rest = str.Substring(offset, str.Length - offset)
|
|
let comment = rest.IndexOf('/')
|
|
let spaceLength = if comment = -1 then rest.Length else comment
|
|
if (spaceLength > 0) then delay(WHITESPACE cont, offset, offset + spaceLength - 1)
|
|
if (comment <> -1) then delay(COMMENT(cont), offset + comment, offset + rest.Length - 1)
|
|
|
|
// Split a directive line from lexer into tokens usable in VS
|
|
let processDirectiveLine ofs f =
|
|
let delayed = new ResizeArray<_>()
|
|
f (fun (tok, s, e) -> delayed.Add (tok, s + ofs, e + ofs) )
|
|
// delay all the tokens and return the remaining one
|
|
for i = delayed.Count - 1 downto 1 do delayToken delayed.[i]
|
|
delayed.[0]
|
|
|
|
// Split the following line:
|
|
// anywhite* ("#else"|"#endif") anywhite* ("//" [^'\n''\r']*)?
|
|
let processHashEndElse ofs (str:string) length cont =
|
|
processDirectiveLine ofs (fun delay ->
|
|
// Process: anywhite* "#else" / anywhite* "#endif"
|
|
let offset = processDirective str length delay cont
|
|
// Process: anywhite* ("//" [^'\n''\r']*)?
|
|
processWhiteAndComment str offset delay cont )
|
|
|
|
// Split the following line:
|
|
// anywhite* "#if" anywhite+ ident anywhite* ("//" [^'\n''\r']*)?
|
|
let processHashIfLine ofs (str:string) cont =
|
|
let ( $? ) n m = if (n < 0) then m else n
|
|
processDirectiveLine ofs (fun delay ->
|
|
// Process: anywhite* "#if"
|
|
let offset = processDirective str 2 delay cont
|
|
// Process: anywhite+ ident
|
|
let rest, spaces =
|
|
(let w = str.Substring(offset)
|
|
let r = w.TrimStart([| ' '; '\t' |])
|
|
r, w.Length - r.Length)
|
|
let beforeIdent = offset + spaces
|
|
let identLength = rest.IndexOfAny([| '/'; '\t'; ' ' |]) $? rest.Length
|
|
delay(WHITESPACE cont, offset, beforeIdent - 1)
|
|
delay(IDENT(rest.Substring(0, identLength)), beforeIdent, beforeIdent + identLength - 1)
|
|
// Process: anywhite* ("//" [^'\n''\r']*)?
|
|
let offset = beforeIdent + identLength
|
|
processWhiteAndComment str offset delay cont )
|
|
|
|
// ----------------------------------------------------------------------------------
|
|
|
|
// We don't need any error reporting for tokenzier here -
|
|
// the errors are reported with the wrong range anyway!
|
|
let noReportLogger =
|
|
{ new ErrorLogger with
|
|
member x.WarnSink (e:exn) = ()
|
|
member x.ErrorSink (e:exn) = ()
|
|
member x.ErrorCount = 0 }
|
|
|
|
do resetLexbufPos filename lexbuf
|
|
|
|
member t.StartNewLine() =
|
|
singleLineTokenState <- SingleLineTokenState.BeforeHash
|
|
|
|
member x.ScanToken(lexintInitial) : Option<TokenInformation> * LexState =
|
|
// Crack the whitespace syntax flag
|
|
// Ideally we would explicitly install DiscardErrorsLogger here. However different threads are using the error logger!
|
|
// Indeed we really have to move to a model where the error logger is passed explicitly everywhere in the codebase.
|
|
// For the moment we jsut make the default global error logger discard errors.
|
|
//use unwind = InstallGlobalErrorLogger (fun _ -> DiscardErrorsLogger)
|
|
let lightSyntaxStatusInital, lexcontInitial = LexerStateEncoding.decode_lexint lexintInitial
|
|
let lightSyntaxStatus = LightSyntaxStatus(lightSyntaxStatusInital,false)
|
|
|
|
// Build the arguments to the lexer function
|
|
let dummySourceDirectoryFun = fun()->"C:\\" // the tokenizer doesn't need the value of __SOURCE_DIRECTORY__, so any value is fine
|
|
let lexargs = mkLexargs(dummySourceDirectoryFun,filename,defineConstants,lightSyntaxStatus,lexResourceManager, ref [],noReportLogger)
|
|
|
|
let GetTokenWithPosition(lexcontInitial) =
|
|
// Column of token
|
|
let ColumnsOfCurrentToken() =
|
|
let leftp = lexbuf.StartPos
|
|
let rightp = lexbuf.EndPos
|
|
let leftc = leftp.Column
|
|
let rightc = if rightp.Line > leftp.Line then text.Length else rightp.Column
|
|
let rightc = rightc - 1
|
|
leftc,rightc
|
|
|
|
// Get the token & position - either from a stack or from the lexer
|
|
try
|
|
if (tokenStack.Count > 0) then true, tokenStack.Pop()
|
|
else
|
|
// Choose which lexer entrypoint to call and call it
|
|
let token = LexerStateEncoding.call_lexcont lexcontInitial lexargs skip lexbuf
|
|
let leftc, rightc = ColumnsOfCurrentToken()
|
|
|
|
// Splits tokens like ">." into multiple tokens - this duplicates behavior from the 'lexfilter'
|
|
// which cannot be (easily) used from the langauge service. The rules here are not always valid,
|
|
// because sometimes token shouldn't be split. However it is just for colorization &
|
|
// for VS (which needs to recognize when user types ".") - note, this doesn't show any intellisense
|
|
// if you have custom operator (e.g. ">.>", because there won't be any info available)
|
|
match token with
|
|
| HASH_IF(m, lineStr, cont) when lineStr <> "" ->
|
|
false, processHashIfLine (start_col_of_range m) lineStr cont
|
|
| HASH_ELSE(m, lineStr, cont) when lineStr <> "" ->
|
|
false, processHashEndElse (start_col_of_range m) lineStr 4 cont
|
|
| HASH_ENDIF(m, lineStr, cont) when lineStr <> "" ->
|
|
false, processHashEndElse (start_col_of_range m) lineStr 5 cont
|
|
| GREATER_DOT ->
|
|
delayToken(DOT, leftc + 1, rightc)
|
|
false, (GREATER, leftc, rightc - 1)
|
|
| RQUOTE_DOT (s,raw) ->
|
|
delayToken(DOT, rightc, rightc)
|
|
false, (RQUOTE (s,raw), leftc, rightc - 1)
|
|
| INFIX_COMPARE_OP (Lexfilter.TyparsCloseOp(greaters,afterOp) as opstr) ->
|
|
match afterOp with
|
|
| None -> ()
|
|
| Some tok -> delayToken(tok, leftc + greaters.Length, rightc)
|
|
for i = greaters.Length - 1 downto 1 do
|
|
delayToken(greaters.[i], leftc + i, rightc - opstr.Length + i + 1)
|
|
false, (greaters.[0], leftc, rightc - opstr.Length + 1)
|
|
| _ -> false, (token, leftc, rightc)
|
|
with
|
|
| e -> false, (EOF LexerStateEncoding.revert_to_default_lexcont, 0, 0) // REVIEW: report lex failure here
|
|
|
|
// Grab a token
|
|
let isCached, (token, leftc, rightc) = GetTokenWithPosition(lexcontInitial)
|
|
|
|
// Check for end-of-string and failure
|
|
let tokenDataOption, lexcontFinal, tokenTag =
|
|
match token with
|
|
| EOF lexcont ->
|
|
// End of text! No more tokens.
|
|
None,lexcont,0
|
|
| LEX_FAILURE s ->
|
|
// REVIEW: report this error
|
|
Trace.PrintLine("Lexing", fun _ -> sprintf "LEX_FAILURE:%s\n" s)
|
|
None, LexerStateEncoding.revert_to_default_lexcont, 0
|
|
| _ ->
|
|
// Get the information about the token
|
|
let (colorClass,charClass,triggerClass) = TokenClassifications.tokenInfo token
|
|
let lexcontFinal =
|
|
// If we're using token from cache, we don't move forward with lexing
|
|
if isCached then lexcontInitial else LexerStateEncoding.computeNextLexState token lexcontInitial
|
|
let tokenTag = tagOfToken token
|
|
let name = (token_to_string token).ToLower(Globalization.CultureInfo.InvariantCulture);
|
|
let tokenData = {TokenName = name; LeftColumn=leftc; RightColumn=rightc;ColorClass=colorClass;CharClass=charClass;TriggerClass=triggerClass;Tag=tokenTag}
|
|
Some(tokenData), lexcontFinal, tokenTag
|
|
|
|
// Get the final lex int and color state
|
|
let FinalState(lexcontFinal) =
|
|
LexerStateEncoding.encode_lexint lightSyntaxStatus.Status lexcontFinal
|
|
|
|
// Check for patterns like #-IDENT and see if they look like meta commands for .fsx files. If they do then merge them into a single token.
|
|
let tokenDataOption,lexintFinal =
|
|
let lexintFinal = FinalState(lexcontFinal)
|
|
match tokenDataOption, singleLineTokenState, tokenTagToTokenId tokenTag with
|
|
| Some(tokenData), SingleLineTokenState.BeforeHash, TOKEN_HASH ->
|
|
// Don't allow further matches.
|
|
singleLineTokenState <- SingleLineTokenState.NoFurtherMatchPossible
|
|
// Peek at the next token
|
|
let isCached, (nextToken, _, rightc) = GetTokenWithPosition(lexcontInitial)
|
|
match nextToken with
|
|
| IDENT possibleMetacommand ->
|
|
match fsx,possibleMetacommand with
|
|
// These are for script (.fsx and .fsscript) files.
|
|
| true,"r"
|
|
| true,"reference"
|
|
| true,"I"
|
|
| true,"load"
|
|
| true,"time"
|
|
| true,"cd"
|
|
#if DEBUG
|
|
| true,"terms"
|
|
| true,"types"
|
|
| true,"savedll"
|
|
| true,"nosavedll"
|
|
#endif
|
|
| true,"silentCd"
|
|
| true,"q"
|
|
| true,"quit"
|
|
| true,"help"
|
|
// These are for script and non-script
|
|
| _,"nowarn" ->
|
|
// Merge both tokens into one.
|
|
let lexcontFinal = if (isCached) then lexcontInitial else LexerStateEncoding.computeNextLexState token lexcontInitial
|
|
let tokenTag = tagOfToken token
|
|
let tokenData = {tokenData with RightColumn=rightc;ColorClass=TokenColorKind.PreprocessorKeyword;CharClass=TokenCharKind.Keyword;TriggerClass=TriggerClass.None}
|
|
let lexintFinal = FinalState(lexcontFinal)
|
|
Some(tokenData),lexintFinal
|
|
| _ -> tokenDataOption,lexintFinal
|
|
| _ -> tokenDataOption,lexintFinal
|
|
| _, SingleLineTokenState.BeforeHash, TOKEN_WHITESPACE ->
|
|
// Allow leading whitespace.
|
|
tokenDataOption,lexintFinal
|
|
| _ ->
|
|
singleLineTokenState <- SingleLineTokenState.NoFurtherMatchPossible
|
|
tokenDataOption,lexintFinal
|
|
|
|
tokenDataOption, lexintFinal
|
|
|
|
|
|
|
|
type Severity = Warning | Error
|
|
|
|
type ErrorInfo = {
|
|
StartLine:int
|
|
EndLine:int
|
|
StartColumn:int
|
|
EndColumn:int
|
|
Severity:Severity
|
|
Message:string } with
|
|
override e.ToString()=
|
|
sprintf "(%d,%d)-(%d,%d) %s %s"
|
|
e.StartLine e.StartColumn e.EndLine e.EndColumn
|
|
(if e.Severity=Warning then "warning" else "error")
|
|
e.Message
|
|
|
|
/// Decompose a warning or error into parts: position, severity, message
|
|
static member CreateFromExceptionAndAdjustEof(exn,warn,trim:bool,fallbackRange:range, (linesCount:int, lastLength:int)) =
|
|
let r = ErrorInfo.CreateFromException(exn,warn,trim,fallbackRange)
|
|
|
|
// Adjust to make sure that errors reported at Eof are shown at the linesCount
|
|
let startline, schange = min (r.StartLine, false) (linesCount, true)
|
|
let endline, echange = min (r.EndLine, false) (linesCount, true)
|
|
|
|
if not (schange || echange) then r
|
|
else
|
|
let r = if schange then { r with StartLine = startline; StartColumn = lastLength } else r
|
|
if echange then { r with EndLine = endline; EndColumn = 1 + lastLength } else r
|
|
|
|
/// Decompose a warning or error into parts: position, severity, message
|
|
static member CreateFromException(exn,warn,trim:bool,fallbackRange:range) =
|
|
let adjust p = (line_of_pos p - 1),(col_of_pos p)
|
|
let m = match RangeOfError exn with Some m -> m | None -> fallbackRange
|
|
let (s1:int),(s2:int) = adjust (start_of_range m)
|
|
let (s3:int),(s4:int) = adjust (if trim then start_of_range m else end_of_range m);
|
|
let msg = bufs (fun buf -> OutputException buf exn false)
|
|
{StartLine=s1; StartColumn=s2; EndLine=s3; EndColumn=s4; Severity=(if warn then Warning else Error); Message=msg}
|
|
|
|
/// Create an error info from individual parts
|
|
static member CreateFromMessage(severity, message) =
|
|
{StartLine=0; StartColumn=0; EndLine=0; EndColumn=0; Severity=severity; Message=message}
|
|
|
|
|
|
/// Use to reset error and warning handlers
|
|
type ErrorScope() as x =
|
|
let mutable errors = []
|
|
static let mutable mostRecentError = None
|
|
|
|
let unwind =
|
|
InstallGlobalErrorLogger (fun oldLogger ->
|
|
{ new ErrorLogger with
|
|
member x.WarnSink(exn) =
|
|
errors <- ErrorInfo.CreateFromException(exn,true,false,0L):: errors
|
|
member x.ErrorSink(exn) =
|
|
let err = ErrorInfo.CreateFromException(exn,false,false,0L)
|
|
errors <- err :: errors
|
|
mostRecentError <- Some(err)
|
|
member x.ErrorCount = errors.Length })
|
|
|
|
member x.Errors = errors |> List.filter (fun error -> error.Severity = Error)
|
|
member x.Warnings = errors |> List.filter (fun error -> error.Severity = Warning)
|
|
member x.ErrorsAndWarnings = errors
|
|
member x.TryGetFirstErrorText() =
|
|
match x.Errors with
|
|
| error :: rest -> Some(error.Message)
|
|
| [] -> None
|
|
|
|
interface IDisposable with
|
|
member d.Dispose() =
|
|
unwind.Dispose()
|
|
|
|
static member MostRecentError = mostRecentError
|
|
|
|
static member Protect<'a> (m:range) (f:unit->'a) (err:string->'a) : 'a =
|
|
use errorScope = new ErrorScope()
|
|
let res =
|
|
try
|
|
Some(f())
|
|
with e -> errorRecovery e m; None
|
|
match res with
|
|
| Some(res) ->res
|
|
| None ->
|
|
match errorScope.TryGetFirstErrorText() with
|
|
| Some text -> err text
|
|
| None -> err ""
|
|
|
|
static member ProtectWithDefault m f dflt =
|
|
ErrorScope.Protect m f (fun _ -> dflt)
|
|
|
|
static member ProtectAndDiscard m f =
|
|
ErrorScope.Protect m f (fun _ -> ())
|
|
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Display characteristics of typechecking items
|
|
//--------------------------------------------------------------------------
|
|
|
|
|
|
(* First of Pair: text
|
|
Second of Pair: Option<libOfXmlDocHelpSigOfItemForLookup * GetXmlDocHelpSigOfItemForLookup>
|
|
- if present the text for latter is appended by the VS C++ code because it queries a VS C++ API *)
|
|
type TextWithXmlSig = string * (string * string) option
|
|
|
|
|
|
/// Interface that defines methods for comparing objects using partial equality relation
|
|
type IPartialEqualityComparer<'a> =
|
|
inherit IEqualityComparer<'a>
|
|
/// Can the specified object be tested for equality?
|
|
abstract InEqualityRelation : 'a -> bool
|
|
|
|
|
|
type iDeclarationSet = int
|
|
|
|
module ItemDescriptions =
|
|
|
|
// Hardwired constants from older versions of Visual Studio. These constants were used with Babel and VS internals.
|
|
let iIconGroupClass = 0x0000
|
|
let iIconGroupConstant = 0x0001
|
|
let iIconGroupDelegate = 0x0002
|
|
let iIconGroupEnum = 0x0003
|
|
let iIconGroupEnumMember = 0x0004
|
|
let iIconGroupEvent = 0x0005
|
|
let iIconGroupException = 0x0006
|
|
let iIconGroupFieldBlue = 0x0007
|
|
let iIconGroupInterface = 0x0008 // Absolute = 48
|
|
let iIconGroupTextLine = 0x0009
|
|
let iIconGroupScript = 0x000a
|
|
let iIconGroupScript2 = 0x000b
|
|
let iIconGroupMethod = 0x000c
|
|
let iIconGroupMethod2 = 0x000d
|
|
let iIconGroupModule = 0x000e
|
|
let iIconGroupNameSpace = 0x000f // Absolute = 90
|
|
let iIconGroupFormula = 0x0010
|
|
let iIconGroupProperty = 0x00011
|
|
let iIconGroupStruct = 0x00012
|
|
let iIconGroupTemplate = 0x00013
|
|
let iIconGroupTypedef = 0x00014
|
|
let iIconGroupType = 0x00015
|
|
let iIconGroupUnion = 0x00016
|
|
let iIconGroupVariable = 0x00017
|
|
let iIconGroupValueType = 0x00018 // Absolute = 144
|
|
let iIconGroupIntrinsic = 0x00019
|
|
let iIconGroupError = 0x0001f
|
|
let iIconGroupFieldYellow = 0x0020
|
|
let iIconGroupMisc1 = 0x00021
|
|
let iIconGroupMisc2 = 0x0022
|
|
let iIconGroupMisc3 = 0x00023
|
|
|
|
let iIconItemPublic = 0x0000
|
|
let iIconItemInternal = 0x0001
|
|
let iIconItemSpecial = 0x0002
|
|
let iIconItemProtected = 0x0003
|
|
let iIconItemPrivate = 0x0004
|
|
let iIconItemShortCut = 0x0005
|
|
let iIconItemNormal = iIconItemPublic
|
|
|
|
let iIconBlackBox = 162
|
|
let iIconLibrary = 163
|
|
let iIconProgram = 164
|
|
let iIconWebProgram = 165
|
|
let iIconProgramEmpty = 166
|
|
let iIconWebProgramEmpty = 167
|
|
|
|
let iIconComponents = 168
|
|
let iIconEnvironment = 169
|
|
let iIconWindow = 170
|
|
let iIconFolderOpen = 171
|
|
let iIconFolder = 172
|
|
let iIconArrowRight = 173
|
|
|
|
let iIconAmbigious = 174
|
|
let iIconShadowClass = 175
|
|
let iIconShadowMethodPrivate = 176
|
|
let iIconShadowMethodProtected = 177
|
|
let iIconShadowMethod = 178
|
|
let iIconInCompleteSource = 179
|
|
|
|
let is_function g typ =
|
|
let tps,tau = try_dest_forall_typ g typ
|
|
is_fun_typ g tau
|
|
|
|
let boutput_xmldoc os (XmlDoc s) =
|
|
match s with
|
|
| [| |] -> ()
|
|
| l ->
|
|
bprintf os "\n";
|
|
l |> Array.iter (fun (s:string) ->
|
|
|
|
// Bug FSharp1.0:3232: replace some common XmlDoc characters
|
|
let s = s.Replace("<c>","").Replace("</c>","").Replace("<","<").Replace(">",">").Replace("&","&")
|
|
|
|
bprintf os "\n%s" s)
|
|
|
|
let boutput_fullname ppF fnF os r =
|
|
match ppF r with
|
|
| None -> ()
|
|
| Some _ -> bprintf os "\n\nFull name: %s" (fnF r)
|
|
|
|
// Format the supertypes and other useful information about a type to a buffer
|
|
let OutputUsefulTypeInfo (infoReader:InfoReader) m denv os ty =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
let GetSuperTypes() =
|
|
let supertypes = AllSuperTypesOfType g amap m ty
|
|
let supertypes = supertypes |> List.filter (AccessibilityLogic.IsTypeAccessible g AccessibleFromSomewhere)
|
|
let supertypes = supertypes |> List.filter (type_equiv g g.obj_ty >> not)
|
|
let selfs,supertypes = supertypes |> List.partition (type_equiv g ty)
|
|
let supertypesC,supertypesI = supertypes |> List.partition (is_interface_typ g)
|
|
let supertypes = selfs @ supertypesC @ supertypesI
|
|
supertypes
|
|
|
|
let ConstructUsefulTypeInfo() =
|
|
let supertypes = GetSuperTypes()
|
|
let supertypeLs,_ = NicePrint.typesAndConstraintsL denv supertypes
|
|
if List.length supertypes > 1 then
|
|
bprintf os "\n\n";
|
|
List.zip supertypes supertypeLs |> List.iter (fun (superty,supertyL) ->
|
|
if type_equiv g superty ty then bprintf os " type: %a\n" bufferL supertyL
|
|
elif is_class_typ g superty or is_interface_typ g ty then bprintf os " inherits: %a\n" bufferL supertyL
|
|
else bprintf os " implements: %a\n" bufferL supertyL)
|
|
|
|
if is_enum_typ g ty then
|
|
bprintf os "\n";
|
|
infoReader.GetILFieldInfosOfType(None,AccessibleFromEverywhere,m,ty)
|
|
|> List.filter (fun finfo -> finfo.IsStatic )
|
|
|> List.filter (AccessibilityLogic.IsILFieldInfoAccessible g amap m AccessibleFromSomewhere)
|
|
|> List.iter (fun finfo ->
|
|
bprintf os "\nconst %a.%s" (NicePrint.output_tref denv) finfo.ILTypeRef finfo.FieldName;
|
|
match finfo.LiteralValue with
|
|
| None -> ()
|
|
| Some v ->
|
|
try bprintf os " = %s" (Layout.showL ( NicePrint.constL (TypeChecker.TcFieldInit m v) ))
|
|
with _ -> ())
|
|
ErrorScope.ProtectAndDiscard m (fun () -> ConstructUsefulTypeInfo())
|
|
|
|
|
|
let range_of_pinfo (pinfo:PropInfo) = pinfo.ArbitraryValRef |> Option.map (fun v -> v.Range)
|
|
let range_of_minfo (minfo:MethInfo) = minfo.ArbitraryValRef |> Option.map (fun v -> v.Range)
|
|
|
|
let range_of_item g isDecl d =
|
|
// skip all default generated constructors for structs
|
|
let (|FilterDefaultStructCtors|) ctors =
|
|
ctors |> List.filter (function DefaultStructCtor _ -> false | _ -> true)
|
|
|
|
match d with
|
|
| Item_val vref -> Some(if isDecl then vref.Range else vref.DefinitionRange)
|
|
| Item_ucase(ucr) -> Some(ucr.UnionCase.Range)
|
|
| Item_apelem(apref) -> Some(apref.ActivePatternVal.Range)
|
|
| Item_ecref(ecr) -> Some(ecr.Range)
|
|
| Item_recdfield(rfinfo) -> Some(rfinfo.RecdFieldRef.Range)
|
|
| Item_event _ | Item_il_field _ -> None
|
|
| Item_property(_,pinfos) -> (List.hd pinfos) |> range_of_pinfo
|
|
| Item_meth_group(_,(minfo :: _))
|
|
| Item_ctor_group(_,FilterDefaultStructCtors(minfo :: _)) -> range_of_minfo minfo
|
|
| Item_typs(_,(typ :: _)) -> Some((tcref_of_stripped_typ g typ).Range)
|
|
| Item_modrefs(modref :: _) -> Some(modref.Range)
|
|
| Item_apres(APInfo(_, _, m),_, _) -> Some(m)
|
|
| _ -> None
|
|
|
|
let ccu_of_item g d =
|
|
match d with
|
|
| Item_val vref -> ccu_of_vref vref
|
|
| Item_ucase(ucr) -> ccu_of_tcref ucr.TyconRef
|
|
| Item_apelem(apref) -> ccu_of_vref apref.ActivePatternVal
|
|
| Item_ecref(ecr) -> ccu_of_tcref ecr
|
|
| Item_recdfield(rfinfo) -> ccu_of_tcref rfinfo.RecdFieldRef.TyconRef
|
|
| Item_event _ | Item_il_field _ -> None
|
|
| Item_property(_,pinfos) -> (List.hd pinfos).ArbitraryValRef |> Option.bind ccu_of_vref
|
|
| Item_meth_group(_,(minfo :: _))
|
|
| Item_ctor_group(_,(minfo :: _)) -> minfo.ArbitraryValRef |> Option.bind ccu_of_vref
|
|
| Item_typs(_,(typ :: _)) -> ccu_of_tcref (tcref_of_stripped_typ g typ)
|
|
| Item_modrefs(modref :: _) -> ccu_of_tcref modref
|
|
| _ -> None
|
|
|
|
/// Work out the likely source file for an item
|
|
let filename_of_item g qualProjectDir m h =
|
|
let file = file_of_range m in
|
|
dprintf "file stored in metadata is '%s'\n" file
|
|
if Filename.is_relative file then
|
|
match (ccu_of_item g h) with
|
|
| Some ccu ->
|
|
|
|
// Note: For F# library DLLs, the code in build.ml fixes uo the SourceCodeDirectory (compile_time_working_dir)
|
|
// to be defaultFSharpBinariesDir\..\lib\<library-name>, i.e. the location of the source for the
|
|
// file in the F# installation location
|
|
|
|
Filename.concat ccu.SourceCodeDirectory file
|
|
| None ->
|
|
match qualProjectDir with
|
|
| None -> file
|
|
| Some dir -> Filename.concat dir file
|
|
else file
|
|
|
|
/// Cut long filenames to make them visually appealing
|
|
let cutFileName s = if String.length s > 40 then String.sub s 0 10 ^ "..."^String.sub s (String.length s - 27) 27 else s
|
|
|
|
/// Output where an item is defined
|
|
let boutput_range_of_item os x = ()
|
|
(*
|
|
let mDefnOpt = range_of_item false x
|
|
let mDeclOpt = range_of_item true x
|
|
match mDeclOpt with
|
|
| None -> ()
|
|
| Some mDecl ->
|
|
let filenameDecl = filename_of_item None mDecl x |> cutFileName
|
|
bprintf os "\nDeclared at %s, line %d" filenameDecl (line_of_pos (start_of_range mDecl));
|
|
match mDefnOpt with
|
|
| None -> ()
|
|
| Some mDefn ->
|
|
if mDefn <> mDecl then
|
|
let filenameDefn = filename_of_item None mDefn x |> cutFileName
|
|
bprintf os "\nDefined at %s, line %d" filenameDefn (line_of_pos (start_of_range mDefn))
|
|
*)
|
|
|
|
/// Output a method info
|
|
let FormatMemberInfosToBuffer (infoReader:InfoReader) m denv os d minfos =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
let FormatMethInfoToBuffer_first minfo =
|
|
FormatMethInfoToBuffer amap m denv os minfo;
|
|
boutput_xmldoc os minfo.XmlDoc;
|
|
boutput_range_of_item os d
|
|
|
|
let ConstructMemberInfoText() =
|
|
if List.length minfos >= 1 then (FormatMethInfoToBuffer_first (List.nth minfos 0));
|
|
if List.length minfos >= 2 then (bprintf os "\n"; FormatMethInfoToBuffer amap m denv os (List.nth minfos 1));
|
|
if List.length minfos >= 3 then (bprintf os "\n"; FormatMethInfoToBuffer amap m denv os (List.nth minfos 2));
|
|
if List.length minfos >= 4 then (bprintf os "\n"; FormatMethInfoToBuffer amap m denv os (List.nth minfos 3));
|
|
if List.length minfos >= 5 then (bprintf os "\n"; FormatMethInfoToBuffer amap m denv os (List.nth minfos 4));
|
|
if List.length minfos >= 6 then (bprintf os "\n"; bprintf os "and %d other overloads" (List.length minfos - 5))
|
|
|
|
match !TestHooks.ConstructMemberInfoText with
|
|
| Some(hook) -> hook(ConstructMemberInfoText)
|
|
| None -> ConstructMemberInfoText()
|
|
|
|
let pubpath_of_vref (v:ValRef) = v.PublicPath
|
|
let pubpath_of_tcref (x:TyconRef) = x.PublicPath
|
|
|
|
|
|
// Wrapper type for use by the 'partial_distinct_by' function
|
|
type WrapType<'a> = Wrap of 'a
|
|
|
|
// Like Seq.distinct_by but only filters out duplicates for some of the elements
|
|
let partial_distinct_by (per:IPartialEqualityComparer<_>) seq =
|
|
// Wrap a Wrap(_) aroud all keys in case the key type is itself a type using null as a representation
|
|
let dict = new Dictionary<'a WrapType,obj>(per)
|
|
seq |> List.filter (fun v ->
|
|
let v = Wrap(v)
|
|
if (per.InEqualityRelation(v)) then
|
|
if dict.ContainsKey(v) then false else (dict.[v] <- null; true)
|
|
else true)
|
|
|
|
|
|
/// Specifies functions for comparing 'NamedItem' objects with respect to the user
|
|
/// (this means that some values that are not technically equal are treated as equal
|
|
/// if this is what we want to show to the user, because we're comparing just the name
|
|
// for some cases e.g. when using 'full_display_text_of_modref')
|
|
let ItemDisplayPartialEquality g =
|
|
{ new IPartialEqualityComparer<_> with
|
|
member x.InEqualityRelation item =
|
|
match item with
|
|
| Wrap(Item_typs(_,[_])) -> true
|
|
| Wrap(Item_il_field(ILFieldInfo(_, _))) -> true
|
|
| Wrap(Item_recdfield(_)) -> true
|
|
| Wrap(Item_prop_name(_)) -> true
|
|
| Wrap(Item_modrefs(_ :: _)) -> true
|
|
| Wrap(Item_meth_group(_, _)) -> true
|
|
| Wrap(Item_val(_)) -> true
|
|
| Wrap(Item_apelem(APElemRef(apinfo, vref, idx))) -> true
|
|
| Wrap(Item_delegate_ctor(_)) -> true
|
|
| Wrap(Item_ucase(_)) -> true
|
|
| Wrap(Item_ecref(_)) -> true
|
|
| Wrap(Item_event(_)) -> true
|
|
| Wrap(Item_property(_)) -> true
|
|
| _ -> false
|
|
|
|
member x.Equals(item1, item2) =
|
|
let equalTypes(ty1, ty2) =
|
|
if is_stripped_tyapp_typ g ty1 && is_stripped_tyapp_typ g ty2 then tcref_eq g (tcref_of_stripped_typ g ty1) (tcref_of_stripped_typ g ty2)
|
|
else type_equiv g ty1 ty2
|
|
match item1,item2 with
|
|
| Wrap(Item_delegate_ctor(ty1)), Wrap(Item_delegate_ctor(ty2)) -> equalTypes(ty1, ty2)
|
|
| Wrap(Item_typs(dn1,[ty1])), Wrap(Item_typs(dn2,[ty2])) ->
|
|
// Bug 4403: We need to compare names as well, because 'int' and 'Int32' are physically the same type, but we want to show both
|
|
dn1 = dn2 && equalTypes(ty1, ty2)
|
|
| Wrap(Item_ecref(tcref1)), Wrap(Item_ecref(tcref2)) -> tcref_eq g tcref1 tcref2
|
|
| Wrap(Item_il_field(ILFieldInfo(_, fld1))), Wrap(Item_il_field(ILFieldInfo(_, fld2))) ->
|
|
fld1 === fld2 // reference equality on the object identity of the AbstractIL metadata blobs for the fields
|
|
| Wrap(Item_modrefs(modref1 :: _)), Wrap(Item_modrefs(modref2 :: _)) -> full_display_text_of_modref modref1 = full_display_text_of_modref modref2
|
|
| Wrap(Item_prop_name(id1)), Wrap(Item_prop_name(id2)) -> (id1.idRange, id1.idText) = (id2.idRange, id2.idText)
|
|
| Wrap(Item_meth_group(_, meths1)), Wrap(Item_meth_group(_, meths2)) ->
|
|
Seq.zip meths1 meths2 |> Seq.forall (fun (m1, m2) ->
|
|
Infos.MethInfosUseIdenticalDefinitions () m1 m2)
|
|
| Wrap(Item_val(vref1)), Wrap(Item_val(vref2)) -> g.vref_eq vref1 vref2
|
|
| Wrap(Item_apelem(APElemRef(apinfo1, vref1, idx1))), Wrap(Item_apelem(APElemRef(apinfo2, vref2, idx2))) ->
|
|
idx1 = idx2 && g.vref_eq vref1 vref2
|
|
| Wrap(Item_ucase(UnionCaseInfo(_, ur1))), Wrap(Item_ucase(UnionCaseInfo(_, ur2))) -> g.ucref_eq ur1 ur2
|
|
| Wrap(Item_recdfield(RecdFieldInfo(_, RFRef(tcref1, n1)))), Wrap(Item_recdfield(RecdFieldInfo(_, RFRef(tcref2, n2)))) ->
|
|
(tcref_eq g tcref1 tcref2) && (n1 = n2) // there is no direct function as in the previous case
|
|
| Wrap(Item_property(_, pi1s)), Wrap(Item_property(_, pi2s)) ->
|
|
List.zip pi1s pi2s |> List.forall(fun (pi1, pi2) -> Infos.PropInfosUseIdenticalDefinitions pi1 pi2)
|
|
| Wrap(Item_event(evt1)), Wrap(Item_event(evt2)) -> Infos.EventInfosUseIdenticalDefintions evt1 evt2
|
|
| _ -> false
|
|
|
|
member x.GetHashCode item =
|
|
match item with
|
|
| Wrap(Item_delegate_ctor(ty))
|
|
| Wrap(Item_typs(_,[ty])) ->
|
|
if is_stripped_tyapp_typ g ty then hash (tcref_of_stripped_typ g ty).Stamp
|
|
else 1010
|
|
| Wrap(Item_il_field(ILFieldInfo(_, fld))) ->
|
|
fld.GetHashCode() // hash on the object identity of the AbstractIL metadata blob for the field
|
|
| Wrap(Item_modrefs(modref :: _)) -> hash (full_display_text_of_modref modref)
|
|
| Wrap(Item_prop_name(id)) -> hash (id.idRange, id.idText)
|
|
| Wrap(Item_meth_group(_, meths)) -> meths |> List.fold (fun st a -> st + (Infos.GetMethInfoHashCode(a))) 0
|
|
| Wrap(Item_val(vref)) -> hash vref.MangledName
|
|
| Wrap(Item_apelem(APElemRef(apinfo, vref, idx))) -> hash (vref.MangledName, idx)
|
|
| Wrap(Item_ecref(tcref)) -> hash tcref.Stamp
|
|
| Wrap(Item_ucase(UnionCaseInfo(_, UCRef(tcref, n)))) -> hash(tcref.Stamp, n)
|
|
| Wrap(Item_recdfield(RecdFieldInfo(_, RFRef(tcref, n)))) -> hash(tcref.Stamp, n)
|
|
| Wrap(Item_event(evt)) -> Infos.GetEventInfoHashCode(evt)
|
|
| Wrap(Item_property(name, pis)) -> hash (pis |> List.map Infos.GetPropInfoHashCode)
|
|
| _ -> failwith "unreachable" }
|
|
|
|
let getPartialStructuralComparerBy f =
|
|
let hid = HashIdentity.Structural
|
|
{ new IPartialEqualityComparer<_> with
|
|
member x.InEqualityRelation (Wrap(item)) = f(item) |> Option.is_some
|
|
member x.Equals(Wrap(item1), Wrap(item2)) = hid.Equals(item1, item2)
|
|
member x.GetHashCode(Wrap(item)) = hid.GetHashCode(item) }
|
|
|
|
// Remove items containing the same module references, where f projects out the module reference
|
|
let RemoveDuplicateModuleRefs f xs =
|
|
xs |> partial_distinct_by (getPartialStructuralComparerBy (f >> Option.map full_display_text_of_modref))
|
|
|
|
/// Remove all duplicate items
|
|
let RemoveDuplicateItems g items = partial_distinct_by (ItemDisplayPartialEquality g) items
|
|
|
|
/// Filter types that are explicitly suppressed from the IntelliSense (such as uppercase "FSharpList", "Option", etc.)
|
|
let RemoveExplicitlySuppressed g items =
|
|
items |> List.filter (function
|
|
| Item_typs(it, [ty]) -> g.suppressed_types |> List.forall (fun supp ->
|
|
if is_stripped_tyapp_typ g ty then
|
|
// check if they are the same logical type (after removing all abbreviations)
|
|
let tcr1 = tcref_of_stripped_typ g ty
|
|
let tcr2 = tcref_of_stripped_typ g (snd(generalize_tcref supp) )
|
|
not(tcref_eq g tcr1 tcr2 &&
|
|
// check the display name is precisely the one we're suppressing
|
|
it = supp.DisplayName)
|
|
else true )
|
|
| _ -> true )
|
|
|
|
let SimplerDisplayEnv denv = { denv with suppressInlineKeyword=true; shortConstraints=true; showConstraintTyparAnnotations=false; abbreviateAdditionalConstraints=false }
|
|
|
|
/// Output a the description of a language item
|
|
let FormatItemDescriptionToBuffer (infoReader:InfoReader) m denv os d =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
let denv = SimplerDisplayEnv denv
|
|
match d with
|
|
| Item_val v ->
|
|
bprintf os "%a%a%a"
|
|
(NicePrint.output_qualified_val_spec denv) (deref_val v)
|
|
boutput_xmldoc v.XmlDoc
|
|
(boutput_fullname pubpath_of_vref full_display_text_of_vref) v;
|
|
|
|
// adjust the type in case this is the 'this' pointer stored in a reference cell
|
|
let ty = if v.BaseOrThisInfo = CtorThisVal && is_refcell_ty g v.Type then dest_refcell_ty g v.Type else v.Type
|
|
|
|
OutputUsefulTypeInfo infoReader m denv os ty;
|
|
boutput_range_of_item os d
|
|
// Union tags (constructors)
|
|
| Item_ucase(ucr) ->
|
|
let uc = ucr.UnionCase
|
|
let rty =snd(generalize_tcref ucr.TyconRef)
|
|
let recd = uc.RecdFields
|
|
let ty = if recd = [] then rty else (mk_tupled_ty g (recd |> List.map (fun rfld -> rfld.FormalType))) --> rty
|
|
bprintf os "union case %a.%s: %a%a"
|
|
(NicePrint.output_tcref denv) ucr.TyconRef
|
|
(DecompileOpName uc.ucase_id.idText)
|
|
(NicePrint.output_typ denv) ty
|
|
boutput_xmldoc uc.ucase_xmldoc;
|
|
boutput_range_of_item os d
|
|
|
|
// Active pattern tag inside the declaration (result)
|
|
| Item_apres(APInfo(_, items, _), ty, idx) ->
|
|
bprintf os "active pattern result %s: %a" (List.nth items idx) (NicePrint.output_typ denv) ty
|
|
|
|
// Active pattern tags
|
|
| Item_apelem(apref) ->
|
|
|
|
let v = apref.ActivePatternVal
|
|
let tps,tau = v.TypeScheme
|
|
let args,res = strip_fun_typ g tau
|
|
let apinfo = the (apinfo_of_vref v)
|
|
let apnames = names_of_apinfo apinfo
|
|
let aparity = List.length apnames
|
|
|
|
let rty = if aparity <= 1 then res else List.nth (tinst_of_stripped_typ g res) apref.CaseIndex
|
|
let ty = mk_iterated_fun_ty args rty
|
|
|
|
// Format the type parameters to get e.g. ('a -> 'a) rather than ('?1234 -> '?1234)
|
|
let tps,tau = v.TypeScheme
|
|
let tprenaming,ptau,cxs = PrettyTypes.PrettifyTypes1 denv.g tau
|
|
let ptps =
|
|
tps
|
|
|> generalize_typars
|
|
|> List.map (InstType tprenaming)
|
|
|> List.filter (is_anypar_typ denv.g)
|
|
|> List.map (dest_anypar_typ denv.g)
|
|
|
|
bprintf os "active recognizer %s: %a%a%a"
|
|
(name_of_apref apref)
|
|
(NicePrint.output_typ denv) ptau
|
|
boutput_xmldoc v.XmlDoc
|
|
(boutput_fullname pubpath_of_vref full_display_text_of_vref) v
|
|
// F# exception names
|
|
| Item_ecref(ecref: TyconRef) ->
|
|
bprintf os "%a%a%a" (NicePrint.output_exnc denv) (deref_tycon ecref)
|
|
boutput_xmldoc ecref.XmlDoc
|
|
(boutput_fullname pubpath_of_tcref full_display_text_of_ecref) ecref;
|
|
boutput_range_of_item os d
|
|
|
|
// F# record field names
|
|
| Item_recdfield(rfinfo) ->
|
|
let f = rfinfo.RecdField
|
|
let _,ty,tpcs = PrettyTypes.PrettifyTypes1 g rfinfo.FieldType
|
|
bprintf os "%a.%s: %a"
|
|
(NicePrint.output_tcref denv) rfinfo.TyconRef
|
|
(DecompileOpName f.Name)
|
|
(NicePrint.output_typ denv) ty;
|
|
match rfinfo.LiteralValue with
|
|
| None -> ()
|
|
| Some lit ->
|
|
try bprintf os " = %s" (Layout.showL ( NicePrint.constL lit )) with _ -> ()
|
|
bprintf os "%a"
|
|
boutput_xmldoc f.rfield_xmldoc;
|
|
boutput_range_of_item os d
|
|
|
|
// Not used
|
|
| Item_newdef(id) -> bprintf os "patvar %s" id.idText
|
|
|
|
// .NET fields
|
|
| Item_il_field(finfo) ->
|
|
bprintf os "field %a.%s" (NicePrint.output_tref denv) finfo.ILTypeRef finfo.FieldName;
|
|
match finfo.LiteralValue with
|
|
| None -> ()
|
|
| Some v ->
|
|
try bprintf os " = %s" (Layout.showL ( NicePrint.constL (TypeChecker.TcFieldInit m v) ))
|
|
with _ -> ()
|
|
|
|
// .NET events
|
|
| Item_event(ILEvent(g,ilEventInfo) as einfo) ->
|
|
let rty = PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo
|
|
let _,rty,tpcs = PrettyTypes.PrettifyTypes1 g rty
|
|
bprintf os "event %a.%s: %a" (NicePrint.output_tref denv) ilEventInfo.TypeRef einfo.EventName
|
|
(NicePrint.output_typ denv) rty
|
|
|
|
// F# and .NET properties
|
|
| Item_property(_,pinfos) ->
|
|
let pinfo = List.hd pinfos
|
|
let rty = PropertyTypeOfPropInfo amap m pinfo
|
|
let _,rty,tpcs = PrettyTypes.PrettifyTypes1 g rty
|
|
let ty = if pinfo.IsIndexer then mk_tupled_ty g (List.map snd (ParamNamesAndTypesOfPropInfo amap m pinfo)) --> rty else rty
|
|
bprintf os "property %a.%s: %a%a"
|
|
(NicePrint.output_tcref denv) (tcref_of_stripped_typ g pinfo.EnclosingType)
|
|
pinfo.PropertyName
|
|
(NicePrint.output_typ denv) rty
|
|
boutput_xmldoc pinfo.XmlDoc;
|
|
boutput_range_of_item os d
|
|
|
|
// F# constructors
|
|
| Item_ctor_group(_,minfos) ->
|
|
FormatMemberInfosToBuffer infoReader m denv os d minfos
|
|
| Item_meth_group(_,minfos) ->
|
|
FormatMemberInfosToBuffer infoReader m denv os d minfos
|
|
|
|
// The 'fake' zero-argument constructors of .NET structs
|
|
| Item_fake_intf_ctor typ ->
|
|
let _,typ,tpcs = PrettyTypes.PrettifyTypes1 g typ
|
|
bprintf os "%a" (NicePrint.output_tcref denv) (tcref_of_stripped_typ g typ)
|
|
|
|
// The 'fake' representation of constructors of .NET delegate types
|
|
| Item_delegate_ctor delty ->
|
|
let _,delty,tpcs = PrettyTypes.PrettifyTypes1 g delty
|
|
let minfo, argtys,rty,fty = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomewhere
|
|
bprintf os "%a(%a)" (NicePrint.output_tcref denv) (tcref_of_stripped_typ g delty) (NicePrint.output_typ denv) fty;
|
|
boutput_range_of_item os d
|
|
|
|
// Types.
|
|
| Item_typs(_,((TType_app(tcref,_) as typ):: _)) ->
|
|
bprintf os "%a" (NicePrint.output_tycon denv) (deref_tycon tcref);
|
|
boutput_xmldoc os tcref.XmlDoc;
|
|
boutput_fullname pubpath_of_tcref full_display_text_of_tcref os tcref;
|
|
OutputUsefulTypeInfo infoReader m denv os typ;
|
|
boutput_range_of_item os d
|
|
|
|
// F# Modules and namespaces
|
|
| Item_modrefs((modref :: _) as modrefs) ->
|
|
let modrefs = modrefs |> RemoveDuplicateModuleRefs (fun x -> Some(x))
|
|
let definiteNamespace = modrefs |> List.forall (fun modref -> modref.IsNamespace)
|
|
let kind =
|
|
if definiteNamespace then "namespace"
|
|
elif modrefs |> List.forall (fun modref -> modref.IsModule) then "module"
|
|
else "namespace/module"
|
|
bprintf os "%s %s" kind (if definiteNamespace then full_display_text_of_modref modref else demangled_name_of_modref modref)
|
|
if not definiteNamespace then
|
|
let namesToAdd = modrefs |> Seq.fold (fun st modref ->
|
|
match full_display_text_of_parent_of_modref modref with
|
|
| Some(txt) -> txt::st | _ -> st) [] |> Seq.mapi (fun i x -> i,x) |> Seq.to_list
|
|
if namesToAdd <> [] then
|
|
bprintf os "\n"
|
|
for i, txt in namesToAdd do
|
|
bprintf os "\n%s %s" (if i = 0 then "from" else "also from") txt
|
|
boutput_xmldoc os modref.XmlDoc
|
|
boutput_range_of_item os d
|
|
|
|
// Named parameters
|
|
| Item_param_name(id) ->
|
|
//let _,typ,tpcs = PrettyTypes.PrettifyTypes1 typ
|
|
bprintf os "argument %s" id.idText; // (NicePrint.output_typ denv) typ
|
|
|
|
| Item_prop_name(id) ->
|
|
bprintf os "property %s" id.idText; // (NicePrint.output_typ denv) typ
|
|
|
|
| _ -> ()
|
|
|
|
// Format the return type of an item
|
|
let FormatItemReturnTypeToBuffer (infoReader:InfoReader) m denv os d =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
let denv = SimplerDisplayEnv denv
|
|
match d with
|
|
| Item_val vref ->
|
|
let tps,tau = vref.TypeScheme
|
|
(* Note: prettify BEFORE we strip to make sure params look the same as types *)
|
|
if is_fun_typ g tau then
|
|
let dtau,rtau = dest_fun_typ g tau
|
|
let ptausL,tpcsL = NicePrint.typesAndConstraintsL denv [dtau;rtau]
|
|
let _,prtauL = List.frontAndBack ptausL
|
|
bprintf os "%a %a" bufferL prtauL bufferL tpcsL
|
|
else
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] tau)
|
|
| Item_ucase(ucr) ->
|
|
let uc = ucr.UnionCase
|
|
let rty =snd(generalize_tcref ucr.TyconRef)
|
|
bprintf os "%a" (NicePrint.output_typ denv) rty
|
|
| Item_apelem(apref) ->
|
|
let v = apref.ActivePatternVal
|
|
let tps,tau = v.TypeScheme
|
|
let args,res = strip_fun_typ g tau
|
|
let apinfo = the (apinfo_of_vref v)
|
|
let apnames = names_of_apinfo apinfo
|
|
let aparity = apnames.Length
|
|
|
|
let rty = if aparity <= 1 then res else List.nth (tinst_of_stripped_typ g res) apref.CaseIndex
|
|
bprintf os "%a" (NicePrint.output_typ denv) rty
|
|
| Item_ecref(ecr) ->
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] g.exn_ty)
|
|
| Item_recdfield(rfinfo) ->
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] rfinfo.FieldType);
|
|
| Item_il_field(finfo) ->
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] (FieldTypeOfILFieldInfo amap m finfo))
|
|
| Item_event(einfo) ->
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo))
|
|
| Item_property(_,pinfos) ->
|
|
let pinfo = List.hd pinfos
|
|
let rty = PropertyTypeOfPropInfo amap m pinfo
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] rty)
|
|
| Item_meth_group(_,(minfo :: _))
|
|
| Item_ctor_group(_,(minfo :: _)) ->
|
|
let rty = FSharpReturnTyOfMeth amap m minfo minfo.FormalMethodInst
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] rty)
|
|
| Item_fake_intf_ctor typ
|
|
| Item_delegate_ctor typ ->
|
|
bufferL os (NicePrint.topTypAndConstraintsL denv [] typ)
|
|
|
|
| _ -> ()
|
|
|
|
// Find the name of the metadata file for this external definition
|
|
let ftinfo_of_il_tcref (infoReader:InfoReader) m tcref =
|
|
let g = infoReader.g
|
|
match tcref with
|
|
| ERef_private _ -> None
|
|
| ERef_nonlocal nlref ->
|
|
match (ccu_of_nlpath (nlpath_of_nlref nlref)).FileName with
|
|
| None -> None
|
|
| Some libfile ->
|
|
(* Generalize the pinfo to get a formal signature *)
|
|
let ftctps = tcref.Typars(m)
|
|
let ftinst = generalize_typars ftctps
|
|
let ftinfo = tinfo_of_il_typ g (TType_app(tcref,ftinst))
|
|
Some(libfile,ftctps,ftinfo)
|
|
|
|
|
|
// This function gets the signature to pass to Visual Studio to use its lookup functions for .NET stuff.
|
|
// NOTE: XmlDoc for F# items is added by FormatItemDescriptionToBuffer
|
|
let GetXmlDocHelpSigOfItemForLookup (infoReader:InfoReader) m d =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
match d with
|
|
| Item_val v -> None
|
|
| Item_ucase(ucr) -> None
|
|
| Item_ecref(ecr) -> None
|
|
| Item_recdfield(rfinfo) -> None
|
|
| Item_newdef(id) -> None
|
|
| Item_il_field(ILFieldInfo(tinfo, fdef)) ->
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
(libfile,
|
|
"F:"^ftinfo.ILTypeRef.FullName^"."^fdef.fdName))
|
|
| Item_typs(_,((TType_app(tcref,_) as typ) :: _)) ->
|
|
// Find the name of the metadata file for this external definition
|
|
if tcref.IsILTycon then
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
(libfile,"T:"^ftinfo.ILTypeRef.FullName))
|
|
else None
|
|
| Item_modrefs(modref :: _) -> None
|
|
| Item_property(_,(pinfo :: _)) ->
|
|
match pinfo with
|
|
| FSProp _ -> None
|
|
| ILProp(g, (ILPropInfo(tinfo,pdef) as ilpinfo)) ->
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
let filpinfo = ILPropInfo(ftinfo,pdef)
|
|
(libfile,
|
|
"P:"^ftinfo.ILTypeRef.FullName^"."^pdef.propName^
|
|
XmlDocArgsEnc g ftctps (List.map snd (params_of_il_pinfo amap m filpinfo))))
|
|
| Item_event(ILEvent(g,ilEventInfo) as einfo) ->
|
|
let tinfo = ilEventInfo.ILTypeInfo
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
(libfile,
|
|
"E:"^ftinfo.ILTypeRef.FullName^"."^einfo.EventName))
|
|
| Item_meth_group(_,minfos)
|
|
| Item_ctor_group(_,minfos) ->
|
|
match minfos with
|
|
| [] -> None
|
|
| FSMeth _ :: _ -> None
|
|
| (ILMeth (g,ILMethInfo(tinfo,isExt,mdef,fmtps)) as minfo) :: _ ->
|
|
// REVIEW: this is not right for extension members
|
|
// Generalize the minfo to get a formal signature
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
let filminfo = ILMethInfo(ftinfo,isExt,mdef,fmtps)
|
|
(libfile,
|
|
"M:"^tinfo.ILTypeRef.FullName^"."^mdef.mdName^
|
|
XmlDocArgsEnc g (ftctps@fmtps) (filminfo.ArgTypes(amap,m,minfo.FormalMethodInst))))
|
|
| (DefaultStructCtor _ :: _) -> None
|
|
|
|
| _ -> None
|
|
|
|
let GetF1Keyword (infoReader:InfoReader) m d : string option =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
match d with
|
|
| Item_val v -> None
|
|
| Item_ucase(ucr) -> None
|
|
| Item_ecref(ecr) -> None
|
|
| Item_recdfield(rfinfo) -> None
|
|
| Item_newdef(id) -> None
|
|
| Item_il_field(ILFieldInfo(tinfo, fdef)) ->
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
(tcref |> ticks_and_argcount_text_of_tcref)^"."^fdef.fdName)
|
|
| Item_typs(_,((TType_app(tcref,_) as typ) :: _)) ->
|
|
Some (ticks_and_argcount_text_of_tcref tcref)
|
|
| Item_modrefs(modref :: _) -> None
|
|
| Item_property(_,(pinfo :: _)) ->
|
|
match pinfo with
|
|
| FSProp _ -> None
|
|
| ILProp(g, (ILPropInfo(tinfo,pdef) as ilpinfo)) ->
|
|
let tcref = tinfo.TyconRef
|
|
begin
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
let filpinfo = ILPropInfo(ftinfo,pdef)
|
|
(tcref |> ticks_and_argcount_text_of_tcref)^"."^pdef.propName)
|
|
end
|
|
| Item_event(ILEvent(g,ilEventInfo) as einfo) ->
|
|
let tinfo = ilEventInfo.ILTypeInfo
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) -> (tcref |> ticks_and_argcount_text_of_tcref)^"."^einfo.EventName)
|
|
|
|
| Item_ctor_group(_,minfos) ->
|
|
match minfos with
|
|
| [] -> None
|
|
| FSMeth _ :: _ -> None
|
|
| (ILMeth (g,ILMethInfo(tinfo,isExt,mdef,fmtps)) as minfo) :: _ ->
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (libfile,ftctps,ftinfo) ->
|
|
let filminfo = ILMethInfo(ftinfo,isExt,mdef,fmtps)
|
|
//tinfo.ILTypeRef.FullName^".#ctor" // dmilom: spec suggests I need to name it #ctor
|
|
(tcref |> ticks_and_argcount_text_of_tcref)^"."^tcref.DisplayName) // but this is what works
|
|
| (DefaultStructCtor _ :: _) -> None
|
|
|
|
| Item_meth_group(_,minfos) ->
|
|
match minfos with
|
|
| [] -> None
|
|
| FSMeth _ :: _ -> None
|
|
| (ILMeth (g,ILMethInfo(tinfo,isExt,mdef,fmtps)) as minfo) :: _ ->
|
|
// REVIEW: this is not right for extension members
|
|
// Generalize the minfo to get a formal signature
|
|
let tcref = tinfo.TyconRef
|
|
ftinfo_of_il_tcref infoReader m tcref
|
|
|> Option.map (fun (_,ftctps,ftinfo) ->
|
|
let filminfo = ILMethInfo(ftinfo,isExt,mdef,fmtps)
|
|
let nGenericParams = mdef.GenericParams.Length
|
|
let paramString =
|
|
if nGenericParams > 0 then "`"^(nGenericParams.ToString()) else ""
|
|
(tcref |> ticks_and_argcount_text_of_tcref)^"."^mdef.mdName^paramString)
|
|
|
|
| (DefaultStructCtor _ :: _) -> None
|
|
|
|
| _ -> None
|
|
|
|
|
|
let FormatDescriptionOfItem (infoReader:InfoReader) m denv d =
|
|
ErrorScope.Protect m
|
|
(fun () ->
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
let text,xmlSigToAdd =
|
|
bufs (fun buf -> FormatItemDescriptionToBuffer infoReader m denv buf d), GetXmlDocHelpSigOfItemForLookup infoReader m d
|
|
if verbose then xmlSigToAdd |> Option.iter (fun (lib,sg) -> dprintf "FormatDescriptionOfItem: libOfXmlSigToAdd = %s, xmlSigToAdd = %s\n" lib sg);
|
|
(text,xmlSigToAdd))
|
|
(fun err -> err,None)
|
|
|
|
let FormatReturnTypeOfItem (infoReader:InfoReader) m denv d =
|
|
ErrorScope.Protect m (fun () -> bufs (fun buf -> FormatItemReturnTypeToBuffer infoReader m denv buf d)) (fun err -> err)
|
|
|
|
// Compute the index of the VS glyph shown with an item in the Intellisense menu
|
|
let GlyphOfItem(denv,d) =
|
|
|
|
/// Find the glyph for the given representation.
|
|
let ReprToGlyph(repr) =
|
|
match repr with
|
|
| TFsObjModelRepr om ->
|
|
match om.fsobjmodel_kind with
|
|
| TTyconClass -> iIconGroupClass
|
|
| TTyconInterface -> iIconGroupInterface
|
|
| TTyconStruct -> iIconGroupStruct
|
|
| TTyconDelegate _ -> iIconGroupDelegate
|
|
| TTyconEnum _ -> iIconGroupEnum
|
|
| TRecdRepr _ -> iIconGroupType
|
|
| TFiniteUnionRepr _ -> iIconGroupUnion
|
|
| TILObjModelRepr(_,_,{tdKind=kind}) ->
|
|
match kind with
|
|
| TypeDef_class -> iIconGroupClass
|
|
| TypeDef_valuetype -> iIconGroupStruct
|
|
| TypeDef_interface -> iIconGroupInterface
|
|
| TypeDef_enum -> iIconGroupEnum
|
|
| TypeDef_delegate -> iIconGroupDelegate
|
|
| TypeDef_other _ -> iIconGroupTypedef
|
|
| TAsmRepr _ -> iIconGroupTypedef
|
|
| TMeasureableRepr _-> iIconGroupTypedef
|
|
|
|
/// Find the glyph for the given type representation.
|
|
let rec TypToGlyph(typ) =
|
|
if is_stripped_tyapp_typ denv.g typ then
|
|
let tcref = tcref_of_stripped_typ denv.g typ
|
|
tcref.TypeReprInfo |> (function None -> iIconGroupClass | Some repr -> ReprToGlyph repr)
|
|
elif is_tuple_typ denv.g typ then iIconGroupStruct
|
|
elif is_function denv.g typ then iIconGroupDelegate
|
|
elif is_typar_typ denv.g typ then iIconGroupStruct
|
|
else iIconGroupTypedef
|
|
|
|
|
|
/// Find the glyph for the given value representation.
|
|
let ValueToGlyph(typ) =
|
|
if is_function denv.g typ then iIconGroupMethod
|
|
else iIconGroupConstant
|
|
|
|
/// Find the major glyph of the given named item.
|
|
let NamedItemToMajorGlyph = function
|
|
| Item_val(vref) -> ValueToGlyph(vref.Type)
|
|
| Item_typs(_,typ::_) -> TypToGlyph(strip_tpeqns_and_tcabbrevs denv.g typ)
|
|
| Item_ucase _
|
|
| Item_apelem _ -> iIconGroupEnumMember
|
|
| Item_ecref _ -> iIconGroupException
|
|
| Item_recdfield _ -> iIconGroupFieldBlue
|
|
| Item_il_field _ -> iIconGroupFieldBlue
|
|
| Item_event _ -> iIconGroupEvent
|
|
| Item_property _ -> iIconGroupProperty
|
|
| Item_ctor_group _
|
|
| Item_delegate_ctor _
|
|
| Item_fake_intf_ctor _
|
|
| Item_meth_group _ -> iIconGroupMethod
|
|
| Item_typs _ -> iIconGroupClass
|
|
| Item_modrefs(modref::_) ->
|
|
if modref.IsNamespace then iIconGroupNameSpace else iIconGroupModule
|
|
| Item_param_name _ -> iIconGroupVariable
|
|
| Item_prop_name _ -> iIconGroupVariable
|
|
| x -> iIconGroupError
|
|
|
|
/// Find the minor glyph of the given named item.
|
|
let NamedItemToMinorGlyph = function
|
|
| Item_val(vref) when is_function denv.g vref.Type -> iIconItemSpecial
|
|
| _ -> iIconItemNormal
|
|
|
|
(6 * NamedItemToMajorGlyph(d)) + NamedItemToMinorGlyph(d)
|
|
|
|
|
|
let string_is_prefix_of m n = String.length n >= String.length m && String.sub n 0 (String.length m) = m
|
|
|
|
|
|
|
|
open ItemDescriptions
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Scopes etc. for intellisense
|
|
//--------------------------------------------------------------------------
|
|
|
|
type Names = string list
|
|
type NamesWithResidue = Names * string
|
|
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Declarations
|
|
//--------------------------------------------------------------------------
|
|
[<Sealed>]
|
|
type TextResult(v: TextWithXmlSig) =
|
|
member x.TextWithXmlSig = v
|
|
member x.Text= fst v
|
|
member x.XMLFileAndSig = snd v
|
|
|
|
/// An intellisense declaration
|
|
[<Sealed>]
|
|
type Declaration(name, description:TextWithXmlSig Lazy.t, glyph:int, syncop:(unit->unit)->unit) =
|
|
let mutable descriptionText:TextResult option = None
|
|
member decl.Name = name
|
|
member decl.DescriptionText =
|
|
match descriptionText with
|
|
| Some(descriptionText) -> descriptionText
|
|
| None ->
|
|
// syncop "Synchronous Operation" causes the lambda to execute inside the background compiler.
|
|
syncop (fun () -> descriptionText<-Some(TextResult(Lazy.force description)))
|
|
descriptionText.Value
|
|
member decl.Glyph = glyph
|
|
|
|
/// A table of declarations for Intellisense completion
|
|
[<Sealed>]
|
|
type Decls(d: Declaration array) =
|
|
|
|
member self.Items = d
|
|
|
|
member self.Count =
|
|
Array.length d
|
|
|
|
member self.Name i : string =
|
|
d.[i].Name
|
|
|
|
member self.Description i : TextWithXmlSig =
|
|
ErrorScope.Protect Range.range0 (fun () -> d.[i].DescriptionText.TextWithXmlSig) (fun err -> err, None)
|
|
|
|
member self.Glyph i = d.[i].Glyph
|
|
|
|
// Make a 'Declarations' object for a set of selected items
|
|
static member Create(infoReader:InfoReader,m,denv,items, syncop:(unit->unit)->unit) =
|
|
let g = infoReader.g
|
|
|
|
// Remove all duplicates first
|
|
let items = items |> RemoveDuplicateItems g
|
|
let items = items |> RemoveExplicitlySuppressed g
|
|
|
|
// Bag by name using multi-maps
|
|
let items = items |> List.map (fun d -> DisplayNameOfItem g d, d)
|
|
let items = List.foldBack (fun (n,d) acc -> NameMultiMap.add n d acc) items NameMultiMap.empty
|
|
|
|
// Prefer to show types first - they usually have very useful XmlDocs
|
|
let items = items |> NameMap.to_list
|
|
let items =
|
|
items
|
|
|> List.map (fun (nm,bag) ->
|
|
nm,
|
|
bag |> List.sortWith (fun a b ->
|
|
match a,b with
|
|
| Item_ctor_group _, Item_typs _ -> 1
|
|
| Item_typs _, Item_ctor_group _ -> -1
|
|
| _ -> 0))
|
|
|
|
// Sort by name
|
|
let items = items |> List.sortBy fst
|
|
if verbose then dprintf "service.ml: mkDecls: %d found after filtering\n" (List.length items);
|
|
|
|
// Get the descriptions, lazily
|
|
let getDescription item rest =
|
|
lazy (let text,xmlSigToAdd = FormatDescriptionOfItem infoReader m denv item
|
|
let text = System.String.Join("\n-------------\n", Array.of_list (text :: (rest |> List.map (FormatDescriptionOfItem infoReader m denv >> fst))))
|
|
text, xmlSigToAdd)
|
|
|
|
let decls =
|
|
// Filter out operators
|
|
let items = items |> List.filter (fun (nm,d) -> not (IsOpName nm) || (is_ap_name nm))
|
|
|
|
// Filter out duplicate names
|
|
items |> List.map (fun (nm,itemsWithSameName) ->
|
|
match itemsWithSameName with
|
|
| [] -> failwith "Unexpected empty bag"
|
|
| item :: rest ->
|
|
let desc = getDescription item rest
|
|
Declaration(nm,desc,GlyphOfItem(denv,item),syncop))
|
|
|
|
new Decls(Array.of_list decls)
|
|
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Methods
|
|
//--------------------------------------------------------------------------
|
|
|
|
|
|
type Param =
|
|
{ Name: string;
|
|
Display: string;
|
|
Description: string }
|
|
|
|
/// Format parameters for Intellisense completion
|
|
module Params =
|
|
let param_of_typL denv tyL =
|
|
{ Name= "";
|
|
Display = Layout.showL tyL;
|
|
Description = "" }
|
|
|
|
let ParamOfRecdField denv f =
|
|
{ Name= "" (* f.rfield_id.idText *) ;
|
|
Display = NicePrint.pretty_string_of_typ denv f.rfield_type;
|
|
Description = "" }
|
|
let ParamOfParamData denv paramData =
|
|
{ Name= ""; //(match pname with None -> "" | Some pn -> pn);
|
|
Display = string_of_param_data denv paramData;
|
|
Description = "" }
|
|
|
|
let ParamsOfParamDatas denv (paramDatas:ParamData list) rty =
|
|
let paramPrefixes,paramTypes =
|
|
paramDatas
|
|
|> List.map (fun (ParamData(_,_,optArgInfo,nmOpt,pty)) ->
|
|
let isOptArg = optArgInfo <> NotOptional
|
|
match nmOpt, isOptArg, try_dest_option_ty denv.g pty with
|
|
// Layout an optional argument
|
|
| Some(nm), true, Some(pty) ->
|
|
(sprintf "?%s:" nm), pty
|
|
// Layout an unnamed argument
|
|
| None, _,_ ->
|
|
"", pty;
|
|
// Layout a named argument
|
|
| Some nm,_,_ ->
|
|
(sprintf "%s: " nm),pty)
|
|
|> List.unzip
|
|
let paramTypeAndRetLs,_ = NicePrint.typesAndConstraintsL denv (paramTypes@[rty])
|
|
let paramTypeLs,_ = List.frontAndBack paramTypeAndRetLs
|
|
(paramPrefixes,paramTypeLs) ||> List.map2 (fun paramPrefix tyL ->
|
|
{ Name= "";
|
|
Display = paramPrefix^(showL tyL);
|
|
Description = "" })
|
|
|
|
let ParamsOfTypes denv args rtau =
|
|
(*let arg,rtau = dest_fun_typ rtau
|
|
let args = try_dest_tuple_typ arg *)
|
|
let ptausL,tpcsL = NicePrint.typesAndConstraintsL denv (args@[rtau])
|
|
let argsL,_ = List.frontAndBack ptausL
|
|
List.map (param_of_typL denv) argsL
|
|
|
|
let ParamsOfItem (infoReader:InfoReader) m denv d =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
match d with
|
|
| Item_val vref ->
|
|
let tps,tau = vref.TypeScheme
|
|
if is_fun_typ denv.g tau then
|
|
let arg,rtau = dest_fun_typ denv.g tau
|
|
let args = try_dest_tuple_typ denv.g arg
|
|
ParamsOfTypes denv args rtau
|
|
else []
|
|
| Item_ucase(ucr) -> ucr.UnionCase.RecdFields |> List.map (ParamOfRecdField denv)
|
|
| Item_apelem(apref) ->
|
|
let v = apref.ActivePatternVal
|
|
let tps,tau = v.TypeScheme
|
|
let args,res = strip_fun_typ denv.g tau
|
|
ParamsOfTypes denv args tau
|
|
| Item_ecref(ecref) ->
|
|
ecref |> rfields_of_ecref |> List.map (ParamOfRecdField denv)
|
|
| Item_property(_,pinfo :: _) ->
|
|
let paramDatas =
|
|
ParamNamesAndTypesOfPropInfo amap m pinfo
|
|
|> List.map (fun (nm,pty) -> ParamData(false,false,NotOptional,nm, pty))
|
|
|
|
let rty = PropertyTypeOfPropInfo amap m pinfo
|
|
ParamsOfParamDatas denv paramDatas rty
|
|
| Item_ctor_group(_,(minfo :: _))
|
|
| Item_meth_group(_,(minfo :: _)) ->
|
|
let paramDatas = ParamDatasOfMethInfo amap m minfo minfo.FormalMethodInst |> List.hd
|
|
let rty = FSharpReturnTyOfMeth amap m minfo minfo.FormalMethodInst
|
|
ParamsOfParamDatas denv paramDatas rty
|
|
| Item_fake_intf_ctor typ -> []
|
|
| Item_delegate_ctor delty ->
|
|
let minfo, argtys,rty,fty = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomeFSharpCode
|
|
ParamsOfParamDatas denv [ParamData(false,false,NotOptional,None, fty)] delty
|
|
| _ -> []
|
|
|
|
|
|
/// A single method for Intellisense completion
|
|
type Method =
|
|
{ Description: TextResult;
|
|
Type: string;
|
|
Parameters: Param array }
|
|
|
|
|
|
/// A table of methods for Intellisense completion
|
|
[<Sealed>]
|
|
type MethodOverloads( name: string, methods: Method array) =
|
|
member x.Name = name
|
|
member x.Methods = methods
|
|
|
|
member meths.Count =
|
|
try
|
|
methods.Length
|
|
with | e ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "Unexpected error (Methods.getCount): %s\n" (e.ToString()));
|
|
0
|
|
|
|
member meths.Description i : TextResult =
|
|
ErrorScope.Protect Range.range0 (fun () -> methods.[i].Description) (fun err -> TextResult((err, None)))
|
|
|
|
member meths.Type i : string =
|
|
ErrorScope.ProtectWithDefault Range.range0 (fun () -> methods.[i].Type) ""
|
|
|
|
member meths.ParameterCount i =
|
|
ErrorScope.ProtectWithDefault Range.range0 (fun () -> methods.[i].Parameters.Length) 0
|
|
|
|
member meths.ParameterInfo i j : Param =
|
|
ErrorScope.Protect Range.range0 (fun () -> methods.[i].Parameters.[j]) (fun err -> { Name= "";Display = "";Description = err })
|
|
|
|
static member Create(infoReader:InfoReader,m,denv,items) =
|
|
let g = infoReader.g
|
|
let amap = infoReader.amap
|
|
if verbose then dprintf "mkMethods: %d items on input\n" (List.length items);
|
|
if items = [] then new MethodOverloads("", [| |]) else
|
|
let name = DisplayNameOfItem g (List.hd items)
|
|
let items =
|
|
items |> List.collect (fun item ->
|
|
match item with
|
|
| Item_meth_group(nm,minfos) -> List.map (fun minfo -> Item_meth_group(nm,[minfo])) minfos
|
|
| Item_ctor_group(nm,cinfos) -> List.map (fun minfo -> Item_ctor_group(nm,[minfo])) cinfos
|
|
| Item_fake_intf_ctor _
|
|
| Item_delegate_ctor _ -> [item]
|
|
| Item_newdef _
|
|
| Item_il_field _ -> []
|
|
| Item_event _ -> []
|
|
| Item_recdfield(rfinfo) ->
|
|
if is_function g rfinfo.FieldType then [item] else []
|
|
| Item_val v ->
|
|
if is_function g v.Type then [item] else []
|
|
| Item_ucase(ucr) ->
|
|
if not ucr.UnionCase.IsNullary then [item] else []
|
|
| Item_ecref(ecr) ->
|
|
if rfields_of_ecref ecr |> nonNil then [item] else []
|
|
| Item_property(_,pinfos) ->
|
|
let pinfo = List.hd pinfos
|
|
let rty = PropertyTypeOfPropInfo amap m pinfo
|
|
if pinfo.IsIndexer then [item] else []
|
|
| _ -> [])
|
|
|
|
if verbose then dprintf "mkMethods: %d items after filtering for methodness\n" (List.length items);
|
|
|
|
let methods =
|
|
items |> Array.of_list |> Array.map (fun item ->
|
|
{ Description= TextResult(FormatDescriptionOfItem infoReader m denv item);
|
|
Type= (FormatReturnTypeOfItem infoReader m denv item);
|
|
Parameters = Array.of_list (Params.ParamsOfItem infoReader m denv item) })
|
|
|
|
new MethodOverloads(name, methods)
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Scopes.
|
|
//--------------------------------------------------------------------------
|
|
|
|
type Position = int * int
|
|
type Range = Position * Position
|
|
|
|
type FindDeclResult =
|
|
/// no identifier at this locn
|
|
| IdNotFound
|
|
/// no decl info in this buffer at the moment
|
|
| NoDeclInfo
|
|
/// found declaration; return (position-in-file, name-of-file, names-of-referenced-assemblies)
|
|
| DeclFound of Position * string * (string list)
|
|
/// found declaration but source file doesn't exist; try to generate an .fsi
|
|
| NeedToGenerate of string * (string -> string) * (string list)
|
|
|
|
|
|
/// This type is used to describe what was found during the name resolution.
|
|
/// (Depending on the kind of the items, we may stop processing or continue to find better items)
|
|
[<RequireQualifiedAccess>]
|
|
type NameResResult =
|
|
| Members of (NamedItem list * DisplayEnv * range)
|
|
| Cancel of DisplayEnv * range
|
|
| Empty
|
|
|
|
|
|
// A scope represents everything we get back from the typecheck of a file.
|
|
// It acts like an in-memory database about the file.
|
|
// It is effectively immutable and not updated: when we re-typecheck we just drop the previous
|
|
// scope object on the floor and make a new one.
|
|
[<Sealed>]
|
|
type Scope(/// Information corresponding to miscellaneous command-line options (--define, etc).
|
|
sTcConfig: Build.TcConfig,
|
|
g: Env.TcGlobals,
|
|
/// AssemblyName -> IL-Module
|
|
amap: Import.ImportMap,
|
|
/// project directory, or directory containing the file that generated this scope if no project directory given
|
|
sProjectDir: string ,
|
|
sFile:string,
|
|
/// Name resolution environments for every interesting region in the file. These regions may
|
|
/// overlap, in which case the smallest region applicable should be used.
|
|
sEnvs: ResizeArray<range * Nameres.NameResolutionEnv * AccessorDomain>,
|
|
/// This is a name resolution environment to use if no better match can be found.
|
|
sFallback:Nameres.NameResolutionEnv,
|
|
/// Information of exact types found for expressions, that can be to the left of a dot.
|
|
/// Also for exact name resolutions
|
|
/// pos -- line and column
|
|
/// typ - the inferred type for an expression
|
|
/// NamedItem -- named item
|
|
/// DisplayEnv -- information about printing. For example, should redundant keywords be hidden?
|
|
/// NameResolutionEnv -- naming environment--for example, currently open namespaces.
|
|
/// range -- the starting and ending position
|
|
capturedExprTypings: ResizeArray<(pos * typ * DisplayEnv * Nameres.NameResolutionEnv * AccessorDomain * range)>,
|
|
capturedNameResolutions: ResizeArray<(pos * NamedItem * ItemOccurence * DisplayEnv * Nameres.NameResolutionEnv * AccessorDomain * range)>,
|
|
capturedReferenceResolutions : AssemblyResolution list,
|
|
syncop:(unit->unit)->unit) =
|
|
|
|
// These strings are potentially large and the editor may choose to hold them for a while.
|
|
// Use this cache to fold together data tip text results that are the same.
|
|
// 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 getDataTipTextCache = AgedLookup<int*int*string,TextWithXmlSig>(recentForgroundTypeCheckLookupSize)
|
|
|
|
let infoReader = new InfoReader(g,amap)
|
|
let ncenv = new NameResolver(g,amap,infoReader,Nameres.FakeInstantiationGenerator)
|
|
|
|
// Visual Studio uses line counts starting at 0, F# uses them starting at 1
|
|
let mkPos line idx = mk_pos (line+1) idx
|
|
|
|
/// Find the most precise naming environment for the given line and column
|
|
let GetBestEnvForPos cursorPos =
|
|
|
|
let bestSoFar = ref None
|
|
|
|
// Find the most deeply nested enclosing scope
|
|
sEnvs |> ResizeArray.iter (fun (possm,env,ad) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Examining range %s for strict inclusion\n" (string_of_range possm))
|
|
if range_contains_pos possm cursorPos then
|
|
match !bestSoFar with
|
|
| Some (bestm,_,_) ->
|
|
if range_contains_range bestm possm then
|
|
bestSoFar := Some (possm,env,ad)
|
|
| None ->
|
|
bestSoFar := Some (possm,env,ad));
|
|
|
|
let mostDeeplyNestedEnclosingScope = !bestSoFar
|
|
|
|
match mostDeeplyNestedEnclosingScope with
|
|
| Some (m,env,ad) -> Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Strict Inclusion found env for range %s\n" (string_of_range m))
|
|
| None ->Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Strict Inclusion found no environment, cursorPos = %s\n" (string_of_pos cursorPos))
|
|
|
|
// Look for better subtrees on the r.h.s. of the subtree to the left of where we are
|
|
// Should really go all the way down the r.h.s. of the subtree to the left of where we are
|
|
// This is all needed when the index is floating free in the area just after the environment we really want to capture
|
|
// We guarantee to only refine to a more nested environment. It may not be strictly
|
|
// the right environment, but will alwauys be at least as rich
|
|
|
|
let bestAlmostIncludedSoFar = ref None
|
|
|
|
sEnvs |> ResizeArray.iter (fun (possm,env,ad) ->
|
|
if range_before_pos possm cursorPos then
|
|
let contained =
|
|
match mostDeeplyNestedEnclosingScope with
|
|
| Some (bestm,_,_) -> range_contains_range bestm possm
|
|
| None -> true
|
|
|
|
if contained then
|
|
match !bestAlmostIncludedSoFar with
|
|
| Some (rightm,_,_) ->
|
|
if pos_gt (end_of_range possm) (end_of_range rightm) ||
|
|
(pos_eq (end_of_range possm) (end_of_range rightm) &&
|
|
pos_gt (start_of_range possm) (start_of_range rightm)) then
|
|
bestAlmostIncludedSoFar := Some (possm,env,ad)
|
|
| _ -> bestAlmostIncludedSoFar := Some (possm,env,ad));
|
|
|
|
let resEnv =
|
|
match !bestAlmostIncludedSoFar with
|
|
| Some (m,env,ad) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Chose refined-rightmost env covering range %s\n" (string_of_range m))
|
|
env,ad
|
|
| None ->
|
|
match mostDeeplyNestedEnclosingScope with
|
|
| Some (m,env,ad) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Chose refined env covering range %s\n" (string_of_range m))
|
|
env,ad
|
|
| None ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> "Using fallback global env\n")
|
|
(sFallback,AccessibleFromSomeFSharpCode)
|
|
let pm = mk_range sFile cursorPos cursorPos
|
|
|
|
resEnv,pm
|
|
|
|
/// The items that come back from ResolveCompletionsInType are a bit
|
|
/// noisy. Filter a few things out.
|
|
///
|
|
/// e.g. prefer types to constructors for DataTipText
|
|
let FilterItemsForCtors filterCtors items =
|
|
let items = items |> List.filter (function (Item_ctor_group _) when filterCtors = ResolveTypeNamesToTypeRefs -> false | _ -> true)
|
|
items
|
|
|
|
/// Looks at the exact name resolutions that occurred during type checking
|
|
/// If 'membersByResidue' is specified, we look for members of the item obtained
|
|
/// from the name resultion and fitler them by the specified residue (?)
|
|
let GetPreciseItemsFromNameResolution(line,colAtEndOfNames,membersByResidue,filterCtors) =
|
|
let endOfNamesPos = mkPos line colAtEndOfNames
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: line = %d, colAtEndOfNames = %d, endOfNamesPos = %s\n" line colAtEndOfNames (string_of_pos endOfNamesPos))
|
|
|
|
let quals =
|
|
capturedNameResolutions
|
|
|> ResizeArray.filter (fun (pos,_,_,_,_,_,_) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Checking position %s = %s\n" (string_of_pos endOfNamesPos) (string_of_pos pos))
|
|
pos_eq pos endOfNamesPos)
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: Found %d relevant quals\n" quals.Count)
|
|
|
|
let items = quals |> ResizeArray.to_list
|
|
|
|
// Filter items to show only valid & return Some if there are any
|
|
let returnItemsOfType items g denv m f =
|
|
let items = items |> RemoveDuplicateItems g
|
|
let items = items |> RemoveExplicitlySuppressed g
|
|
let items = items |> FilterItemsForCtors filterCtors
|
|
if (items <> []) then
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: Results in %d items!\n" items.Length)
|
|
f(items, denv, m)
|
|
else NameResResult.Empty
|
|
|
|
match items, membersByResidue with
|
|
|
|
// If we're looking for members using a residue, we'd expect only
|
|
// a single item (pick the first one) and we need the residue (which may be "")
|
|
| (_,Item_typs(_,(typ::_)),_,denv,nenv,ad,m)::_, Some(_) ->
|
|
let items = ResolveCompletionsInType ncenv nenv m ad true typ
|
|
returnItemsOfType items g denv m NameResResult.Members
|
|
|
|
// Value reference from the name resolution. Primarilly to disallow "let x.$ = 1"
|
|
// In most of the cases, value references can be obtained from expression typings or from environment,
|
|
// so we wouldn't have to handle values here. However, if we have something like:
|
|
// let varA = "string"
|
|
// let varA = if b then 0 else varA.
|
|
// then the expression typings get confused (thinking 'varA:int'), so we use name resolution even for usual values.
|
|
|
|
| (_, Item_val(vref), occurence, denv, nenv, ad, m)::_, Some(_) ->
|
|
if (occurence <> ItemOccurence.Use) then
|
|
// Return empty list to stop further lookup - for value declarations
|
|
NameResResult.Cancel(denv, m)
|
|
else
|
|
// If we have any valid items for the value, then return completions for its type now
|
|
let items = ResolveCompletionsInType ncenv nenv m ad false vref.TauType
|
|
returnItemsOfType items g denv m NameResResult.Members
|
|
|
|
// No residue, so the items are the full resolution of the name
|
|
|
|
// Grab the first resolution (note the capturedNameResolutions come in in reversed order: latest recorded comes
|
|
// first, so this will be the last name resolution recorded for this text in the file. This is used to update the
|
|
// resolution for an expression
|
|
// new Type
|
|
// to an Item_ctor_group rather than an Item_typs
|
|
| (_,_,_,denv,nenv,ad,m) :: _, None ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseItemsFromNameResolution: No residue, precise results found\n")
|
|
let items = items |> List.map (fun (_,item,_,_,_,_,_) -> item)
|
|
let items = items |> RemoveDuplicateItems g
|
|
let items = items |> RemoveExplicitlySuppressed g
|
|
NameResResult.Members(items, denv,m)
|
|
| _ , _ -> NameResResult.Empty
|
|
|
|
|
|
/// Looks at the exact expression types at the position to the left of the
|
|
/// residue then the source when it was typechecked.
|
|
let GetPreciseCompletionListFromExprTypings(line,colAtEndOfNames,filterCtors) =
|
|
let endOfExprPos = mkPos line colAtEndOfNames
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseCompletionListFromExprTypings: line = %d, colAtEndOfNames = %d, endOfExprPos = %s\n" line colAtEndOfNames (string_of_pos endOfExprPos))
|
|
let quals =
|
|
capturedExprTypings
|
|
|> ResizeArray.filter (fun (pos,_,_,_,_,_) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "Checking position %s = %s\n" (string_of_pos endOfExprPos) (string_of_pos pos))
|
|
pos_eq pos endOfExprPos)
|
|
|> ResizeArray.to_list
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseCompletionListFromExprTypings: Found %d relevant quals\n" quals.Length)
|
|
|
|
// Note the capturedExprTypings come in in reversed order (latest recorded comes first).
|
|
// If expressions overlap we want to find the last one pushed.
|
|
// e.g. this happens with expressions of the form
|
|
// (a + b)
|
|
// which are really
|
|
// ((+) a) b
|
|
// but where both applications are marked to be at the same position
|
|
|
|
// Heuristic "not (is_fun_typ typ)":
|
|
// Generally, we prefer qualItems since it is the result of resolving the particular thing we're dotting off of.
|
|
//
|
|
// However, qualItems isn't guaranteed to be accurate because it's the result of a type check on possibly incomplete
|
|
// code. See bug 2584 for example.
|
|
//
|
|
// We can do a little better when the thing being dotted is thought to be a function by qualItems. In this case, dotting
|
|
// the function will just show methods for System.Object anyway so we can return the best named environment instead since
|
|
// it will also contain the methods for System.Object.
|
|
|
|
quals |> List.iter (fun (_,typ,denv,nenv,ad,m) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseCompletionListFromExprTypings: before filter, type '%s', is_typar_ty=%b, IsFromError=%b\n" (showL (typeL typ)) (is_typar_typ g typ) (is_typar_typ g typ && (dest_typar_typ g typ).IsFromError)))
|
|
|
|
let quals =
|
|
quals |> List.filter (fun (_,typ,denv,nenv,ad,m) ->
|
|
not (is_fun_typ denv.g typ) &&
|
|
not (is_typar_typ denv.g typ && (dest_typar_typ denv.g typ).IsFromError))
|
|
|
|
quals |> List.iter (fun (_,typ,denv,nenv,ad,m) ->
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseCompletionListFromExprTypings: after filter, type '%s'\n" (showL (typeL typ))))
|
|
|
|
match quals |> List.rev with
|
|
| (_,typ,denv,nenv,ad,m) :: _ ->
|
|
let items = ResolveCompletionsInType ncenv nenv m ad false typ
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetPreciseCompletionListFromExprTypings: Results in %d items!\n" items.Length)
|
|
let items = items |> RemoveDuplicateItems g
|
|
let items = items |> RemoveExplicitlySuppressed g
|
|
let items = items |> FilterItemsForCtors filterCtors
|
|
Some(items,denv,m)
|
|
| _ -> None
|
|
|
|
/// Find items in the best naming environment.
|
|
let GetEnvironmentLookupResolutions(line,colAtEndOfNamesAndResidue,plid,filterCtors,showObsolete) =
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetEnvironmentLookupResolutions: line = %d, colAtEndOfNamesAndResidue = %d, plid = %+A, showObsolete = %b\n" line colAtEndOfNamesAndResidue plid showObsolete)
|
|
let cursorPos = mkPos line colAtEndOfNamesAndResidue
|
|
let (nenv,ad),m = GetBestEnvForPos cursorPos
|
|
let items = Nameres.ResolvePartialLongIdent ncenv nenv m ad plid showObsolete
|
|
let items = items |> RemoveDuplicateItems g
|
|
let items = items |> RemoveExplicitlySuppressed g
|
|
let items = items |> FilterItemsForCtors filterCtors
|
|
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "GetEnvironmentLookupResolutions: found %d item groups by looking up long identifier chain in environment\n" (List.length items))
|
|
items, nenv.DisplayEnv,m
|
|
|
|
|
|
/// Resolve a location and/or text to items.
|
|
// Three techniques are used
|
|
// - look for an exact known name resolution from type checking
|
|
// - use the known type of an expression, e.g. (expr).Name, to generate an item list
|
|
// - lookup an entire name in the name resolution environment, e.g. A.B.Name, to generate an item list
|
|
//
|
|
// The overall aim is to resolve as accurately as possible based on what we know from type inference
|
|
|
|
let GetDeclItemsForNamesAtPosition(origLongIdentOpt: string list option,residueOpt,line,(lineStr:string),colAtEndOfNamesAndResidue,filterCtors) =
|
|
use t = Trace.Call("CompilerServices","GetDeclItemsForNamesAtPosition", fun _->sprintf " plid=%+A residueOpt=%+A line=%d colAtEndOfNames=%d" origLongIdentOpt (residueOpt:option<string>) line colAtEndOfNamesAndResidue)
|
|
|
|
// Try to use the exact results of name resolution during type checking to generate the results
|
|
// This is based on position (i.e. colAtEndOfNamesAndResidue). This is not used if a residueOpt is given.
|
|
let nameResItems =
|
|
match residueOpt with
|
|
| None -> GetPreciseItemsFromNameResolution(line, colAtEndOfNamesAndResidue, None, filterCtors)
|
|
| Some(residue) when
|
|
(let loc = colAtEndOfNamesAndResidue - residue.Length - 1
|
|
loc >= 0 && loc < lineStr.Length && lineStr.[loc] = '.') ->
|
|
// for "Foo.B", get location at the end of Foo (or "Foo<int>")
|
|
let colAtEndOfNames = max 0 (colAtEndOfNamesAndResidue - residue.Length - 1)
|
|
GetPreciseItemsFromNameResolution(line, colAtEndOfNames, Some(residue), filterCtors)
|
|
| _ -> NameResResult.Empty
|
|
|
|
// Normalize to form A.B.C.D where D is the residue. It may be empty for "A.B.C."
|
|
let plid, residue =
|
|
match origLongIdentOpt, residueOpt with
|
|
| None, _ -> [], ""
|
|
| Some(origLongIdent), Some(r) -> origLongIdent,r
|
|
| Some(origLongIdent), None ->
|
|
assert (nonNil origLongIdent)
|
|
List.frontAndBack origLongIdent
|
|
|
|
/// Post-filter items to make sure they have precisely the right name
|
|
/// This also checks that there are some remaining results
|
|
let (|FilterRelevantItems|_|) ((items,denv,m) as orig) =
|
|
|
|
// Return only items with the specified name
|
|
let filterDeclItemsByResidue items =
|
|
items |> List.filter (fun item ->
|
|
let n1 = DisplayNameOfItem g item
|
|
Trace.PrintLine("CompilerServicesVerbose", fun () -> sprintf "\nn1 = <<<%s>>>\nn2 = <<<%s>>>\n" n1 residue)
|
|
match item with
|
|
| Item_typs _ | Item_ctor_group _ -> residue + "Attribute" = n1 || residue = n1
|
|
| _ -> residue = n1 )
|
|
|
|
// Are we looking for items with precisely the given name?
|
|
if origLongIdentOpt <> None && items <> [] && isNone residueOpt then
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "looking through %d items before filtering by residue\n" (List.length items))
|
|
let items = items |> filterDeclItemsByResidue
|
|
if nonNil items then Some(items,denv,m) else None
|
|
else
|
|
// When (items = []) we must returns Some([],..) and not None
|
|
// because this value is used if we want to stop further processing (e.g. let x.$ = ...)
|
|
Some(orig)
|
|
|
|
match nameResItems with
|
|
| NameResResult.Cancel(denv,m) -> Some([], denv, m)
|
|
| NameResResult.Members(FilterRelevantItems(items)) ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on name resolution results successful, #items = %d, exists ctor = %b\n" (p13 items).Length (items |> p13 |> List.exists (function Item_ctor_group _ -> true | _ -> false)))
|
|
Some items
|
|
| _ ->
|
|
|
|
match origLongIdentOpt with
|
|
| None -> None
|
|
| Some(_) ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: plid = %+A, residue = %+A, colAtEndOfNamesAndResidue = %+A\n" plid residue colAtEndOfNamesAndResidue)
|
|
|
|
// Try to use the type of the expression on the left to help generate a completion list
|
|
let qualItems =
|
|
// we're looking for 'expr.residue'. Drop the residue and the "."
|
|
if isNil plid then
|
|
None
|
|
else
|
|
let colAtEndOfNames = max 0 (colAtEndOfNamesAndResidue - residue.Length - 1)
|
|
GetPreciseCompletionListFromExprTypings(line,colAtEndOfNames,filterCtors)
|
|
|
|
match qualItems with
|
|
| Some(FilterRelevantItems(items))
|
|
// Initially we only use the expression typings when looking up, e.g. (expr).Nam or (expr).Name1.Nam
|
|
// These come through as a long identifier with plid starting with "". Otherwise we try an environment lookup
|
|
// and then return to the qualItems. This is because the expression typings are a little inaccurate, primarily because
|
|
// it appears we're getting some typings recorded for non-atomic expressions like "f x"
|
|
when (match plid with "" :: _ -> true | _ -> false) ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on expression typings successful\n")
|
|
Some items
|
|
| _ ->
|
|
// Use an environment lookup as the last resort
|
|
|
|
// Do we need to look for obsolete modules & types?
|
|
// This will be true when we're after a dot and we want completions in an (otherwise) unseen module.
|
|
// Note this doesn't mean that we want any unseen things (e.g. private) - only 'Obsolete'!
|
|
// e.g.: SomeModuleName.SomeObsoleteModule.<$> ~> residueOpt = Some("")
|
|
let showObsolete = residueOpt.IsSome
|
|
|
|
let envItems = GetEnvironmentLookupResolutions(line,colAtEndOfNamesAndResidue-1,plid,filterCtors,showObsolete) // we should check whether the skipped char is '.'
|
|
match nameResItems, envItems, qualItems with
|
|
|
|
// First, use unfiltered name resolution items, if they're not empty
|
|
| NameResResult.Members(items, denv, m), _, _ when items <> [] ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on name resolution results successful, #items = %d, exists ctor = %b\n" (items).Length (items |> List.exists (function Item_ctor_group _ -> true | _ -> false)))
|
|
Some(items, denv, m)
|
|
|
|
// If we have nonempty items from environment that were resolved from a type, then use them...
|
|
// (that's better than the next case - here we'd return 'int' as a type)
|
|
| _, FilterRelevantItems(items, denv, m), _ when items <> [] ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "GetDeclItemsForNamesAtPosition: lookup based on name and environment successful\n")
|
|
Some(items, denv, m)
|
|
|
|
// Try again with the qualItems
|
|
| _, _, Some(FilterRelevantItems(items)) ->
|
|
Some(items)
|
|
|
|
| _ -> None
|
|
|
|
member x.GetDeclarations line lineStr colAtEndOfNames (names,residue) : Decls =
|
|
use t = Trace.Call("CompilerServices","GetDeclarations", fun _->sprintf " line=%+A,colAtEndOfNames=%+A,names=%+A" line colAtEndOfNames names)
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
match GetDeclItemsForNamesAtPosition(Some(names),Some(residue),line,lineStr,colAtEndOfNames,ResolveTypeNamesToTypeRefs) with
|
|
| None -> Decls [| |]
|
|
| Some(items,denv,m) -> Decls.Create(infoReader,m,denv,items,syncop))
|
|
(fun msg ->
|
|
//#if DEBUG
|
|
Decls [| Declaration("<Note>", (lazy(msg,None)), 0, syncop) |]
|
|
//#else
|
|
// Decls [| |]
|
|
//#endif
|
|
)
|
|
member scope.GetReferenceResolutionDataTipText(line,lineStr,col) : TextWithXmlSig =
|
|
let pos = Range.mk_pos (line+1) col
|
|
let LineIfExists(append) =
|
|
if not(String.IsNullOrEmpty(append)) then append.Trim([|' '|])+"\n"
|
|
else ""
|
|
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
let matches =
|
|
capturedReferenceResolutions
|
|
|> List.filter(fun resolved->(Range.range_contains_pos resolved.originalReference.Range pos) && (resolved.originalReference.Range <> rangeStartup))
|
|
match matches with
|
|
| [resolved] ->
|
|
let tip =
|
|
match resolved.resolvedFrom with
|
|
| AssemblyFolders ->
|
|
LineIfExists(resolved.resolvedPath)
|
|
+ LineIfExists(resolved.fusionName)
|
|
+ "Found by AssemblyFolders registry key"
|
|
| AssemblyFoldersEx ->
|
|
LineIfExists(resolved.resolvedPath)
|
|
+ LineIfExists(resolved.fusionName)
|
|
+ "Found by AssemblyFoldersEx registry key"
|
|
| TargetFrameworkDirectory ->
|
|
LineIfExists(resolved.resolvedPath)
|
|
+ LineIfExists(resolved.fusionName)
|
|
+ ".NET Framework"
|
|
| RawFileName ->
|
|
LineIfExists(resolved.fusionName)
|
|
| GlobalAssemblyCache ->
|
|
LineIfExists(resolved.fusionName)
|
|
+ "Global Assembly Cache\n"
|
|
+ LineIfExists(resolved.redist)
|
|
| Unknown
|
|
| Path _ ->
|
|
LineIfExists(resolved.resolvedPath)
|
|
+ LineIfExists(resolved.fusionName)
|
|
(tip.TrimEnd([|'\n'|])) ,None
|
|
| _::_ -> failwith "Did not expect multiple results"
|
|
| [] -> "",None)
|
|
(fun err -> err,None)
|
|
|
|
// GetDataTipText: return the "pop up" (or "Quick Info") text given a certain context.
|
|
member x.GetDataTipText line lineStr colAtEndOfNames names : TextWithXmlSig =
|
|
use t = Trace.Call("CompilerServices","GetDataTipText", fun _->sprintf " line=%+A,idx=%+A,names=%+A" line colAtEndOfNames names)
|
|
|
|
let Compute() =
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
match GetDeclItemsForNamesAtPosition(Some(names),None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToTypeRefs) with
|
|
| None -> "", None
|
|
| Some(items,denv,m) ->
|
|
match items with
|
|
| [] -> "",None
|
|
| item :: rest ->
|
|
let item,xmlSigToAdd = FormatDescriptionOfItem infoReader m denv item
|
|
let restText = rest |> List.map (FormatDescriptionOfItem infoReader m denv >> fst)
|
|
// Note: If you change the formatting of ToolTips to not contain "----" when multiple items
|
|
// were returned, make sure to change the test "Quickinfo.OnlyClassInfo" and "Quickinfo.AsyncToolTips" as well.
|
|
let text = System.String.Join("\n-------------\n", Array.of_list (item :: restText))
|
|
(text,xmlSigToAdd))
|
|
(fun err -> err,None)
|
|
|
|
// See devdiv bug 646520 for rationale behind truncating and caching these quick infos (they can be big!)
|
|
let key = line,colAtEndOfNames,lineStr
|
|
let maxLinesInText = 45
|
|
match getDataTipTextCache.TryGet(key) with
|
|
| Some(res) -> res
|
|
| None ->
|
|
let text,xmlSigToAdd = Compute()
|
|
// Trim it down to a reasonable size if necessary.
|
|
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.to_array
|
|
let join = String.Join("\n",lines)
|
|
let res = (join,xmlSigToAdd)
|
|
getDataTipTextCache.Put(key,res)
|
|
res
|
|
|
|
|
|
member x.GetF1Keyword line lineStr colAtEndOfNames names : string option =
|
|
use t = Trace.Call("CompilerServices","GetF1Keyword", fun _->sprintf " line=%+A,idx=%+A,names=%+A" line colAtEndOfNames names)
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
match GetDeclItemsForNamesAtPosition(Some(names),None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToTypeRefs) with
|
|
| None -> None
|
|
| Some(items,denv,m) ->
|
|
match items with
|
|
| [] -> None
|
|
| item :: _ ->
|
|
GetF1Keyword infoReader (Microsoft.FSharp.Compiler.Range.range0) item
|
|
)
|
|
(fun _ -> None)
|
|
|
|
member scope.GetMethods line lineStr colAtEndOfNames namesOpt : MethodOverloads =
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
use t = Trace.Call("CompilerServices", "GetMethods", fun _ -> sprintf "line = %d, idx = %d, names = %+A" line colAtEndOfNames namesOpt)
|
|
match GetDeclItemsForNamesAtPosition(namesOpt,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors) with
|
|
| None -> MethodOverloads("",[| |])
|
|
| Some(items,denv,m) -> MethodOverloads.Create(infoReader,m,denv,items))
|
|
(fun msg ->
|
|
MethodOverloads(msg,[| |]))
|
|
|
|
member scope.GetDeclarationLocationInternal (forceFsiGeneration : bool)(line : int)(lineStr : string)(idx : int)(names : Names)(tag : tokenId option)(isDecl : bool) : FindDeclResult =
|
|
// Get the fully-qualified name of a `namedItemInEnv`
|
|
//
|
|
// This code relies on the fact that the pretty printing code in tastops.ml has been augmented (in subtle ways)
|
|
// to attach "mangled paths" to each item that is pretty printed. These paths
|
|
// are then attached as attributes to the layout object generated by the pretty printing. A somewhat baroque piece of
|
|
// code in FsiGeneration.Renderer (posTrackMappingBuildingR) consumes these attributes during the rendering process
|
|
// and uses them to build up a dicitonary that tracks the "path --> line number" mapping as the printing proceeds.
|
|
// This dictionary is saved. When queried (here), the paths are re-generated using 'fullMangledNameOfItemForFsiGeneration', and
|
|
// this path is used as a key into the dictionary.
|
|
//
|
|
// Thus the behaviour of fullMangledNameOfItemForFsiGeneration must patch the mangled path generation during the recursive-decent pretty printing.
|
|
//
|
|
// It would be better to get remove these pseudo-unique paths altogether and instead simply
|
|
// attach the stamp of the item via a (non-string) attribute to the pretty printing layout object and
|
|
// do the lookup based on the unique integer stamp. However this would require
|
|
// (a) rely on having unique stamps for:
|
|
// - each Abstract IL declaration entity (ILTypeDef, ILMethodDef, ILFieldDef etc.)
|
|
// - each UnionCase and RecordField declaration entity
|
|
// (both would be "Good" to have for other reasons, e.g. get rid of pointer equality on these elements in several places)
|
|
// (b) require us to change the attribution object on layouts to "obj" or some other generic type
|
|
|
|
let rec fullMangledNameOfItemForFsiGeneration x =
|
|
let stringName =
|
|
match x with
|
|
| Item_val v -> approx_full_mangled_name_of_vref v
|
|
| Item_ucase (UnionCaseInfo(_,v)) -> approx_full_mangled_name_of_ucref v
|
|
| Item_ecref v -> approx_full_mangled_name_of_ecref v
|
|
| Item_recdfield (RecdFieldInfo (_, v)) -> approx_full_mangled_name_of_rfref v
|
|
| Item_typs (_, (TType_app (v, _)) :: _) -> approx_full_mangled_name_of_tcref v
|
|
| Item_modrefs (v :: _) -> approx_full_mangled_name_of_modref v
|
|
| Item_meth_group (s, meth :: _) ->
|
|
match meth with // grab just the first overload
|
|
| FSMeth (_,_, v) -> approx_full_mangled_name_of_vref v
|
|
| ILMeth (_,ILMethInfo (t, _, i, _)) ->
|
|
let methName = i.Name // this is the name only of the method, so we'll have to look up the class's full name also
|
|
let className = Item_typs ("", [ t.ToType ]) |> fullMangledNameOfItemForFsiGeneration
|
|
className @ [ methName ] |> PrettyNaming.JoinNamesForFsiGenerationPath
|
|
| _ -> ""
|
|
| Item_il_field (ILFieldInfo (ti, fd)) ->
|
|
let className = Item_typs ("", [ ti.ToType ]) |> fullMangledNameOfItemForFsiGeneration
|
|
className @ [fd.Name] |> PrettyNaming.JoinNamesForFsiGenerationPath
|
|
| _ -> ""
|
|
stringName |> PrettyNaming.SplitNamesForFsiGenerationPath |> PrettyNaming.ChopUnshowableInFsiGenerationPath
|
|
|
|
match tag with
|
|
| None // we have to be charitable in this case -- this makes `scope.GetDeclarationLocation` backward-compatible
|
|
| Some TOKEN_IDENT ->
|
|
match GetDeclItemsForNamesAtPosition (Some(names), None, line, lineStr, idx, ResolveTypeNamesToTypeRefs) with
|
|
| None
|
|
| Some ([], _, _) -> FindDeclResult.IdNotFound
|
|
| Some (h :: _ , denv, m) ->
|
|
let h' =
|
|
match h with
|
|
| Item_meth_group (_, (ILMeth (_,ilinfo)) :: _) // range_of_item, ccu_of_item don't work on IL methods or fields; we'll be okay, though, looking up the method's *type* instead because they've the same CCU / source file
|
|
| Item_ctor_group (_, (ILMeth (_,ilinfo)) :: _) ->
|
|
let (ILMethInfo (typeInfo,_,_,_)) = ilinfo
|
|
Item_typs ("", [ typeInfo.ToType ])
|
|
| Item_il_field (ILFieldInfo (typeInfo, _)) -> Item_typs ("", [ typeInfo.ToType ])
|
|
| _ -> h
|
|
match range_of_item g isDecl h' with
|
|
| None -> FindDeclResult.IdNotFound
|
|
| Some m ->
|
|
if verbose then dprintf "tcConfig.fsharpBinariesDir = '%s'\n" sTcConfig.fsharpBinariesDir
|
|
|
|
let filename = filename_of_item g (Some sProjectDir) m h'
|
|
|
|
let resultInFile = FindDeclResult.DeclFound ((start_line_of_range m - 1, start_col_of_range m), filename, []) // REVIEW: WHAT WAS I THINKING HERE? SINCE I JUST GET THE FILENAME (I.E., NOT THE PROJECT) I'M NOT SURE WHERE I'D FIND THE REF'D ASSEMBLIES FOR A SOURCE FILE
|
|
let generateFsi () =
|
|
match ccu_of_item g h' with
|
|
| Some ccu ->
|
|
match ccu.FileName with
|
|
| Some n when enableInterfaceGeneration() ->
|
|
// Generation of source from assembly is currently disabled
|
|
// it can be turned on using the 'enableInterfaceGeneration' flag
|
|
FindDeclResult.NeedToGenerate (n, Filename.fullpath g.directoryToResolveRelativePaths, fullMangledNameOfItemForFsiGeneration h)
|
|
| _ -> FindDeclResult.IdNotFound
|
|
| _ -> FindDeclResult.IdNotFound
|
|
|
|
if forceFsiGeneration
|
|
then generateFsi ()
|
|
else if Internal.Utilities.FileSystem.File.SafeExists filename
|
|
then resultInFile
|
|
else generateFsi ()
|
|
| _ -> FindDeclResult.IdNotFound
|
|
|
|
member scope.GetDeclarationLocation (line:int)(lineStr:string)(idx:int)(names: Names)(isDecl:bool) : FindDeclResult = scope.GetDeclarationLocationInternal false line lineStr idx names None isDecl
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Navigation items.
|
|
//--------------------------------------------------------------------------
|
|
|
|
/// Represents an item to be displayed in the navigation bar
|
|
[<Sealed>]
|
|
type DeclarationItem(uniqueName : string, name : string, glyph : int, range : range, bodyRange : range, singleTopLevel:bool) =
|
|
|
|
let range_of_m m =
|
|
((start_col_of_range m, start_line_of_range m),
|
|
(end_col_of_range m, end_line_of_range m))
|
|
member x.bodyRange = bodyRange
|
|
|
|
member x.UniqueName = uniqueName
|
|
member x.Name = name
|
|
member x.Glyph = glyph
|
|
member x.Range = range_of_m range
|
|
member x.BodyRange = range_of_m bodyRange
|
|
member x.IsSingleTopLevel = singleTopLevel
|
|
member x.WithUniqueName(uniqueName : string) =
|
|
DeclarationItem(uniqueName, name, glyph, range, bodyRange, singleTopLevel)
|
|
static member Create(name : string, glyph : int, range : range, bodyRange : range, singleTopLevel:bool) =
|
|
DeclarationItem("", name, glyph, range, bodyRange, singleTopLevel)
|
|
|
|
/// Represents top-level declarations (that should be in the type drop-down)
|
|
/// with nested declarations (that can be shown in the member drop-down)
|
|
type TopLevelDeclaration =
|
|
{ Declaration : DeclarationItem
|
|
Nested : DeclarationItem[] }
|
|
|
|
/// Represents result of 'GetNavigationItems' operation - this contains
|
|
/// all the members and currently selected indices. First level correspond to
|
|
/// types & modules and second level are methods etc.
|
|
[<Sealed>]
|
|
type NavigationItems(declarations:TopLevelDeclaration[]) =
|
|
member x.Declarations = declarations
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Untyped scope
|
|
//----------------------------------------------------------------------------
|
|
|
|
type UntypedParseResults =
|
|
{ // Error infos
|
|
Errors : ErrorInfo array
|
|
// Untyped AST
|
|
Input : input option
|
|
// Do not report errors from the type checker
|
|
StopErrorReporting : bool
|
|
/// When these files change then the build is invalid
|
|
DependencyFiles : string list
|
|
}
|
|
|
|
///
|
|
[<Sealed>]
|
|
type UntypedParseInfo(parsed:UntypedParseResults, syncop:(unit -> unit) -> unit) =
|
|
|
|
let union_ranges_checked r1 r2 = if r1 = 0L then r2 elif r2 = 0L then r1 else union_ranges r1 r2
|
|
|
|
let range_of_decls' f decls =
|
|
match (decls |> List.map (f >> (fun (d:DeclarationItem) -> d.bodyRange))) with
|
|
| hd::tl -> tl |> List.fold (union_ranges_checked) hd
|
|
| [] -> 0L
|
|
|
|
let range_of_decls = range_of_decls' fst
|
|
|
|
let moduleRange idm others =
|
|
union_ranges_checked (end_range_of_range idm) (range_of_decls' (fun (a, _, _) -> a) others)
|
|
|
|
let fldspec_range fldspec =
|
|
match fldspec with
|
|
| UnionCaseFields(flds) -> flds |> List.fold (fun st (Field(_, _, _, _, _, _, _, m)) -> union_ranges_checked m st) 0L
|
|
| UnionCaseFullType(ty, _) -> range_of_syntype ty
|
|
|
|
let bodyRange mb decls =
|
|
union_ranges_checked (range_of_decls decls) mb
|
|
|
|
/// Get information for implementation file
|
|
let getNavigationFromImplFile (name:string) (modules:moduleImpl list) =
|
|
|
|
// Map for dealing with name conflicts
|
|
let nameMap = ref Map.empty
|
|
let addItemName name =
|
|
let count = defaultArg (!nameMap |> Map.tryFind name) 0
|
|
nameMap := (Map.add name (count + 1) (!nameMap))
|
|
(count + 1)
|
|
let uniqueName name idx =
|
|
let total = Map.find name (!nameMap)
|
|
sprintf "%s_%d_of_%d" name idx total
|
|
|
|
// Create declaration (for the left dropdown)
|
|
let createDeclLid(baseName, lid, baseGlyph, m, bodym, nested) =
|
|
let name = (if baseName <> "" then baseName + "." else "") + (text_of_lid lid)
|
|
DeclarationItem.Create
|
|
(name, baseGlyph * 6, m, bodym, false), (addItemName name), nested
|
|
|
|
let createDecl(baseName, (id:ident), baseGlyph, m, bodym, nested) =
|
|
let name = (if baseName <> "" then baseName + "." else "") + (id.idText)
|
|
DeclarationItem.Create
|
|
(name, baseGlyph * 6, m, bodym, false), (addItemName name), nested
|
|
|
|
// Create member-kind-of-thing for the right dropdown
|
|
let createMemberLid(lid, baseGlyph, m) =
|
|
DeclarationItem.Create(text_of_lid lid, baseGlyph * 6, m, m, false), (addItemName(text_of_lid lid))
|
|
|
|
let createMember((id:ident), baseGlyph, m) =
|
|
DeclarationItem.Create(id.idText, baseGlyph * 6, m, m, false), (addItemName(id.idText))
|
|
|
|
|
|
// Process let-binding
|
|
let processBinding isMember (Binding(_, kind, _, _, _, _, ValSynData(memebrOpt, _, _), synPat, BindingRhs(_, _, synExpr), m, _)) =
|
|
let m = match synExpr with
|
|
| Expr_typed(e, _, _) -> range_of_synexpr e // fix range for properties with type annotations
|
|
| _ -> range_of_synexpr synExpr
|
|
match synPat, memebrOpt with
|
|
| Pat_lid(lid, _, _, _, _), Some(flags) when isMember ->
|
|
let icon =
|
|
match flags.MemberKind with
|
|
| MemberKindClassConstructor
|
|
| MemberKindConstructor
|
|
| MemberKindMember -> if (flags.MemberIsOverrideOrExplicitImpl || flags.MemberIsVirtual) then iIconGroupMethod2 else iIconGroupMethod
|
|
| MemberKindPropertyGetSet
|
|
| MemberKindPropertySet
|
|
| MemberKindPropertyGet -> iIconGroupProperty
|
|
let lidShow, rangeMerge =
|
|
match lid with
|
|
| slf::nm::_ -> (List.tl lid, nm.idRange)
|
|
| hd::_ -> (lid, hd.idRange)
|
|
| _ -> (lid, m)
|
|
[ createMemberLid(lidShow, icon, union_ranges rangeMerge m) ]
|
|
| Pat_lid(lid, _, _, _, _), _ -> [ createMemberLid(lid, iIconGroupConstant, union_ranges (List.hd lid).idRange m) ]
|
|
| _ -> []
|
|
|
|
// Process a class declaration or F# type declaration
|
|
let rec processTycon baseName (TyconDefn(ComponentInfo(_, _, _, _, lid, _, _, _, _), repr, membDefns, m)) =
|
|
let topMembers = processMembers membDefns |> snd
|
|
match repr with
|
|
| TyconDefnRepr_class(kind, membDefns, mb) -> // mb is odd
|
|
// F# class declaration
|
|
let members = processMembers membDefns |> snd
|
|
let nested = members@topMembers
|
|
([ createDeclLid(baseName, lid, iIconGroupClass, m, bodyRange (start_range_of_range mb) nested, nested) ] : ((DeclarationItem * int * _) list))
|
|
| TyconDefnRepr_simple(simple, _) ->
|
|
// F# type declaration
|
|
match simple with
|
|
| TyconCore_union(_, cases, mb) -> // mb has wrong end, we use only start
|
|
let cases =
|
|
[ for (UnionCase(_, id, fldspec, _, _, m)) in cases ->
|
|
createMember(id, iIconGroupValueType, union_ranges (fldspec_range fldspec) id.idRange) ]
|
|
let nested = cases@topMembers
|
|
[ createDeclLid(baseName, lid, iIconGroupUnion, m, bodyRange (start_range_of_range mb) nested, nested) ]
|
|
| TyconCore_enum(cases, mb) -> // mb is wrong
|
|
let cases =
|
|
[ for (EnumCase(_, id, _, _, m)) in cases ->
|
|
createMember(id, iIconGroupEnumMember, m) ]
|
|
let nested = cases@topMembers
|
|
[ createDeclLid(baseName, lid, iIconGroupEnum, m, bodyRange (start_range_of_range mb) nested, nested) ]
|
|
| TyconCore_recd(_, fields, mb) ->
|
|
let fields =
|
|
[ for (Field(_, _, id, _, _, _, _, m)) in fields do
|
|
if (id.IsSome) then
|
|
yield createMember(id.Value, iIconGroupFieldBlue, m) ]
|
|
let nested = fields@topMembers
|
|
[ createDeclLid(baseName, lid, iIconGroupType, m, bodyRange mb nested, nested) ] // no start_range_of_range here, records work fine
|
|
| TyconCore_abbrev(_, mb) ->
|
|
[ createDeclLid(baseName, lid, iIconGroupTypedef, m, bodyRange mb topMembers, topMembers) ] // should be ok too
|
|
|
|
//| TyconCore_general of TyconKind * (SynType * range * ident option) list * (valSpfn * MemberFlags) list * fieldDecls * bool * bool * range
|
|
//| TyconCore_asm of ILType * range
|
|
//| TyconCore_repr_hidden of range
|
|
| _ -> []
|
|
|
|
// Returns class-members for the right dropdown
|
|
and processMembers members : (int64 * list<DeclarationItem * int>) =
|
|
let members = members |> List.map (fun memb ->
|
|
(range_of_classmember memb,
|
|
match memb with
|
|
| ClassMemberDefn_let_bindings(binds, _, _, _) -> List.collect (processBinding false) binds
|
|
| ClassMemberDefn_member_binding(bind, _) -> processBinding true bind
|
|
| ClassMemberDefn_field(Field(_, _, Some(rcid), ty, _, _, _, _), _) ->
|
|
[ createMember(rcid, iIconGroupFieldBlue, (range_of_syntype ty)) ]
|
|
| ClassMemberDefn_slotsig(ValSpfn(_, id, _, ty, _, _, _, _, _, _, _), flags, _) ->
|
|
[ createMember(id, iIconGroupMethod2, (range_of_syntype ty)) ]
|
|
| ClassMemberDefn_tycon(tycon, _, m3) -> failwith "tycon as member????" //processTycon tycon
|
|
| ClassMemberDefn_interface(synty, Some(membs), _) ->
|
|
processMembers membs |> snd
|
|
| _ -> [] ))
|
|
((members |> Seq.map fst |> Seq.fold union_ranges_checked 0L),
|
|
(members |> List.map snd |> List.concat))
|
|
|
|
// Process declarations in a module that belong to the right drop-down (let bindings)
|
|
let processNestedDeclarations decls = decls |> List.collect (function
|
|
| Def_let(_, binds, _) -> List.collect (processBinding false) binds
|
|
| _ -> [] )
|
|
|
|
// Process declarations nested in a module that should be displayed in the left dropdown
|
|
// (such as type declarations, nested modules etc.)
|
|
let rec processTopLevelDeclarations(baseName, decls) = decls |> List.collect (function
|
|
| Def_module_abbrev(id, lid, m) ->
|
|
[ createDecl(baseName, id, iIconGroupModule, m, range_of_lid lid, []) ]
|
|
|
|
| Def_module(ComponentInfo(_, _, _, _, lid, _, _, _, _), decls, _, m) ->
|
|
// Find let bindings (for the right dropdown)
|
|
let nested = processNestedDeclarations(decls)
|
|
let newBaseName = (if (baseName = "") then "" else baseName+".") + (text_of_lid lid)
|
|
|
|
// Get nested modules and types (for the left dropdown)
|
|
let other = processTopLevelDeclarations(newBaseName, decls)
|
|
createDeclLid(baseName, lid, iIconGroupModule, m, union_ranges_checked (range_of_decls nested) (moduleRange (range_of_lid lid) other), nested)::other
|
|
|
|
| Def_tycons(tydefs, _) -> tydefs |> List.collect (processTycon baseName)
|
|
| Def_partial_tycon(ComponentInfo(_, _, _, _, lid, _, _, _, mimpl), membDefns, m) ->
|
|
// Type augmentation / extension
|
|
let membersM, nested = processMembers membDefns
|
|
[ createDeclLid(baseName, lid, iIconGroupClass, m, union_ranges (start_range_of_range membersM) (range_of_decls nested), nested) ]
|
|
|
|
| Def_exn(ExconDefn(ExconCore(_, (UnionCase(_, id, fldspec, _, _, _)), _, _, _, _), membDefns, _), m) ->
|
|
// Exception declaraton
|
|
let nested = processMembers membDefns |> snd
|
|
[ createDecl(baseName, id, iIconGroupException, m, fldspec_range fldspec, nested) ]
|
|
| _ -> [] )
|
|
|
|
// Collect all the items
|
|
let items =
|
|
// Show base name for this module only if it's not the root one
|
|
let singleTopLevel = (modules.Length = 1)
|
|
modules |> List.collect (fun (ModuleOrNamespaceImpl(id,isModule,decls,_,_,_,m)) ->
|
|
let baseName = if (not singleTopLevel) then text_of_lid id else ""
|
|
// Find let bindings (for the right dropdown)
|
|
let nested = processNestedDeclarations(decls)
|
|
// Get nested modules and types (for the left dropdown)
|
|
let other = processTopLevelDeclarations(baseName, decls)
|
|
|
|
// Create explicitly - it can be 'single top level' thing that is hidden
|
|
let decl =
|
|
DeclarationItem.Create
|
|
(text_of_lid id, iIconGroupModule * 6, m,
|
|
union_ranges_checked (range_of_decls nested) (moduleRange (range_of_lid id) other),
|
|
singleTopLevel), (addItemName(text_of_lid id)), nested
|
|
decl::other )
|
|
|
|
let items =
|
|
items
|
|
|> Array.of_list
|
|
|> Array.map (fun (d, idx, nest) ->
|
|
let nest = nest |> Array.of_list |> Array.map (fun (decl, idx) -> decl.WithUniqueName(uniqueName d.Name idx))
|
|
nest |> Array.sortInPlaceWith (fun a b -> compare a.Name b.Name)
|
|
{ Declaration = d.WithUniqueName(uniqueName d.Name idx); Nested = nest } )
|
|
items |> Array.sortInPlaceWith (fun a b -> compare a.Declaration.Name b.Declaration.Name)
|
|
new NavigationItems(items)
|
|
|
|
member scope.Results = parsed
|
|
|
|
/// Get declaraed items and the selected item at the specified location
|
|
member private scope.GetNavigationItemsImpl() =
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
use t = Trace.Call("CompilerServices", "GetNavigationItems", fun _ -> "")
|
|
match parsed.Input with
|
|
| Some(ImplFileInput(ImplFile(modname,isScript,qualName,pragmas,hashDirectives,modules,canContainEntryPoint))) ->
|
|
getNavigationFromImplFile modname modules
|
|
| Some(SigFileInput(SigFile(modname,qualName,pragmas,hashDirectives,modules))) ->
|
|
new NavigationItems([| |])
|
|
| _ ->
|
|
new NavigationItems([| |]) )
|
|
(fun msg -> new NavigationItems([| |]))
|
|
|
|
member private scope.ValidateBreakpointLocationImpl((line,col)) =
|
|
|
|
|
|
let pos = mk_pos (line+1) col
|
|
let adjust p = (line_of_pos p - 1),(col_of_pos p)
|
|
let adjustRange m = adjust (start_of_range m), adjust (end_of_range m)
|
|
|
|
// Process let-binding
|
|
let findBreakPoints allowSameLine =
|
|
let checkRange m = [ if range_contains_pos m pos || (allowSameLine && start_line_of_range m = line_of_pos pos) then
|
|
yield adjustRange m ]
|
|
let walkBindSeqPt sp = [ match sp with SequencePointAtBinding m -> yield! checkRange m | _ -> () ]
|
|
let walkForSeqPt sp = [ match sp with SequencePointAtForLoop m -> yield! checkRange m | _ -> () ]
|
|
let walkWhileSeqPt sp = [ match sp with SequencePointAtWhileLoop m -> yield! checkRange m | _ -> () ]
|
|
let walkTrySeqPt sp = [ match sp with SequencePointAtTry m -> yield! checkRange m | _ -> () ]
|
|
let walkWithSeqPt sp = [ match sp with SequencePointAtWith m -> yield! checkRange m | _ -> () ]
|
|
let walkFinallySeqPt sp = [ match sp with SequencePointAtFinally m -> yield! checkRange m | _ -> () ]
|
|
|
|
let rec walkBind (Binding(_, _, _, _, _, _, ValSynData(memFlagsOpt,_,_), pat, BindingRhs(_,_,e), _, spInfo)) =
|
|
[ // Don't yield the binding sequence point if there are any arguments, i.e. we're defining a function or a method
|
|
let isFunction =
|
|
isSome memFlagsOpt ||
|
|
match pat with
|
|
| Pat_lid (_,_,args,_,_) when nonNil args -> true
|
|
| _ -> false
|
|
if not isFunction then
|
|
yield! walkBindSeqPt spInfo
|
|
yield! walkExpr (isFunction || (match spInfo with SequencePointAtBinding _ -> false | _-> true)) e ]
|
|
|
|
and walkExprs es = [ for e in es do yield! walkExpr false e ]
|
|
and walkBinds es = [ for e in es do yield! walkBind e ]
|
|
and walkMatchClauses cl =
|
|
[ for (Clause(_,whenExpr,e,_,_)) in cl do
|
|
match whenExpr with Some e -> yield! walkExpr false e | _ -> ()
|
|
yield! walkExpr true e; ]
|
|
|
|
and walkExprOpt (spAlways:bool) eOpt = [ match eOpt with Some e -> yield! walkExpr spAlways e | _ -> () ]
|
|
|
|
// Determine the breakpoint locations for an expression. spAlways indicates we always
|
|
// emit a breakpoing location for the expression unless it is a syntactic control flow construct
|
|
and walkExpr (spAlways:bool) e =
|
|
[ if spAlways && not (IsControlFlowExpression e) then
|
|
yield! checkRange (range_of_synexpr e)
|
|
match e with
|
|
|
|
| Expr_arb _
|
|
| Expr_lid_get _
|
|
| Expr_quote _
|
|
| Expr_asm _
|
|
| Expr_static_optimization _
|
|
| Expr_null _
|
|
| Expr_typeof _
|
|
| Expr_id_get _
|
|
| Comp_zero _
|
|
| Expr_const _ ->
|
|
()
|
|
|
|
| Expr_isinst (e,_,_)
|
|
| Expr_upcast (e,_,_)
|
|
| Expr_addrof (_,e,_,_)
|
|
| Expr_comprehension (_,_,e,_)
|
|
| Expr_array_or_list_of_seq (_,e,_)
|
|
| Expr_typed (e,_,_)
|
|
| Expr_throwaway (e,_)
|
|
| Expr_do (e,_)
|
|
| Expr_assert (e,_)
|
|
| Expr_lvalue_get (e,_,_)
|
|
| Expr_lid_set (_,e,_)
|
|
| Expr_new (_,_,e,_)
|
|
| Expr_tyapp (e,_,_)
|
|
| Expr_constr_field_get (e,_,_,_)
|
|
| Expr_downcast (e,_,_)
|
|
| Expr_inferred_upcast (e,_)
|
|
| Expr_inferred_downcast (e,_)
|
|
| Expr_lazy (e, _)
|
|
| Expr_trait_call(_,_,e,_)
|
|
| Comp_yield (_,e,_)
|
|
| Comp_yieldm (_,e,_)
|
|
| Comp_do_bind (e,_)
|
|
| Expr_paren(e,_) ->
|
|
yield! walkExpr false e
|
|
|
|
| Expr_lid_indexed_set (_,e1,e2,_)
|
|
| Expr_lvalue_set (e1,_,e2,_)
|
|
| Expr_constr_field_set (e1,_,_,e2,_)
|
|
| Expr_ifnull (e1,e2,_)
|
|
| Expr_app (_,e1,e2,_) ->
|
|
yield! walkExpr false e1;
|
|
yield! walkExpr false e2;
|
|
|
|
| Expr_array_or_list (_,es,_)
|
|
| Expr_tuple (es,_) ->
|
|
yield! walkExprs es
|
|
|
|
| Expr_recd (_,_,fs,_) ->
|
|
yield! walkExprs (List.map snd fs)
|
|
|
|
| Expr_impl (_,_,bs,is,_) ->
|
|
yield! walkBinds bs ;
|
|
for (InterfaceImpl(_,bs,_)) in is do yield! walkBinds bs
|
|
| Expr_while (spWhile,e1,e2,_) ->
|
|
yield! walkWhileSeqPt spWhile
|
|
yield! walkExpr false e1;
|
|
yield! walkExpr true e2;
|
|
| Expr_for (spFor,_,e1,_,e2,e3,_) ->
|
|
yield! walkForSeqPt spFor
|
|
yield! walkExpr false e1;
|
|
yield! walkExpr true e2;
|
|
yield! walkExpr true e3;
|
|
| Expr_foreach (spFor,_,_,e1,e2,_) ->
|
|
yield! walkForSeqPt spFor
|
|
yield! walkExpr false e1;
|
|
yield! walkExpr true e2;
|
|
| Expr_lambda (_,_,_,e,_) ->
|
|
yield! walkExpr true e;
|
|
| Expr_match (spBind,e,cl,_,_) ->
|
|
yield! walkBindSeqPt spBind
|
|
yield! walkExpr false e;
|
|
for (Clause(_,whenExpr,e,_,_)) in cl do
|
|
yield! walkExprOpt false whenExpr
|
|
yield! walkExpr true e;
|
|
| Expr_let (_,_,bs,e,_) ->
|
|
yield! walkBinds bs ;
|
|
yield! walkExpr true e;
|
|
|
|
| Expr_try_catch (e,_,cl,_,_,spTry,spWith) ->
|
|
yield! walkTrySeqPt spTry
|
|
yield! walkWithSeqPt spWith
|
|
yield! walkExpr true e
|
|
yield! walkMatchClauses cl
|
|
|
|
| Expr_try_finally (e1,e2,_,spTry,spFinally) ->
|
|
yield! walkExpr true e1
|
|
yield! walkExpr true e2
|
|
yield! walkTrySeqPt spTry
|
|
yield! walkFinallySeqPt spFinally
|
|
| Expr_seq (spSeq,_,e1,e2,_) ->
|
|
yield! walkExpr (match spSeq with SuppressSequencePointOnStmtOfSequential -> false | _ -> true) e1
|
|
yield! walkExpr (match spSeq with SuppressSequencePointOnExprOfSequential -> false | _ -> true) e2
|
|
| Expr_cond (e1,e2,e3opt,spBind,_,_) ->
|
|
yield! walkBindSeqPt spBind
|
|
yield! walkExpr false e1
|
|
yield! walkExpr true e2
|
|
yield! walkExprOpt true e3opt
|
|
| Expr_lbrack_get (e1,es,_,_) ->
|
|
yield! walkExpr false e1;
|
|
yield! walkExprs es;
|
|
|
|
| Expr_lbrack_set (e1,es,e2,_,_) ->
|
|
yield! walkExpr false e1;
|
|
yield! walkExprs es;
|
|
yield! walkExpr false e2;
|
|
| Expr_lvalue_indexed_set (e1,_,e2,e3,_) ->
|
|
yield! walkExpr false e1;
|
|
yield! walkExpr false e2;
|
|
yield! walkExpr false e3;
|
|
|
|
| Comp_bind (spBind,_,_,e1,e2,_) ->
|
|
yield! walkBindSeqPt spBind
|
|
yield! walkExpr true e1
|
|
yield! walkExpr true e2 ]
|
|
|
|
// Process a class declaration or F# type declaration
|
|
let rec walkTycon (TyconDefn(ComponentInfo(_, _, _, _, lid, _, _, _, _), repr, membDefns, m)) =
|
|
[ for m in membDefns do yield! walkMember m
|
|
match repr with
|
|
| TyconDefnRepr_class(_, membDefns, _) ->
|
|
for m in membDefns do yield! walkMember m
|
|
| _ -> () ]
|
|
|
|
// Returns class-members for the right dropdown
|
|
and walkMember memb =
|
|
[ match memb with
|
|
| ClassMemberDefn_let_bindings(binds, _, _, _) -> yield! walkBinds binds
|
|
| ClassMemberDefn_implicit_ctor(_,_,_,_,m) -> yield! checkRange m
|
|
| ClassMemberDefn_member_binding(bind, _) -> yield! walkBind bind
|
|
| ClassMemberDefn_interface(synty, Some(membs), _) -> for m in membs do yield! walkMember m
|
|
| ClassMemberDefn_inherit(_, _, m) ->
|
|
// can break on the "inherit" clause
|
|
yield! checkRange m
|
|
| _ -> () ]
|
|
|
|
// Process declarations nested in a module that should be displayed in the left dropdown
|
|
// (such as type declarations, nested modules etc.)
|
|
let rec walkDecl decl =
|
|
[ match decl with
|
|
| Def_let(_, binds, m) ->
|
|
if range_contains_pos m pos then
|
|
yield! walkBinds binds
|
|
| Def_expr(spExpr,expr, m) ->
|
|
yield! walkBindSeqPt spExpr
|
|
yield! walkExpr false expr
|
|
| Def_module_abbrev(id, lid, m) ->
|
|
()
|
|
| Def_module(ComponentInfo(_, _, _, _, lid, _, _, _, _), decls, _, m) ->
|
|
if range_contains_pos m pos then
|
|
for d in decls do yield! walkDecl d
|
|
| Def_tycons(tydefs, m) ->
|
|
if range_contains_pos m pos then
|
|
for d in tydefs do yield! walkTycon d
|
|
| Def_partial_tycon(ComponentInfo(_, _, _, _, lid, _, _, _, mimpl), membDefns, m) ->
|
|
if range_contains_pos m pos then
|
|
for m in membDefns do yield! walkMember m
|
|
| Def_exn(ExconDefn(ExconCore(_, _, _, _, _, _), membDefns, _), m) ->
|
|
if range_contains_pos m pos then
|
|
for m in membDefns do yield! walkMember m
|
|
| _ ->
|
|
() ]
|
|
|
|
// Collect all the items
|
|
let walkModule (ModuleOrNamespaceImpl(id,isModule,decls,_,_,_,m)) =
|
|
if range_contains_pos m pos then
|
|
[ for d in decls do yield! walkDecl d ]
|
|
else
|
|
[]
|
|
|
|
/// Get information for implementation file
|
|
let walkImplFile (modules:moduleImpl list) =
|
|
[ for x in modules do yield! walkModule x ]
|
|
|
|
match parsed.Input with
|
|
| Some(ImplFileInput(ImplFile(_,_,_,_,_,modules,_))) -> walkImplFile modules
|
|
| _ -> []
|
|
|
|
ErrorScope.Protect
|
|
Range.range0
|
|
(fun () ->
|
|
// Find the last breakpoint reported where the position is inside the region
|
|
match findBreakPoints false |> List.rev with
|
|
| h::t -> Some(h)
|
|
| _ ->
|
|
// If there is no such breakpoint, look for any breakpoint beginning on this line
|
|
match findBreakPoints true with
|
|
| h::t -> Some(h)
|
|
| _ -> None)
|
|
(fun msg -> None)
|
|
|
|
/// When these files appear or disappear the configuration for the current project is invalidated.
|
|
member scope.DependencyFiles() : string list =
|
|
parsed.DependencyFiles
|
|
|
|
member scope.FileName =
|
|
match parsed.Input with
|
|
| Some(ImplFileInput(ImplFile(modname, _, _, _, _, _, _)))
|
|
| Some(SigFileInput(SigFile(modname, _, _, _, _))) -> modname
|
|
| _ -> ""
|
|
|
|
// Get items for the navigation drop down bar
|
|
member scope.GetNavigationItems() =
|
|
use t = Trace.Call("SyncOp","GetNavigationItems", fun _->"")
|
|
// This does not need to be run on the background thread
|
|
scope.GetNavigationItemsImpl()
|
|
|
|
member scope.ValidateBreakpointLocation(pos:Position) =
|
|
use t = Trace.Call("SyncOp","ValidateBreakpointLocation", fun _->"")
|
|
// This does not need to be run on the background thread
|
|
scope.ValidateBreakpointLocationImpl(pos)
|
|
|
|
//----------------------------------------------------------------------------
|
|
// parseSource builds all the information necessary to report errors, match braces and build scopes
|
|
// See service.cpp for the code that picks up the generated data. We don't call the C++ sinks
|
|
// functions directly (i.e. via 'external' calls) since I've had problems
|
|
// using to build DLLs that call from C to and back again. Instead
|
|
// we return an array of specifications of calls that need to be made.
|
|
//--------------------------------------------------------------------------
|
|
|
|
module Parser =
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Error handling for parsing & type checking
|
|
//--------------------------------------------------------------------------
|
|
|
|
let push r x = r := x :: !r
|
|
|
|
type ErrorHandler(reportErrors, mainInputFileName, tcConfig : TcConfig, source:string) =
|
|
let errors = ref false
|
|
let errorsAndWarningsCollector = ref []
|
|
let errorCount = ref 0
|
|
let errorsAreOn = ref false
|
|
let errorsAreFullyOff = ref false
|
|
|
|
// We'll need number of lines for adjusting error messages at EOF
|
|
let fileInfo =
|
|
(source |> Seq.sum_by (fun c -> if c = '\n' then 1 else 0), // number of lines in the source file
|
|
source.Length - source.LastIndexOf("\n",StringComparison.Ordinal) - 1) // length of the last line
|
|
|
|
// This function gets called whenever an error happens during parsing or checking
|
|
let errorSink warn exn =
|
|
if reportErrors then
|
|
let warn = warn && not (ReportWarningAsError tcConfig.globalWarnLevel tcConfig.specificWarnOff tcConfig.specificWarnAsError tcConfig.globalWarnAsError exn)
|
|
if (!errorsAreOn && not !errorsAreFullyOff && (not warn or ReportWarning tcConfig.globalWarnLevel tcConfig.specificWarnOff exn)) then
|
|
let oneError trim exn =
|
|
// We use the first line of the file as a fallbackRange for reporting unexpected errors.
|
|
// Not ideal, but it's hard to see what else to do.
|
|
let fallbackRange = rangeN mainInputFileName 1
|
|
let ei = ErrorInfo.CreateFromExceptionAndAdjustEof(exn,warn,trim,fallbackRange,fileInfo)
|
|
Trace.PrintLine("UntypedParseAux", fun _ -> sprintf "Reporting one error: %s\n" (ei.ToString()))
|
|
push errorsAndWarningsCollector ei
|
|
if not warn then
|
|
errors := true;
|
|
incr errorCount
|
|
|
|
let mainError,relatedErrors = Build.SplitRelatedErrors exn
|
|
oneError false mainError
|
|
List.iter (oneError true) relatedErrors
|
|
|
|
let errorLogger =
|
|
{ new ErrorLogger with
|
|
member x.WarnSink(exn) = errorSink true exn
|
|
member x.ErrorSink(exn) = errorSink false exn
|
|
member x.ErrorCount = !errorCount }
|
|
|
|
let errorsOn () = errorsAreOn := true
|
|
let errorsOff() = errorsAreOn := false
|
|
|
|
(* Errors on while parsing project arguments *)
|
|
do errorsOn()
|
|
|
|
|
|
// Public members
|
|
member x.GetErrorsState() = !errorsAreOn
|
|
member x.ErrorLogger = errorLogger
|
|
member x.ErrorSink = errorSink
|
|
member x.PushErrorInfo ei =
|
|
push errorsAndWarningsCollector ei
|
|
incr errorCount
|
|
member x.CollectedErrorsAndWarnings = !errorsAndWarningsCollector
|
|
member x.ErrorCount = !errorCount
|
|
|
|
// switch error logging on/off
|
|
member x.ErrorsOn() = errorsOn()
|
|
member x.ErrorsOff() = errorsOff()
|
|
member x.ErrorsFullyOff() = errorsAreFullyOff := true;
|
|
member x.AnyErrors = !errors
|
|
|
|
|
|
/// Locate addition #r references for script file.
|
|
let AdditionalReferencesFromScript(mainInputFileName,tcConfig,parseResult,tcImports,tcGlobals,projectDir,tcStateForPriorInputs:tcState,lexResourceManager,(errHandler:ErrorHandler)) =
|
|
if Build.IsScript(mainInputFileName) then
|
|
// Process meta commands to get referenced DLLs
|
|
let fileSpecificTcConfig = ApplyMetaCommandsFromInputToTcConfig tcConfig parseResult
|
|
let capturedReferenceResolutions = GetResolvedAssemblyInformation(fileSpecificTcConfig)
|
|
|
|
Trace.PrintLine("UntypedParseAux", fun () -> sprintf "Computing parse for fsx with referenced DLLs %+A" fileSpecificTcConfig.referencedDLLs)
|
|
|
|
// Handle errors and warnings of #loaded files. See 3149.
|
|
let FilterByHashLoaded handler = function
|
|
| HashLoadedSourceHasIssues _ as loadproblem -> handler loadproblem
|
|
| _ -> ()
|
|
|
|
// From here, we're assuming this is a script project and that there are no other files in the project.
|
|
|
|
let priorErrorsAreOn = errHandler.GetErrorsState()
|
|
errHandler.ErrorsOn() // Don't show errors for prior parsing.
|
|
|
|
let errorLogger =
|
|
{ new ErrorLogger with
|
|
member x.ErrorCount=0;
|
|
member x.WarnSink(err) = FilterByHashLoaded errHandler.ErrorLogger.WarnSink err;
|
|
member x.ErrorSink(err) = FilterByHashLoaded errHandler.ErrorLogger.ErrorSink err }
|
|
let build,dependencyFiles =
|
|
IncrementalFSharpBuild.Create
|
|
(fileSpecificTcConfig, projectDir, "myscript.dll",
|
|
tcStateForPriorInputs.NiceNameGenerator, lexResourceManager,
|
|
[], // Files come from loaded sources.
|
|
true,
|
|
IncrementalFSharpBuild.BuildEvents.Default,errorLogger,
|
|
(fun (e:exn) (m:range) ->raise e));
|
|
|
|
if priorErrorsAreOn then errHandler.ErrorsOn() else errHandler.ErrorsOff() // Don't show errors for prior parsing.
|
|
|
|
let loadedSourcesCount = List.length (fileSpecificTcConfig.GetAvailableLoadedSources())
|
|
let build = IncrementalFSharpBuild.EvalTypeCheckSlot(loadedSourcesCount,build)
|
|
match IncrementalFSharpBuild.GetAntecedentTypeCheckResultsBySlot(loadedSourcesCount,build) with
|
|
| Some(tcState,tcImports,tcGlobals,tcConfig,_) -> tcImports, tcState, tcGlobals,tcConfig,capturedReferenceResolutions
|
|
| None -> tcImports,tcStateForPriorInputs, tcGlobals,tcConfig,capturedReferenceResolutions
|
|
else
|
|
// Process meta commands to get warnings for referenced DLLs
|
|
ApplyMetaCommandsFromInputToTcConfig tcConfig parseResult |> ignore
|
|
tcImports,tcStateForPriorInputs,tcGlobals,tcConfig,[]
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Parsing
|
|
//--------------------------------------------------------------------------
|
|
|
|
let parseSource
|
|
(source: string)
|
|
(matchBracesOnly:bool)
|
|
(reportErrors:bool)
|
|
(mainInputFileName:string)
|
|
(projectSourceFiles : string list)
|
|
(tcConfig : TcConfig)
|
|
:
|
|
(
|
|
// Error infos
|
|
ErrorInfo array *
|
|
// Brace matchin
|
|
(int * int * int * int * int * int * int * int) array (* MatchPair*) *
|
|
// Untyped AST
|
|
input option *
|
|
// Any errors during parsing
|
|
bool
|
|
) =
|
|
|
|
try
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "Service.parseSource %s, matchBraces = %b, reportErrors = %b" mainInputFileName matchBracesOnly reportErrors)
|
|
|
|
// Initialize the error handler
|
|
let errHandler = new ErrorHandler(reportErrors, mainInputFileName, tcConfig, source)
|
|
|
|
// This helps reason=MethodTip to work - todo: investigate why. reason=MethodTip
|
|
// calls with only partial text. Preumably adding this causes the final EndParameters
|
|
// call to refer to a different line than the StartParameters call we're really interested in
|
|
// Or something like that. Yuck.
|
|
let source = source ^ "\n\n\n"
|
|
let lexbuf = UnicodeLexing.StringAsLexbuf source
|
|
|
|
let adjust p = (line_of_pos p - 1),(col_of_pos p)
|
|
|
|
let matchPairRef = ref []
|
|
let matchPairSink m1 m2 =
|
|
if matchBracesOnly then
|
|
let s1,s2 = adjust (start_of_range m1)
|
|
let s3,s4 = adjust (end_of_range m1)
|
|
let s5,s6 = adjust (start_of_range m2)
|
|
let s7,s8 = adjust (end_of_range m2)
|
|
Trace.PrintLine("MatchPairs", fun _ -> sprintf "MatchPair: (%s,%s)\n" (string_of_range m1) (string_of_range m2));
|
|
push matchPairRef (s1,s2,s3,s4,s5,s6,s7,s8)
|
|
|
|
use unwind = InstallGlobalErrorLogger (fun oldLogger -> errHandler.ErrorLogger)
|
|
|
|
(* Errors on while parsing project arguments *)
|
|
|
|
let parseResult =
|
|
if verbose then dprintf "Parsing, text = \n<<<\n%s\n>>>\n" source;
|
|
|
|
// If we're editing a script then we define INTERACTIVE otherwise COMPILED. Since this parsing for intellisense we always
|
|
// define EDITING
|
|
let conditionalCompilationDefines =
|
|
SourceFile.AdditionalDefinesForUseInEditor(mainInputFileName) @ tcConfig.conditionalCompilationDefines
|
|
|
|
(* Note: there is currently no way to override this *)
|
|
|
|
let syntaxFlagRequired = tcConfig.ComputeSyntaxFlagRequired(mainInputFileName)
|
|
let lightSyntaxStatusInital = tcConfig.ComputeLightSyntaxInitialStatus mainInputFileName
|
|
let lightSyntaxStatus = LightSyntaxStatus(lightSyntaxStatusInital,true)
|
|
|
|
// Note: we don't really attempt to intern strings across a large scope
|
|
let lexResourceManager = new Lexhelp.LexResourceManager()
|
|
let lexargs = mkLexargs((fun () -> tcConfig.implicitIncludeDir),
|
|
mainInputFileName,
|
|
conditionalCompilationDefines,
|
|
lightSyntaxStatus,
|
|
lexResourceManager,
|
|
ref [],
|
|
errHandler.ErrorLogger)
|
|
Lexhelp.usingLexbufForParsing (lexbuf, mainInputFileName, None) (fun lexbuf ->
|
|
try
|
|
let skip = true
|
|
let tokenizer = Lexfilter.create syntaxFlagRequired lightSyntaxStatus (Lexer.token lexargs skip) lexbuf
|
|
let lexfun = tokenizer.lexer
|
|
if matchBracesOnly then
|
|
(* Quick bracket matching parse *)
|
|
let parenTokensBalance t1 t2 =
|
|
match t1,t2 with
|
|
| (LPAREN,RPAREN)
|
|
| (LBRACE,RBRACE)
|
|
| (SIG,END)
|
|
| (STRUCT,END)
|
|
| (LBRACK_BAR,BAR_RBRACK)
|
|
| (LBRACK,RBRACK)
|
|
| (BEGIN,END) -> true
|
|
| (LQUOTE q1,RQUOTE q2) when q1 = q2 -> true
|
|
| _ -> false
|
|
let rec matchBraces stack =
|
|
match lexfun lexbuf,stack with
|
|
| tok2,((tok1,m1) :: stack') when parenTokensBalance tok1 tok2-> matchPairSink m1 (Ast.GetLexerRange lexbuf); matchBraces stack'
|
|
| ((LPAREN | LBRACE | LBRACK | LBRACK_BAR | LQUOTE _) as tok),_ -> matchBraces ((tok,Ast.GetLexerRange lexbuf) :: stack)
|
|
| (EOF _ | LEX_FAILURE _),_ -> ()
|
|
| _ -> matchBraces stack
|
|
|
|
matchBraces [];
|
|
None
|
|
else
|
|
let canContainEntryPoint =
|
|
tcConfig.target.IsExe &&
|
|
projectSourceFiles.Length >= 1 &&
|
|
System.String.Compare(List.last projectSourceFiles,mainInputFileName,StringComparison.CurrentCultureIgnoreCase)=0
|
|
|
|
let parseResult = ParseInput(lexfun,errHandler.ErrorLogger,lexbuf,None,mainInputFileName,canContainEntryPoint)
|
|
Some(parseResult)
|
|
with e ->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "Could not recover from errors while parsing: %s\n" (e.ToString()))
|
|
errHandler.ErrorSink false e
|
|
None)
|
|
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "#errors = %d\n" errHandler.CollectedErrorsAndWarnings.Length);
|
|
|
|
Array.of_list (List.rev errHandler.CollectedErrorsAndWarnings),
|
|
Array.of_list (List.rev !matchPairRef),
|
|
parseResult,
|
|
errHandler.AnyErrors
|
|
with
|
|
| e ->
|
|
System.Diagnostics.Debug.Assert(false, sprintf "Bug seen in service-level parse source: %s\n" (e.ToString()))
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "Unexpected error %s\n" (e.ToString()));
|
|
[| |],
|
|
[| |],
|
|
None,
|
|
true
|
|
|
|
type TypecheckResultsSink() =
|
|
let capturedEnvs = new ResizeArray<_>(100)
|
|
let capturedExprTypings = new ResizeArray<_>(100)
|
|
let capturedNameResolutions = new ResizeArray<_>(100)
|
|
interface Nameres.ITypecheckResultsSink with
|
|
member sink.NotifyEnvWithScope(scopem,nenv,ad) = capturedEnvs.Add((scopem,nenv,ad))
|
|
member sink.NotifyExprHasType(endPos,ty,denv,nenv,ad,m) = capturedExprTypings.Add((endPos,ty,denv,nenv,ad,m))
|
|
member sink.NotifyNameResolution(endPos,item,occurenceType,denv,nenv,ad,m) = capturedNameResolutions.Add((endPos,item,occurenceType,denv,nenv,ad,m))
|
|
member x.CapturedEnvs = capturedEnvs
|
|
member x.CapturedExprTypings = capturedExprTypings
|
|
member x.CapturedNameResolutions = capturedNameResolutions
|
|
|
|
let InstallTypecheckResultsSink sink =
|
|
Nameres.GlobalTypecheckResultsSink := Some sink
|
|
{ new IDisposable with member x.Dispose() = Nameres.GlobalTypecheckResultsSink := None }
|
|
|
|
//----------------------------------------------------------------------------
|
|
// Type-checking
|
|
//--------------------------------------------------------------------------
|
|
|
|
let typeCheckSource
|
|
(parseResult:input option)
|
|
(source: string)
|
|
(mainInputFileName:string)
|
|
(projectFileName:string)
|
|
(tcConfig : TcConfig)
|
|
(tcGlobals : TcGlobals)
|
|
(tcImports : TcImports)
|
|
(tcState : tcState)
|
|
(syncop:(unit->unit)->unit)
|
|
(suppressTypecheckErrors : bool)
|
|
: (ErrorInfo array *
|
|
Scope option) =
|
|
try
|
|
let projectDir = Filename.dirname (if projectFileName = "" then mainInputFileName else projectFileName)
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "Service.typeCheckSource %s, projectDir = %s" mainInputFileName projectDir)
|
|
match parseResult with
|
|
// When processing the following cases, we don't need to type-check
|
|
| None -> [| |], None
|
|
|
|
// Run the type checker...
|
|
| Some parsedMainInput ->
|
|
|
|
// Initialize the error handler
|
|
let errHandler = new ErrorHandler(true,mainInputFileName,tcConfig, source)
|
|
|
|
// TODO: get rid of this use of global state and pass the sink as a parameter to the type checker
|
|
use unwind = InstallGlobalErrorLogger (fun oldLogger -> errHandler.ErrorLogger)
|
|
|
|
// If additional references were brought in by the preprocessor then we need to process them
|
|
let lexResourceManager = new Lexhelp.LexResourceManager()
|
|
let tcImportsAfterParse,tcStateForPriorInputs,tcGlobals,tcConfig,capturedReferenceResolutions =
|
|
AdditionalReferencesFromScript(mainInputFileName,tcConfig,parsedMainInput,tcImports,tcGlobals,projectDir,
|
|
tcState,lexResourceManager,errHandler)
|
|
|
|
// If we got real errors during parsing don;t report any more errors at all, but typecheck for intellisense
|
|
if suppressTypecheckErrors then errHandler.ErrorsFullyOff()
|
|
|
|
if verbose then
|
|
tcConfig.includes |> List.iter (fun p -> Trace.PrintLine("CompilerServicesVerbose", fun _ -> sprintf "include directory '%s'\n" p)) ;
|
|
tcConfig.implicitOpens |> List.iter (fun p -> Trace.PrintLine("CompilerServicesVerbose", fun _ -> sprintf "implicit open '%s'\n" p)) ;
|
|
tcConfig.referencedDLLs |> List.iter (fun r -> Trace.PrintLine("CompilerServicesVerbose", fun _ -> sprintf "dll from flags '%s'\n" r.Text)) ;
|
|
|
|
// A problem arises with nice name generation, which really should only
|
|
// be done in the backend, but is also done in the typechecker for better or worse.
|
|
// If we don't do this the NNG accumulates data and
|
|
// we get a memory leak.
|
|
tcStateForPriorInputs.NiceNameGenerator.Reset();
|
|
|
|
// Typecheck the real input.
|
|
let sink = TypecheckResultsSink()
|
|
|
|
// TODO: get rid of this use of global state and pass the sink as a parameter to the type checker
|
|
use unwind2 = InstallTypecheckResultsSink sink
|
|
|
|
let amap = tcImportsAfterParse.GetImportMap()
|
|
let tcEnvAtEnd =
|
|
try
|
|
// Note: this is a long running operation which will make the background build thread unavailable.
|
|
// Ideally we should convert this into an Eventually computation, and time slice it, and perform the continuation
|
|
// as a new SyncOp
|
|
let (tcEnvAtEnd,_,mimpls),_ = TypecheckMultipleInputs ((fun () -> errHandler.ErrorCount = 0),tcConfig,tcImportsAfterParse,tcGlobals,None,tcStateForPriorInputs,[parsedMainInput])
|
|
tcEnvAtEnd
|
|
with e ->
|
|
errHandler.ErrorSink false e
|
|
tcStateForPriorInputs.TcEnvFromSignatures
|
|
|
|
Trace.PrintLine("CompilerServicesVerbose", fun _ -> sprintf "Building and returning scope\n");
|
|
Array.of_list (List.rev errHandler.CollectedErrorsAndWarnings),
|
|
Some (new Scope(tcConfig,tcGlobals, amap ,projectDir,mainInputFileName ,
|
|
sink.CapturedEnvs ,(nenv_of_tenv tcEnvAtEnd),
|
|
sink.CapturedExprTypings,
|
|
sink.CapturedNameResolutions,
|
|
capturedReferenceResolutions,
|
|
syncop))
|
|
with
|
|
| e ->
|
|
System.Diagnostics.Debug.Assert(false, sprintf "Bug seen in service-level parse source: %s\n" (e.ToString()))
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "Unexpected error %s\n" (e.ToString()));
|
|
[| |], None
|
|
|
|
open TokenClassifications
|
|
open ItemDescriptions
|
|
|
|
|
|
|
|
// NOTE: may be better just to move to optional arguments here
|
|
type ParseOptions =
|
|
{ FileName: string
|
|
ProjectFileName: string
|
|
ProjectFileNames: string array
|
|
ProjectOptions: string array
|
|
IsIncompleteTypeCheckEnvironment : bool;
|
|
}
|
|
static member Defaults =
|
|
{ FileName="";
|
|
ProjectFileName="";
|
|
ProjectFileNames= Array.empty;
|
|
ProjectOptions=Array.empty;
|
|
IsIncompleteTypeCheckEnvironment = false;
|
|
}
|
|
/// Whether the two parse options refer to the same project.
|
|
static member AreSameProjectName(options1,options2) =
|
|
options1.ProjectFileName = options2.ProjectFileName
|
|
/// Compare two options sets with respect to the parts of the options that are important to building.
|
|
static member AreSameProject(options1,options2) =
|
|
ParseOptions.AreSameProjectName(options1,options2) &&
|
|
options1.ProjectFileNames = options2.ProjectFileNames &&
|
|
options1.ProjectOptions = options2.ProjectOptions
|
|
/// Compute the project directory.
|
|
member po.ProjectDirectory
|
|
with get() = System.IO.Path.GetDirectoryName(po.ProjectFileName)
|
|
|
|
/// A thin wrapper over a Decls object (we could eventually eleiminate one for the other)
|
|
[<Sealed>]
|
|
type DeclarationSet(v: Decls) =
|
|
member x.Items = v.Items
|
|
|
|
[<Sealed>]
|
|
type TypeCheckInfo(scope: Scope, fsiGens : (string -> string) -> string -> FsiGeneration.FsiGenerationResult, syncop: (unit->unit)->unit) =
|
|
|
|
|
|
let runSyncOp f =
|
|
let result = ref None
|
|
syncop (fun () -> result := Some(f()))
|
|
Option.get !result
|
|
|
|
/// Resolve the names at the given location to a set of declarations
|
|
member info.GetDeclarations((line,colAtEndOfNames),lineStr,names:NamesWithResidue,tokenTag:int) =
|
|
use t = Trace.Call("SyncOp","GetDeclarations", fun _->sprintf " at=(%d:%d),names=%+A" line colAtEndOfNames names)
|
|
runSyncOp (fun () -> DeclarationSet(scope.GetDeclarations line lineStr colAtEndOfNames names))
|
|
|
|
/// Resolve the names at the given location to give a data tip
|
|
member info.GetDataTipText((x1,x2),lineStr,names:Names,tokenTag:int) =
|
|
use t = Trace.Call("SyncOp","GetDataTipText", fun _->sprintf " at=(%d:%d),names=%+A tag=%d tokenId=%+A" x1 x2 names tokenTag (tokenTagToTokenId tokenTag))
|
|
match tokenTagToTokenId tokenTag with
|
|
| TOKEN_IDENT ->
|
|
runSyncOp (fun () -> TextResult(scope.GetDataTipText x1 lineStr x2 names))
|
|
| TOKEN_STRING | TOKEN_STRING_TEXT ->
|
|
runSyncOp (fun () -> TextResult(scope.GetReferenceResolutionDataTipText(x1,lineStr,x2)))
|
|
| _ -> TextResult(("",None))
|
|
|
|
member info.GetF1Keyword ((line,colAtEndOfNames),lineStr,names) : string option =
|
|
use t = Trace.Call("SyncOp","GetF1Keyword", fun _->sprintf " at=(%d:%d),names=%+A" line colAtEndOfNames names)
|
|
runSyncOp (fun () -> scope.GetF1Keyword line lineStr colAtEndOfNames names)
|
|
|
|
|
|
// Resolve the names at the given location to a set of methods
|
|
member info.GetMethods((x1,x2):Position,lineStr:string,names:Names option,tokenTag:int) =
|
|
use t = Trace.Call("SyncOp","GetMethods", fun _->sprintf " at=(%d:%d),names=%+A" x1 x2 names)
|
|
runSyncOp (fun () -> scope.GetMethods x1 lineStr x2 names)
|
|
|
|
member info.GetDeclarationLocationInternal (forceFsiGeneration : bool)((x1, x2) : Position, lineStr:string, names : Names, tokenTag : int, flag : bool) =
|
|
use t = Trace.Call("SyncOp","GetDeclarationLocation", fun _->sprintf " at=(%d:%d),names=%+A,flag=%+A" x1 x2 names flag)
|
|
let result = ref None
|
|
let GetDeclarationLocation() =
|
|
let res = scope.GetDeclarationLocationInternal forceFsiGeneration x1 lineStr x2 names (Some (tokenTagToTokenId tokenTag)) flag
|
|
let res =
|
|
match res with
|
|
| FindDeclResult.NeedToGenerate (s, fnf, nm) ->
|
|
// NOTE: This will be called only when 'enableInterfaceGeneration' is set to 'true'
|
|
assert(enableInterfaceGeneration())
|
|
match (fsiGens fnf s) with
|
|
| Some (f, m, assms) ->
|
|
|
|
|
|
// Search for the item that has specified name as the prefix
|
|
// This fixes the issue when reported name contains additional items (to be unique)
|
|
// such as ["Class"; "foo"; "1"; "Static"] and we're looking for ["Class"; "foo"]
|
|
let rec tryGetValueUsingPrefix (names:ResizeArray<string>) =
|
|
let ok, point = m.TryGetValue(List.of_seq names)
|
|
if ok then ok, point
|
|
else
|
|
names.RemoveAt(names.Count - 1)
|
|
tryGetValueUsingPrefix names
|
|
|
|
let ok,point = tryGetValueUsingPrefix (ResizeArray.of_list nm)
|
|
if ok then
|
|
let x,y = point
|
|
FindDeclResult.DeclFound ((y, x), f, assms)
|
|
else FindDeclResult.DeclFound ((0, 0), f, assms) // couldn't find the identifier; let's show the file anyhow
|
|
| None -> FindDeclResult.NoDeclInfo
|
|
| _ -> res
|
|
result:=Some(res)
|
|
syncop GetDeclarationLocation
|
|
Option.get !result
|
|
|
|
/// Resolve the names at the given location to the declaration location of the corresponding construct
|
|
member info.GetDeclarationLocation (p, lineStr, names, tokenTag, flag) = info.GetDeclarationLocationInternal false (p, lineStr, names, tokenTag, flag)
|
|
|
|
/// Information about the compilation environment
|
|
module CompilerEnvironment =
|
|
/// These are the names of assemblies that should be referenced for scripting (.fsx)
|
|
let DefaultReferencesForScripting = scriptingFramework
|
|
|
|
/// These are the names of assemblies that should be referenced for .fs, .ml, .fsi, .mli files that
|
|
/// are not asscociated with a project
|
|
let DefaultReferencesForOrphanSources = coreFramework @ extendedFramework
|
|
|
|
// Apply command-line arguments.
|
|
let ApplyCommandLineArgumentsToTcConfig(commandLineArgs, tcConfig) =
|
|
try
|
|
ParseCompilerOptions
|
|
(fun sourceOrDll -> () )
|
|
(Fscopts.GetCoreServiceCompilerOptions tcConfig)
|
|
commandLineArgs
|
|
with e -> errorRecovery e range0
|
|
|
|
#if TRYING_TO_FIX_4577
|
|
#else
|
|
let ProjectGlobalsScope(projectDir) =
|
|
if String.IsNullOrEmpty(projectDir) then null
|
|
else
|
|
let savedDirectory = System.IO.Directory.GetCurrentDirectory()
|
|
System.IO.Directory.SetCurrentDirectory(projectDir)
|
|
{new IDisposable with
|
|
member d.Dispose() =
|
|
System.IO.Directory.SetCurrentDirectory(savedDirectory) }
|
|
#endif
|
|
|
|
/// Create a type-check configuration
|
|
let CreateTcConfig(projectDir,commandLineArgs,mainFileName:string) =
|
|
let defaultFSharpBinariesDir =
|
|
match Internal.Utilities.FSharpEnvironment.FSharpRunningBinFolder with
|
|
Some(dir)->dir
|
|
| None -> System.Environment.GetEnvironmentVariable("mFSharp_BinDir")
|
|
|
|
#if TRYING_TO_FIX_4577
|
|
#else
|
|
use unwind = ProjectGlobalsScope(projectDir)
|
|
#endif
|
|
let tcConfigB = Build.TcConfigBuilder.CreateNew(defaultFSharpBinariesDir, true (* optimize for memory *), projectDir)
|
|
// The following uses more memory but means we don't take read-exclusions on the DLLs we reference
|
|
// Could detect well-known assemblies--ie System.dll--and open them with read-locks
|
|
tcConfigB.openBinariesInMemory <- true;
|
|
tcConfigB.resolutionEnvironment
|
|
<- if SourceFile.MustBeSingleFileProject(mainFileName)
|
|
then MSBuildResolver.RuntimeLike
|
|
else MSBuildResolver.CompileTimeLike
|
|
|
|
ApplyCommandLineArgumentsToTcConfig(commandLineArgs, tcConfigB)
|
|
|
|
if tcConfigB.framework then
|
|
// ~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
|
|
// If you see a failure here running unittests consider whether it it caused by
|
|
// a mismatched version of Microsoft.Build.Framework. Run unittests under a debugger. If
|
|
// you see an old version of Microsoft.Build.*.dll getting loaded it it is likely caused by
|
|
// using an old ITask or ITaskItem from some tasks assembly.
|
|
// I solved this problem by adding a Unittests.config.dll which has a binding redirect to
|
|
// the current (right now, 4.0.0.0) version of the tasks assembly.
|
|
// ~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
|
|
System.Diagnostics.Debug.Assert(false, "Language service requires --noframework flag")
|
|
tcConfigB.framework<-false
|
|
tcConfigB
|
|
|
|
/// Gets compiler defines.
|
|
let CreateEditorDefines(filename:string, compilerFlags :string list) =
|
|
use t = Trace.Call("CompilerEnvironment","CreateEditorDefines", fun () -> sprintf "filename = %s, compilerFlags = %A" filename compilerFlags)
|
|
// Ignore errors in command line args on this path
|
|
// Ideally we would explicitly install DiscardErrorsLogger here. However different threads are using the error logger!
|
|
// Indeed we really have to move to a model where the error logger is passed explicitly everywhere in the codebase.
|
|
// For the moment we jsut make the default global error logger discard errors.
|
|
// use unwind = InstallGlobalErrorLogger (fun _ -> DiscardErrorsLogger)
|
|
let tcConfigB = CreateTcConfig(@"C:\" (*dummy path unused*), compilerFlags, filename)
|
|
let tcConfig = TcConfig.Create(tcConfigB,validate=false)
|
|
|
|
let defines = tcConfig.conditionalCompilationDefines
|
|
let defines = SourceFile.AdditionalDefinesForUseInEditor(filename) @ defines
|
|
defines
|
|
|
|
let definesCache = MruCache(Flags.definesCacheSize, CreateEditorDefines)
|
|
|
|
/// Publish compiler-flags parsing logic
|
|
let GetCompilationDefinesForEditing(filename:string, compilerFlags : string list) =
|
|
definesCache.Get((filename,compilerFlags))
|
|
|
|
/// Information about the debugging environment
|
|
module DebuggerEnvironment =
|
|
/// Return the language ID, which is the expression evaluator id that the
|
|
/// debugger will use.
|
|
let GetLanguageID() =
|
|
System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy)
|
|
|
|
[<Sealed>]
|
|
type TypeCheckResults(errors: ErrorInfo array,
|
|
scope: TypeCheckInfo option,
|
|
untypedInfo : UntypedParseInfo) =
|
|
member pr.Errors = errors
|
|
member pr.TypeCheckInfo = scope
|
|
member pr.UntypedParse = untypedInfo
|
|
|
|
/// Callbacks to notify of background changes
|
|
[<AutoSerializable(false)>]
|
|
type BackgroundCompilerEvents =
|
|
{ FileTypeCheckStateIsDirty: string -> unit }
|
|
|
|
// Identical to _VSFILECHANGEFLAGS in vsshell.idl
|
|
type DependencyChangeCode =
|
|
| Nil = 0x00000000 // Not an actual value - here to make FxCop happy
|
|
| FileChanged = 0x00000001
|
|
| TimeChanged = 0x00000002
|
|
| Size = 0x00000004
|
|
| Deleted = 0x00000008
|
|
| Added = 0x00000010
|
|
|
|
module Reactor =
|
|
open Microsoft.FSharp.Control
|
|
|
|
|
|
|
|
type ReactorCommands =
|
|
/// Kick off a build.
|
|
| StartBuild of ParseOptions
|
|
/// Kick off the most recently known build.
|
|
| StartRecentBuild
|
|
/// Do a bit of work on the given build.
|
|
| Step
|
|
/// Do some work synchronized in the mailbox.
|
|
| SyncOp of (unit->unit) * AsyncReplyChannel<ResultOrException<unit>>
|
|
/// Do some work not synchronized in the mailbox.
|
|
| AsyncOp of (unit->unit)
|
|
/// Stop building after finishing the current unit of work.
|
|
| StopBuild of AsyncReplyChannel<ResultOrException<unit>>
|
|
/// Finish building.
|
|
| FinishBuild of AsyncReplyChannel<ResultOrException<unit>>
|
|
override rc.ToString() =
|
|
match rc with
|
|
| StartBuild _->"StartBuild"
|
|
| StartRecentBuild -> "StartRecentBuild"
|
|
| Step->"Step"
|
|
| SyncOp _->"SyncOp"
|
|
| AsyncOp _->"AsyncOp"
|
|
| StopBuild _->"StopBuild"
|
|
| FinishBuild _->"FinishBuild"
|
|
|
|
type ReactorState =
|
|
| Idling
|
|
| ActivelyBuilding of ParseOptions
|
|
| FinishingBuild of ParseOptions * AsyncReplyChannel<ResultOrException<unit>>
|
|
| BackgroundError of Exception // An exception was seen in a prior state. The exception is preserved so it can be thrown back to the calling thread.
|
|
override rs.ToString() =
|
|
match rs with
|
|
| Idling->"Idling"
|
|
| ActivelyBuilding _->"ActivelyBuilding"
|
|
| FinishingBuild _->"FinishingBuild"
|
|
| BackgroundError _->"BackgroundError"
|
|
|
|
[<AutoSerializable(false)>]
|
|
/// There is one global Reactor for the entire language service, no matter how many projects or files
|
|
/// are open.
|
|
type Reactor(backgroundCompilerEvents:BackgroundCompilerEvents) =
|
|
//------------------------------------------------------------------------------------
|
|
// Rules for reactive building.
|
|
//
|
|
// This phrases the compile as a series of vector functions and vector manipulations.
|
|
//
|
|
// Rules written in this language are then transformed into a plan to execute the
|
|
// various steps of the process in small parts.
|
|
//-----------------------------------------------------------------------------------
|
|
let CreateIncrementalBuilder (options:ParseOptions) =
|
|
use t = Trace.Call("Reactor","CreateIncrementalBuilder", fun () -> sprintf "options = %+A" options)
|
|
#if TRYING_TO_FIX_4577
|
|
#else
|
|
// Set the project directory
|
|
use unwind = CompilerEnvironment.ProjectGlobalsScope(options.ProjectDirectory)
|
|
#endif
|
|
// Trap and report warnings and errors from creation.
|
|
use errorScope = new ErrorScope()
|
|
|
|
// Create the builder.
|
|
let resourceManager = new Lexhelp.LexResourceManager()
|
|
let sourceFiles = (options.ProjectFileNames|>Array.to_list)
|
|
|
|
let commandLineArgs = options.ProjectOptions |> Array.to_list
|
|
|
|
// Build initial TC config
|
|
let tcConfigB = CompilerEnvironment.CreateTcConfig(options.ProjectDirectory, commandLineArgs, options.FileName)
|
|
let outfile,pdbfile,assemblyName = tcConfigB.DecideNames sourceFiles
|
|
|
|
let tcConfig = TcConfig.Create(tcConfigB,validate=true)
|
|
// Share intern'd strings across all lexing/parsing
|
|
let niceNameGen = NiceNameGenerator()
|
|
let lexResourceManager = new Lexhelp.LexResourceManager()
|
|
|
|
// Sink internal errors and warnings.
|
|
let warnSink (exn:exn) = Trace.PrintLine("IncrementalBuild", (exn.ToString >> sprintf "Background warning: %s"))
|
|
let errorSink (exn:exn) = Trace.PrintLine("IncrementalBuild", (exn.ToString >> sprintf "Background error: %s"))
|
|
|
|
//--------------------------------------------------------------------------------------------------------
|
|
// Background notifications switched back to the given thread context.
|
|
//--------------------------------------------------------------------------------------------------------
|
|
let HandleBackgroundBeforeTypeCheckFile(filename:string) =
|
|
backgroundCompilerEvents.FileTypeCheckStateIsDirty(filename)
|
|
|
|
let builder, dependencyFiles =
|
|
let errorLogger =
|
|
{ new ErrorLogger with
|
|
member x.ErrorCount=0;
|
|
member x.WarnSink(e)=warnSink e;
|
|
member x.ErrorSink(e)=errorSink e }
|
|
IncrementalFSharpBuild.Create (tcConfig, options.ProjectDirectory, assemblyName, niceNameGen,
|
|
resourceManager, sourceFiles,
|
|
true, // stay reactive
|
|
{ BeforeTypeCheckFile = HandleBackgroundBeforeTypeCheckFile },
|
|
errorLogger,
|
|
(fun (e:exn)->raise e))
|
|
|
|
Trace.PrintLine("IncrementalBuild", fun () -> sprintf "CreateIncrementalBuilder: %A" dependencyFiles)
|
|
#if DEBUG
|
|
dependencyFiles |> List.iter (fun df -> System.Diagnostics.Debug.Assert(System.IO.Path.IsPathRooted(df.Filename), sprintf "dependency file was not absolute: '%s'" df.Filename))
|
|
#endif
|
|
(tcConfig, builder, dependencyFiles, errorScope.ErrorsAndWarnings)
|
|
|
|
/// Cache of builds keyed by options.
|
|
let buildCache = MruCache(Flags.buildCacheSize, CreateIncrementalBuilder, areSame = ParseOptions.AreSameProject, areSameForSubsumption = ParseOptions.AreSameProjectName)
|
|
|
|
/// See if the build cache needs to be invalidated. Return true if there was an invalidation.
|
|
let InvalidateBuildCacheEntry(options,changedFiles: (string * DependencyChangeCode) list) =
|
|
let t = Trace.Call("ChangeEvents","InvalidateBuildCacheEntry", fun _ -> sprintf "Received notification to invalidate build. Changed files are:\n%A" changedFiles)
|
|
|
|
match buildCache.GetAvailable(options) with
|
|
| None -> ()
|
|
| Some(tcConfigA,builderA,dependencyFilesA,errorsA) ->
|
|
let IsExistentialChangeCode(file,code) =
|
|
(int (code &&& (DependencyChangeCode.Added ||| DependencyChangeCode.Deleted)))<>0
|
|
|
|
// The list of adds and deletes
|
|
let existenceChange = changedFiles
|
|
|> List.filter IsExistentialChangeCode
|
|
|> List.map fst
|
|
|
|
// The list of files for which an add or delete would cause a refresh of the TcConfig
|
|
let existenceDependencies = dependencyFilesA
|
|
|> List.filter(fun dep -> dep.ExistenceDependency)
|
|
|> List.map(fun dep -> dep.Filename)
|
|
|
|
// REVIEW: this doesn't look correct - we are ignoring the names in 'existenceChange'
|
|
let acc (last:bool) (file:string) : bool =
|
|
last or List.exists (fun s->true) existenceChange
|
|
let configurationRefresh = existenceDependencies |> List.fold acc false
|
|
|
|
if configurationRefresh then
|
|
Trace.PrintLine("ChangeEvents", fun _ -> "Refreshing configuration")
|
|
|
|
let tcConfigB, builderB, dependencyFilesB, errorsB = CreateIncrementalBuilder(options)
|
|
buildCache.SetAlternate(options, (tcConfigB, builderB, dependencyFilesB, errorsB))
|
|
else
|
|
Trace.PrintLine("ChangeEvents", fun _ -> "Not refreshing configuration because the change indicated only an incremental build is needed")
|
|
|
|
|
|
|
|
/// Get the antecedant typecheck state for the give file (in the options). Return none if not available.
|
|
let GetAntecendantResultWithoutSideEffects(options) =
|
|
match buildCache.GetAvailable(options) with
|
|
| Some(_,build,dependencyFiles,createErrors) ->
|
|
let slotOfFile = IncrementalFSharpBuild.GetSlotOfFileName(options.FileName, build)
|
|
Some(build, dependencyFiles, createErrors, IncrementalFSharpBuild.GetAntecedentTypeCheckResultsBySlot(slotOfFile,build))
|
|
| None->None
|
|
|
|
|
|
/// Parses the source file and returns untyped AST
|
|
let UntypedParseImpl (source,options) syncop =
|
|
Trace.PrintLine("CompilerServices", fun _ -> "Service.UntypedParseImpl")
|
|
use t = Trace.CallByThreadNamed("Reactor", "UntypedParseImpl", "ThreadPool", fun _->"")
|
|
|
|
let tcConfig,_,dependencyFiles,_ = buildCache.Get(options) // Q: Whis it it ok to ignore createErrors in the build cache? A: These errors will be appended into the typecheck results
|
|
|
|
// Do the parsing.
|
|
let parseErrors, matchPairs, inputOpt, anyErrors =
|
|
Parser.parseSource
|
|
source
|
|
false
|
|
true
|
|
options.FileName
|
|
(options.ProjectFileNames |> Array.to_list)
|
|
tcConfig
|
|
|
|
// Strip everything but the file name.
|
|
let dependencyFiles = dependencyFiles |> List.map (fun dep->dep.Filename)
|
|
|
|
UntypedParseInfo(parsed = { Errors = parseErrors;
|
|
Input = inputOpt;
|
|
StopErrorReporting = anyErrors
|
|
DependencyFiles = dependencyFiles},
|
|
syncop = syncop)
|
|
|
|
/// Parses the source file and returns untyped AST
|
|
let MatchBracesImpl (source,options) syncop =
|
|
Trace.PrintLine("CompilerServices", fun _ -> "Service.MatchBracesImpl")
|
|
use t = Trace.CallByThreadNamed("Reactor", "MatchBracesImpl", "ThreadPool", fun _->"")
|
|
let tcConfig,_,_,_ = buildCache.Get(options)
|
|
// Do the parsing.
|
|
let parseErrors, matchPairs, inputOpt, anyErrors =
|
|
Parser.parseSource
|
|
source
|
|
true
|
|
false
|
|
options.FileName
|
|
(options.ProjectFileNames |> Array.to_list)
|
|
tcConfig
|
|
|
|
matchPairs |> Array.map (fun (s1,s2,s3,s4,s5,s6,s7,s8) -> ((s1,s2),(s3,s4)),((s5,s6),(s7,s8)))
|
|
|
|
/// Type-check the result obtained by parsing
|
|
/// The input should be first parsed using 'UntypedParseImpl'
|
|
let TypeCheckSourceImpl (parseResult:UntypedParseResults) source options syncop =
|
|
use t = Trace.CallByThreadNamed("Reactor", "TypeCheckSourceImpl", "ThreadPool", fun _->"")
|
|
match GetAntecendantResultWithoutSideEffects(options) with
|
|
| Some(build,dependencyFiles,createErrors,Some(tcPriorState,tcImports,tcGlobals,tcConfig,antecedantTimeStamp)) ->
|
|
|
|
// Run the function
|
|
let suppressTypecheckErrors = parseResult.StopErrorReporting
|
|
let tcErrors, scopeOpt =
|
|
Parser.typeCheckSource
|
|
parseResult.Input
|
|
source
|
|
options.FileName
|
|
options.ProjectFileName
|
|
tcConfig
|
|
tcGlobals
|
|
tcImports
|
|
tcPriorState
|
|
syncop
|
|
suppressTypecheckErrors
|
|
|
|
// Collect thunks for .fsi generators used by GotoDefinition
|
|
let (generators, build) = IncrementalFSharpBuild.GetFsiGenerators build
|
|
|
|
// Append all the errors together.
|
|
let errors =
|
|
[| yield! createErrors;
|
|
yield! parseResult.Errors
|
|
if options.IsIncompleteTypeCheckEnvironment then
|
|
yield! Seq.truncate Flags.maxErrorsOutOfProjectContext tcErrors
|
|
else
|
|
yield! tcErrors |]
|
|
|
|
let res =
|
|
TypeCheckResults (errors = errors,
|
|
scope = (scopeOpt |> Option.map (fun v -> TypeCheckInfo (v, generators, syncop))),
|
|
untypedInfo = new UntypedParseInfo(parseResult, syncop))
|
|
|
|
Some res
|
|
| _ ->
|
|
// Either the builder did not exist or the antecedent to the slot was not ready. Return 'None'.
|
|
// The caller will send a request for a background build of this project. This
|
|
// will create the builder and notify the UI when the antecedent to the slot is ready.
|
|
None
|
|
|
|
/// Mailbox dispatch function.
|
|
let Dispatch (inbox:MailboxProcessor<_>) =
|
|
|
|
// Post an exception back to FinishingBuild channel.
|
|
let UnexpectedFinishingBuild commandName (channel:AsyncReplyChannel<_>) =
|
|
channel.Reply(Exception (new Exception(sprintf "[Bug]Did not expect %s during FinishingBuild." commandName)))
|
|
|
|
// Kick off a build.
|
|
let HandleStartBuild options state =
|
|
inbox.Post Step
|
|
match state with
|
|
| ActivelyBuilding(_)
|
|
| Idling -> ActivelyBuilding options
|
|
| FinishingBuild(_) -> state
|
|
| BackgroundError(_)-> state
|
|
|
|
// Kick off a build of the most recently known project if there is one.
|
|
let HandleStartRecentBuild = function
|
|
| Idling ->
|
|
match buildCache.MostRecent with
|
|
| Some(options,_)->HandleStartBuild options Idling
|
|
| None -> Idling
|
|
| state -> state
|
|
|
|
// Stop the build.
|
|
let HandleStopBuild (channel:AsyncReplyChannel<_>) state =
|
|
buildCache.Clear()
|
|
match state with
|
|
| ActivelyBuilding(_)
|
|
| Idling -> channel.Reply(Result ())
|
|
| FinishingBuild(options,channel) -> UnexpectedFinishingBuild "StopBuild" channel
|
|
| BackgroundError(e)-> channel.Reply(Exception e)
|
|
Idling
|
|
|
|
// Do the given operation
|
|
let HandleAsyncOp op state =
|
|
use t = Trace.CallByThreadNamed("Reactor", "HandleAsyncOp", "ThreadPool", fun _->sprintf "state=%+A" state)
|
|
match state with
|
|
| ActivelyBuilding(_)
|
|
| BackgroundError(_)
|
|
| Idling ->
|
|
try
|
|
op()
|
|
state
|
|
with e->
|
|
System.Diagnostics.Debug.Assert(false, sprintf "Bug in target of HandleAsyncOp: %A: %s\nThe most recent error reported to an error scope: %A\n%+A\n" (e.GetType()) e.Message ErrorScope.MostRecentError e.StackTrace)
|
|
state
|
|
| FinishingBuild(options,oldChannel) ->
|
|
UnexpectedFinishingBuild "AsyncOp" oldChannel
|
|
Idling
|
|
|
|
// Do the given operation and reply
|
|
let HandleSyncOp op (channel:AsyncReplyChannel<_>) state =
|
|
use t = Trace.CallByThreadNamed("Reactor", "HandleSyncOp", "ThreadPool", fun _->sprintf "state=%+A" state)
|
|
match state with
|
|
| ActivelyBuilding(_)
|
|
| Idling ->
|
|
try
|
|
op()
|
|
channel.Reply(Result ())
|
|
state
|
|
with e->
|
|
System.Diagnostics.Debug.Assert(false, sprintf "Bug in target of HandleSyncOp: %A: %s\nThe most recent error reported to an error scope: %A\n%+A\n" (e.GetType()) e.Message ErrorScope.MostRecentError e.StackTrace)
|
|
channel.Reply(Exception e)
|
|
state
|
|
| FinishingBuild(options,oldChannel) ->
|
|
UnexpectedFinishingBuild "SyncOp" channel
|
|
UnexpectedFinishingBuild "SyncOp" oldChannel
|
|
Idling
|
|
| BackgroundError(e)->
|
|
channel.Reply(Exception e)
|
|
Idling
|
|
|
|
// Do a step in the build.
|
|
let HandleStep state =
|
|
use t = Trace.CallByThreadNamed("Reactor", "HandleStep", "ThreadPool", fun _->sprintf "state=%+A" state)
|
|
match state with
|
|
| FinishingBuild(options,_)
|
|
| ActivelyBuilding options ->
|
|
// Gather any require reply channel.
|
|
let replyChannel =
|
|
match state with
|
|
| Idling | ActivelyBuilding(_) | BackgroundError(_)->None
|
|
| FinishingBuild(_,channel)->Some(channel)
|
|
|
|
try
|
|
// Do the step.
|
|
let tcConfig,last,dependencyFiles,createErrors = buildCache.Get(options)
|
|
let next = IncrementalFSharpBuild.Step(last)
|
|
|
|
// Did the step do work?
|
|
match next with
|
|
| Some(next)->
|
|
buildCache.SetAlternate(options,(tcConfig,next,dependencyFiles,createErrors))
|
|
inbox.Post Step
|
|
state
|
|
| None->
|
|
match replyChannel with
|
|
| Some(replyChannel)-> replyChannel.Reply(Result ())
|
|
| None->()
|
|
|
|
// Switch to idle state.
|
|
Idling
|
|
with e->
|
|
System.Diagnostics.Debug.Assert(false, sprintf "[Bug]Failure in HandleStep: %s" (e.ToString()))
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "[Bug]Failure in HandleStep: %+A\n" e)
|
|
match replyChannel with
|
|
| Some(replyChannel)->
|
|
replyChannel.Reply(Exception e)
|
|
Idling
|
|
| None->BackgroundError e
|
|
| Idling -> Idling
|
|
| BackgroundError(e)->state
|
|
|
|
|
|
let HandleFinishBuilding (channel:AsyncReplyChannel<_>) = function
|
|
| ActivelyBuilding(options)->
|
|
inbox.Post Step
|
|
FinishingBuild(options,channel)
|
|
| FinishingBuild(options,channelOld)->
|
|
// Don't expect to get here. If this is required then we need to keep all channels and post back to each
|
|
// when the build finishes. For now, throw an exception back.
|
|
UnexpectedFinishingBuild "FinishBuilding" channel
|
|
UnexpectedFinishingBuild "FinishBuilding" channelOld
|
|
Idling
|
|
| Idling->
|
|
channel.Reply(Result ())
|
|
Idling
|
|
| BackgroundError e->
|
|
// We have a waiting channel to post our exception to.
|
|
channel.Reply(Exception e)
|
|
Idling
|
|
|
|
|
|
// Async workflow which receives messages and dispatches to worker functions.
|
|
let rec Loop (state:ReactorState) =
|
|
Trace.PrintLine("Reactor", fun () -> sprintf "Background compiler state is now: %s\n" (state.ToString()))
|
|
async { let! msg = inbox.Receive()
|
|
Trace.PrintLine("Reactor", fun () -> sprintf "Background compiler about to process message %s\n" (msg.ToString()))
|
|
match msg with
|
|
| StartBuild options -> return! Loop(HandleStartBuild options state)
|
|
| StartRecentBuild -> return! Loop(HandleStartRecentBuild state)
|
|
| Step -> return! Loop(HandleStep state)
|
|
| SyncOp(op,channel) -> return! Loop(HandleSyncOp op channel state)
|
|
| AsyncOp(op) -> return! Loop(HandleAsyncOp op state)
|
|
| StopBuild(channel) -> return! Loop(HandleStopBuild channel state)
|
|
| FinishBuild(channel) -> return! Loop(HandleFinishBuilding channel state)
|
|
}
|
|
Loop Idling
|
|
|
|
let builder = MailboxProcessor<_>.Start(Dispatch)
|
|
|
|
// [Foreground Mailbox Accessors] -----------------------------------------------------------
|
|
member r.StartBuilding(options) = builder.Post(StartBuild options)
|
|
member r.StartBuildingRecent() = builder.Post(StartRecentBuild)
|
|
member r.StopBuilding() =
|
|
match builder.PostAndReply(fun replyChannel->StopBuild(replyChannel)) with
|
|
| Result result->result
|
|
| Exception excn->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "[Bug]Exception in StopBuilding. Inner exception was:\n%+A\n%s" excn excn.StackTrace)
|
|
raise excn
|
|
member r.SyncOp(op) =
|
|
match builder.PostAndReply(fun replyChannel->SyncOp(op,replyChannel)) with
|
|
| Result result->result
|
|
| Exception excn->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "[Bug]Exception in SyncOp Inner exception was:\n%+A\n%s" excn excn.StackTrace)
|
|
raise excn
|
|
|
|
member r.AsyncOp(op) =
|
|
builder.Post(AsyncOp(op))
|
|
|
|
member r.UntypedParse(inputs)=
|
|
use t = Trace.Call("SyncOp","UntypedParse", fun _->"")
|
|
let result = ref None
|
|
let UntypedParseOp () =
|
|
result:=Some(UntypedParseImpl inputs r.SyncOp)
|
|
r.SyncOp UntypedParseOp
|
|
Option.get !result
|
|
member r.MatchBraces(inputs)=
|
|
use t = Trace.Call("SyncOp","MatchBraces", fun _->"")
|
|
let result = ref None
|
|
let MatchBracesOp () =
|
|
result:=Some(MatchBracesImpl inputs r.SyncOp)
|
|
r.SyncOp MatchBracesOp
|
|
Option.get !result
|
|
|
|
member r.TypeCheckSource(parseSourceRes,source,options)=
|
|
use t = Trace.Call("SyncOp","TypeCheckSource", fun _->"")
|
|
let result = ref None
|
|
let TypeCheckSourceOp () =
|
|
result:=Some(TypeCheckSourceImpl parseSourceRes source options r.SyncOp)
|
|
r.SyncOp TypeCheckSourceOp
|
|
Option.get !result
|
|
|
|
member r.InvalidateConfiguration(options : ParseOptions, changedFiles: (string * DependencyChangeCode) list) =
|
|
use t = Trace.Call("SyncOp","InvalidateConfiguration", fun _->"")
|
|
r.AsyncOp (fun () -> InvalidateBuildCacheEntry(options,changedFiles))
|
|
r.StartBuilding(options)
|
|
()
|
|
|
|
member r.WaitForBackgroundCompile() =
|
|
match builder.PostAndReply(fun replyChannel->FinishBuild(replyChannel)) with
|
|
| Result result->result
|
|
| Exception excn->
|
|
Trace.PrintLine("CompilerServices", fun _ -> sprintf "[Bug]Exception in WaitForBackgroundCompile Inner exception was:\n%+A\n%s" excn excn.StackTrace)
|
|
raise excn
|
|
|
|
|
|
[<Sealed>]
|
|
[<AutoSerializable(false)>]
|
|
type InteractiveChecker(backgroundCompilerEvents) =
|
|
let reactor = new Reactor.Reactor(backgroundCompilerEvents)
|
|
static let mutable foregroundParseCount = 0
|
|
static let mutable foregroundTypeCheckCount = 0
|
|
|
|
|
|
/// Determine whether two sets of sources and parse options are the same.
|
|
let AreSameForParsing((s1,o1),(s2,o2:ParseOptions)) =
|
|
let same =
|
|
o1.FileName=o2.FileName
|
|
&& ParseOptions.AreSameProject(o1,o2)
|
|
same && s1 = s2
|
|
|
|
/// Determine whether two sets of sources and parse options should be subsumed under the same project.
|
|
let AreSubsumableForParsing((s1,o1),(s2,o2)) =
|
|
ParseOptions.AreSameProjectName(o1,o2)
|
|
|
|
// Parse using reactor
|
|
let ComputeBraceMatching(source,options) =
|
|
Trace.PrintLine("CompilerServices", fun () -> sprintf "ComputeBraceMatching, FileName = %s\n " options.FileName)
|
|
reactor.MatchBraces(source,options)
|
|
|
|
|
|
let braceMatchMru = MruCache<_,_>(Flags.braceMatchCacheSize,ComputeBraceMatching,areSame=AreSameForParsing,areSameForSubsumption=AreSubsumableForParsing,isStillValid=(fun _ -> true))
|
|
|
|
// /// Cache which holds recently seen parses, up to one for each file, keyed by source text and parse/project options for the file
|
|
// let parseLookup = AgedLookup<(string * ParseOptions),UntypedParseInfo>(8)
|
|
|
|
/// Cache which holds recently seen type-checks, no more than one for each file.
|
|
/// This cache may hold out-of-date entries, in two senses
|
|
/// - there may be a more recent antecedent state available because the background build has made it available
|
|
/// - the source for the file may have changed
|
|
|
|
let typeCheckLookup = AgedLookup<ParseOptions,UntypedParseInfo * TypeCheckResults>(recentForgroundTypeCheckLookupSize)
|
|
|
|
/// Instantiate an interactive checker.
|
|
static member Create (backgroundCompilerEvents) = new InteractiveChecker(backgroundCompilerEvents)
|
|
|
|
/// Parse a source code file, returning an information about the untyped results
|
|
/// and the results needed for further processing using 'TypeCheckSource'
|
|
member ic.MatchBraces(source,options) =
|
|
let pair = (source,options)
|
|
braceMatchMru.Get(pair)
|
|
|
|
/// Parse a source code file, returning an information about the untyped results
|
|
/// and the results needed for further processing using 'TypeCheckSource'
|
|
member ic.UntypedParse(source,options) =
|
|
Trace.PrintLine("CompilerServices", fun () -> sprintf "UntypedParse, FileName = %s\n " options.FileName)
|
|
foregroundParseCount <- foregroundParseCount + 1
|
|
reactor.UntypedParse(source,options)
|
|
|
|
/// Try to get recent approximate type check results for a file.
|
|
member ic.TryGetRecentTypeCheckResultsForFile(options) =
|
|
match typeCheckLookup.TryGet(options) with
|
|
| Some res ->
|
|
Trace.PrintLine("CompilerServices", fun () -> sprintf "TryGetRecentTypeCheckResults, OK, FileName = %s\n " options.FileName)
|
|
Some res
|
|
| _ ->
|
|
None
|
|
|
|
/// This function is called when the configuration is known to have changed for reasons not encoded in the ParseOptions.
|
|
/// For example, dependent references may have been deleted or created.
|
|
member ic.InvalidateConfiguration(options : ParseOptions, changedFiles: (string * DependencyChangeCode) list) =
|
|
reactor.InvalidateConfiguration(options,changedFiles)
|
|
|
|
/// TypeCheck a source code file, returning a handle to the results of the
|
|
/// parse including the reconstructed types in the file.
|
|
member ic.TypeCheckSource(parseRes:UntypedParseInfo,source,options) =
|
|
Trace.PrintLine("CompilerServices", fun () -> sprintf "TypeCheckSource, FileName = %s\n " options.FileName)
|
|
match reactor.TypeCheckSource(parseRes.Results,source,options) with
|
|
| None ->
|
|
reactor.StartBuilding(options)
|
|
None
|
|
| Some typedResults ->
|
|
foregroundTypeCheckCount <- foregroundTypeCheckCount + 1
|
|
typeCheckLookup.Put(options,(parseRes,typedResults))
|
|
Some typedResults
|
|
|
|
/// Begin background parsing the given project.
|
|
member ic.StartBackgroundCompile(options) = reactor.StartBuilding(options)
|
|
/// Stop the background compile.
|
|
member ic.StopBackgroundCompile() = reactor.StopBuilding()
|
|
/// Block until the background compile finishes.
|
|
member ic.WaitForBackgroundCompile() = reactor.WaitForBackgroundCompile()
|
|
|
|
static member GlobalForegroundParseCountStatistic = foregroundParseCount
|
|
static member GlobalForegroundTypeCheckCountStatistic = foregroundTypeCheckCount
|
|
|
|
//----------------------------------------------------------------------------
|
|
//INDEX: FsiIntelisense
|
|
//----------------------------------------------------------------------------
|
|
|
|
module FsiIntelisense =
|
|
|
|
let rec getLineIndex (text:string,offset) =
|
|
let crIndex = text.IndexOf("\n",StringComparison.Ordinal)
|
|
if crIndex <> -1 then
|
|
if offset <= crIndex then
|
|
0,offset,text
|
|
else
|
|
let text = text.Substring(crIndex + 1)
|
|
let line,index,text = getLineIndex (text,offset - (crIndex+1))
|
|
line+1,index,text
|
|
else
|
|
0,offset,text
|
|
|
|
let getDeclarations (tcConfig,tcGlobals,tcImports,tcState) (text:string) names =
|
|
let syncop f = f() : unit
|
|
let mockFileName = "stdin.fs" (* Note: build.ml:ParseInput parses differently based on filename extension... *)
|
|
let _, _, inp, suppressTypecheckErrors = Parser.parseSource text false false mockFileName [] tcConfig
|
|
let _, scopeOpt = Parser.typeCheckSource inp text mockFileName "project" tcConfig tcGlobals tcImports tcState syncop suppressTypecheckErrors
|
|
|
|
match scopeOpt with
|
|
| Some scope when Array.length names > 0 ->
|
|
let line,index,lineStr = getLineIndex (text,text.Length)
|
|
let res = scope.GetDeclarations line lineStr index (List.frontAndBack (List.of_array names))
|
|
let project i =
|
|
let name = res.Name(i)
|
|
let desc = res.Description(i) |> fst
|
|
let glyph = res.Glyph(i)
|
|
let displ = name
|
|
name,desc,displ,glyph
|
|
let results = Array.init res.Count project
|
|
results
|
|
| _ -> [| |]
|
|
|
|
module PrettyNaming =
|
|
let IsIdentifierPartCharacter = Microsoft.FSharp.Compiler.PrettyNaming.IsIdentifierPartCharacter
|
|
let IsLongIdentifierPartCharacter = Microsoft.FSharp.Compiler.PrettyNaming.IsLongIdentifierPartCharacter
|
|
let GetLongNameFromString = Microsoft.FSharp.Compiler.PrettyNaming.SplitNamesForFsiGenerationPath
|
|
|