From 6b9d58e3c7b66f1bea51aa94d881464e29bac004 Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 12:42:38 +0300 Subject: [PATCH 01/12] copy sources from Fantomas --- .../FSharp.Compiler.Private.fsproj | 28 +- .../vs/ServiceFormatting/CodeFormatter.fs | 123 ++ .../vs/ServiceFormatting/CodeFormatter.fsi | 108 ++ .../vs/ServiceFormatting/CodeFormatterImpl.fs | 728 ++++++++++ .../vs/ServiceFormatting/CodePrinter.fs | 1144 ++++++++++++++++ .../vs/ServiceFormatting/FormatConfig.fs | 421 ++++++ .../vs/ServiceFormatting/SourceParser.fs | 1209 +++++++++++++++++ .../vs/ServiceFormatting/SourceTransformer.fs | 294 ++++ .../vs/ServiceFormatting/TokenMatcher.fs | 690 ++++++++++ src/fsharp/vs/ServiceFormatting/Utils.fs | 16 + 10 files changed, 4760 insertions(+), 1 deletion(-) create mode 100644 src/fsharp/vs/ServiceFormatting/CodeFormatter.fs create mode 100644 src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi create mode 100644 src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs create mode 100644 src/fsharp/vs/ServiceFormatting/CodePrinter.fs create mode 100644 src/fsharp/vs/ServiceFormatting/FormatConfig.fs create mode 100644 src/fsharp/vs/ServiceFormatting/SourceParser.fs create mode 100644 src/fsharp/vs/ServiceFormatting/SourceTransformer.fs create mode 100644 src/fsharp/vs/ServiceFormatting/TokenMatcher.fs create mode 100644 src/fsharp/vs/ServiceFormatting/Utils.fs diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index efee92eb164..2e7933ce164 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -618,7 +618,33 @@ Service/ServiceStructure.fs - + + Service/ServiceFormatting/Utils.fs + + + Service/ServiceFormatting/TokenMatcher.fs + + + Service/ServiceFormatting/FormatConfig.fs + + + Service/ServiceFormatting/SourceParser.fs + + + Service/ServiceFormatting/SourceTransformer.fs + + + Service/ServiceFormatting/CodePrinter.fs + + + Service/ServiceFormatting/CodeFormatterImpl.fs + + + Service/ServiceFormatting/CodeFormatter.fsi + + + Service/ServiceFormatting/CodeFormatter.fs + FSIstrings.txt diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs new file mode 100644 index 00000000000..0dfd629a7da --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs @@ -0,0 +1,123 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Range + +[] +type CodeFormatter = + static member FormatDocumentAsync(fileName, source, config, projectOptions, checker) = + CodeFormatterImpl.createFormatContext fileName source projectOptions checker + |> CodeFormatterImpl.formatDocument config + + static member FormatDocument(fileName, source, config) = + CodeFormatterImpl.createFormatContextNoChecker fileName source + |> CodeFormatterImpl.formatDocument config + |> Async.RunSynchronously + + static member FormatSelectionAsync(fileName, selection, source, config, projectOptions, checker) = + CodeFormatterImpl.createFormatContext fileName source projectOptions checker + |> CodeFormatterImpl.formatSelection selection config + + static member FormatSelection(fileName, selection, source, config) = + CodeFormatterImpl.createFormatContextNoChecker fileName source + |> CodeFormatterImpl.formatSelection selection config + |> Async.RunSynchronously + + static member FormatAroundCursorAsync(fileName, cursorPos, source, config, projectOptions, checker) = + CodeFormatterImpl.createFormatContext fileName source projectOptions checker + |> CodeFormatterImpl.formatAroundCursor cursorPos config + + static member InferSelectionFromCursorPos(fileName, cursorPos, source) = + CodeFormatterImpl.inferSelectionFromCursorPos cursorPos fileName source + + static member internal FormatSelectionInDocumentAsync(fileName, selection, source, config, projectOptions, checker) = + CodeFormatterImpl.createFormatContext fileName source projectOptions checker + |> CodeFormatterImpl.formatSelectionInDocument selection config + + static member FormatAST(ast, fileName, source, config) = + CodeFormatterImpl.formatAST ast fileName source config + + static member ParseAsync(fileName, source, projectOptions, checker) = + CodeFormatterImpl.createFormatContext fileName source projectOptions checker + |> CodeFormatterImpl.parse + + static member Parse(fileName, source) = + CodeFormatterImpl.createFormatContextNoChecker fileName source + |> CodeFormatterImpl.parse + |> Async.RunSynchronously + + static member IsValidAST ast = + CodeFormatterImpl.isValidAST ast + + static member IsValidFSharpCodeAsync(fileName, source, projectOptions, checker) = + CodeFormatterImpl.createFormatContext fileName source projectOptions checker + |> CodeFormatterImpl.isValidFSharpCode + + static member IsValidFSharpCode(fileName, source) = + CodeFormatterImpl.createFormatContextNoChecker fileName source + |> CodeFormatterImpl.isValidFSharpCode + |> Async.RunSynchronously + + static member MakePos(line, col) = + CodeFormatterImpl.makePos line col + + static member MakeRange(fileName, startLine, startCol, endLine, endCol) = + CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol + +[] +module CodeFormatter = + let internal createFormatContextNoFileName isFsiFile sourceCode = + let fileName = if isFsiFile then "/tmp.fsi" else "/tmp.fsx" + CodeFormatterImpl.createFormatContextNoChecker fileName sourceCode + + let parse isFsiFile sourceCode = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.parse + |> Async.RunSynchronously + + let isValidAST ast = + CodeFormatterImpl.isValidAST ast + + let isValidFSharpCode isFsiFile sourceCode = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.isValidFSharpCode + |> Async.RunSynchronously + + let formatSourceString isFsiFile sourceCode config = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.formatDocument config + |> Async.RunSynchronously + + let formatAST ast sourceCode config = + CodeFormatterImpl.formatAST ast "/tmp.fsx" sourceCode config + + let makeRange startLine startCol endLine endCol = + CodeFormatterImpl.makeRange "/tmp.fsx" startLine startCol endLine endCol + + let formatSelectionOnly isFsiFile (range : range) (sourceCode : string) config = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.formatSelection range config + |> Async.RunSynchronously + + let formatSelectionExpanded isFsiFile (range : range) (sourceCode : string) config = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.formatSelectionExpanded range config + |> Async.RunSynchronously + + let formatSelectionFromString isFsiFile (range : range) (sourceCode : string) config = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.formatSelectionInDocument range config + |> Async.RunSynchronously + + let makePos line col = + CodeFormatterImpl.makePos line col + + let formatAroundCursor isFsiFile (cursorPos : pos) (sourceCode : string) config = + createFormatContextNoFileName isFsiFile sourceCode + |> CodeFormatterImpl.formatAroundCursor cursorPos config + |> Async.RunSynchronously + + let inferSelectionFromCursorPos (cursorPos : pos) (sourceCode : string) = + CodeFormatterImpl.inferSelectionFromCursorPos cursorPos "/tmp.fsx" sourceCode diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi new file mode 100644 index 00000000000..19df03c3105 --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi @@ -0,0 +1,108 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting + +open System +open Fantomas.FormatConfig +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.SourceCodeServices + +[] +type CodeFormatter = + /// Parse a source string using given config + static member Parse : fileName:string * source:string -> ParsedInput + /// Parse a source string using given config + static member ParseAsync : fileName:string * source:string * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async + /// Format an abstract syntax tree using an optional source for looking up literals + static member FormatAST : ast:ParsedInput * fileName:string * source:string option * config:FormatConfig -> string + + /// Infer selection around cursor by looking for a pair of '[' and ']', '{' and '}' or '(' and ')'. + static member InferSelectionFromCursorPos : fileName:string * cursorPos:pos * source:string -> range + + /// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. + /// (Only use in testing.) + static member internal FormatAroundCursorAsync : + fileName:string * cursorPos:pos * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async + + /// Format a source string using given config + static member FormatDocument : + fileName:string * source:string * config:FormatConfig -> string + + /// Format a source string using given config + static member FormatDocumentAsync : + fileName:string * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async + + /// Format a part of source string using given config, and return the (formatted) selected part only. + /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. + static member FormatSelection : + fileName:string * selection:range * source:string * config:FormatConfig -> string + + /// Format a part of source string using given config, and return the (formatted) selected part only. + /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. + static member FormatSelectionAsync : + fileName:string * selection:range * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async + + /// Format a selected part of source string using given config; keep other parts unchanged. + /// (Only use in testing.) + static member internal FormatSelectionInDocumentAsync : + fileName:string * selection:range * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async + + /// Check whether an AST consists of parsing errors + static member IsValidAST : ast:ParsedInput -> bool + /// Check whether an input string is invalid in F# by looking for erroneous nodes in ASTs + static member IsValidFSharpCode : fileName:string * source:string -> bool + /// Check whether an input string is invalid in F# by looking for erroneous nodes in ASTs + static member IsValidFSharpCodeAsync : fileName:string * source:string * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async + + static member MakePos : line:int * col:int -> pos + static member MakeRange : fileName:string * startLine:int * startCol:int * endLine:int * endCol:int -> range + +[] +module CodeFormatter = + /// Parse a source code string + [] + val parse : isFsiFile:bool -> sourceCode:string -> ParsedInput + + [] + val makePos : line:int -> col:int -> pos + + [] + val makeRange : startLine:int -> startCol:int -> endLine:int -> endCol:int -> range + + /// Check whether an AST consists of parsing errors + [] + val isValidAST : ast:ParsedInput -> bool + + /// Check whether an input string is invalid in F# by looking for erroneous nodes in ASTs + [] + val isValidFSharpCode : isFsiFile:bool -> sourceCode:string -> bool + + /// Format a source string using given config + [] + val formatSourceString : isFsiFile:bool -> sourceCode:string -> config:FormatConfig -> string + + /// Format an abstract syntax tree using given config + [] + val formatAST : ast:ParsedInput -> sourceCode:string option -> config:FormatConfig -> string + + /// Format a part of source string using given config, and return the (formatted) selected part only. + /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. + [] + val formatSelectionOnly : isFsiFile:bool -> range:range -> sourceCode:string -> config:FormatConfig -> string + + /// Format a selected part of source string using given config; expanded selected ranges to parsable ranges. + [] + val formatSelectionExpanded : isFsiFile:bool -> range:range -> sourceCode:string -> config:FormatConfig -> string * range + + /// Format a selected part of source string using given config; keep other parts unchanged. + [] + val formatSelectionFromString : isFsiFile:bool -> range:range -> sourceCode:string -> config:FormatConfig -> string + + /// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. + [] + val formatAroundCursor : isFsiFile:bool -> cursorPos:pos -> sourceCode:string -> config:FormatConfig -> string + + /// Infer selection around cursor by looking for a pair of '[' and ']', '{' and '}' or '(' and ')'. + [] + val inferSelectionFromCursorPos : cursorPos:pos -> sourceCode:string -> range \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs new file mode 100644 index 00000000000..b5693d1b748 --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs @@ -0,0 +1,728 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +[] +module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.CodeFormatterImpl + +open System +open System.Diagnostics +open System.Collections.Generic +open System.Text.RegularExpressions + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.SourceCodeServices + +open TokenMatcher +open FormatConfig +open SourceParser +open CodePrinter +open System.IO + +/// Check whether an AST consists of parsing errors +let isValidAST ast = + let (|IndexerArg|) = function + | SynIndexerArg.Two(e1, e2) -> [e1; e2] + | SynIndexerArg.One e -> [e] + + let (|IndexerArgList|) xs = + List.collect (|IndexerArg|) xs + + let rec validateImplFileInput (ParsedImplFileInput(_, moduleOrNamespaceList)) = + List.forall validateModuleOrNamespace moduleOrNamespaceList + + and validateModuleOrNamespace(SynModuleOrNamespace(decls = decls)) = + List.forall validateModuleDecl decls + + and validateModuleDecl(decl: SynModuleDecl) = + match decl with + | SynModuleDecl.Exception(SynExceptionDefn(_repr, synMembers, _defnRange), _range) -> + List.forall validateMemberDefn synMembers + | SynModuleDecl.Let(_isRecursive, bindings, _range) -> + List.forall validateBinding bindings + | SynModuleDecl.ModuleAbbrev(_lhs, _rhs, _range) -> + true + | SynModuleDecl.NamespaceFragment(fragment) -> + validateModuleOrNamespace fragment + | SynModuleDecl.NestedModule(_componentInfo, _isRec, modules, _isContinuing, _range) -> + List.forall validateModuleDecl modules + | SynModuleDecl.Types(typeDefs, _range) -> + List.forall validateTypeDefn typeDefs + | SynModuleDecl.DoExpr (_, expr, _) -> + validateExpr expr + | SynModuleDecl.Attributes _ + | SynModuleDecl.HashDirective _ + | SynModuleDecl.Open _ -> + true + + and validateTypeDefn(TypeDefn(_componentInfo, representation, members, _range)) = + validateTypeDefnRepr representation && List.forall validateMemberDefn members + + and validateTypeDefnRepr(typeDefnRepr: SynTypeDefnRepr) = + match typeDefnRepr with + | SynTypeDefnRepr.ObjectModel(_kind, members, _range) -> + List.forall validateMemberDefn members + | SynTypeDefnRepr.Simple(repr, _range) -> + match repr with + | SynTypeDefnSimpleRepr.Union(_, cases, _) -> + not (List.isEmpty cases) + | SynTypeDefnSimpleRepr.Enum(cases, _) -> + not (List.isEmpty cases) + | SynTypeDefnSimpleRepr.Record(_, fields, _) -> + not (List.isEmpty fields) + | SynTypeDefnSimpleRepr.General(_, types, _, _, _, _, _, _) -> + not (List.isEmpty types) + | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly _ + | SynTypeDefnSimpleRepr.TypeAbbrev _ + | SynTypeDefnSimpleRepr.Exception _ + | SynTypeDefnSimpleRepr.None _ -> + true + | SynTypeDefnRepr.Exception _ -> + true + + and validateMemberDefn (memberDefn: SynMemberDefn) = + match memberDefn with + | SynMemberDefn.AbstractSlot(_synValSig, _memberFlags, _range) -> + true + | SynMemberDefn.AutoProperty(_attributes, _isStatic, _id, _type, _memberKind, _memberFlags, _xmlDoc, _access, expr, _r1, _r2) -> + validateExpr expr + | SynMemberDefn.Interface(_interfaceType, members, _range) -> + defaultArg (Option.map (List.forall validateMemberDefn) members) true + | SynMemberDefn.Member(binding, _range) -> + validateBinding binding + | SynMemberDefn.NestedType(typeDef, _access, _range) -> + validateTypeDefn typeDef + | SynMemberDefn.ValField(_field, _range) -> + true + | SynMemberDefn.LetBindings(bindings, _isStatic, _isRec, _range) -> + List.forall validateBinding bindings + | SynMemberDefn.Open _ + | SynMemberDefn.Inherit _ + | SynMemberDefn.ImplicitCtor _ -> + true + | SynMemberDefn.ImplicitInherit(_, expr, _, _) -> + validateExpr expr + + and validateBinding (Binding(_access, _bindingKind, _isInline, _isMutable, _attrs, _xmldoc, _valData, headPat, _retTy, expr, _bindingRange, _seqPoint)) = + validateExpr expr && validatePattern headPat + + and validateClause (Clause(pat, expr, exprOpt)) = + validatePattern pat && validateExpr expr && defaultArg (Option.map validateExpr exprOpt) true + + and validateExpr = function + | SynExpr.Quote(synExpr1, _, synExpr2, _, _range) -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.Const(_synConst, _range) -> + true + + | SynExpr.Paren(synExpr, _, _, _parenRange) -> + validateExpr synExpr + | SynExpr.Typed(synExpr, _synType, _range) -> + validateExpr synExpr + + | SynExpr.Tuple(synExprList, _, _range) + | SynExpr.ArrayOrList(_, synExprList, _range) -> + List.forall validateExpr synExprList + | SynExpr.Record(_inheritOpt, _copyOpt, fields, _range) -> + List.forall (fun (_, e, _) -> defaultArg (Option.map validateExpr e) true) fields + + | SynExpr.New(_, _synType, synExpr, _range) -> + validateExpr synExpr + + | SynExpr.ObjExpr(_ty, _baseCallOpt, binds, _ifaces, _range1, _range2) -> + List.forall validateBinding binds + + | SynExpr.While(_sequencePointInfoForWhileLoop, synExpr1, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] + | SynExpr.ForEach(_sequencePointInfoForForLoop, _seqExprOnly, _isFromSource, synPat, synExpr1, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] && validatePattern synPat + + | SynExpr.For(_sequencePointInfoForForLoop, _ident, synExpr1, _, synExpr2, synExpr3, _range) -> + List.forall validateExpr [synExpr1; synExpr2; synExpr3] + + | SynExpr.ArrayOrListOfSeqExpr(_, synExpr, _range) -> + validateExpr synExpr + | SynExpr.CompExpr(_, _, synExpr, _range) -> + validateExpr synExpr + | SynExpr.Lambda(_, _, _synSimplePats, synExpr, _range) -> + validateExpr synExpr + + | SynExpr.MatchLambda(_isExnMatch, _argm, synMatchClauseList, _spBind, _wholem) -> + List.forall validateClause synMatchClauseList + | SynExpr.Match(_sequencePointInfoForBinding, synExpr, synMatchClauseList, _, _range) -> + validateExpr synExpr && List.forall validateClause synMatchClauseList + + | SynExpr.Lazy(synExpr, _range) -> + validateExpr synExpr + | SynExpr.Do(synExpr, _range) -> + validateExpr synExpr + | SynExpr.Assert(synExpr, _range) -> + validateExpr synExpr + + | SynExpr.App(_exprAtomicFlag, _isInfix, synExpr1, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.TypeApp(synExpr, _, _synTypeList, _commas, _, _, _range) -> + validateExpr synExpr + + | SynExpr.LetOrUse(_, _, synBindingList, synExpr, _range) -> + List.forall validateBinding synBindingList && validateExpr synExpr + + | SynExpr.TryWith(synExpr, _range, synMatchClauseList, _range2, _range3, _sequencePointInfoForTry, _sequencePointInfoForWith) -> + validateExpr synExpr && List.forall validateClause synMatchClauseList + + | SynExpr.TryFinally(synExpr1, synExpr2, _range, _sequencePointInfoForTry, _sequencePointInfoForFinally) -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.Sequential(_sequencePointInfoForSeq, _, synExpr1, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.IfThenElse(synExpr1, synExpr2, synExprOpt, _sequencePointInfoForBinding, _isRecovery, _range, _range2) -> + match synExprOpt with + | Some synExpr3 -> + List.forall validateExpr [synExpr1; synExpr2; synExpr3] + | None -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.Ident(_ident) -> + true + | SynExpr.LongIdent(_, _longIdent, _altNameRefCell, _range) -> + true + + | SynExpr.LongIdentSet(_longIdent, synExpr, _range) -> + validateExpr synExpr + | SynExpr.DotGet(synExpr, _dotm, _longIdent, _range) -> + validateExpr synExpr + + | SynExpr.DotSet(synExpr1, _longIdent, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.DotIndexedGet(synExpr, IndexerArgList synExprList, _range, _range2) -> + validateExpr synExpr && List.forall validateExpr synExprList + + | SynExpr.DotIndexedSet(synExpr1, IndexerArgList synExprList, synExpr2, _, _range, _range2) -> + [ yield synExpr1 + yield! synExprList + yield synExpr2 ] + |> List.forall validateExpr + + | SynExpr.JoinIn(synExpr1, _range, synExpr2, _range2) -> + List.forall validateExpr [synExpr1; synExpr2] + | SynExpr.NamedIndexedPropertySet(_longIdent, synExpr1, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] + + | SynExpr.DotNamedIndexedPropertySet(synExpr1, _longIdent, synExpr2, synExpr3, _range) -> + List.forall validateExpr [synExpr1; synExpr2; synExpr3] + + | SynExpr.TypeTest(synExpr, _synType, _range) + | SynExpr.Upcast(synExpr, _synType, _range) + | SynExpr.Downcast(synExpr, _synType, _range) -> + validateExpr synExpr + | SynExpr.InferredUpcast(synExpr, _range) + | SynExpr.InferredDowncast(synExpr, _range) -> + validateExpr synExpr + | SynExpr.AddressOf(_, synExpr, _range, _range2) -> + validateExpr synExpr + | SynExpr.TraitCall(_synTyparList, _synMemberSig, synExpr, _range) -> + validateExpr synExpr + + | SynExpr.Null(_range) + | SynExpr.ImplicitZero(_range) -> + true + + | SynExpr.YieldOrReturn(_, synExpr, _range) + | SynExpr.YieldOrReturnFrom(_, synExpr, _range) + | SynExpr.DoBang(synExpr, _range) -> + validateExpr synExpr + + | SynExpr.LetOrUseBang(_sequencePointInfoForBinding, _, _, synPat, synExpr1, synExpr2, _range) -> + List.forall validateExpr [synExpr1; synExpr2] && validatePattern synPat + + | SynExpr.LibraryOnlyILAssembly _ + | SynExpr.LibraryOnlyStaticOptimization _ + | SynExpr.LibraryOnlyUnionCaseFieldGet _ + | SynExpr.LibraryOnlyUnionCaseFieldSet _ -> + true + + | SynExpr.ArbitraryAfterError(_debugStr, _range) -> + false + | SynExpr.FromParseError(_synExpr, _range) + | SynExpr.DiscardAfterMissingQualificationAfterDot(_synExpr, _range) -> + false + | SynExpr.Fixed _ + | SynExpr.StructTuple _ -> + true + + and validatePattern = function + | SynPat.Const(_const, _range) -> true + | SynPat.Wild _ + | SynPat.Null _-> true + | SynPat.Named(pat, _ident, _isThis, _accessOpt, _range) -> + validatePattern pat + | SynPat.Typed(pat, _typ, _range) -> + validatePattern pat + | SynPat.Attrib(pat, _attrib, _range) -> + validatePattern pat + | SynPat.Or(pat1, pat2, _range) -> + validatePattern pat1 && validatePattern pat2 + | SynPat.Ands(pats, _range) -> + List.forall validatePattern pats + | SynPat.LongIdent(_, _, _, constructorArgs, _, _) -> + validateConstructorArgs constructorArgs + | SynPat.Tuple(pats, _range) -> + List.forall validatePattern pats + | SynPat.Paren(pat, _range) -> + validatePattern pat + | SynPat.ArrayOrList(_isArray, pats, _range) -> + List.forall validatePattern pats + | SynPat.Record(identPats, _range) -> + List.forall (fun (_, pat) -> validatePattern pat) identPats + | SynPat.OptionalVal(_ident, _range) -> true + | SynPat.IsInst(_typ, _range) -> true + | SynPat.QuoteExpr(expr, _range) -> + validateExpr expr + | SynPat.DeprecatedCharRange _ + | SynPat.InstanceMember _ + | SynPat.StructTuple _ -> true + | SynPat.FromParseError _ -> false + + and validateConstructorArgs = function + | SynConstructorArgs.Pats pats -> + List.forall validatePattern pats + | SynConstructorArgs.NamePatPairs(identPats, _range) -> + List.forall (snd >> validatePattern) identPats + + match ast with + | ParsedInput.SigFile _input -> + // There is not much to explore in signature files + true + | ParsedInput.ImplFile input -> + validateImplFileInput input + +/// Check whether an input AST is invalid in F# by looking for erroneous nodes. +let isValidFSharpCode ast = try isValidAST ast with _ -> false + +let formatWith ast moduleName input config = + // Use '\n' as the new line delimiter consistently + // It would be easier for F# parser + let sourceCode = defaultArg input String.Empty + let normalizedSourceCode = String.normalizeNewLine sourceCode + let formattedSourceCode = + Context.create config normalizedSourceCode + |> genParsedInput { ASTContext.Default with TopLevelModuleName = moduleName } ast + |> dump + |> if config.StrictMode then id else integrateComments normalizedSourceCode + + // Sometimes F# parser gives a partial AST for incorrect input + if input.IsSome && String.IsNullOrWhiteSpace normalizedSourceCode <> String.IsNullOrWhiteSpace formattedSourceCode then + raise <| FormatException "Incomplete code fragment which is most likely due to parsing errors or the use of F# constructs newer than supported." + else formattedSourceCode + +/// Format an abstract syntax tree using given config +let formatAST ast fileName sourceCode config = + let formattedSourceCode = formatWith ast fileName sourceCode config + + // When formatting the whole document, an EOL is required + if formattedSourceCode.EndsWith(Environment.NewLine) then + formattedSourceCode + else + formattedSourceCode + Environment.NewLine + +/// Make a range from (startLine, startCol) to (endLine, endCol) to select some text +let makeRange fileName startLine startCol endLine endCol = + mkRange fileName (mkPos startLine startCol) (mkPos endLine endCol) + +/// Get first non-whitespace line +let rec getStartLineIndex (lines : _ []) i = + if i = lines.Length-1 || not <| String.IsNullOrWhiteSpace(lines.[i]) then i + else getStartLineIndex lines (i + 1) + +let rec getEndLineIndex (lines : _ []) i = + if i = 0 || not <| String.IsNullOrWhiteSpace(lines.[i]) then i + else getEndLineIndex lines (i - 1) + +let isSignificantToken (tok : FSharpTokenInfo) = + tok.CharClass <> FSharpTokenCharKind.WhiteSpace && + tok.CharClass <> FSharpTokenCharKind.LineComment && + tok.CharClass <> FSharpTokenCharKind.Comment && + tok.TokenName <> "STRING_TEXT" + +/// Find out the start token +let rec getStartCol (r : range) (tokenizer : FSharpLineTokenizer) lexState = + match tokenizer.ScanToken(!lexState) with + | Some(tok), state -> + if tok.RightColumn >= r.StartColumn && isSignificantToken tok then tok.LeftColumn + else + lexState := state + getStartCol r tokenizer lexState + | None, _ -> r.StartColumn + +/// Find out the end token +let rec getEndCol (r : range) (tokenizer : FSharpLineTokenizer) lexState = + match tokenizer.ScanToken(!lexState) with + | Some(tok), state -> + Debug.WriteLine("End token: {0}", sprintf "%A" tok |> box) + if tok.RightColumn >= r.EndColumn && isSignificantToken tok then tok.RightColumn + else + lexState := state + getEndCol r tokenizer lexState + | None, _ -> r.EndColumn + +type PatchKind = + | TypeMember + | RecType + | RecLet + | Nothing + +let startWithMember (sel : string) = + [|"member"; "abstract"; "default"; "override"; + "static"; "interface"; "new"; "val"; "inherit"|] + |> Array.exists (sel.TrimStart().StartsWith) + +/// Find the first type declaration or let binding at beginnings of lines +let getPatch startCol (lines : string []) = + let rec loop i = + if i < 0 then Nothing + elif Regex.Match(lines.[i], "^[\s]*type").Success then RecType + else + // Need to compare column to ensure that the let binding is at the same level + let m = Regex.Match(lines.[i], "^[\s]*let") + let col = m.Index + m.Length + // Value 4 accounts for length of "and " + if m.Success && col <= startCol + 4 then RecLet else loop (i - 1) + loop (lines.Length - 1) + +/// Convert from range to string positions +let stringPos (r : range) (sourceCode : string) = + // Assume that content has been normalized (no "\r\n" anymore) + let positions = + sourceCode.Split('\n') + // Skip '\r' as a new line character on Windows + |> Seq.map (fun s -> String.length s + 1) + |> Seq.scan (+) 0 + |> Seq.toArray + + let start = positions.[r.StartLine-1] + r.StartColumn + // We can't assume the range is valid, so check string boundary here + let finish = + let pos = positions.[r.EndLine-1] + r.EndColumn + if pos >= sourceCode.Length then sourceCode.Length - 1 else pos + (start, finish) + +let formatRange returnFormattedContentOnly (range : range) (lines : string[]) (sourceCode: string) config ast = + let startLine = range.StartLine + let startCol = range.StartColumn + let endLine = range.EndLine + + let (start, finish) = stringPos range sourceCode + let pre = if start = 0 then String.Empty else sourceCode.[0..start-1].TrimEnd('\r') + + // Prepend selection by an appropriate amount of whitespace + let (selection, patch) = + let sel = sourceCode.[start..finish].TrimEnd('\r') + if startWithMember sel then + (String.Join(String.Empty, "type T = ", Environment.NewLine, new String(' ', startCol), sel), TypeMember) + elif String.startsWithOrdinal "and" (sel.TrimStart()) then + let p = getPatch startCol lines.[..startLine-1] + let pattern = Regex("and") + let replacement = + match p with + | RecType -> "type" + | RecLet -> "let rec" + | _ -> "and" + // Replace "and" by "type" or "let rec" + if startLine = endLine then (pattern.Replace(sel, replacement, 1), p) + else (new String(' ', startCol) + pattern.Replace(sel, replacement, 1), p) + elif startLine = endLine then (sel, Nothing) + else (new String(' ', startCol) + sel, Nothing) + + let post = + if finish < sourceCode.Length then + let post = sourceCode.[finish+1..] + if String.startsWithOrdinal "\n" post then Environment.NewLine + post.[1..] + else post + else String.Empty + + Debug.WriteLine("pre:\n'{0}'", box pre) + Debug.WriteLine("selection:\n'{0}'", box selection) + Debug.WriteLine("post:\n'{0}'", box post) + + let formatSelection (sourceCode: string) config = + async { + // From this point onwards, we focus on the current selection + let formatContext = { formatContext with Source = sourceCode } + let! formattedSourceCode = format config formatContext + // If the input is not inline, the output should not be inline as well + if sourceCode.EndsWith("\n") && not <| formattedSourceCode.EndsWith(Environment.NewLine) then + return formattedSourceCode + Environment.NewLine + elif not <| sourceCode.EndsWith("\n") && formattedSourceCode.EndsWith(Environment.NewLine) then + return formattedSourceCode.TrimEnd('\r', '\n') + else + return formattedSourceCode + } + + let reconstructSourceCode startCol formatteds pre post = + Debug.WriteLine("Formatted parts: '{0}' at column {1}", sprintf "%A" formatteds, startCol) + // Realign results on the correct column + Context.create config String.Empty + // Mono version of indent text writer behaves differently from .NET one, + // So we add an empty string first to regularize it + |> if returnFormattedContentOnly then str String.Empty else str pre + |> atIndentLevel startCol (col sepNln formatteds str) + |> if returnFormattedContentOnly then str String.Empty else str post + |> dump + + async { + match patch with + | TypeMember -> + // Get formatted selection with "type T = \n" patch + let! result = formatSelection selection config + // Remove the patch + let contents = String.normalizeThenSplitNewLine result + if Array.isEmpty contents then + if returnFormattedContentOnly then + return result + else + return String.Join(String.Empty, pre, result, post) + else + // Due to patching, the text has at least two lines + let first = contents.[1] + let column = first.Length - first.TrimStart().Length + let formatteds = contents.[1..] |> Seq.map (fun s -> s.[column..]) + return reconstructSourceCode startCol formatteds pre post + | RecType + | RecLet -> + // Get formatted selection with "type" or "let rec" replacement for "and" + let! result = formatSelection selection config + // Substitute by old contents + let pattern = if patch = RecType then Regex("type") else Regex("let rec") + let formatteds = String.normalizeThenSplitNewLine (pattern.Replace(result, "and", 1)) + return reconstructSourceCode startCol formatteds pre post + | Nothing -> + let! result = formatSelection selection config + let formatteds = String.normalizeThenSplitNewLine result + return reconstructSourceCode startCol formatteds pre post + } + +/// Format a part of source string using given config, and return the (formatted) selected part only. +/// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. +let formatSelection (range : range) config ({ Source = sourceCode; FileName = fileName } as formatContext) = + let lines = String.normalizeThenSplitNewLine sourceCode + + // Move to the section with real contents + let contentRange = + if range.StartLine = range.EndLine then range + else + let startLine = getStartLineIndex lines (range.StartLine - 1) + 1 + let endLine = getEndLineIndex lines (range.EndLine - 1) + 1 + Debug.Assert(startLine >= range.StartLine, "Should shrink selections only.") + Debug.Assert(endLine <= range.EndLine, "Should shrink selections only.") + let startCol = if startLine = range.StartLine then max range.StartColumn 0 else 0 + let endCol = + if endLine = range.EndLine then + min range.EndColumn (lines.[endLine-1].Length - 1) + else lines.[endLine-1].Length - 1 + // Notice that Line indices start at 1 while Column indices start at 0. + makeRange fileName startLine startCol endLine endCol + + let startCol = + let line = lines.[contentRange.StartLine-1].[contentRange.StartColumn..] + contentRange.StartColumn + line.Length - line.TrimStart().Length + + let endCol = + let line = lines.[contentRange.EndLine-1].[..contentRange.EndColumn] + contentRange.EndColumn - line.Length + line.TrimEnd().Length + + let modifiedRange = makeRange fileName range.StartLine startCol range.EndLine endCol + Debug.WriteLine("Original range: {0} --> content range: {1} --> modified range: {2}", + sprintf "%O" range, sprintf "%O" contentRange, sprintf "%O" modifiedRange) + + async { + let! formatted = formatRange true modifiedRange lines config formatContext + + let (start, finish) = stringPos range sourceCode + let (newStart, newFinish) = stringPos modifiedRange sourceCode + let pre = sourceCode.[start..newStart-1].TrimEnd('\r') + let post = + if newFinish + 1 >= sourceCode.Length || newFinish >= finish then + String.Empty + else + sourceCode.[newFinish+1..finish].Replace("\r", "\n") + Debug.WriteLine("Original index: {0} --> modified index: {1}", sprintf "%O" (start, finish), sprintf "%O" (newStart, newFinish)) + Debug.WriteLine("Join '{0}', '{1}' and '{2}'", pre, formatted, post) + return String.Join(String.Empty, pre, formatted, post) + } + + /// Format a selected part of source string using given config; expanded selected ranges to parsable ranges. +let formatSelectionExpanded (range : range) config ({ FileName = fileName; Source = sourceCode } as formatContext) = + let lines = String.normalizeThenSplitNewLine sourceCode + let sourceTokenizer = FSharpSourceTokenizer([], Some fileName) + + // Move to the section with real contents + let contentRange = + if range.StartLine = range.EndLine then range + else + let startLine = getStartLineIndex lines (range.StartLine - 1) + 1 + let endLine = getEndLineIndex lines (range.EndLine - 1) + 1 + let startCol = 0 + let endCol = lines.[endLine-1].Length - 1 + // Notice that Line indices start at 1 while Column indices start at 0. + makeRange fileName startLine startCol endLine endCol + + let startTokenizer = sourceTokenizer.CreateLineTokenizer(lines.[contentRange.StartLine-1]) + + let startCol = getStartCol contentRange startTokenizer (ref 0L) + + let endTokenizer = + if contentRange.StartLine = contentRange.EndLine then startTokenizer + else sourceTokenizer.CreateLineTokenizer(lines.[contentRange.EndLine-1]) + + let endCol = getEndCol contentRange endTokenizer (ref 0L) + + let expandedRange = makeRange fileName contentRange.StartLine startCol contentRange.EndLine endCol + async { + let! result = formatRange false expandedRange lines config formatContext + return (result, expandedRange) + } + +/// Format a selected part of source string using given config; keep other parts unchanged. +let formatSelectionInDocument (range : range) config formatContext = + async { + let! (formatted, _) = formatSelectionExpanded range config formatContext + return formatted + } + +type internal BlockType = + | List + | Array + | SequenceOrRecord + | Tuple + +/// Make a position at (line, col) to denote cursor position +let makePos line col = mkPos line col + +/// Infer selection around cursor by looking for a pair of '[' and ']', '{' and '}' or '(' and ')'. +let inferSelectionFromCursorPos (cursorPos : pos) fileName (sourceCode : string) = + let lines = String.normalizeThenSplitNewLine sourceCode + let sourceTokenizer = FSharpSourceTokenizer([], Some fileName) + let openDelimiters = dict ["[", List; "[|", Array; "{", SequenceOrRecord; "(", Tuple] + let closeDelimiters = dict ["]", List; "|]", Array; "}", SequenceOrRecord; ")", Tuple] + + /// Find the delimiter at the end + let rec tryFindEndDelimiter (dic : Dictionary<_, _>) i (lines : _ []) = + if i >= lines.Length then + None + else + let line = lines.[i] + let lineTokenizer = sourceTokenizer.CreateLineTokenizer(line) + let finLine = ref false + let result = ref None + let lexState = ref 0L + while not !finLine do + let tok, newLexState = lineTokenizer.ScanToken(!lexState) + lexState := newLexState + match tok with + | None -> + finLine := true + | Some t when t.CharClass = FSharpTokenCharKind.Delimiter -> + if i + 1 > cursorPos.Line || (i + 1 = cursorPos.Line && t.RightColumn >= cursorPos.Column) then + let text = line.[t.LeftColumn..t.RightColumn] + match text with + | "[" | "[|" | "{" | "(" -> + Debug.WriteLine("Found opening token '{0}'", text) + let delimiter = openDelimiters.[text] + match dic.TryGetValue(delimiter) with + | true, c -> + dic.[delimiter] <- c + 1 + | _ -> + dic.Add(delimiter, 1) + | "]" | "|]" | "}" | ")" -> + Debug.WriteLine("Found closing token '{0}'", text) + let delimiter = closeDelimiters.[text] + match dic.TryGetValue(delimiter) with + | true, 1 -> + dic.Remove(delimiter) |> ignore + | true, c -> + dic.[delimiter] <- c - 1 + | _ -> + // The delimiter has count 0; record as a result + Debug.WriteLine("Record closing token '{0}'", text) + result := Some (i + 1, t.RightColumn, delimiter) + | _ -> () + | _ -> () + + if Option.isNone !result then + tryFindEndDelimiter dic (i + 1) lines + else + !result + + /// Find the delimiter at the beginning + let rec tryFindStartDelimiter blockType (dic : Dictionary<_, _>) acc i (lines : _ []) = + if i >= cursorPos.Line then + acc + else + let line = lines.[i] + let lineTokenizer = sourceTokenizer.CreateLineTokenizer(line) + let finLine = ref false + let result = ref acc + let lexState = ref 0L + while not !finLine do + let tok, newLexState = lineTokenizer.ScanToken(!lexState) + lexState := newLexState + match tok with + | None -> + finLine := true + | Some t when t.CharClass = FSharpTokenCharKind.Delimiter -> + if i + 1 < cursorPos.Line || (i + 1 = cursorPos.Line && t.LeftColumn <= cursorPos.Column) then + let text = line.[t.LeftColumn..t.RightColumn] + match text, blockType with + | "]", List + | "|]", Array + | "}", SequenceOrRecord + | ")", Tuple -> + Debug.WriteLine("Found closing delimiter '{0}'", text) + let delimiter = closeDelimiters.[text] + match dic.TryGetValue(delimiter) with + | true, 1 -> + dic.Remove(delimiter) |> ignore + | true, c -> + dic.[delimiter] <- c - 1 + | _ -> + Debug.WriteLine("It's a dangling closing delimiter") + result := None + | "[", List + | "[|", Array + | "{", SequenceOrRecord + | "(", Tuple -> + Debug.WriteLine("Found opening delimiter '{0}'", text) + let delimiter = openDelimiters.[text] + match dic.TryGetValue(delimiter) with + | true, c -> + dic.[delimiter] <- c + 1 + | _ -> + Debug.WriteLine("Record opening delimiter '{0}'", text) + dic.Add(delimiter, 1) + result := Some (i + 1, t.LeftColumn) + | _ -> () + | _ -> () + + // We find the last opening delimiter + tryFindStartDelimiter blockType dic !result (i + 1) lines + + match tryFindEndDelimiter (Dictionary()) (cursorPos.Line - 1) lines with + | None -> + raise <| FormatException("""Found no pair of delimiters (e.g. "[ ]", "[| |]", "{ }" or "( )") around the cursor.""") + | Some (endLine, endCol, blockType) -> + match tryFindStartDelimiter blockType (Dictionary()) None 0 lines with + | None -> + raise <| FormatException("""Found no pair of delimiters (e.g. "[ ]", "[| |]", "{ }" or "( )") around the cursor.""") + | Some (startLine, startCol) -> + makeRange fileName startLine startCol endLine endCol + +/// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. +let formatAroundCursor (cursorPos : pos) config ({ FileName = fileName; Source = sourceCode } as formatContext) = + async { + let selection = inferSelectionFromCursorPos cursorPos fileName sourceCode + return! formatSelectionInDocument selection config formatContext + } diff --git a/src/fsharp/vs/ServiceFormatting/CodePrinter.fs b/src/fsharp/vs/ServiceFormatting/CodePrinter.fs new file mode 100644 index 00000000000..74e91008ee6 --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/CodePrinter.fs @@ -0,0 +1,1144 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.CodePrinter + +open System +open Microsoft.FSharp.Compiler.Ast +open FormatConfig +open SourceParser +open SourceTransformer + +/// This type consists of contextual information which is important for formatting +type ASTContext = + { + /// Original file name without extension of the parsed AST + TopLevelModuleName: string + /// Current node is the first child of its parent + IsFirstChild: bool + /// Current node is a subnode deep down in an interface + IsInterface: bool + /// This pattern matters for formatting extern declarations + IsCStylePattern: bool + /// Range operators are naked in 'for..in..do' constructs + IsNakedRange: bool + /// The optional `|` in pattern matching and union type definitions + HasVerticalBar: bool + /// A field is rendered as union field or not + IsUnionField: bool + /// First type param might need extra spaces to avoid parsing errors on `<^`, `<'`, etc. + IsFirstTypeParam: bool + /// Check whether the context is inside DotGet to suppress whitespaces + IsInsideDotGet: bool + } + static member Default = + { TopLevelModuleName = "" + IsFirstChild = false; IsInterface = false + IsCStylePattern = false; IsNakedRange = false + HasVerticalBar = false; IsUnionField = false + IsFirstTypeParam = false; IsInsideDotGet = false } + +let rec addSpaceBeforeParensInFunCall functionOrMethod arg = + match functionOrMethod, arg with + | _, ConstExpr(Const "()", _) -> false + | SynExpr.LongIdent(_, LongIdentWithDots s, _, _), _ -> + let parts = s.Split '.' + not <| Char.IsUpper parts.[parts.Length - 1].[0] + | SynExpr.Ident(Ident s), _ -> not <| Char.IsUpper s.[0] + | SynExpr.TypeApp(e, _, _, _, _, _, _), _ -> addSpaceBeforeParensInFunCall e arg + | _ -> true + +let addSpaceBeforeParensInFunDef functionOrMethod args = + match functionOrMethod, args with + | _, PatParen (PatConst(Const "()", _)) -> false + | "new", _ -> false + | (s:string), _ -> + let parts = s.Split '.' + not <| Char.IsUpper parts.[parts.Length - 1].[0] + | _ -> true + +let rec genParsedInput astContext = function + | ImplFile im -> genImpFile astContext im + | SigFile si -> genSigFile astContext si + +and genImpFile astContext (ParsedImplFileInput(hs, mns)) = + col sepNone hs genParsedHashDirective +> (if hs.IsEmpty then sepNone else sepNln) + +> col sepNln mns (genModuleOrNamespace astContext) + +and genSigFile astContext (ParsedSigFileInput(hs, mns)) = + col sepNone hs genParsedHashDirective +> (if hs.IsEmpty then sepNone else sepNln) + +> col sepNln mns (genSigModuleOrNamespace astContext) + +and genParsedHashDirective (ParsedHashDirective(h, s)) = + let printArgument arg = + match arg with + | "" -> sepNone + // Use verbatim string to escape '\' correctly + | _ when arg.Contains("\\") -> !- (sprintf "@\"%O\"" arg) + | _ -> !- (sprintf "\"%O\"" arg) + + !- "#" -- h +> sepSpace +> col sepSpace s printArgument + +and genModuleOrNamespace astContext (ModuleOrNamespace(ats, px, ao, s, mds, isModule)) = + genPreXmlDoc px + +> genAttributes astContext ats + +> ifElse (String.Equals(s, astContext.TopLevelModuleName, StringComparison.InvariantCultureIgnoreCase)) sepNone + (ifElse isModule (!- "module ") (!- "namespace ") + +> opt sepSpace ao genAccess +> ifElse (s = "") (!- "global") (!- s) +> rep 2 sepNln) + +> genModuleDeclList astContext mds + +and genSigModuleOrNamespace astContext (SigModuleOrNamespace(ats, px, ao, s, mds, isModule)) = + genPreXmlDoc px + +> genAttributes astContext ats + +> ifElse (String.Equals(s, astContext.TopLevelModuleName, StringComparison.InvariantCultureIgnoreCase)) sepNone + (ifElse isModule (!- "module ") (!- "namespace ") + +> opt sepSpace ao genAccess -- s +> rep 2 sepNln) + +> genSigModuleDeclList astContext mds + +and genModuleDeclList astContext = function + | [x] -> genModuleDecl astContext x + + | OpenL(xs, ys) -> + fun ctx -> + let xs = sortAndDeduplicate ((|Open|_|) >> Option.get) xs ctx + match ys with + | [] -> col sepNln xs (genModuleDecl astContext) ctx + | _ -> (col sepNln xs (genModuleDecl astContext) +> rep 2 sepNln +> genModuleDeclList astContext ys) ctx + + | HashDirectiveL(xs, ys) + | DoExprAttributesL(xs, ys) + | ModuleAbbrevL(xs, ys) + | OneLinerLetL(xs, ys) -> + match ys with + | [] -> col sepNln xs (genModuleDecl astContext) + | _ -> col sepNln xs (genModuleDecl astContext) +> rep 2 sepNln +> genModuleDeclList astContext ys + + | MultilineModuleDeclL(xs, ys) -> + match ys with + | [] -> col (rep 2 sepNln) xs (genModuleDecl astContext) + | _ -> col (rep 2 sepNln) xs (genModuleDecl astContext) +> rep 2 sepNln +> genModuleDeclList astContext ys + | _ -> sepNone + +and genSigModuleDeclList astContext = function + | [x] -> genSigModuleDecl astContext x + + | SigOpenL(xs, ys) -> + fun ctx -> + let xs = sortAndDeduplicate ((|SigOpen|_|) >> Option.get) xs ctx + match ys with + | [] -> col sepNln xs (genSigModuleDecl astContext) ctx + | _ -> (col sepNln xs (genSigModuleDecl astContext) +> rep 2 sepNln +> genSigModuleDeclList astContext ys) ctx + + | SigHashDirectiveL(xs, ys) -> + match ys with + | [] -> col sepNone xs (genSigModuleDecl astContext) + | _ -> col sepNone xs (genSigModuleDecl astContext) +> sepNln +> genSigModuleDeclList astContext ys + + | SigModuleAbbrevL(xs, ys) + | SigValL(xs, ys) -> + match ys with + | [] -> col sepNln xs (genSigModuleDecl astContext) + | _ -> col sepNln xs (genSigModuleDecl astContext) +> rep 2 sepNln +> genSigModuleDeclList astContext ys + + | SigMultilineModuleDeclL(xs, ys) -> + match ys with + | [] -> col (rep 2 sepNln) xs (genSigModuleDecl astContext) + | _ -> col (rep 2 sepNln) xs (genSigModuleDecl astContext) +> rep 2 sepNln +> genSigModuleDeclList astContext ys + + | _ -> sepNone + +and genModuleDecl astContext = function + | Attributes(ats) -> + col sepNln ats (genAttribute astContext) + | DoExpr(e) -> + genExpr astContext e + | Exception(ex) -> + genException astContext ex + | HashDirective(p) -> + genParsedHashDirective p + | Extern(ats, px, ao, t, s, ps) -> + genPreXmlDoc px + +> genAttributes astContext ats + -- "extern " +> genType astContext false t +> sepSpace +> opt sepSpace ao genAccess + -- s +> sepOpenT +> col sepComma ps (genPat { astContext with IsCStylePattern = true }) +> sepCloseT + // Add a new line after module-level let bindings + | Let(b) -> + genLetBinding { astContext with IsFirstChild = true } "let " b + | LetRec(b::bs) -> + genLetBinding { astContext with IsFirstChild = true } "let rec " b + +> colPre (rep 2 sepNln) (rep 2 sepNln) bs (genLetBinding { astContext with IsFirstChild = false } "and ") + + | ModuleAbbrev(s1, s2) -> + !- "module " -- s1 +> sepEq +> sepSpace -- s2 + | NamespaceFragment(m) -> + failwithf "NamespaceFragment hasn't been implemented yet: %O" m + | NestedModule(ats, px, ao, s, mds) -> + genPreXmlDoc px + +> genAttributes astContext ats -- "module " +> opt sepSpace ao genAccess -- s +> sepEq + +> indent +> sepNln +> genModuleDeclList astContext mds +> unindent + + | Open(s) -> + !- (sprintf "open %s" s) + // There is no nested types and they are recursive if there are more than one definition + | Types(t::ts) -> + genTypeDefn { astContext with IsFirstChild = true } t + +> colPre (rep 2 sepNln) (rep 2 sepNln) ts (genTypeDefn { astContext with IsFirstChild = false }) + | md -> + failwithf "Unexpected module declaration: %O" md + +and genSigModuleDecl astContext = function + | SigException(ex) -> + genSigException astContext ex + | SigHashDirective(p) -> + genParsedHashDirective p + | SigVal(v) -> + genVal astContext v + | SigModuleAbbrev(s1, s2) -> + !- "module " -- s1 +> sepEq +> sepSpace -- s2 + | SigNamespaceFragment(m) -> + failwithf "NamespaceFragment is not supported yet: %O" m + | SigNestedModule(ats, px, ao, s, mds) -> + genPreXmlDoc px + +> genAttributes astContext ats -- "module " +> opt sepSpace ao genAccess -- s +> sepEq + +> indent +> sepNln +> genSigModuleDeclList astContext mds +> unindent + + | SigOpen(s) -> + !- (sprintf "open %s" s) + | SigTypes(t::ts) -> + genSigTypeDefn { astContext with IsFirstChild = true } t + +> colPre (rep 2 sepNln) (rep 2 sepNln) ts (genSigTypeDefn { astContext with IsFirstChild = false }) + | md -> + failwithf "Unexpected module signature declaration: %O" md + +and genAccess (Access s) = !- s + +and genAttribute astContext (Attribute(s, e, target)) = + match e with + // Special treatment for function application on attributes + | ConstExpr(Const "()", _) -> + !- "[<" +> opt sepColonFixed target (!-) -- s -- ">]" + | e -> + !- "[<" +> opt sepColonFixed target (!-) -- s +> genExpr astContext e -- ">]" + +and genAttributesCore astContext ats = + let genAttributeExpr astContext (Attribute(s, e, target)) = + match e with + | ConstExpr(Const "()", _) -> + opt sepColonFixed target (!-) -- s + | e -> + opt sepColonFixed target (!-) -- s +> genExpr astContext e + ifElse (Seq.isEmpty ats) sepNone (!- "[<" +> col sepSemi ats (genAttributeExpr astContext) -- ">]") + +and genOnelinerAttributes astContext ats = + ifElse (Seq.isEmpty ats) sepNone (genAttributesCore astContext ats +> sepSpace) + +/// Try to group attributes if they are on the same line +/// Separate same-line attributes by ';' +/// Each bucket is printed in a different line +and genAttributes astContext ats = + ats + |> Seq.groupBy (fun at -> at.Range.StartLine) + |> Seq.map snd + |> Seq.toList + |> fun atss -> colPost sepNln sepNln atss (genAttributesCore astContext) + +and genPreXmlDoc (PreXmlDoc lines) ctx = + if ctx.Config.StrictMode then + colPost sepNln sepNln lines (sprintf "///%s" >> (!-)) ctx + else ctx + +and breakNln astContext brk e = + ifElse brk (indent +> sepNln +> genExpr astContext e +> unindent) + (indent +> autoNln (genExpr astContext e) +> unindent) + +and breakNlnOrAddSpace astContext brk e = + ifElse brk (indent +> sepNln +> genExpr astContext e +> unindent) + (indent +> autoNlnOrSpace (genExpr astContext e) +> unindent) + +/// Preserve a break even if the expression is a one-liner +and preserveBreakNln astContext e ctx = + breakNln astContext (checkPreserveBreakForExpr e ctx) e ctx + +and preserveBreakNlnOrAddSpace astContext e ctx = + breakNlnOrAddSpace astContext (checkPreserveBreakForExpr e ctx) e ctx + +/// Break but doesn't indent the expression +and noIndentBreakNln astContext e ctx = + ifElse (checkPreserveBreakForExpr e ctx) (sepNln +> genExpr astContext e) (autoNln (genExpr astContext e)) ctx + +and genTyparList astContext tps = + ifElse (List.atMostOne tps) (col wordOr tps (genTypar astContext)) (sepOpenT +> col wordOr tps (genTypar astContext) +> sepCloseT) + +and genTypeParam astContext tds tcs = + ifElse (List.isEmpty tds) sepNone + (!- "<" +> coli sepComma tds (fun i decl -> genTyparDecl { astContext with IsFirstTypeParam = i = 0 } decl) + +> colPre (!- " when ") wordAnd tcs (genTypeConstraint astContext) -- ">") + +and genLetBinding astContext pref b = + match b with + | LetBinding(ats, px, ao, isInline, isMutable, p, e) -> + let prefix = + genPreXmlDoc px + +> ifElse astContext.IsFirstChild (genAttributes astContext ats -- pref) + (!- pref +> genOnelinerAttributes astContext ats) + +> opt sepSpace ao genAccess + +> ifElse isMutable (!- "mutable ") sepNone +> ifElse isInline (!- "inline ") sepNone + +> genPat astContext p + + match e with + | TypedExpr(Typed, e, t) -> prefix +> sepColon +> genType astContext false t +> sepEq + +> preserveBreakNlnOrAddSpace astContext e + | e -> prefix +> sepEq +> preserveBreakNlnOrAddSpace astContext e + + | DoBinding(ats, px, e) -> + let prefix = if pref.Contains("let") then pref.Replace("let", "do") else "do " + genPreXmlDoc px + +> genAttributes astContext ats -- prefix +> preserveBreakNln astContext e + + | b -> + failwithf "%O isn't a let binding" b + +and genShortGetProperty astContext e = + sepEq +> preserveBreakNlnOrAddSpace astContext e + +and genProperty astContext prefix ao propertyKind ps e = + let tuplerize ps = + let rec loop acc = function + | [p] -> (List.rev acc, p) + | p1::ps -> loop (p1::acc) ps + | [] -> invalidArg "p" "Patterns should not be empty" + loop [] ps + + match ps with + | [PatTuple ps] -> + let (ps, p) = tuplerize ps + !- prefix +> opt sepSpace ao genAccess -- propertyKind + +> ifElse (List.atMostOne ps) (col sepComma ps (genPat astContext) +> sepSpace) + (sepOpenT +> col sepComma ps (genPat astContext) +> sepCloseT +> sepSpace) + +> genPat astContext p +> sepEq +> preserveBreakNlnOrAddSpace astContext e + + | ps -> + !- prefix +> opt sepSpace ao genAccess -- propertyKind +> col sepSpace ps (genPat astContext) + +> sepEq +> preserveBreakNlnOrAddSpace astContext e + +and genPropertyWithGetSet astContext (b1, b2) = + match b1, b2 with + | PropertyBinding(ats, px, ao, isInline, mf1, PatLongIdent(ao1, s1, ps1, _), e1), + PropertyBinding(_, _, _, _, _, PatLongIdent(ao2, _, ps2, _), e2) -> + let prefix = + genPreXmlDoc px + +> genAttributes astContext ats +> genMemberFlags astContext mf1 + +> ifElse isInline (!- "inline ") sepNone +> opt sepSpace ao genAccess + assert(ps1 |> Seq.map fst |> Seq.forall Option.isNone) + assert(ps2 |> Seq.map fst |> Seq.forall Option.isNone) + let ps1 = List.map snd ps1 + let ps2 = List.map snd ps2 + prefix -- s1 +> sepSpace +> indent +> sepNln + +> genProperty astContext "with " ao1 "get " ps1 e1 +> sepNln + +> genProperty astContext "and " ao2 "set " ps2 e2 + +> unindent + | _ -> sepNone + +/// Each member is separated by a new line. +and genMemberBindingList astContext = function + | [x] -> genMemberBinding astContext x + + | MultilineBindingL(xs, ys) -> + let prefix = sepNln +> col (rep 2 sepNln) xs (function + | Pair(x1, x2) -> genPropertyWithGetSet astContext (x1, x2) + | Single x -> genMemberBinding astContext x) + match ys with + | [] -> prefix + | _ -> prefix +> rep 2 sepNln +> genMemberBindingList astContext ys + + | OneLinerBindingL(xs, ys) -> + match ys with + | [] -> col sepNln xs (genMemberBinding astContext) + | _ -> col sepNln xs (genMemberBinding astContext) +> sepNln +> genMemberBindingList astContext ys + | _ -> sepNone + +and genMemberBinding astContext b = + match b with + | PropertyBinding(ats, px, ao, isInline, mf, p, e) -> + let prefix = + genPreXmlDoc px + +> genAttributes astContext ats +> genMemberFlags astContext mf + +> ifElse isInline (!- "inline ") sepNone +> opt sepSpace ao genAccess + + let propertyKind = + match mf with + | MFProperty PropertyGet -> "get " + | MFProperty PropertySet -> "set " + | mf -> failwithf "Unexpected member flags: %O" mf + + match p with + | PatLongIdent(ao, s, ps, _) -> + assert (ps |> Seq.map fst |> Seq.forall Option.isNone) + match ao, propertyKind, ps with + | None, "get ", [_, PatParen(PatConst(Const "()", _))] -> + // Provide short-hand notation `x.Member = ...` for `x.Member with get()` getters + prefix -- s +> genShortGetProperty astContext e + | _ -> + let ps = List.map snd ps + prefix -- s +> sepSpace +> indent +> sepNln +> + genProperty astContext "with " ao propertyKind ps e + +> unindent + | p -> failwithf "Unexpected pattern: %O" p + + | MemberBinding(ats, px, ao, isInline, mf, p, e) -> + let prefix = + genPreXmlDoc px + +> genAttributes astContext ats +> genMemberFlags astContext mf + +> ifElse isInline (!- "inline ") sepNone +> opt sepSpace ao genAccess +> genPat astContext p + + match e with + | TypedExpr(Typed, e, t) -> prefix +> sepColon +> genType astContext false t +> sepEq +> preserveBreakNlnOrAddSpace astContext e + | e -> prefix +> sepEq +> preserveBreakNlnOrAddSpace astContext e + + | ExplicitCtor(ats, px, ao, p, e, so) -> + let prefix = + genPreXmlDoc px + +> genAttributes astContext ats + +> opt sepSpace ao genAccess +> genPat astContext p + +> opt sepNone so (sprintf " as %s" >> (!-)) + + match e with + // Handle special "then" block i.e. fake sequential expressions in constructors + | Sequential(e1, e2, false) -> + prefix +> sepEq +> indent +> sepNln + +> genExpr astContext e1 ++ "then " +> preserveBreakNln astContext e2 +> unindent + + | e -> prefix +> sepEq +> preserveBreakNlnOrAddSpace astContext e + + | b -> failwithf "%O isn't a member binding" b + +and genMemberFlags astContext = function + | MFMember _ -> !- "member " + | MFStaticMember _ -> !- "static member " + | MFConstructor _ -> sepNone + | MFOverride _ -> ifElse astContext.IsInterface (!- "member ") (!- "override ") + +and genVal astContext (Val(ats, px, ao, s, t, vi, _)) = + let (FunType namedArgs) = (t, vi) + genPreXmlDoc px + +> genAttributes astContext ats + +> atCurrentColumn (indent -- "val " +> opt sepSpace ao genAccess -- s + +> sepColon +> genTypeList astContext namedArgs +> unindent) + +and genRecordFieldName astContext (RecordFieldName(s, eo)) = + opt sepNone eo (fun e -> !- s +> sepEq +> preserveBreakNlnOrAddSpace astContext e) + +and genExpr astContext = function + | SingleExpr(kind, e) -> str kind +> genExpr astContext e + | ConstExpr(c) -> genConst c + | NullExpr -> !- "null" + // Not sure about the role of e1 + | Quote(_, e2, isRaw) -> + let e = genExpr astContext e2 + ifElse isRaw (!- "<@@ " +> e -- " @@>") (!- "<@ " +> e -- " @>") + | TypedExpr(TypeTest, e, t) -> genExpr astContext e -- " :? " +> genType astContext false t + | TypedExpr(New, e, t) -> + !- "new " +> genType astContext false t +> ifElse (hasParenthesis e) sepNone sepSpace +> genExpr astContext e + | TypedExpr(Downcast, e, t) -> genExpr astContext e -- " :?> " +> genType astContext false t + | TypedExpr(Upcast, e, t) -> genExpr astContext e -- " :> " +> genType astContext false t + | TypedExpr(Typed, e, t) -> genExpr astContext e +> sepColon +> genType astContext false t + | Tuple es -> atCurrentColumn (coli sepComma es (fun i -> if i = 0 then genExpr astContext else noIndentBreakNln astContext)) + | ArrayOrList(isArray, [], _) -> + ifElse isArray (sepOpenAFixed +> sepCloseAFixed) (sepOpenLFixed +> sepCloseLFixed) + | ArrayOrList(isArray, xs, isSimple) -> + let sep = ifElse isSimple sepSemi sepSemiNln + ifElse isArray (sepOpenA +> atCurrentColumn (colAutoNlnSkip0 sep xs (genExpr astContext)) +> sepCloseA) + (sepOpenL +> atCurrentColumn (colAutoNlnSkip0 sep xs (genExpr astContext)) +> sepCloseL) + + | Record(inheritOpt, xs, eo) -> + sepOpenS + +> opt (if xs.IsEmpty then sepNone else sepSemi) inheritOpt + (fun (typ, expr) -> !- "inherit " +> genType astContext false typ +> genExpr astContext expr) + +> opt (!- " with ") eo (genExpr astContext) +> atCurrentColumn (col sepSemiNln xs (genRecordFieldName astContext)) + +> sepCloseS + + | ObjExpr(t, eio, bd, ims) -> + // Check the role of the second part of eio + let param = opt sepNone (Option.map fst eio) (genExpr astContext) + sepOpenS +> + atCurrentColumn (!- "new " +> genType astContext false t +> param -- " with" + +> indent +> sepNln +> genMemberBindingList { astContext with IsInterface = true } bd +> unindent + +> colPre sepNln sepNln ims (genInterfaceImpl astContext)) +> sepCloseS + + | While(e1, e2) -> + atCurrentColumn (!- "while " +> genExpr astContext e1 -- " do" + +> indent +> sepNln +> genExpr astContext e2 +> unindent) + + | For(s, e1, e2, e3, isUp) -> + atCurrentColumn (!- (sprintf "for %s = " s) +> genExpr astContext e1 + +> ifElse isUp (!- " to ") (!- " downto ") +> genExpr astContext e2 -- " do" + +> indent +> sepNln +> genExpr astContext e3 +> unindent) + + // Handle the form 'for i in e1 -> e2' + | ForEach(p, e1, e2, isArrow) -> + atCurrentColumn (!- "for " +> genPat astContext p -- " in " +> genExpr { astContext with IsNakedRange = true } e1 + +> ifElse isArrow (sepArrow +> preserveBreakNln astContext e2) (!- " do" +> indent +> sepNln +> genExpr astContext e2 +> unindent)) + + | CompExpr(isArrayOrList, e) -> + let astContext = { astContext with IsNakedRange = true } + ifElse isArrayOrList (genExpr astContext e) + (sepOpenS +> noIndentBreakNln astContext e + +> ifElse (checkBreakForExpr e) (unindent +> sepNln +> sepCloseSFixed) sepCloseS) + + | ArrayOrListOfSeqExpr(isArray, e) -> + let astContext = { astContext with IsNakedRange = true } + ifElse isArray (sepOpenA +> genExpr astContext e +> sepCloseA) (sepOpenL +> genExpr astContext e +> sepCloseL) + | JoinIn(e1, e2) -> genExpr astContext e1 -- " in " +> genExpr astContext e2 + | Paren(DesugaredLambda(cps, e)) -> + sepOpenT -- "fun " +> col sepSpace cps (genComplexPats astContext) +> sepArrow +> noIndentBreakNln astContext e +> sepCloseT + | DesugaredLambda(cps, e) -> + !- "fun " +> col sepSpace cps (genComplexPats astContext) +> sepArrow +> preserveBreakNln astContext e + | Paren(Lambda(e, sps)) -> + sepOpenT -- "fun " +> col sepSpace sps (genSimplePats astContext) +> sepArrow +> noIndentBreakNln astContext e +> sepCloseT + // When there are parentheses, most likely lambda will appear in function application + | Lambda(e, sps) -> + !- "fun " +> col sepSpace sps (genSimplePats astContext) +> sepArrow +> preserveBreakNln astContext e + | MatchLambda(sp, _) -> !- "function " +> colPre sepNln sepNln sp (genClause astContext true) + | Match(e, cs) -> + atCurrentColumn (!- "match " +> genExpr astContext e -- " with" +> colPre sepNln sepNln cs (genClause astContext true)) + | TraitCall(tps, msg, e) -> + genTyparList astContext tps +> sepColon +> sepOpenT +> genMemberSig astContext msg +> sepCloseT + +> sepSpace +> genExpr astContext e + + | Paren e -> + // Parentheses nullify effects of no space inside DotGet + sepOpenT +> genExpr { astContext with IsInsideDotGet = false } e +> sepCloseT + | CompApp(s, e) -> + !- s +> sepSpace +> sepOpenS +> genExpr { astContext with IsNakedRange = true } e + +> ifElse (checkBreakForExpr e) (sepNln +> sepCloseSFixed) sepCloseS + // This supposes to be an infix function, but for some reason it isn't picked up by InfixApps + | App(Var "?", e::es) -> genExpr astContext e -- "?" +> col sepSpace es (genExpr astContext) + | App(Var "..", [e1; e2]) -> + let expr = genExpr astContext e1 -- ".." +> genExpr astContext e2 + ifElse astContext.IsNakedRange expr (sepOpenS +> expr +> sepCloseS) + | App(Var ".. ..", [e1; e2; e3]) -> + let expr = genExpr astContext e1 -- ".." +> genExpr astContext e2 -- ".." +> genExpr astContext e3 + ifElse astContext.IsNakedRange expr (sepOpenS +> expr +> sepCloseS) + // Separate two prefix ops by spaces + | PrefixApp(s1, PrefixApp(s2, e)) -> !- (sprintf "%s %s" s1 s2) +> genExpr astContext e + | PrefixApp(s, e) -> !- s +> genExpr astContext e + // Handle spaces of infix application based on which category it belongs to + | InfixApps(e, es) -> + // Only put |> on the same line in a very trivial expression + atCurrentColumn (genExpr astContext e +> genInfixApps astContext (checkNewLine e es) es) + + | TernaryApp(e1,e2,e3) -> + atCurrentColumn (genExpr astContext e1 +> !- "?" +> genExpr astContext e2 +> sepSpace +> !- "<-" +> sepSpace +> genExpr astContext e3) + + // This filters a few long examples of App + | DotGetAppSpecial(s, es) -> + !- s + +> atCurrentColumn + (colAutoNlnSkip0 sepNone es (fun (s, e) -> + (!- (sprintf ".%s" s) + +> ifElse (hasParenthesis e) sepNone sepSpace +> genExpr astContext e))) + + | DotGetApp(e, es) -> + let expr = + match e with + | App(e1, [e2]) -> + noNln (genExpr astContext e1 +> ifElse (hasParenthesis e2) sepNone sepSpace +> genExpr astContext e2) + | _ -> + noNln (genExpr astContext e) + expr + +> indent + +> (col sepNone es (fun (s, e) -> + autoNln (!- (sprintf ".%s" s) + +> ifElse (hasParenthesis e) sepNone sepSpace +> genExpr astContext e))) + +> unindent + + // Unlike infix app, function application needs a level of indentation + | App(e1, [e2]) -> + atCurrentColumn (genExpr astContext e1 +> + ifElse (not astContext.IsInsideDotGet) + (ifElse (hasParenthesis e2) + (ifElse (addSpaceBeforeParensInFunCall e1 e2) sepBeforeArg sepNone) + sepSpace) + sepNone + +> indent +> autoNln (genExpr astContext e2) +> unindent) + + // Always spacing in multiple arguments + | App(e, es) -> + atCurrentColumn (genExpr astContext e +> + colPre sepSpace sepSpace es (fun e -> indent +> autoNln (genExpr astContext e) +> unindent)) + + | TypeApp(e, ts) -> genExpr astContext e -- "<" +> col sepComma ts (genType astContext false) -- ">" + | LetOrUses(bs, e) -> + atCurrentColumn (genLetOrUseList astContext bs +> sepNln +> genExpr astContext e) + + // Could customize a bit if e is single line + | TryWith(e, cs) -> + let prefix = !- "try " +> indent +> sepNln +> genExpr astContext e +> unindent ++ "with" + match cs with + | [c] -> + atCurrentColumn (prefix +> sepSpace +> genClause astContext false c) + | _ -> + atCurrentColumn (prefix +> indentOnWith +> sepNln +> col sepNln cs (genClause astContext true) +> unindentOnWith) + + | TryFinally(e1, e2) -> + atCurrentColumn (!- "try " +> indent +> sepNln +> genExpr astContext e1 +> unindent ++ "finally" + +> indent +> sepNln +> genExpr astContext e2 +> unindent) + + | SequentialSimple es -> atCurrentColumn (colAutoNlnSkip0 sepSemi es (genExpr astContext)) + // It seems too annoying to use sepSemiNln + | Sequentials es -> atCurrentColumn (col sepNln es (genExpr astContext)) + // A generalization of IfThenElse + | ElIf((e1,e2, _)::es, en) -> + atCurrentColumn (!- "if " +> ifElse (checkBreakForExpr e1) (genExpr astContext e1 ++ "then") (genExpr astContext e1 +- "then") -- " " + +> preserveBreakNln astContext e2 + +> fun ctx -> col sepNone es (fun (e1, e2, r) -> + ifElse (startWith "elif" r ctx) (!+ "elif ") (!+ "else if ") + +> ifElse (checkBreakForExpr e1) (genExpr astContext e1 ++ "then") (genExpr astContext e1 +- "then") + -- " " +> preserveBreakNln astContext e2) ctx + ++ "else " +> preserveBreakNln astContext en) + + | IfThenElse(e1, e2, None) -> + atCurrentColumn (!- "if " +> ifElse (checkBreakForExpr e1) (genExpr astContext e1 ++ "then") (genExpr astContext e1 +- "then") + -- " " +> preserveBreakNln astContext e2) + // At this stage, all symbolic operators have been handled. + | OptVar(s, isOpt) -> ifElse isOpt (!- "?") sepNone -- s + | LongIdentSet(s, e) -> !- (sprintf "%s <- " s) +> genExpr astContext e + | DotIndexedGet(e, es) -> genExpr astContext e -- "." +> sepOpenLFixed +> genIndexers astContext es +> sepCloseLFixed + | DotIndexedSet(e1, es, e2) -> genExpr astContext e1 -- ".[" +> genIndexers astContext es -- "] <- " +> genExpr astContext e2 + | DotGet(e, s) -> + genExpr { astContext with IsInsideDotGet = true } e -- sprintf ".%s" s + | DotSet(e1, s, e2) -> genExpr astContext e1 -- sprintf ".%s <- " s +> genExpr astContext e2 + | LetOrUseBang(isUse, p, e1, e2) -> + atCurrentColumn (ifElse isUse (!- "use! ") (!- "let! ") + +> genPat astContext p -- " = " +> genExpr astContext e1 +> sepNln +> genExpr astContext e2) + + | ParsingError r -> + raise <| FormatException (sprintf "Parsing error(s) between line %i column %i and line %i column %i" + r.StartLine (r.StartColumn + 1) r.EndLine (r.EndColumn + 1)) + | UnsupportedExpr r -> + raise <| FormatException (sprintf "Unsupported construct(s) between line %i column %i and line %i column %i" + r.StartLine (r.StartColumn + 1) r.EndLine (r.EndColumn + 1)) + | e -> failwithf "Unexpected expression: %O" e + +and genLetOrUseList astContext = function + | [p, x] -> genLetBinding { astContext with IsFirstChild = true } p x + | OneLinerLetOrUseL(xs, ys) -> + match ys with + | [] -> + col sepNln xs (fun (p, x) -> genLetBinding { astContext with IsFirstChild = p <> "and" } p x) + | _ -> + col sepNln xs (fun (p, x) -> genLetBinding { astContext with IsFirstChild = p <> "and" } p x) + +> rep 2 sepNln +> genLetOrUseList astContext ys + + | MultilineLetOrUseL(xs, ys) -> + match ys with + | [] -> + col (rep 2 sepNln) xs (fun (p, x) -> genLetBinding { astContext with IsFirstChild = p <> "and" } p x) + // Add a trailing new line to separate these with the main expression + +> sepNln + | _ -> + col (rep 2 sepNln) xs (fun (p, x) -> genLetBinding { astContext with IsFirstChild = p <> "and" } p x) + +> rep 2 sepNln +> genLetOrUseList astContext ys + + | _ -> sepNone + +/// When 'hasNewLine' is set, the operator is forced to be in a new line +and genInfixApps astContext hasNewLine = function + | (s, e)::es -> + (ifElse hasNewLine (sepNln -- s +> sepSpace +> genExpr astContext e) + (ifElse (NoSpaceInfixOps.Contains s) (!- s +> autoNln (genExpr astContext e)) + (ifElse (NoBreakInfixOps.Contains s) (sepSpace -- s +> sepSpace +> genExpr astContext e) + (sepSpace +> autoNln (!- s +> sepSpace +> genExpr astContext e))))) + +> genInfixApps astContext (hasNewLine || checkNewLine e es) es + + | [] -> sepNone + +/// Use in indexed set and get only +and genIndexers astContext = function + | Indexer(Pair(IndexedVar eo1, IndexedVar eo2)) :: es -> + ifElse (eo1.IsNone && eo2.IsNone) (!- "*") + (opt sepNone eo1 (genExpr astContext) -- ".." +> opt sepNone eo2 (genExpr astContext)) + +> ifElse es.IsEmpty sepNone (sepComma +> genIndexers astContext es) + | Indexer(Single(IndexedVar eo)) :: es -> + ifElse eo.IsNone (!- "*") (opt sepNone eo (genExpr astContext)) + +> ifElse es.IsEmpty sepNone (sepComma +> genIndexers astContext es) + | Indexer(Single e) :: es -> + genExpr astContext e +> ifElse es.IsEmpty sepNone (sepComma +> genIndexers astContext es) + | _ -> sepNone + +and genTypeDefn astContext (TypeDef(ats, px, ao, tds, tcs, tdr, ms, s)) = + let typeName = + genPreXmlDoc px + +> ifElse astContext.IsFirstChild (genAttributes astContext ats -- "type ") + (!- "and " +> genOnelinerAttributes astContext ats) + +> opt sepSpace ao genAccess -- s + +> genTypeParam astContext tds tcs + + match tdr with + | Simple(TDSREnum ecs) -> + typeName +> sepEq + +> indent +> sepNln + +> col sepNln ecs (genEnumCase { astContext with HasVerticalBar = true }) + +> genMemberDefnList { astContext with IsInterface = false } ms + // Add newline after un-indent to be spacing-correct + +> unindent + + | Simple(TDSRUnion(ao', xs)) -> + typeName +> sepEq + +> indent +> sepNln +> opt sepNln ao' genAccess + +> col sepNln xs (genUnionCase { astContext with HasVerticalBar = true }) + +> genMemberDefnList { astContext with IsInterface = false } ms + +> unindent + + | Simple(TDSRRecord(ao', fs)) -> + typeName +> sepEq + +> indent +> sepNln +> opt sepSpace ao' genAccess +> sepOpenS + +> atCurrentColumn (col sepSemiNln fs (genField astContext "")) +> sepCloseS + +> genMemberDefnList { astContext with IsInterface = false } ms + +> unindent + + | Simple TDSRNone -> + typeName + | Simple(TDSRTypeAbbrev t) -> + typeName +> sepEq +> sepSpace +> genType astContext false t + | Simple(TDSRException(ExceptionDefRepr(ats, px, ao, uc))) -> + genExceptionBody astContext ats px ao uc + + | ObjectModel(TCSimple (TCStruct | TCInterface | TCClass) as tdk, MemberDefnList(impCtor, others)) -> + let isInterface = + match tdk with + | TCSimple TCInterface -> true + | _ -> false + let astContext = { astContext with IsInterface = isInterface} + typeName +> opt sepNone impCtor (genMemberDefn astContext) +> sepEq + +> indent +> sepNln +> genTypeDefKind tdk + +> indent +> genMemberDefnList astContext others +> unindent + ++ "end" +> unindent + + | ObjectModel(TCSimple TCAugmentation, _) -> + typeName -- " with" +> indent + // Remember that we use MemberDefn of parent node + +> genMemberDefnList { astContext with IsInterface = false } ms +> unindent + + | ObjectModel(TCDelegate(FunType ts), _) -> + typeName +> sepEq +> sepSpace -- "delegate of " +> genTypeList astContext ts + | ObjectModel(_, MemberDefnList(impCtor, others)) -> + typeName +> opt sepNone impCtor (genMemberDefn { astContext with IsInterface = false }) +> sepEq +> indent + +> genMemberDefnList { astContext with IsInterface = false } others +> unindent + + | ExceptionRepr(ExceptionDefRepr(ats, px, ao, uc)) -> + genExceptionBody astContext ats px ao uc + +and genSigTypeDefn astContext (SigTypeDef(ats, px, ao, tds, tcs, tdr, ms, s)) = + let typeName = + genPreXmlDoc px + +> ifElse astContext.IsFirstChild (genAttributes astContext ats -- "type ") + (!- "and " +> genOnelinerAttributes astContext ats) + +> opt sepSpace ao genAccess -- s + +> genTypeParam astContext tds tcs + + match tdr with + | SigSimple(TDSREnum ecs) -> + typeName +> sepEq + +> indent +> sepNln + +> col sepNln ecs (genEnumCase { astContext with HasVerticalBar = true }) + +> colPre sepNln sepNln ms (genMemberSig astContext) + // Add newline after un-indent to be spacing-correct + +> unindent + + | SigSimple(TDSRUnion(ao', xs)) -> + typeName +> sepEq + +> indent +> sepNln +> opt sepNln ao' genAccess + +> col sepNln xs (genUnionCase { astContext with HasVerticalBar = true }) + +> colPre sepNln sepNln ms (genMemberSig astContext) + +> unindent + + | SigSimple(TDSRRecord(ao', fs)) -> + typeName +> sepEq + +> indent +> sepNln +> opt sepNln ao' genAccess +> sepOpenS + +> atCurrentColumn (col sepSemiNln fs (genField astContext "")) +> sepCloseS + +> colPre sepNln sepNln ms (genMemberSig astContext) + +> unindent + + | SigSimple TDSRNone -> + typeName + | SigSimple(TDSRTypeAbbrev t) -> + typeName +> sepEq +> sepSpace +> genType astContext false t + | SigSimple(TDSRException(ExceptionDefRepr(ats, px, ao, uc))) -> + genExceptionBody astContext ats px ao uc + + | SigObjectModel(TCSimple (TCStruct | TCInterface | TCClass) as tdk, mds) -> + typeName +> sepEq +> indent +> sepNln +> genTypeDefKind tdk + +> indent +> colPre sepNln sepNln mds (genMemberSig astContext) +> unindent + ++ "end" +> unindent + + | SigObjectModel(TCSimple TCAugmentation, _) -> + typeName -- " with" +> indent +> sepNln + // Remember that we use MemberSig of parent node + +> col sepNln ms (genMemberSig astContext) +> unindent + + | SigObjectModel(TCDelegate(FunType ts), _) -> + typeName +> sepEq +> sepSpace -- "delegate of " +> genTypeList astContext ts + | SigObjectModel(_, mds) -> + typeName +> sepEq +> indent +> sepNln + +> col sepNln mds (genMemberSig astContext) +> unindent + + | SigExceptionRepr(SigExceptionDefRepr(ats, px, ao, uc)) -> + genExceptionBody astContext ats px ao uc + +and genMemberSig astContext = function + | MSMember(Val(ats, px, ao, s, t, vi, _), mf) -> + let (FunType namedArgs) = (t, vi) + genPreXmlDoc px +> genAttributes astContext ats + +> atCurrentColumn (indent +> genMemberFlags { astContext with IsInterface = false } mf +> opt sepNone ao genAccess + +> ifElse (s = "``new``") (!- "new") (!- s) + +> sepColon +> genTypeList astContext namedArgs +> unindent) + + | MSInterface t -> !- "interface " +> genType astContext false t + | MSInherit t -> !- "inherit " +> genType astContext false t + | MSValField f -> genField astContext "val " f + | MSNestedType _ -> invalidArg "md" "This is not implemented in F# compiler" + +and genTyparDecl astContext (TyparDecl(ats, tp)) = + genOnelinerAttributes astContext ats +> genTypar astContext tp + +and genTypeDefKind = function + | TCSimple TCUnspecified -> sepNone + | TCSimple TCClass -> !- "class" + | TCSimple TCInterface -> !- "interface" + | TCSimple TCStruct -> !- "struct" + | TCSimple TCRecord -> sepNone + | TCSimple TCUnion -> sepNone + | TCSimple TCAbbrev -> sepNone + | TCSimple TCHiddenRepr -> sepNone + | TCSimple TCAugmentation -> sepNone + | TCSimple TCILAssemblyCode -> sepNone + | TCDelegate _ -> sepNone + +and genExceptionBody astContext ats px ao uc = + genPreXmlDoc px + +> genAttributes astContext ats -- "exception " + +> opt sepSpace ao genAccess +> genUnionCase { astContext with HasVerticalBar = false } uc + +and genException astContext (ExceptionDef(ats, px, ao, uc, ms)) = + genExceptionBody astContext ats px ao uc + +> ifElse ms.IsEmpty sepNone + (!- " with" +> indent +> genMemberDefnList { astContext with IsInterface = false } ms +> unindent) + +and genSigException astContext (SigExceptionDef(ats, px, ao, uc, ms)) = + genExceptionBody astContext ats px ao uc + +> colPre sepNln sepNln ms (genMemberSig astContext) + +and genUnionCase astContext (UnionCase(ats, px, _, s, UnionCaseType fs)) = + genPreXmlDoc px + +> ifElse astContext.HasVerticalBar sepBar sepNone + +> genOnelinerAttributes astContext ats -- s + +> colPre wordOf sepStar fs (genField { astContext with IsUnionField = true } "") + +and genEnumCase astContext (EnumCase(ats, px, _, c)) = + genPreXmlDoc px + +> ifElse astContext.HasVerticalBar sepBar sepNone + +> genOnelinerAttributes astContext ats +> genConst c + +and genField astContext prefix (Field(ats, px, ao, isStatic, isMutable, t, so)) = + // Being protective on union case declaration + let t = genType astContext astContext.IsUnionField t + genPreXmlDoc px + +> genAttributes astContext ats +> ifElse isStatic (!- "static ") sepNone -- prefix + +> ifElse isMutable (!- "mutable ") sepNone +> opt sepSpace ao genAccess + +> opt sepColon so (!-) +> t + +and genType astContext outerBracket t = + let rec loop = function + | THashConstraint t -> !- "#" +> loop t + | TMeasurePower(t, n) -> loop t -- "^" +> str n + | TMeasureDivide(t1, t2) -> loop t1 -- " / " +> loop t2 + | TStaticConstant(c) -> genConst c + | TStaticConstantExpr(e) -> genExpr astContext e + | TStaticConstantNamed(t1, t2) -> loop t1 -- "=" +> loop t2 + | TArray(t, n) -> loop t -- " [" +> rep (n - 1) (!- ",") -- "]" + | TAnon -> sepWild + | TVar tp -> genTypar astContext tp + // Drop bracket around tuples before an arrow + | TFun(TTuple ts, t) -> sepOpenT +> loopTTupleList ts +> sepArrow +> loop t +> sepCloseT + // Do similar for tuples after an arrow + | TFun(t, TTuple ts) -> sepOpenT +> loop t +> sepArrow +> loopTTupleList ts +> sepCloseT + | TFuns ts -> sepOpenT +> col sepArrow ts loop +> sepCloseT + | TApp(t, ts, isPostfix) -> + let postForm = + match ts with + | [] -> loop t + | [t'] -> loop t' +> sepSpace +> loop t + | ts -> sepOpenT +> col sepComma ts loop +> sepCloseT +> loop t + + ifElse isPostfix postForm (loop t +> genPrefixTypes astContext ts) + + | TLongIdentApp(t, s, ts) -> loop t -- sprintf ".%s" s +> genPrefixTypes astContext ts + | TTuple ts -> sepOpenT +> loopTTupleList ts +> sepCloseT + | TWithGlobalConstraints(TFuns ts, tcs) -> col sepArrow ts loop +> colPre (!- " when ") wordAnd tcs (genTypeConstraint astContext) + | TWithGlobalConstraints(t, tcs) -> loop t +> colPre (!- " when ") wordAnd tcs (genTypeConstraint astContext) + | TLongIdent s -> !- s + | t -> failwithf "Unexpected type: %O" t + + and loopTTupleList = function + | [] -> sepNone + | [(_, t)] -> loop t + | (isDivide, t) :: ts -> + loop t -- (if isDivide then " / " else " * ") +> loopTTupleList ts + + match t with + | TFun(TTuple ts, t) -> + ifElse outerBracket (sepOpenT +> loopTTupleList ts +> sepArrow +> loop t +> sepCloseT) + (loopTTupleList ts +> sepArrow +> loop t) + | TFuns ts -> ifElse outerBracket (sepOpenT +> col sepArrow ts loop +> sepCloseT) (col sepArrow ts loop) + | TTuple ts -> ifElse outerBracket (sepOpenT +> loopTTupleList ts +> sepCloseT) (loopTTupleList ts) + | _ -> loop t + +and genPrefixTypes astContext = function + | [] -> sepNone + // Some patterns without spaces could cause a parsing error + | (TStaticConstant _ | TStaticConstantExpr _ | TStaticConstantNamed _ | TVar(Typar(_, true)) as t)::ts -> + !- "< " +> col sepComma (t::ts) (genType astContext false) -- " >" + | ts -> !- "<" +> col sepComma ts (genType astContext false) -- ">" + +and genTypeList astContext = function + | [] -> sepNone + | (t, [ArgInfo(attribs, so, isOpt)])::ts -> + let hasBracket = not ts.IsEmpty + let gt = + match t with + | TTuple _ -> + opt sepColonFixed so (if isOpt then (sprintf "?%s" >> (!-)) else (!-)) + +> genType astContext hasBracket t + | TFun _ -> + // Fun is grouped by brackets inside 'genType astContext true t' + opt sepColonFixed so (if isOpt then (sprintf "?%s" >> (!-)) else (!-)) + +> genType astContext true t + | _ -> + opt sepColonFixed so (!-) +> genType astContext false t + genOnelinerAttributes astContext attribs + +> gt +> ifElse ts.IsEmpty sepNone (autoNln (sepArrow +> genTypeList astContext ts)) + + | (TTuple ts', argInfo)::ts -> + // The '/' separator shouldn't appear here + let hasBracket = not ts.IsEmpty + let gt = col sepStar (Seq.zip argInfo (Seq.map snd ts')) + (fun (ArgInfo(attribs, so, isOpt), t) -> + genOnelinerAttributes astContext attribs + +> opt sepColonFixed so (if isOpt then (sprintf "?%s" >> (!-)) else (!-)) + +> genType astContext hasBracket t) + gt +> ifElse ts.IsEmpty sepNone (autoNln (sepArrow +> genTypeList astContext ts)) + + | (t, _)::ts -> + let gt = genType astContext false t + gt +> ifElse ts.IsEmpty sepNone (autoNln (sepArrow +> genTypeList astContext ts)) + +and genTypar astContext (Typar(s, isHead)) = + ifElse isHead (ifElse astContext.IsFirstTypeParam (!- " ^") (!- "^")) (!-"'") -- s + +and genTypeConstraint astContext = function + | TyparSingle(kind, tp) -> genTypar astContext tp +> sepColon -- sprintf "%O" kind + | TyparDefaultsToType(tp, t) -> !- "default " +> genTypar astContext tp +> sepColon +> genType astContext false t + | TyparSubtypeOfType(tp, t) -> genTypar astContext tp -- " :> " +> genType astContext false t + | TyparSupportsMember(tps, msg) -> + genTyparList astContext tps +> sepColon +> sepOpenT +> genMemberSig astContext msg +> sepCloseT + | TyparIsEnum(tp, ts) -> + genTypar astContext tp +> sepColon -- "enum<" +> col sepComma ts (genType astContext false) -- ">" + | TyparIsDelegate(tp, ts) -> + genTypar astContext tp +> sepColon -- "delegate<" +> col sepComma ts (genType astContext false) -- ">" + +and genInterfaceImpl astContext (InterfaceImpl(t, bs)) = + match bs with + | [] -> !- "interface " +> genType astContext false t + | bs -> + !- "interface " +> genType astContext false t -- " with" + +> indent +> sepNln +> genMemberBindingList { astContext with IsInterface = true } bs +> unindent + +and genClause astContext hasBar (Clause(p, e, eo)) = + ifElse hasBar sepBar sepNone +> genPat astContext p + +> optPre (!- " when ") sepNone eo (genExpr astContext) +> sepArrow +> preserveBreakNln astContext e + +/// Each multiline member definition has a pre and post new line. +and genMemberDefnList astContext = function + | [x] -> sepNln +> genMemberDefn astContext x + + | MDOpenL(xs, ys) -> + fun ctx -> + let xs = sortAndDeduplicate ((|MDOpen|_|) >> Option.get) xs ctx + match ys with + | [] -> col sepNln xs (genMemberDefn astContext) ctx + | _ -> (col sepNln xs (genMemberDefn astContext) +> rep 2 sepNln +> genMemberDefnList astContext ys) ctx + + | MultilineMemberDefnL(xs, []) -> + rep 2 sepNln + +> col (rep 2 sepNln) xs (function + | Pair(x1, x2) -> genPropertyWithGetSet astContext (x1, x2) + | Single x -> genMemberDefn astContext x) + + | MultilineMemberDefnL(xs, ys) -> + rep 2 sepNln + +> col (rep 2 sepNln) xs (function + | Pair(x1, x2) -> genPropertyWithGetSet astContext (x1, x2) + | Single x -> genMemberDefn astContext x) + +> sepNln +> genMemberDefnList astContext ys + + | OneLinerMemberDefnL(xs, ys) -> + sepNln +> col sepNln xs (genMemberDefn astContext) +> genMemberDefnList astContext ys + | _ -> sepNone + +and genMemberDefn astContext = function + | MDNestedType _ -> invalidArg "md" "This is not implemented in F# compiler" + | MDOpen(s) -> !- (sprintf "open %s" s) + // What is the role of so + | MDImplicitInherit(t, e, _) -> !- "inherit " +> genType astContext false t +> genExpr astContext e + | MDInherit(t, _) -> !- "inherit " +> genType astContext false t + | MDValField f -> genField astContext "val " f + | MDImplicitCtor(ats, ao, ps, so) -> + // In implicit constructor, attributes should come even before access qualifiers + ifElse ats.IsEmpty sepNone (sepSpace +> genOnelinerAttributes astContext ats) + +> optPre sepSpace sepSpace ao genAccess +> sepOpenT + +> col sepComma ps (genSimplePat astContext) +> sepCloseT + +> optPre (!- " as ") sepNone so (!-) + + | MDMember(b) -> genMemberBinding astContext b + | MDLetBindings(isStatic, isRec, b::bs) -> + let prefix = + if isStatic && isRec then "static let rec " + elif isStatic then "static let " + elif isRec then "let rec " + else "let " + + genLetBinding { astContext with IsFirstChild = true } prefix b + +> colPre sepNln sepNln bs (genLetBinding { astContext with IsFirstChild = false } "and ") + + | MDInterface(t, mdo) -> + !- "interface " +> genType astContext false t + +> opt sepNone mdo + (fun mds -> !- " with" +> indent +> genMemberDefnList { astContext with IsInterface = true } mds +> unindent) + + | MDAutoProperty(ats, px, ao, mk, e, s, _isStatic, typeOpt, memberKindToMemberFlags) -> + let isFunctionProperty = + match typeOpt with + | Some (TFun _) -> true + | _ -> false + genPreXmlDoc px + +> genAttributes astContext ats +> genMemberFlags astContext (memberKindToMemberFlags mk) +> str "val " + +> opt sepSpace ao genAccess -- s +> optPre sepColon sepNone typeOpt (genType astContext false) + +> sepEq +> sepSpace +> genExpr astContext e -- genPropertyKind (not isFunctionProperty) mk + + | MDAbstractSlot(ats, px, ao, s, t, vi, ValTyparDecls(tds, _, tcs), MFMemberFlags mk) -> + let (FunType namedArgs) = (t, vi) + let isFunctionProperty = + match t with + | TFun _ -> true + | _ -> false + genPreXmlDoc px + +> genAttributes astContext ats + +> opt sepSpace ao genAccess -- sprintf "abstract %s" s + +> genTypeParam astContext tds tcs + +> sepColon +> genTypeList astContext namedArgs -- genPropertyKind (not isFunctionProperty) mk + + | md -> failwithf "Unexpected member definition: %O" md + +and genPropertyKind useSyntacticSugar = function + | PropertyGet -> + // Try to use syntactic sugar on real properties (not methods in disguise) + if useSyntacticSugar then "" else " with get" + | PropertySet -> " with set" + | PropertyGetSet -> " with get, set" + | _ -> "" + +and genSimplePat astContext = function + | SPId(s, isOptArg, _) -> ifElse isOptArg (!- (sprintf "?%s" s)) (!- s) + | SPTyped(sp, t) -> genSimplePat astContext sp +> sepColon +> genType astContext false t + | SPAttrib(ats, sp) -> genOnelinerAttributes astContext ats +> genSimplePat astContext sp + +and genSimplePats astContext = function + // Remove parentheses on an extremely simple pattern + | SimplePats [SPId _ as sp] -> genSimplePat astContext sp + | SimplePats ps -> sepOpenT +> col sepComma ps (genSimplePat astContext) +> sepCloseT + | SPSTyped(ps, t) -> genSimplePats astContext ps +> sepColon +> genType astContext false t + +and genComplexPat astContext = function + | CPId p -> genPat astContext p + | CPSimpleId(s, isOptArg, _) -> ifElse isOptArg (!- (sprintf "?%s" s)) (!- s) + | CPTyped(sp, t) -> genComplexPat astContext sp +> sepColon +> genType astContext false t + | CPAttrib(ats, sp) -> genOnelinerAttributes astContext ats +> genComplexPat astContext sp + +and genComplexPats astContext = function + | ComplexPats [c] -> genComplexPat astContext c + | ComplexPats ps -> sepOpenT +> col sepComma ps (genComplexPat astContext) +> sepCloseT + | ComplexTyped(ps, t) -> genComplexPats astContext ps +> sepColon +> genType astContext false t + +and genPatRecordFieldName astContext (PatRecordFieldName(s1, s2, p)) = + ifElse (s1 = "") (!- (sprintf "%s = " s2)) (!- (sprintf "%s.%s = " s1 s2)) +> genPat astContext p + +and genPatWithIdent astContext (ido, p) = + opt (sepEq +> sepSpace) ido (!-) +> genPat astContext p + +and genPat astContext = function + | PatOptionalVal(s) -> !- (sprintf "?%s" s) + | PatAttrib(p, ats) -> genOnelinerAttributes astContext ats +> genPat astContext p + | PatOr(p1, p2) -> genPat astContext p1 -- " | " +> genPat astContext p2 + | PatAnds(ps) -> col (!- " & ") ps (genPat astContext) + | PatNullary PatNull -> !- "null" + | PatNullary PatWild -> sepWild + | PatTyped(p, t) -> + // CStyle patterns only occur on extern declaration so it doesn't escalate to expressions + // We lookup sources to get extern types since it has quite many exceptions compared to normal F# types + let genTypeByLookup t = + fun ctx -> + if ctx.Config.StrictMode then + genType astContext false t ctx + else + match lookup t.Range ctx with + | Some typ -> + str typ ctx + | None -> + genType astContext false t ctx + + ifElse astContext.IsCStylePattern (genTypeByLookup t +> sepSpace +> genPat astContext p) + (genPat astContext p +> sepColon +> genType astContext false t) + | PatNamed(ao, PatNullary PatWild, s) -> opt sepSpace ao genAccess -- s + | PatNamed(ao, p, s) -> opt sepSpace ao genAccess +> genPat astContext p -- sprintf " as %s" s + | PatLongIdent(ao, s, ps, tpso) -> + let aoc = opt sepSpace ao genAccess + let tpsoc = opt sepNone tpso (fun (ValTyparDecls(tds, _, tcs)) -> genTypeParam astContext tds tcs) + // Override escaped new keyword + let s = if s = "``new``" then "new" else s + match ps with + | [] -> aoc -- s +> tpsoc + | [(_, PatTuple [p1; p2])] when s = "(::)" -> + aoc +> genPat astContext p1 -- " :: " +> genPat astContext p2 + | [(ido, p) as ip] -> + aoc -- s +> tpsoc +> + ifElse (hasParenInPat p || Option.isSome ido) (ifElse (addSpaceBeforeParensInFunDef s p) sepBeforeArg sepNone) sepSpace + +> ifElse (Option.isSome ido) (sepOpenT +> genPatWithIdent astContext ip +> sepCloseT) (genPatWithIdent astContext ip) + // This pattern is potentially long + | ps -> + let hasBracket = ps |> Seq.map fst |> Seq.exists Option.isSome + atCurrentColumn (aoc -- s +> tpsoc +> sepSpace + +> ifElse hasBracket sepOpenT sepNone + +> colAutoNlnSkip0 (ifElse hasBracket sepSemi sepSpace) ps (genPatWithIdent astContext) + +> ifElse hasBracket sepCloseT sepNone) + + | PatParen(PatConst(Const "()", _)) -> !- "()" + | PatParen(p) -> sepOpenT +> genPat astContext p +> sepCloseT + | PatTuple ps -> + atCurrentColumn (colAutoNlnSkip0 sepComma ps (genPat astContext)) + | PatSeq(PatList, ps) -> + ifElse ps.IsEmpty (sepOpenLFixed +> sepCloseLFixed) + (sepOpenL +> atCurrentColumn (colAutoNlnSkip0 sepSemi ps (genPat astContext)) +> sepCloseL) + + | PatSeq(PatArray, ps) -> + ifElse ps.IsEmpty (sepOpenAFixed +> sepCloseAFixed) + (sepOpenA +> atCurrentColumn (colAutoNlnSkip0 sepSemi ps (genPat astContext)) +> sepCloseA) + + | PatRecord(xs) -> + sepOpenS +> atCurrentColumn (colAutoNlnSkip0 sepSemi xs (genPatRecordFieldName astContext)) +> sepCloseS + | PatConst(c) -> genConst c + | PatIsInst(t) -> + // Should have brackets around in the type test patterns + !- ":? " +> genType astContext true t + // Quotes will be printed by inner expression + | PatQuoteExpr e -> genExpr astContext e + | p -> failwithf "Unexpected pattern: %O" p diff --git a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs new file mode 100644 index 00000000000..12c19e0748a --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs @@ -0,0 +1,421 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig + +open System +open System.IO +open System.Collections.Generic +open System.Text.RegularExpressions +open System.CodeDom.Compiler + +open Microsoft.FSharp.Compiler.Range +open TokenMatcher + +type FormatException(msg : string) = + inherit Exception(msg) + +type Num = int + +type FormatConfig = + { /// Number of spaces for each indentation + IndentSpaceNum : Num; + /// The column where we break to new lines + PageWidth : Num; + SemicolonAtEndOfLine : bool; + SpaceBeforeArgument : bool; + SpaceBeforeColon : bool; + SpaceAfterComma : bool; + SpaceAfterSemicolon : bool; + IndentOnTryWith : bool; + /// Reordering and deduplicating open statements + ReorderOpenDeclaration : bool; + SpaceAroundDelimiter : bool; + /// Prettyprinting based on ASTs only + StrictMode : bool } + + static member Default = + { IndentSpaceNum = 4; PageWidth = 80; + SemicolonAtEndOfLine = false; SpaceBeforeArgument = true; SpaceBeforeColon = true; + SpaceAfterComma = true; SpaceAfterSemicolon = true; + IndentOnTryWith = false; ReorderOpenDeclaration = false; + SpaceAroundDelimiter = true; StrictMode = false } + + static member create(indentSpaceNum, pageWith, semicolonAtEndOfLine, + spaceBeforeArgument, spaceBeforeColon, spaceAfterComma, + spaceAfterSemicolon, indentOnTryWith, reorderOpenDeclaration) = + { FormatConfig.Default with + IndentSpaceNum = indentSpaceNum; + PageWidth = pageWith; + SemicolonAtEndOfLine = semicolonAtEndOfLine; + SpaceBeforeArgument = spaceBeforeArgument; + SpaceBeforeColon = spaceBeforeColon; + SpaceAfterComma = spaceAfterComma; + SpaceAfterSemicolon = spaceAfterSemicolon; + IndentOnTryWith = indentOnTryWith; + ReorderOpenDeclaration = reorderOpenDeclaration } + + static member create(indentSpaceNum, pageWith, semicolonAtEndOfLine, + spaceBeforeArgument, spaceBeforeColon, spaceAfterComma, + spaceAfterSemicolon, indentOnTryWith, reorderOpenDeclaration, spaceAroundDelimiter) = + { FormatConfig.Default with + IndentSpaceNum = indentSpaceNum; + PageWidth = pageWith; + SemicolonAtEndOfLine = semicolonAtEndOfLine; + SpaceBeforeArgument = spaceBeforeArgument; + SpaceBeforeColon = spaceBeforeColon; + SpaceAfterComma = spaceAfterComma; + SpaceAfterSemicolon = spaceAfterSemicolon; + IndentOnTryWith = indentOnTryWith; + ReorderOpenDeclaration = reorderOpenDeclaration; + SpaceAroundDelimiter = spaceAroundDelimiter } + + static member create(indentSpaceNum, pageWith, semicolonAtEndOfLine, + spaceBeforeArgument, spaceBeforeColon, spaceAfterComma, + spaceAfterSemicolon, indentOnTryWith, reorderOpenDeclaration, + spaceAroundDelimiter, strictMode) = + { FormatConfig.Default with + IndentSpaceNum = indentSpaceNum; + PageWidth = pageWith; + SemicolonAtEndOfLine = semicolonAtEndOfLine; + SpaceBeforeArgument = spaceBeforeArgument; + SpaceBeforeColon = spaceBeforeColon; + SpaceAfterComma = spaceAfterComma; + SpaceAfterSemicolon = spaceAfterSemicolon; + IndentOnTryWith = indentOnTryWith; + ReorderOpenDeclaration = reorderOpenDeclaration; + SpaceAroundDelimiter = spaceAroundDelimiter; + StrictMode = strictMode } + +/// Wrapping IndentedTextWriter with current column position +type internal ColumnIndentedTextWriter(tw : TextWriter) = + let indentWriter = new IndentedTextWriter(tw, " ") + let mutable col = indentWriter.Indent + + member __.Write(s : string) = + match s.LastIndexOf('\n') with + | -1 -> col <- col + s.Length + | i -> col <- s.Length - i - 1 + indentWriter.Write(s) + + member __.WriteLine(s : string) = + col <- indentWriter.Indent + indentWriter.WriteLine(s) + + /// Current column of the page in an absolute manner + member __.Column + with get() = col + and set i = col <- i + + member __.Indent + with get() = indentWriter.Indent + and set i = indentWriter.Indent <- i + + member __.InnerWriter = indentWriter.InnerWriter + + interface IDisposable with + member __.Dispose() = + indentWriter.Dispose() + +type internal Context = + { Config : FormatConfig; + Writer : ColumnIndentedTextWriter; + mutable BreakLines : bool; + BreakOn : string -> bool; + /// The original source string to query as a last resort + Content : string; + /// Positions of new lines in the original source string + Positions : int []; + /// Comments attached to appropriate locations + Comments : Dictionary; + /// Compiler directives attached to appropriate locations + Directives : Dictionary } + + /// Initialize with a string writer and use space as delimiter + static member Default = + { Config = FormatConfig.Default; + Writer = new ColumnIndentedTextWriter(new StringWriter()); + BreakLines = true; BreakOn = (fun _ -> false); + Content = ""; Positions = [||]; Comments = Dictionary(); Directives = Dictionary() } + + static member create config (content : string) = + let content = String.normalizeNewLine content + let positions = + content.Split('\n') + |> Seq.map (fun s -> String.length s + 1) + |> Seq.scan (+) 0 + |> Seq.toArray + let (comments, directives) = filterCommentsAndDirectives content + { Context.Default with + Config = config; Content = content; Positions = positions; + Comments = comments; Directives = directives } + + member x.With(writer : ColumnIndentedTextWriter) = + writer.Indent <- x.Writer.Indent + writer.Column <- x.Writer.Column + // Use infinite column width to encounter worst-case scenario + let config = { x.Config with PageWidth = Int32.MaxValue } + { x with Writer = writer; Config = config } + +let internal dump (ctx: Context) = + ctx.Writer.InnerWriter.ToString() + +// A few utility functions from https://github.com/fsharp/powerpack/blob/master/src/FSharp.Compiler.CodeDom/generator.fs + +/// Indent one more level based on configuration +let internal indent (ctx : Context) = + ctx.Writer.Indent <- ctx.Writer.Indent + ctx.Config.IndentSpaceNum + ctx + +/// Unindent one more level based on configuration +let internal unindent (ctx : Context) = + ctx.Writer.Indent <- max 0 (ctx.Writer.Indent - ctx.Config.IndentSpaceNum) + ctx + +/// Increase indent by i spaces +let internal incrIndent i (ctx : Context) = + ctx.Writer.Indent <- ctx.Writer.Indent + i + ctx + +/// Decrease indent by i spaces +let internal decrIndent i (ctx : Context) = + ctx.Writer.Indent <- max 0 (ctx.Writer.Indent - i) + ctx + +/// Apply function f at an absolute indent level (use with care) +let internal atIndentLevel level (f : Context -> Context) ctx = + if level < 0 then + invalidArg "level" "The indent level cannot be negative." + let oldLevel = ctx.Writer.Indent + ctx.Writer.Indent <- level + let result = f ctx + ctx.Writer.Indent <- oldLevel + result + +/// Write everything at current column indentation +let internal atCurrentColumn (f : _ -> Context) (ctx : Context) = + atIndentLevel ctx.Writer.Column f ctx + +/// Function composition operator +let internal (+>) (ctx : Context -> Context) (f : _ -> Context) x = + f (ctx x) + +/// Break-line and append specified string +let internal (++) (ctx : Context -> Context) (str : string) x = + let c = ctx x + c.Writer.WriteLine("") + c.Writer.Write(str) + c + +/// Break-line if config says so +let internal (+-) (ctx : Context -> Context) (str : string) x = + let c = ctx x + if c.BreakOn str then + c.Writer.WriteLine("") + else + c.Writer.Write(" ") + c.Writer.Write(str) + c + +/// Append specified string without line-break +let internal (--) (ctx : Context -> Context) (str : string) x = + let c = ctx x + c.Writer.Write(str) + c + +let internal (!-) (str : string) = id -- str +let internal (!+) (str : string) = id ++ str + +/// Print object converted to string +let internal str (o : 'T) (ctx : Context) = + ctx.Writer.Write(o.ToString()) + ctx + +/// Similar to col, and supply index as well +let internal coli f' (c : seq<'T>) f (ctx : Context) = + let mutable tryPick = true + let mutable st = ctx + let mutable i = 0 + let e = c.GetEnumerator() + while (e.MoveNext()) do + if tryPick then tryPick <- false else st <- f' st + st <- f i (e.Current) st + i <- i + 1 + st + +/// Process collection - keeps context through the whole processing +/// calls f for every element in sequence and f' between every two elements +/// as a separator. This is a variant that works on typed collections. +let internal col f' (c : seq<'T>) f (ctx : Context) = + let mutable tryPick = true + let mutable st = ctx + let e = c.GetEnumerator() + while (e.MoveNext()) do + if tryPick then tryPick <- false else st <- f' st + st <- f (e.Current) st + st + +/// Similar to col, apply one more function f2 at the end if the input sequence is not empty +let internal colPost f2 f1 (c : seq<'T>) f (ctx : Context) = + if Seq.isEmpty c then ctx + else f2 (col f1 c f ctx) + +/// Similar to col, apply one more function f2 at the beginning if the input sequence is not empty +let internal colPre f2 f1 (c : seq<'T>) f (ctx : Context) = + if Seq.isEmpty c then ctx + else col f1 c f (f2 ctx) + +/// If there is a value, apply f and f' accordingly, otherwise do nothing +let internal opt (f' : Context -> _) o f (ctx : Context) = + match o with + | Some x -> f' (f x ctx) + | None -> ctx + +/// Similar to opt, but apply f2 at the beginning if there is a value +let internal optPre (f2 : _ -> Context) (f1 : Context -> _) o f (ctx : Context) = + match o with + | Some x -> f1 (f x (f2 ctx)) + | None -> ctx + +/// b is true, apply f1 otherwise apply f2 +let internal ifElse b (f1 : Context -> Context) f2 (ctx : Context) = + if b then f1 ctx else f2 ctx + +/// Repeat application of a function n times +let internal rep n (f : Context -> Context) (ctx : Context) = + [1..n] |> List.fold (fun c _ -> f c) ctx + +let internal wordAnd = !- " and " +let internal wordOr = !- " or " +let internal wordOf = !- " of " + +// Separator functions + +let internal sepDot = !- "." +let internal sepSpace = !- " " +let internal sepNln = !+ "" +let internal sepStar = !- " * " +let internal sepEq = !- " =" +let internal sepArrow = !- " -> " +let internal sepWild = !- "_" +let internal sepNone = id +let internal sepBar = !- "| " + +/// opening token of list +let internal sepOpenL (ctx : Context) = + if ctx.Config.SpaceAroundDelimiter then str "[ " ctx else str "[" ctx + +/// closing token of list +let internal sepCloseL (ctx : Context) = + if ctx.Config.SpaceAroundDelimiter then str " ]" ctx else str "]" ctx + +/// opening token of list +let internal sepOpenLFixed = !- "[" + +/// closing token of list +let internal sepCloseLFixed = !- "]" + +/// opening token of array +let internal sepOpenA (ctx : Context) = + if ctx.Config.SpaceAroundDelimiter then str "[| " ctx else str "[|" ctx + +/// closing token of array +let internal sepCloseA (ctx : Context) = + if ctx.Config.SpaceAroundDelimiter then str " |]" ctx else str "|]" ctx + +/// opening token of list +let internal sepOpenAFixed = !- "[|" +/// closing token of list +let internal sepCloseAFixed = !- "|]" + +/// opening token of sequence +let internal sepOpenS (ctx : Context) = + if ctx.Config.SpaceAroundDelimiter then str "{ " ctx else str "{" ctx + +/// closing token of sequence +let internal sepCloseS (ctx : Context) = + if ctx.Config.SpaceAroundDelimiter then str " }" ctx else str "}" ctx + +/// opening token of sequence +let internal sepOpenSFixed = !- "{" + +/// closing token of sequence +let internal sepCloseSFixed = !- "}" + +/// opening token of tuple +let internal sepOpenT = !- "(" + +/// closing token of tuple +let internal sepCloseT = !- ")" + + +/// Set a checkpoint to break at an appropriate column +let internal autoNlnOrAddSep f sep (ctx : Context) = + if not ctx.BreakLines then f (sep ctx) else + // Create a dummy context to evaluate length of current operation + use colWriter = new ColumnIndentedTextWriter(new StringWriter()) + let dummyCtx = ctx.With(colWriter) + let col = (dummyCtx |> sep |> f).Writer.Column + // This isn't accurate if we go to new lines + if col > ctx.Config.PageWidth then + f (sepNln ctx) + else + f (sep ctx) + +let internal autoNln f (ctx : Context) = autoNlnOrAddSep f sepNone ctx + +let internal autoNlnOrSpace f (ctx : Context) = autoNlnOrAddSep f sepSpace ctx + +/// Similar to col, skip auto newline for index 0 +let internal colAutoNlnSkip0i f' (c : seq<'T>) f (ctx : Context) = + coli f' c (fun i c -> if i = 0 then f i c else autoNln (f i c)) ctx + +/// Similar to col, skip auto newline for index 0 +let internal colAutoNlnSkip0 f' c f = colAutoNlnSkip0i f' c (fun _ -> f) + +/// Skip all auto-breaking newlines +let internal noNln f (ctx : Context) : Context = + ctx.BreakLines <- false + let res = f ctx + ctx.BreakLines <- true + res + +let internal sepColon (ctx : Context) = + if ctx.Config.SpaceBeforeColon then str " : " ctx else str ": " ctx + +let internal sepColonFixed = !- ":" + +let internal sepComma (ctx : Context) = + if ctx.Config.SpaceAfterComma then str ", " ctx else str "," ctx + +let internal sepSemi (ctx : Context) = + if ctx.Config.SpaceAfterSemicolon then str "; " ctx else str ";" ctx + +let internal sepSemiNln (ctx : Context) = + // sepNln part is essential to indentation + if ctx.Config.SemicolonAtEndOfLine then (!- ";" +> sepNln) ctx else sepNln ctx + +let internal sepBeforeArg (ctx : Context) = + if ctx.Config.SpaceBeforeArgument then str " " ctx else str "" ctx + +/// Conditional indentation on with keyword +let internal indentOnWith (ctx : Context) = + if ctx.Config.IndentOnTryWith then indent ctx else ctx + +/// Conditional unindentation on with keyword +let internal unindentOnWith (ctx : Context) = + if ctx.Config.IndentOnTryWith then unindent ctx else ctx + +let internal sortAndDeduplicate by l (ctx : Context) = + if ctx.Config.ReorderOpenDeclaration then + l |> Seq.distinctBy by |> Seq.sortBy by |> List.ofSeq + else l + +/// Don't put space before and after these operators +let internal NoSpaceInfixOps = set [".."; "?"] + +/// Always break into newlines on these operators +let internal NewLineInfixOps = set ["|>"; "||>"; "|||>"; ">>"; ">>="] + +/// Never break into newlines on these operators +let internal NoBreakInfixOps = set ["="; ">"; "<";] + diff --git a/src/fsharp/vs/ServiceFormatting/SourceParser.fs b/src/fsharp/vs/ServiceFormatting/SourceParser.fs new file mode 100644 index 00000000000..77347c3f1e9 --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/SourceParser.fs @@ -0,0 +1,1209 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.SourceParser + +open System +open System.Diagnostics +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.PrettyNaming +open FormatConfig +open Microsoft.FSharp.Compiler.SourceCodeServices.PrettyNaming + +type Composite<'a, 'b> = + | Pair of 'b * 'b + | Single of 'a + +#if INTERACTIVE +type Debug = Console +#endif + +[] +let maxLength = 512 + +/// Get source string content based on range value +let lookup (r : range) (c : Context) = + if r.EndLine < c.Positions.Length then + let start = c.Positions.[r.StartLine-1] + r.StartColumn + let startLength = c.Positions.[r.StartLine] - c.Positions.[r.StartLine-1] + let finish = c.Positions.[r.EndLine-1] + r.EndColumn - 1 + let finishLength = c.Positions.[r.EndLine] - c.Positions.[r.EndLine-1] + let content = c.Content + // Any line with more than 512 characters isn't reliable for querying + if start > finish || startLength >= maxLength || finishLength >= maxLength then + Debug.WriteLine("Can't lookup between start = {0} and finish = {1}", start, finish) + None + else + let s = content.[start..finish] + Debug.WriteLine("Content: {0} at start = {1}, finish = {2}", s, start, finish) + if s.Contains("\\\n") then + // Terrible hack to compensate the offset made by F# compiler + let last = content.[c.Positions.[r.EndLine-1]..finish] + let offset = min (last.Length - last.TrimStart(' ').Length) (content.Length - finish - 1) + Debug.WriteLine("Content after patch: {0} with offset = {1}", s, offset) + Some content.[start..finish + offset] + else Some s + else None + +let (|Ident|) (s : Ident) = + let ident = s.idText + match ident with + | "`global`" -> "global" + | _ -> QuoteIdentifierIfNeeded ident + +let (|LongIdent|) (li : LongIdent) = + li + |> Seq.map (fun x -> if x.idText = MangledGlobalName then "global" else (|Ident|) x) + |> String.concat "." + |> fun s -> + // Assume that if it starts with base, it's going to be the base keyword + if String.startsWithOrdinal "``base``." s then + String.Join("", "base.", s.[9..]) + else s + +let inline (|LongIdentWithDots|) (LongIdentWithDots(LongIdent s, _)) = s + +type Identifier = + | Id of Ident + | LongId of LongIdent + member x.Text = + match x with + | Id x -> x.idText + | LongId xs -> + xs + |> Seq.map (fun x -> if x.idText = MangledGlobalName then "global" else x.idText) + |> String.concat "." + +/// Different from (|Ident|), this pattern also accepts keywords +let inline (|IdentOrKeyword|) (s : Ident) = Id s + +let (|LongIdentOrKeyword|) (li : LongIdent) = LongId li + +/// Use infix operators in the short form +let (|OpName|) (x : Identifier) = + let s = x.Text + let s' = DecompileOpName s + if IsActivePatternName s then + sprintf "(%s)" s' + elif IsPrefixOperator s then + if s'.[0] = '~' && s'.Length >= 2 && s'.[1] <> '~' then + s'.[1..] + else s' + else + match x with + | Id(Ident s) | LongId(LongIdent s) -> + DecompileOpName s + +/// Operators in their declaration form +let (|OpNameFull|) (x : Identifier) = + let s = x.Text + let s' = DecompileOpName s + if IsActivePatternName s || IsInfixOperator s || IsPrefixOperator s || IsTernaryOperator s || s = "op_Dynamic" then + /// Use two spaces for symmetry + if String.startsWithOrdinal "*" s' && s' <> "*" then + sprintf "( %s )" s' + else sprintf "(%s)" s' + else + match x with + | Id(Ident s) | LongId(LongIdent s) -> + DecompileOpName s + +// Type params + +let inline (|Typar|) (SynTypar.Typar(Ident s, req , _)) = + match req with + | NoStaticReq -> (s, false) + | HeadTypeStaticReq -> (s, true) + +let inline (|ValTyparDecls|) (SynValTyparDecls(tds, b, tcs)) = + (tds, b, tcs) + +// Literals + +let rec (|RationalConst|) = function + | SynRationalConst.Integer i -> + string i + | SynRationalConst.Rational(numerator, denominator, _) -> + sprintf "(%i/%i)" numerator denominator + | SynRationalConst.Negate (RationalConst s) -> + sprintf "- %s" s + +let (|Measure|) x = + let rec loop = function + | SynMeasure.Var(Typar(s, _), _) -> s + | SynMeasure.Anon _ -> "_" + | SynMeasure.One -> "1" + | SynMeasure.Product(m1, m2, _) -> + let s1 = loop m1 + let s2 = loop m2 + sprintf "%s*%s" s1 s2 + | SynMeasure.Divide(m1, m2, _) -> + let s1 = loop m1 + let s2 = loop m2 + sprintf "%s/%s" s1 s2 + | SynMeasure.Power(m, RationalConst n, _) -> + let s = loop m + sprintf "%s^%s" s n + | SynMeasure.Seq(ms, _) -> + List.map loop ms |> String.concat " " + | SynMeasure.Named(LongIdent s, _) -> s + sprintf "<%s>" <| loop x + +/// Lose information about kinds of literals +let rec (|Const|) c = + match c with + | SynConst.Measure(Const c, Measure m) -> c + m + | SynConst.UserNum(num, ty) -> num + ty + | SynConst.Unit -> "()" + | SynConst.Bool b -> sprintf "%A" b + | SynConst.SByte s -> sprintf "%A" s + | SynConst.Byte b -> sprintf "%A" b + | SynConst.Int16 i -> sprintf "%A" i + | SynConst.UInt16 u -> sprintf "%A" u + | SynConst.Int32 i -> sprintf "%A" i + | SynConst.UInt32 u -> sprintf "%A" u + | SynConst.Int64 i -> sprintf "%A" i + | SynConst.UInt64 u -> sprintf "%A" u + | SynConst.IntPtr i -> sprintf "%in" i + | SynConst.UIntPtr u -> sprintf "%iun" u + | SynConst.Single s -> sprintf "%A" s + | SynConst.Double d -> sprintf "%A" d + | SynConst.Char c -> sprintf "%A" c + | SynConst.Decimal d -> sprintf "%A" d + | SynConst.String(s, _) -> + // Naive check for verbatim strings + if not <| String.IsNullOrEmpty(s) && s.Contains("\\") && not <| s.Contains(@"\\") then sprintf "@%A" s + else sprintf "%A" s + | SynConst.Bytes(bs, _) -> sprintf "%A" bs + // Auto print may cut off the array + | SynConst.UInt16s us -> sprintf "%A" us + +let (|Unresolved|) (Const s as c, r) = (c, r, s) + +// File level patterns + +let (|ImplFile|SigFile|) = function + | ParsedInput.ImplFile im -> + ImplFile im + | ParsedInput.SigFile si -> + SigFile si + +let (|ParsedImplFileInput|) (ParsedImplFileInput.ParsedImplFileInput(_, _, _, _, hs, mns, _)) = + (hs, mns) + +let (|ParsedSigFileInput|) (ParsedSigFileInput.ParsedSigFileInput(_, _, _, hs, mns)) = + (hs, mns) + +let (|ModuleOrNamespace|) (SynModuleOrNamespace.SynModuleOrNamespace(LongIdent s, _, isModule, mds, px, ats, ao, _)) = + (ats, px, ao, s, mds, isModule) + +let (|SigModuleOrNamespace|) (SynModuleOrNamespaceSig.SynModuleOrNamespaceSig(LongIdent s, _, isModule, mds, px, ats, ao, _)) = + (ats, px, ao, s, mds, isModule) + +// Attribute + +let (|Attribute|) (a : SynAttribute) = + let (LongIdentWithDots s) = a.TypeName + (s, a.ArgExpr, Option.map (|Ident|) a.Target) + +// Access modifiers + +let (|Access|) = function + | SynAccess.Public -> "public" + | SynAccess.Internal -> "internal" + | SynAccess.Private -> "private" + +let (|PreXmlDoc|) (px: PreXmlDoc) = + match px.ToXmlDoc() with + | XmlDoc lines -> lines + +let (|ParsedHashDirective|) (ParsedHashDirective(s, ss, _)) = + (s, ss) + +// Module declarations (10 cases) + +let (|Open|_|) = function + | SynModuleDecl.Open(LongIdentWithDots s, _) -> + Some s + | _ -> None + +let (|ModuleAbbrev|_|) = function + | SynModuleDecl.ModuleAbbrev(Ident s1, LongIdent s2, _) -> + Some(s1, s2) + | _ -> None + +let (|HashDirective|_|) = function + | SynModuleDecl.HashDirective(p, _) -> + Some p + | _ -> None + +let (|NamespaceFragment|_|) = function + | SynModuleDecl.NamespaceFragment m -> + Some m + | _ -> None + +let (|Attributes|_|) = function + | SynModuleDecl.Attributes(ats, _) -> + Some ats + | _ -> None + +let (|Let|_|) = function + | SynModuleDecl.Let(false, [x], _) -> + Some x + | _ -> None + +let (|LetRec|_|) = function + | SynModuleDecl.Let(true, xs, _) -> + Some xs + | _ -> None + +let (|DoExpr|_|) = function + | SynModuleDecl.DoExpr(_, x, _) -> + Some x + | _ -> None + +let (|Types|_|) = function + | SynModuleDecl.Types(xs, _) -> + Some xs + | _ -> None + +let (|NestedModule|_|) = function + | SynModuleDecl.NestedModule(SynComponentInfo.ComponentInfo(ats, _, _, LongIdent s, px, _, ao, _), _, xs, _, _) -> + Some(ats, px, ao, s, xs) + | _ -> None + +let (|Exception|_|) = function + | SynModuleDecl.Exception(ed, _) -> + Some ed + | _ -> None + +// Module declaration signatures (8 cases) + +let (|SigOpen|_|) = function + | SynModuleSigDecl.Open(LongIdent s, _) -> + Some s + | _ -> None + +let (|SigModuleAbbrev|_|) = function + | SynModuleSigDecl.ModuleAbbrev(Ident s1, LongIdent s2, _) -> + Some(s1, s2) + | _ -> None + +let (|SigHashDirective|_|) = function + | SynModuleSigDecl.HashDirective(p, _) -> + Some p + | _ -> None + +let (|SigNamespaceFragment|_|) = function + | SynModuleSigDecl.NamespaceFragment m -> + Some m + | _ -> None + +let (|SigVal|_|) = function + | SynModuleSigDecl.Val(v, _) -> + Some v + | _ -> None + +let (|SigTypes|_|) = function + | SynModuleSigDecl.Types(tds, _) -> + Some tds + | _ -> None + +let (|SigNestedModule|_|) = function + | SynModuleSigDecl.NestedModule(SynComponentInfo.ComponentInfo(ats, _, _, LongIdent s, px, _, ao, _), _, xs, _) -> + Some(ats, px, ao, s, xs) + | _ -> None + +let (|SigException|_|) = function + | SynModuleSigDecl.Exception(es, _) -> + Some es + | _ -> None + +// Exception definitions + +let (|ExceptionDefRepr|) (SynExceptionDefnRepr.SynExceptionDefnRepr(ats, uc, _, px, ao, _)) = + (ats, px, ao, uc) + +let (|SigExceptionDefRepr|) (SynExceptionDefnRepr.SynExceptionDefnRepr(ats, uc, _, px, ao, _)) = + (ats, px, ao, uc) + +let (|ExceptionDef|) (SynExceptionDefn.SynExceptionDefn(SynExceptionDefnRepr.SynExceptionDefnRepr(ats, uc, _, px, ao, _), ms, _)) = + (ats, px, ao, uc, ms) + +let (|SigExceptionDef|) (SynExceptionSig.SynExceptionSig(SynExceptionDefnRepr.SynExceptionDefnRepr(ats, uc, _, px, ao, _), ms, _)) = + (ats, px, ao, uc, ms) + +let (|UnionCase|) (SynUnionCase.UnionCase(ats, Ident s, uct, px, ao, _)) = + (ats, px, ao, s, uct) + +let (|UnionCaseType|) = function + | SynUnionCaseType.UnionCaseFields fs -> fs + | SynUnionCaseType.UnionCaseFullType _ -> + failwith "UnionCaseFullType should be used internally only." + +let (|Field|) (SynField.Field(ats, isStatic, ido, t, isMutable, px, ao, _)) = + (ats, px, ao, isStatic, isMutable, t, Option.map (|Ident|) ido) + +let (|EnumCase|) (SynEnumCase.EnumCase(ats, Ident s, c, px, r)) = + (ats, px, s, (c, r)) + +// Member definitions (11 cases) + +let (|MDNestedType|_|) = function + | SynMemberDefn.NestedType(td, ao, _) -> + Some(td, ao) + | _ -> None + +let (|MDOpen|_|) = function + | SynMemberDefn.Open(LongIdent s, _) -> + Some s + | _ -> None + +let (|MDImplicitInherit|_|) = function + | SynMemberDefn.ImplicitInherit(t, e, ido, _) -> + Some(t, e, Option.map (|Ident|) ido) + | _ -> None + +let (|MDInherit|_|) = function + | SynMemberDefn.Inherit(t, ido, _) -> + Some(t, Option.map (|Ident|) ido) + | _ -> None + +let (|MDValField|_|) = function + | SynMemberDefn.ValField(f, _) -> Some f + | _ -> None + +let (|MDImplicitCtor|_|) = function + | SynMemberDefn.ImplicitCtor(ao, ats,ps, ido, _) -> + Some(ats, ao, ps, Option.map (|Ident|) ido) + | _ -> None + +let (|MDMember|_|) = function + | SynMemberDefn.Member(b, _) -> Some b + | _ -> None + +let (|MDLetBindings|_|) = function + | SynMemberDefn.LetBindings(es, isStatic, isRec, _) -> + Some(isStatic, isRec, es) + | _ -> None + +let (|MDAbstractSlot|_|) = function + | SynMemberDefn.AbstractSlot(ValSpfn(ats, Ident s, tds, t, vi, _, _, px, ao, _, _), mf, _) -> + Some(ats, px, ao, s, t, vi, tds, mf) + | _ -> None + +let (|MDInterface|_|) = function + | SynMemberDefn.Interface(t, mdo, _) -> + Some(t, mdo) + | _ -> None + +let (|MDAutoProperty|_|) = function + | SynMemberDefn.AutoProperty(ats, isStatic, Ident s, typeOpt, mk, memberKindToMemberFlags, px, ao, e, _ , _) -> + Some(ats, px, ao, mk, e, s, isStatic, typeOpt, memberKindToMemberFlags) + | _ -> None + +// Interface impl + +let (|InterfaceImpl|) (SynInterfaceImpl.InterfaceImpl (t, bs, _)) = (t, bs) + +// Bindings + +let (|PropertyGet|_|) = function + | MemberKind.PropertyGet -> Some() + | _ -> None + +let (|PropertySet|_|) = function + | MemberKind.PropertySet -> Some() + | _ -> None + +let (|PropertyGetSet|_|) = function + | MemberKind.PropertyGetSet -> Some() + | _ -> None + +let (|MFProperty|_|) (mf : MemberFlags) = + match mf.MemberKind with + | MemberKind.PropertyGet + | MemberKind.PropertySet + | MemberKind.PropertyGetSet as mk -> Some mk + | _ -> None + +let (|MFMemberFlags|) (mf : MemberFlags) = mf.MemberKind + +/// This pattern finds out which keyword to use +let (|MFMember|MFStaticMember|MFConstructor|MFOverride|) (mf : MemberFlags) = + match mf.MemberKind with + | MemberKind.ClassConstructor + | MemberKind.Constructor -> + MFConstructor() + | MemberKind.Member + | MemberKind.PropertyGet + | MemberKind.PropertySet + | MemberKind.PropertyGetSet as mk -> + if mf.IsInstance && mf.IsOverrideOrExplicitImpl then MFOverride mk + elif mf.IsInstance then MFMember mk + else MFStaticMember mk + +let (|DoBinding|LetBinding|MemberBinding|PropertyBinding|ExplicitCtor|) = function + | SynBinding.Binding(ao, _, _, _, ats, px, SynValData(Some MFConstructor, _, ido), pat, _, expr, _, _) -> + ExplicitCtor(ats, px, ao, pat, expr, Option.map (|Ident|) ido) + | SynBinding.Binding(ao, _, isInline, _, ats, px, SynValData(Some(MFProperty _ as mf), _, _), pat, _, expr, _, _) -> + PropertyBinding(ats, px, ao, isInline, mf, pat, expr) + | SynBinding.Binding(ao, _, isInline, _, ats, px, SynValData(Some mf, _, _), pat, _, expr, _, _) -> + MemberBinding(ats, px, ao, isInline, mf, pat, expr) + | SynBinding.Binding(_, DoBinding, _, _, ats, px, _, _, _, expr, _, _) -> + DoBinding(ats, px, expr) + | SynBinding.Binding(ao, _, isInline, isMutable, ats, px, _, pat, _, expr, _, _) -> + LetBinding(ats, px, ao, isInline, isMutable, pat, expr) + +let (|BindingReturnInfo|) (SynBindingReturnInfo (t, _, ats)) = (ats, t) + +// Expressions (55 cases, lacking to handle 11 cases) + +let (|TraitCall|_|) = function + | SynExpr.TraitCall(tps, msg, expr, _) -> + Some(tps, msg, expr) + | _ -> None + +/// isRaw = true with <@@ and @@> +let (|Quote|_|) = function + | SynExpr.Quote(e1, isRaw, e2, _, _) -> + Some(e1, e2, isRaw) + | _ -> None + +let (|Paren|_|) = function + | SynExpr.Paren(e, _, _, _) -> + Some e + | _ -> None + +type ExprKind = + | InferredDowncast | InferredUpcast | Lazy | Assert | AddressOfSingle + | AddressOfDouble | Yield | Return | YieldFrom | ReturnFrom | Do | DoBang + override x.ToString() = + match x with + | InferredDowncast -> "downcast " + | InferredUpcast -> "upcast " + | Lazy -> "lazy " + | Assert -> "assert " + | AddressOfSingle -> "&" + | AddressOfDouble -> "&&" + | Yield -> "yield " + | Return -> "return " + | YieldFrom -> "yield! " + | ReturnFrom -> "return! " + | Do -> "do " + | DoBang -> "do! " + +let (|SingleExpr|_|) = function + | SynExpr.InferredDowncast(e, _) -> Some(InferredDowncast, e) + | SynExpr.InferredUpcast(e, _) -> Some(InferredUpcast, e) + | SynExpr.Lazy(e, _) -> Some(Lazy, e) + | SynExpr.Assert(e, _) -> Some(Assert, e) + | SynExpr.AddressOf(true, e, _, _) -> Some(AddressOfSingle, e) + | SynExpr.AddressOf(false, e, _, _) -> Some(AddressOfDouble, e) + | SynExpr.YieldOrReturn((true, _), e, _) -> Some(Yield, e) + | SynExpr.YieldOrReturn((false, _), e, _) -> Some(Return, e) + | SynExpr.YieldOrReturnFrom((true, _), e, _) -> Some(YieldFrom, e) + | SynExpr.YieldOrReturnFrom((false, _), e, _) -> Some(ReturnFrom, e) + | SynExpr.Do(e, _) -> Some(Do, e) + | SynExpr.DoBang(e, _) -> Some(DoBang, e) + | _ -> None + +type TypedExprKind = + | TypeTest | New | Downcast | Upcast | Typed + +let (|TypedExpr|_|) = function + | SynExpr.TypeTest(e, t, _) -> + Some(TypeTest, e, t) + | SynExpr.New(_, t, e, _) -> + Some(New, e, t) + | SynExpr.Downcast(e, t, _) -> + Some(Downcast, e, t) + | SynExpr.Upcast(e, t, _) -> + Some(Upcast, e, t) + | SynExpr.Typed(e, t, _) -> + Some(Typed, e, t) + | _ -> None + +let (|While|_|) = function + | SynExpr.While(_, e1, e2, _) -> + Some(e1, e2) + | _ -> None + +let (|For|_|) = function + | SynExpr.For(_, Ident s, e1, isUp, e2, e3, _) -> + Some(s, e1, e2, e3, isUp) + | _ -> None + +let (|NullExpr|_|) = function + | SynExpr.Null _ -> + Some() + | _ -> None + +let (|ConstExpr|_|) = function + | SynExpr.Const(x, r) -> + Some(x, r) + | _ -> None + +let (|TypeApp|_|) = function + | SynExpr.TypeApp(e, _, ts, _, _, _, _) -> + Some(e, ts) + | _ -> None + +let (|Match|_|) = function + | SynExpr.Match(_, e, cs, _, _) -> + Some(e, cs) + | _ -> None + +let (|Sequential|_|) = function + | SynExpr.Sequential(_, isSeq, e1, e2, _) -> + Some(e1, e2, isSeq) + | _ -> None + +let rec (|Sequentials|_|) = function + | Sequential(e, Sequentials es, _) -> + Some(e::es) + | Sequential(e1, e2, _) -> + Some [e1; e2] + | _ -> None + +let (|SimpleExpr|_|) = function + | SynExpr.Null _ + | SynExpr.Ident _ + | SynExpr.LongIdent _ + | SynExpr.Const(Const _, _) as e -> Some e + | _ -> None + +/// Only recognize numbers; strings are ignored +let rec (|SequentialSimple|_|) = function + | Sequential(SimpleExpr e, SequentialSimple es, true) -> + Some(e::es) + | Sequential(SimpleExpr e1, SimpleExpr e2, true) -> + Some [e1; e2] + | _ -> None + +let (|CompExpr|_|) = function + | SynExpr.CompExpr(isArray, _, expr, _) -> + Some(isArray, expr) + | _ -> None + +let (|ArrayOrListOfSeqExpr|_|) = function + | SynExpr.ArrayOrListOfSeqExpr(isArray, expr, _) -> + Some(isArray, expr) + | _ -> None + +/// This pattern only includes arrays and lists in computation expressions +let (|ArrayOrList|_|) = function + | ArrayOrListOfSeqExpr(isArray, CompExpr(_, SequentialSimple xs)) -> + Some(isArray, xs, true) + | SynExpr.ArrayOrList(isArray, xs, _) + | ArrayOrListOfSeqExpr(isArray, CompExpr(_, Sequentials xs)) -> + Some(isArray, xs, false) + | _ -> None + +let (|Tuple|_|) = function + | SynExpr.Tuple(exprs, _, _) -> + Some exprs + | _ -> None + +let (|IndexedVar|_|) = function + // We might have to narrow scope of this pattern to avoid incorrect usage + | SynExpr.App(_, _, SynExpr.LongIdent(_, LongIdentWithDots "Microsoft.FSharp.Core.Some", _, _), e, _) -> + Some(Some e) + | SynExpr.LongIdent(_, LongIdentWithDots "Microsoft.FSharp.Core.None", _, _) -> Some None + | _ -> None + +let (|Indexer|) = function + | SynIndexerArg.Two(e1, e2) -> Pair(e1, e2) + | SynIndexerArg.One e -> Single e + +let (|OptVar|_|) = function + | SynExpr.Ident(IdentOrKeyword(OpNameFull s)) -> + Some(s, false) + | SynExpr.LongIdent(isOpt, LongIdentWithDots.LongIdentWithDots(LongIdentOrKeyword(OpNameFull s), _), _, _) -> + Some(s, isOpt) + | _ -> None + +/// This pattern is escaped by using OpName +let (|Var|_|) = function + | SynExpr.Ident(IdentOrKeyword(OpName s)) -> + Some s + | SynExpr.LongIdent(_, LongIdentWithDots.LongIdentWithDots(LongIdentOrKeyword(OpName s), _), _, _) -> + Some s + | _ -> None + +// Compiler-generated patterns often have "_arg" prefix +let (|CompilerGeneratedVar|_|) = function + | SynExpr.Ident(IdentOrKeyword(OpName s)) when String.startsWithOrdinal "_arg" s -> + Some s + | SynExpr.LongIdent(_, LongIdentWithDots.LongIdentWithDots(LongIdentOrKeyword(OpName s), _), opt, _) -> + match opt with + | Some _ -> Some s + | None -> if String.startsWithOrdinal "_arg" s then Some s else None + | _ -> None + +/// Get all application params at once +let (|App|_|) e = + let rec loop = function + // function application is left-recursive + | SynExpr.App(_, _, e, e2, _) -> + let (e1, es) = loop e + (e1, e2::es) + | e -> (e, []) + match loop e with + | (_, []) -> None + | (e, es) -> Some(e, List.rev es) + +let (|CompApp|_|) = function + | SynExpr.App(_, _, Var "seq", (SynExpr.App _ as e), _) -> + Some("seq", e) + | _ -> None + +/// Only process prefix operators here +let (|PrefixApp|_|) = function + // Var pattern causes a few prefix operators appear as infix operators + | SynExpr.App(_, false, SynExpr.Ident(IdentOrKeyword s), e2, _) + | SynExpr.App(_, false, SynExpr.LongIdent(_, LongIdentWithDots.LongIdentWithDots(LongIdentOrKeyword s, _), _, _), e2, _) + when IsPrefixOperator (DecompileOpName s.Text) -> + Some((|OpName|) s, e2) + | _ -> None + +let private (|InfixApp|_|) = function + | SynExpr.App(_, true, Var "::", Tuple [e1; e2], _) -> + Some("::", e1, e2) + // Range operators need special treatments, so we exclude them here + | SynExpr.App(_, _, SynExpr.App(_, true, Var s, e1, _), e2, _) when s <> ".." -> + Some(s, e1, e2) + | _ -> None + +let (|TernaryApp|_|) = function + | SynExpr.App(_, _, SynExpr.App(_, _, SynExpr.App(_, true, Var "?<-", e1, _), e2, _), e3, _) -> + Some(e1, e2, e3) + | _ -> None + +/// We should return the whole triple for convenient check +let (|InfixApps|_|) e = + let rec loop = function + | InfixApp(s, e, e2) -> + let (e1, es) = loop e + (e1, (s, e2)::es) + | e -> (e, []) + match loop e with + | (_, []) -> None + | (e, es) -> Some(e, List.rev es) + +/// Gather all arguments in lambda +let rec (|Lambda|_|) = function + | SynExpr.Lambda(_, _, pats, Lambda(e, patss), _) -> + Some(e, pats::patss) + | SynExpr.Lambda(_, _, pats, e, _) -> + Some(e, [pats]) + | _ -> None + +let (|MatchLambda|_|) = function + | SynExpr.MatchLambda(isMember, _, pats, _, _) -> + Some(pats, isMember) + | _ -> None + +let (|JoinIn|_|) = function + | SynExpr.JoinIn(e1, _, e2, _) -> + Some(e1, e2) + | _ -> None + +let (|LetOrUse|_|) = function + | SynExpr.LetOrUse(isRec, isUse, xs, e, _) -> + Some(isRec, isUse, xs, e) + | _ -> None + +/// Unfold a list of let bindings +/// Recursive and use properties have to be determined at this point +let rec (|LetOrUses|_|) = function + | SynExpr.LetOrUse(isRec, isUse, xs, LetOrUses(ys, e), _) -> + let prefix = + if isUse then "use " + elif isRec then "let rec " + else "let " + let xs' = List.mapi (fun i x -> if i = 0 then (prefix, x) else ("and ", x)) xs + Some(xs' @ ys, e) + | SynExpr.LetOrUse(isRec, isUse, xs, e, _) -> + let prefix = + if isUse then "use " + elif isRec then "let rec " + else "let " + let xs' = List.mapi (fun i x -> if i = 0 then (prefix, x) else ("and ", x)) xs + Some(xs', e) + | _ -> None + +let (|LetOrUseBang|_|) = function + | SynExpr.LetOrUseBang(_, isUse, _, p, e1, e2, _) -> + Some(isUse, p, e1, e2) + | _ -> None + +let (|ForEach|_|) = function + | SynExpr.ForEach(_, SeqExprOnly true, _, pat, e1, SingleExpr(Yield, e2) ,_) -> + Some (pat, e1, e2, true) + | SynExpr.ForEach(_, SeqExprOnly isArrow, _, pat, e1, e2 ,_) -> + Some (pat, e1, e2, isArrow) + | _ -> None + +let (|DotIndexedSet|_|) = function + | SynExpr.DotIndexedSet(e1, es, e2, _, _, _) -> + Some(e1, es, e2) + | _ -> None + +let (|DotIndexedGet|_|) = function + | SynExpr.DotIndexedGet(e1, es, _, _) -> + Some(e1, es) + | _ -> None + +let (|DotGet|_|) = function + | SynExpr.DotGet(e, _, LongIdentWithDots s, _) -> + Some(e, s) + | _ -> None + +/// Gather series of application for line breaking +let rec (|DotGetApp|_|) = function + | SynExpr.App(_, _, DotGet(DotGetApp(e, es), s), e', _) -> Some(e, [yield! es; yield (s, e')]) + | SynExpr.App(_, _, DotGet(e, s), e', _) -> Some(e, [(s, e')]) + | _ -> None + +let (|DotGetAppSpecial|_|) = function + | DotGetApp(SynExpr.App(_, _, Var s, e, _), es) -> + let i = s.IndexOf(".") + if i <> -1 then + Some(s.[..i-1], (s.[i+1..], e)::es) + else None + | _ -> None + +let (|DotSet|_|) = function + | SynExpr.DotSet(e1, LongIdentWithDots s, e2, _) -> + Some(e1, s, e2) + | _ -> None + +let (|IfThenElse|_|) = function + | SynExpr.IfThenElse(e1, e2, e3, _, _, _, _) -> + Some(e1, e2, e3) + | _ -> None + +let rec (|ElIf|_|) = function + | SynExpr.IfThenElse(e1, e2, Some(ElIf(es, e3)), _, _, r, _) -> + Some((e1, e2, r)::es, e3) + | SynExpr.IfThenElse(e1, e2, Some e3, _, _, r, _) -> + Some([(e1, e2, r)], e3) + | _ -> None + +let (|Record|_|) = function + | SynExpr.Record(inheritOpt, eo, xs, _) -> + let inheritOpt = inheritOpt |> Option.map (fun (typ, expr, _, _, _) -> (typ, expr)) + Some(inheritOpt, xs, Option.map fst eo) + | _ -> None + +let (|ObjExpr|_|) = function + | SynExpr.ObjExpr(t, eio, bd, ims, _, _) -> + Some (t, eio, bd, ims) + | _ -> None + +let (|LongIdentSet|_|) = function + | SynExpr.LongIdentSet(LongIdentWithDots s, e, _) -> + Some(s, e) + | _ -> None + +let (|TryWith|_|) = function + | SynExpr.TryWith(e, _,cs, _, _, _, _) -> + Some(e, cs) + | _ -> None + +let (|TryFinally|_|) = function + | SynExpr.TryFinally(e1, e2, _, _, _) -> + Some(e1, e2) + | _ -> None + +let (|ParsingError|_|) = function + | SynExpr.ArbitraryAfterError(_, r) + | SynExpr.FromParseError(_, r) + | SynExpr.DiscardAfterMissingQualificationAfterDot(_, r) -> + Some r + | _ -> None + +let (|UnsupportedExpr|_|) = function + // Temprorarily ignore these cases not often used outside FSharp.Core + | SynExpr.LibraryOnlyILAssembly(_, _, _, _, r) + | SynExpr.LibraryOnlyStaticOptimization(_, _, _, r) + | SynExpr.LibraryOnlyUnionCaseFieldGet(_, _, _, r) + | SynExpr.LibraryOnlyUnionCaseFieldSet(_, _, _, _, r) -> + Some r + | _ -> None + +// Patterns (18 cases, lacking to handle 2 cases) + +let (|PatOptionalVal|_|) = function + | SynPat.OptionalVal(Ident s, _) -> + Some s + | _ -> None + +let (|PatAttrib|_|) = function + | SynPat.Attrib(p, ats, _) -> + Some(p, ats) + | _ -> None + +let (|PatOr|_|) = function + | SynPat.Or(p1, p2, _) -> + Some(p1, p2) + | _ -> None + +let (|PatAnds|_|) = function + | SynPat.Ands(ps, _) -> + Some ps + | _ -> None + +type PatNullaryKind = + | PatNull + | PatWild + +let (|PatNullary|_|) = function + | SynPat.Null _ -> Some PatNull + | SynPat.Wild _ -> Some PatWild + | _ -> None + +let (|PatTuple|_|) = function + | SynPat.Tuple(ps, _) -> + Some ps + | _ -> None + +type SeqPatKind = PatArray | PatList + +let (|PatSeq|_|) = function + | SynPat.ArrayOrList(true, ps, _) -> + Some(PatArray, ps) + | SynPat.ArrayOrList(false, ps, _) -> + Some(PatList, ps) + | _ -> None + +let (|PatTyped|_|) = function + | SynPat.Typed(p, t, _) -> + Some(p, t) + | _ -> None + +let (|PatNamed|_|) = function + | SynPat.Named(p, IdentOrKeyword(OpNameFull s), _, ao, _) -> + Some(ao, p, s) + | _ -> None + +let (|PatLongIdent|_|) = function + | SynPat.LongIdent(LongIdentWithDots.LongIdentWithDots(LongIdentOrKeyword(OpNameFull s), _), _, tpso, xs, ao, _) -> + match xs with + | SynConstructorArgs.Pats ps -> + Some(ao, s, List.map (fun p -> (None, p)) ps, tpso) + | SynConstructorArgs.NamePatPairs(nps, _) -> + Some(ao, s, List.map (fun (Ident ident, p) -> (Some ident, p)) nps, tpso) + | _ -> None + +let (|PatParen|_|) = function + | SynPat.Paren(p, _) -> Some p + | _ -> None + +let (|PatRecord|_|) = function + | SynPat.Record(xs, _) -> Some xs + | _ -> None + +let (|PatConst|_|) = function + | SynPat.Const(c, r) -> Some(c, r) + | _ -> None + +let (|PatIsInst|_|) = function + | SynPat.IsInst(t, _) -> Some t + | _ -> None + +let (|PatQuoteExpr|_|) = function + | SynPat.QuoteExpr(e, _) -> Some e + | _ -> None + +// Members + +let (|SPAttrib|SPId|SPTyped|) = function + | SynSimplePat.Attrib(sp, ats, _) -> + SPAttrib(ats, sp) + // Not sure compiler generated SPIds are used elsewhere. + | SynSimplePat.Id(Ident s, _, isGen, _, isOptArg, _) -> + SPId(s, isOptArg, isGen) + | SynSimplePat.Typed(sp, t, _) -> + SPTyped(sp, t) + +let (|SimplePats|SPSTyped|) = function + | SynSimplePats.SimplePats(ps, _) -> + SimplePats ps + | SynSimplePats.Typed(ps, t, _) -> + SPSTyped(ps, t) + +let (|RecordField|) = function + | SynField.Field(ats, _, ido, _, _, px, ao, _) -> + (ats, px, ao, Option.map (|Ident|) ido) + +let (|Clause|) (SynMatchClause.Clause(p, eo, e, _, _)) = (p, e, eo) + +let rec private (|DesugaredMatch|_|) = function + | SynExpr.Match(_, CompilerGeneratedVar s, [Clause(p, DesugaredMatch(ss, e), None)], _, _) -> + Some((s, p)::ss, e) + | SynExpr.Match(_, CompilerGeneratedVar s, [Clause(p, e, None)], _, _) -> + Some([(s, p)], e) + | _ -> None + +type ComplexPat = + | CPAttrib of SynAttributes * ComplexPat + | CPId of SynPat + | CPSimpleId of string * bool * bool + | CPTyped of ComplexPat * SynType + +type ComplexPats = + | ComplexPats of ComplexPat list + | ComplexTyped of ComplexPats * SynType + +/// Manipulate patterns in case the compiler generate spurious matches +let rec transformPatterns ss = function + | SimplePats sps -> + let rec loop sp = + match sp with + | SPAttrib(ats, sp) -> CPAttrib(ats, loop sp) + | SPId(s, b, true) -> + match List.tryPick(fun (s', p) -> if s = s' then Some p else None) ss with + | Some p -> + match p with + | PatConst _ | PatQuoteExpr _ | PatNullary _ + | PatRecord _ | PatSeq ((PatList | PatArray), _) -> + // A few patterns with delimiters + CPId p + | _ -> + // Add parentheses to separate from other patterns + CPId (SynPat.Paren(p, p.Range)) + | None -> CPSimpleId(s, b, true) + | SPId(s, b, _) -> CPSimpleId(s, b, false) + | SPTyped(sp, t) -> CPTyped(loop sp, t) + List.map loop sps |> ComplexPats + | SPSTyped(sp, t) -> ComplexTyped(transformPatterns ss sp, t) + +/// Process compiler-generated matches in an appropriate way +let (|DesugaredLambda|_|) = function + | Lambda(DesugaredMatch(ss, e), spss) -> + Some(List.map (transformPatterns ss) spss, e) + | _ -> None + +// Type definitions + +let (|TDSREnum|TDSRUnion|TDSRRecord|TDSRNone|TDSRTypeAbbrev|TDSRException|) = function + | SynTypeDefnSimpleRepr.Enum(ecs, _) -> + TDSREnum ecs + | SynTypeDefnSimpleRepr.Union(ao, xs, _) -> + TDSRUnion(ao, xs) + | SynTypeDefnSimpleRepr.Record(ao, fs, _) -> + TDSRRecord(ao, fs) + | SynTypeDefnSimpleRepr.None _ -> + TDSRNone() + | SynTypeDefnSimpleRepr.TypeAbbrev(_, t, _) -> + TDSRTypeAbbrev t + | SynTypeDefnSimpleRepr.General _ -> + failwith "General should not appear in the parse tree" + | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly _ -> + failwith "LibraryOnlyILAssembly is not supported yet" + | SynTypeDefnSimpleRepr.Exception repr -> + TDSRException repr + +let (|Simple|ObjectModel|ExceptionRepr|) = function + | SynTypeDefnRepr.Simple(tdsr, _) -> + Simple tdsr + | SynTypeDefnRepr.ObjectModel(tdk, mds, _) -> + ObjectModel(tdk, mds) + | SynTypeDefnRepr.Exception repr -> + ExceptionRepr repr + +let (|MemberDefnList|) mds = + // Assume that there is at most one implicit constructor + let impCtor = List.tryFind (function MDImplicitCtor _ -> true | _ -> false) mds + // Might need to sort so that let and do bindings come first + let others = List.filter (function MDImplicitCtor _ -> false | _ -> true) mds + (impCtor, others) + +let (|SigSimple|SigObjectModel|SigExceptionRepr|) = function + | SynTypeDefnSigRepr.Simple(tdsr, _) -> + SigSimple tdsr + | SynTypeDefnSigRepr.ObjectModel(tdk, mds, _) -> + SigObjectModel(tdk, mds) + | SynTypeDefnSigRepr.Exception repr -> + SigExceptionRepr repr + +type TypeDefnKindSingle = + | TCUnspecified | TCClass | TCInterface | TCStruct | TCRecord + | TCUnion | TCAbbrev | TCHiddenRepr | TCAugmentation | TCILAssemblyCode + +let (|TCSimple|TCDelegate|) = function + | TyconUnspecified -> TCSimple TCUnspecified + | TyconClass -> TCSimple TCClass + | TyconInterface -> TCSimple TCInterface + | TyconStruct -> TCSimple TCStruct + | TyconRecord -> TCSimple TCRecord + | TyconUnion -> TCSimple TCUnion + | TyconAbbrev -> TCSimple TCAbbrev + | TyconHiddenRepr -> TCSimple TCHiddenRepr + | TyconAugmentation -> TCSimple TCAugmentation + | TyconILAssemblyCode -> TCSimple TCILAssemblyCode + | TyconDelegate(t, vi) -> TCDelegate(t, vi) + +let (|TypeDef|) (SynTypeDefn.TypeDefn(SynComponentInfo.ComponentInfo(ats, tds, tcs, LongIdent s, px, _, ao, _) , tdr, ms, _)) = + (ats, px, ao, tds, tcs, tdr, ms, s) + +let (|SigTypeDef|) (SynTypeDefnSig.TypeDefnSig(SynComponentInfo.ComponentInfo(ats, tds, tcs, LongIdent s, px, _, ao, _) , tdr, ms, _)) = + (ats, px, ao, tds, tcs, tdr, ms, s) + +let (|TyparDecl|) (SynTyparDecl.TyparDecl(ats, tp)) = + (ats, tp) + +// Types (15 cases) + +let (|THashConstraint|_|) = function + | SynType.HashConstraint(t, _) -> + Some t + | _ -> None + +let (|TMeasurePower|_|) = function + | SynType.MeasurePower(t, RationalConst n, _) -> + Some(t, n) + | _ -> None + +let (|TMeasureDivide|_|) = function + | SynType.MeasureDivide(t1, t2, _) -> + Some(t1, t2) + | _ -> None + +let (|TStaticConstant|_|) = function + | SynType.StaticConstant(c, r) -> + Some(c, r) + | _ -> None + +let (|TStaticConstantExpr|_|) = function + | SynType.StaticConstantExpr(c, _) -> + Some c + | _ -> None + +let (|TStaticConstantNamed|_|) = function + | SynType.StaticConstantNamed(t1, t2, _) -> + Some(t1, t2) + | _ -> None + +let (|TArray|_|) = function + | SynType.Array(n, t, _) -> + Some(t, n) + | _ -> None + +let (|TAnon|_|) = function + | SynType.Anon _ -> + Some() + | _ -> None + +let (|TVar|_|) = function + | SynType.Var(tp, _) -> + Some tp + | _ -> None + +let (|TFun|_|) = function + | SynType.Fun(t1, t2, _) -> + Some(t1, t2) + | _ -> None + +// Arrow type is right-associative +let rec (|TFuns|_|) = function + | TFun(t1, TFuns ts) -> + Some[yield t1; yield! ts] + | TFun(t1, t2) -> + Some[t1; t2] + | _ -> None + +let (|TApp|_|) = function + | SynType.App(t, _, ts, _, _, isPostfix, _) -> + Some(t, ts, isPostfix) + | _ -> None + +let (|TLongIdentApp|_|) = function + | SynType.LongIdentApp(t, LongIdentWithDots s, _, ts, _, _, _) -> + Some(t, s, ts) + | _ -> None + +let (|TTuple|_|) = function + | SynType.Tuple(ts, _) -> + Some ts + | _ -> None + +let (|TWithGlobalConstraints|_|) = function + | SynType.WithGlobalConstraints(t, tcs, _) -> + Some(t, tcs) + | _ -> None + +let (|TLongIdent|_|) = function + | SynType.LongIdent(LongIdentWithDots s) -> + Some s + | _ -> None + +// Type parameter + +type SingleTyparConstraintKind = + | TyparIsValueType | TyparIsReferenceType | TyparIsUnmanaged + | TyparSupportsNull | TyparIsComparable | TyparIsEquatable + override x.ToString() = + match x with + | TyparIsValueType -> "struct" + | TyparIsReferenceType -> "not struct" + | TyparIsUnmanaged -> "unmanaged" + | TyparSupportsNull -> "null" + | TyparIsComparable -> "comparison" + | TyparIsEquatable -> "equality" + +let (|TyparSingle|TyparDefaultsToType|TyparSubtypeOfType|TyparSupportsMember|TyparIsEnum|TyparIsDelegate|) = function + | WhereTyparIsValueType(tp, _) -> TyparSingle(TyparIsValueType, tp) + | WhereTyparIsReferenceType(tp, _) -> TyparSingle(TyparIsReferenceType, tp) + | WhereTyparIsUnmanaged(tp, _) -> TyparSingle(TyparIsUnmanaged, tp) + | WhereTyparSupportsNull(tp, _) -> TyparSingle(TyparSupportsNull, tp) + | WhereTyparIsComparable(tp, _) -> TyparSingle(TyparIsComparable, tp) + | WhereTyparIsEquatable(tp, _) -> TyparSingle(TyparIsEquatable, tp) + | WhereTyparDefaultsToType(tp, t, _) -> TyparDefaultsToType(tp, t) + | WhereTyparSubtypeOfType(tp, t, _) -> TyparSubtypeOfType(tp, t) + | WhereTyparSupportsMember(tps, msg, _) -> + TyparSupportsMember(List.choose (function SynType.Var(tp, _) -> Some tp | _ -> None) tps, msg) + | WhereTyparIsEnum(tp, ts, _) -> TyparIsEnum(tp, ts) + | WhereTyparIsDelegate(tp, ts, _) -> TyparIsDelegate(tp, ts) + +let (|MSMember|MSInterface|MSInherit|MSValField|MSNestedType|) = function + | SynMemberSig.Member(vs, mf, _) -> MSMember(vs, mf) + | SynMemberSig.Interface(t, _) -> MSInterface t + | SynMemberSig.Inherit(t, _) -> MSInherit t + | SynMemberSig.ValField(f, _) -> MSValField f + | SynMemberSig.NestedType(tds, _) -> MSNestedType tds + +let (|Val|) (ValSpfn(ats, IdentOrKeyword(OpNameFull s), tds, t, vi, _, _, px, ao, _, _)) = + (ats, px, ao, s, t, vi, tds) + +// Misc + +let (|RecordFieldName|) ((LongIdentWithDots s, _) : RecordFieldName, eo : SynExpr option, _) = (s, eo) + +let (|PatRecordFieldName|) ((LongIdent s1, Ident s2), p) = (s1, s2, p) + +let (|ValInfo|) (SynValInfo(aiss, ai)) = (aiss, ai) + +let (|ArgInfo|) (SynArgInfo(attribs, isOpt, ido)) = + (attribs, Option.map (|Ident|) ido, isOpt) + +/// Extract function arguments with their associated info +let (|FunType|) (t, ValInfo(argTypes, returnType)) = + // Parse arg info by attach them into relevant types. + // The number of arg info will determine semantics of argument types. + let rec loop = function + | TFun(t1, t2), argType::argTypes -> + (t1, argType)::loop(t2, argTypes) + | t, [] -> [(t, [returnType])] + | _ -> [] + loop(t, argTypes) + +/// A rudimentary recognizer for extern functions +/// Probably we should use lexing information to improve its accuracy +let (|Extern|_|) = function + | Let(LetBinding([Attribute(name, _, _)] as ats, px, ao, _, _, PatLongIdent(_, s, [_, PatTuple ps], _), TypedExpr(Typed, _, t))) + when name.EndsWith("DllImport") -> + Some(ats, px, ao, t, s, ps) + | _ -> None \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs b/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs new file mode 100644 index 00000000000..2c1733b826e --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs @@ -0,0 +1,294 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.SourceTransformer + +open FormatConfig +open SourceParser +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Range + +[] +module List = + let inline atMostOne xs = + match xs with + | [] | [_] -> true + | _ -> false + +/// Check whether an expression should be broken into multiple lines. +/// Notice that order of patterns matters due to non-disjoint property. +let rec multiline = function + | ConstExpr _ + | NullExpr + | OptVar _ + | SequentialSimple _ -> + false + + | ObjExpr _ + | While _ + | For _ + | ForEach _ + | TryWith _ + | TryFinally _ + | Sequentials _ + | IfThenElse _ -> + true + + | Paren e + | SingleExpr(_, e) + | TypedExpr(_, e, _) + | CompExpr(_, e) + | ArrayOrListOfSeqExpr(_, e) + | DesugaredLambda(_, e) + | Lambda(e, _) + | TypeApp(e, _) + | LongIdentSet(_, e) + | DotGet(e, _) + | TraitCall(_, _, e) -> + multiline e + + | Quote(e1, e2, _) + | JoinIn(e1, e2) + | DotSet(e1, _, e2) + | LetOrUseBang(_, _, e1, e2) -> + multiline e1 || multiline e2 + + | Tuple es -> + List.exists multiline es + + // An infix app is multiline if it contains at least two new line infix ops + | InfixApps(e, es) -> + multiline e + || not (List.atMostOne (List.filter (fst >> NewLineInfixOps.Contains) es)) + || List.exists (snd >> multiline) es + + | App(e1, es) -> + multiline e1 || List.exists multiline es + | DotIndexedGet(e, _) -> + multiline e + + | DotIndexedSet(e1, _, e2) -> + multiline e1 || multiline e2 + + | MatchLambda(cs, _) -> + not (List.atMostOne cs) + | Match(e, cs) -> + not (List.isEmpty cs) || multiline e + | LetOrUse(_, _, bs, e) -> + not (List.isEmpty bs) || multiline e + + // An array or a list is multiline if there are at least two elements + | ArrayOrList(_, es, _) -> + not (List.atMostOne es) + + // A record is multiline if there is at least two fields present + | Record(_, xs, _) -> + let fields = xs |> List.choose ((|RecordFieldName|) >> snd) + not (List.atMostOne fields) || List.exists multiline fields + + // Default mode is single-line + | _ -> false + +let checkNewLine e es = + match es with + | (s, _) :: _ :: _ -> NewLineInfixOps.Contains s + | _ -> multiline e + +/// Check if the expression already has surrounding parentheses +let hasParenthesis = function + | Paren _ + | ConstExpr(Const "()", _) + | Tuple _ -> true + | _ -> false + +let hasParenInPat = function + | PatParen _ -> true + | _ -> false + +let genConst (Unresolved(c, r, s)) = + let r' = c.Range r + fun ctx -> + if ctx.Config.StrictMode then + str s ctx + else + let s' = defaultArg (lookup r' ctx) s + str s' ctx + +/// Check whether a range starting with a specified token +let startWith prefix (r : range) ctx = + lookup r ctx |> Option.exists (String.startsWithOrdinal prefix) + +// A few active patterns for printing purpose + +let rec (|DoExprAttributesL|_|) = function + | DoExpr _ | Attributes _ as x::DoExprAttributesL(xs, ys) -> Some(x::xs, ys) + | DoExpr _ | Attributes _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|HashDirectiveL|_|) = function + | HashDirective _ as x::HashDirectiveL(xs, ys) -> Some(x::xs, ys) + | HashDirective _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|SigHashDirectiveL|_|) = function + | SigHashDirective _ as x::SigHashDirectiveL(xs, ys) -> Some(x::xs, ys) + | SigHashDirective _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|ModuleAbbrevL|_|) = function + | ModuleAbbrev _ as x::ModuleAbbrevL(xs, ys) -> Some(x::xs, ys) + | ModuleAbbrev _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|SigModuleAbbrevL|_|) = function + | SigModuleAbbrev _ as x::SigModuleAbbrevL(xs, ys) -> Some(x::xs, ys) + | SigModuleAbbrev _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|OpenL|_|) = function + | Open _ as x::OpenL(xs, ys) -> Some(x::xs, ys) + | Open _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|SigOpenL|_|) = function + | SigOpen _ as x::SigOpenL(xs, ys) -> Some(x::xs, ys) + | SigOpen _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|MDOpenL|_|) = function + | MDOpen _ as x::MDOpenL(xs, ys) -> Some(x::xs, ys) + | MDOpen _ as x::ys -> Some([x], ys) + | _ -> None + +let rec (|SigValL|_|) = function + | SigVal _ as x::SigValL(xs, ys) -> Some(x::xs, ys) + | SigVal _ as x::ys -> Some([x], ys) + | _ -> None + +/// Omit a break before an expression if the expression is small and it is already one line in the text +let checkPreserveBreakForExpr e (ctx : Context) = + multiline e || ctx.Comments.ContainsKey(e.Range.Start) || ctx.Directives.ContainsKey(e.Range.Start) + +/// Omit a break before an expression if the expression is small +let checkBreakForExpr e = + multiline e + +let (|OneLinerExpr|_|) (e:Ast.SynExpr) = + if checkBreakForExpr e then None else Some e + +let (|OneLinerBinding|MultilineBinding|) b = + match b with + | LetBinding([], PreXmlDoc [||], _, _, _, _, OneLinerExpr _) + | DoBinding([], PreXmlDoc [||], OneLinerExpr _) + | MemberBinding([], PreXmlDoc [||], _, _, _, _, OneLinerExpr _) + | PropertyBinding([], PreXmlDoc [||], _, _, _, _, OneLinerExpr _) + | ExplicitCtor([], PreXmlDoc [||], _, _, OneLinerExpr _, _) -> + OneLinerBinding b + + | _ -> MultilineBinding b + +let rec (|OneLinerLetL|_|) = function + | Let(OneLinerBinding _) as x::OneLinerLetL(xs, ys) -> Some(x::xs, ys) + | Let(OneLinerBinding _) as x::ys -> Some([x], ys) + | _ -> None + +let (|MultilineModuleDecl|_|) = function + | DoExpr _ + | Attributes _ + | HashDirective _ + | ModuleAbbrev _ + | Open _ + | Let(OneLinerBinding _) -> None + | md -> Some md + +let (|SigMultilineModuleDecl|_|) = function + | SigHashDirective _ + | SigModuleAbbrev _ + | SigVal _ + | SigOpen _ -> None + | md -> Some md + +let rec (|MultilineModuleDeclL|_|) = function + | MultilineModuleDecl x::MultilineModuleDeclL(xs, ys) -> Some(x::xs, ys) + | MultilineModuleDecl x::ys -> Some([x], ys) + | _ -> None + +let rec (|SigMultilineModuleDeclL|_|) = function + | SigMultilineModuleDecl x::SigMultilineModuleDeclL(xs, ys) -> Some(x::xs, ys) + | SigMultilineModuleDecl x::ys -> Some([x], ys) + | _ -> None + +/// Gather PropertyGetSet in one printing call. +/// Assume that PropertySet comes right after PropertyGet. +let (|PropertyWithGetSet|_|) = function + | PropertyBinding(_, _, _, _, MFProperty PropertyGet, PatLongIdent(_, s1, _, _), _) as b1::bs -> + match bs with + | PropertyBinding(_, _, _, _, MFProperty PropertySet, PatLongIdent(_, s2, _, _), _) as b2::bs when s1 = s2 -> + Some((b1, b2), bs) + | _ -> None + | _ -> None + +let (|PropertyWithGetSetMemberDefn|_|) = function + | MDMember(x1)::MDMember(x2)::xs -> + match [x1; x2] with + | PropertyWithGetSet((x1, x2), []) -> Some((x1, x2), xs) + | _ -> None + | _ -> None + +let (|OneLinerMemberDefn|MultilineMemberDefn|) md = + match md with + | MDOpen _ + | MDInherit _ + | MDValField _ + | MDImplicitCtor _ + | MDInterface(_, None) + | MDAbstractSlot([], PreXmlDoc [||], _, _, _, _, _, _) + | MDImplicitInherit(_, OneLinerExpr _, _) + | MDMember(OneLinerBinding _) + | MDAutoProperty([], PreXmlDoc [||], _, _, OneLinerExpr _, _, _, _, _) + | MDLetBindings(_, _, [OneLinerBinding _]) -> + OneLinerMemberDefn md + + | _ -> MultilineMemberDefn md + +let rec (|OneLinerMemberDefnL|_|) xs = + match xs with + /// This pattern prevents PropertyWithGetSet to be taken separately + | PropertyWithGetSetMemberDefn _ -> Some([], xs) + | OneLinerMemberDefn x::OneLinerMemberDefnL(xs, ys) -> Some(x::xs, ys) + | OneLinerMemberDefn x::ys -> Some([x], ys) + | _ -> None + +/// Gather all multiline member definitions. +/// This should be used before one-liner pattern. +let rec (|MultilineMemberDefnL|_|) = function + | PropertyWithGetSetMemberDefn((x1, x2), MultilineMemberDefnL(xs, ys)) -> Some(Pair(x1, x2)::xs, ys) + | PropertyWithGetSetMemberDefn((x1, x2), ys) -> Some([Pair(x1, x2)], ys) + | MultilineMemberDefn x::MultilineMemberDefnL(xs, ys) -> Some(Single x::xs, ys) + | MultilineMemberDefn x::ys -> Some([Single x], ys) + | _ -> None + +let rec (|OneLinerBindingL|_|) xs = + match xs with + | PropertyWithGetSet _ -> Some([], xs) + | OneLinerBinding x::OneLinerBindingL(xs, ys) -> Some(x::xs, ys) + | OneLinerBinding x::ys -> Some([x], ys) + | _ -> None + +/// Gather all multiline bindings. +/// This should be used before one-liner pattern. +let rec (|MultilineBindingL|_|) = function + | PropertyWithGetSet((x1, x2), MultilineBindingL(xs, ys)) -> Some(Pair(x1, x2)::xs, ys) + | PropertyWithGetSet((x1, x2), ys) -> Some([Pair(x1, x2)], ys) + | MultilineBinding x::MultilineBindingL(xs, ys) -> Some(Single x::xs, ys) + | MultilineBinding x::ys -> Some([Single x], ys) + | _ -> None + +let rec (|OneLinerLetOrUseL|_|) = function + | (prefix, OneLinerBinding x)::OneLinerLetOrUseL(xs, ys) -> Some((prefix, x)::xs, ys) + | (prefix, OneLinerBinding x)::ys -> Some([prefix, x], ys) + | _ -> None + +let rec (|MultilineLetOrUseL|_|) = function + | (prefix, MultilineBinding x)::MultilineLetOrUseL(xs, ys) -> Some((prefix, x)::xs, ys) + | (prefix, MultilineBinding x)::ys -> Some([prefix, x], ys) + | _ -> None \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs b/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs new file mode 100644 index 00000000000..59e28852610 --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs @@ -0,0 +1,690 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.TokenMatcher + +open System +open System.Collections.Generic +open System.Diagnostics +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.SourceCodeServices + +#if INTERACTIVE +type Debug = Console +#endif + +type Token = + | EOL + | Tok of FSharpTokenInfo * int + override x.ToString() = + match x with + | EOL -> "" + | Tok(tokInfo, l) -> + sprintf "Tok(%O, %O)" tokInfo.TokenName l + +let tokenize defines (content : string) = + seq { + let sourceTokenizer = FSharpSourceTokenizer(defines, Some "/tmp.fsx") + let lines = String.normalizeThenSplitNewLine content + let lexState = ref 0L + for (i, line) in lines |> Seq.zip [1..lines.Length] do + let lineTokenizer = sourceTokenizer.CreateLineTokenizer line + let finLine = ref false + while not !finLine do + let tok, newLexState = lineTokenizer.ScanToken(!lexState) + lexState := newLexState + match tok with + | None -> + if i <> lines.Length then + // New line except at the very last token + yield (EOL, Environment.NewLine) + finLine := true + | Some t -> + yield (Tok(t, i), line.[t.LeftColumn..t.RightColumn]) + } + +/// Create the view as if there is no attached line number +let (|Token|_|) = function + | EOL -> None + | Tok(ti, _) -> Some ti + +// This part of the module takes care of annotating the AST with additional information +// about comments + +/// Whitespace token without EOL +let (|Space|_|) = function + | (Token origTok, origTokText) when origTok.TokenName = "WHITESPACE" -> + Some origTokText + | _ -> None + +let (|NewLine|_|) = function + | (EOL, tokText) -> Some tokText + | _ -> None + +let (|WhiteSpaces|_|) = function + | Space t1 :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | NewLine t2 :: ts2 + | Space t2 :: ts2 -> loop ts2 (t2 :: acc) + | _ -> List.rev acc, ts + Some (loop moreOrigTokens [t1]) + | _ -> None + +let (|RawDelimiter|_|) = function + | (Token origTok, origTokText) when origTok.CharClass = FSharpTokenCharKind.Delimiter -> + Some origTokText + | _ -> None + +let (|RawAttribute|_|) = function + | RawDelimiter "[<" :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | RawDelimiter ">]" :: ts2 -> Some (List.rev(">]" :: acc), ts2) + | (_, t2) :: ts2 -> loop ts2 (t2 :: acc) + | [] -> None + loop moreOrigTokens ["[<"] + | _ -> None + +let (|Comment|_|) = function + | (Token ti, t) + when ti.CharClass = FSharpTokenCharKind.Comment || ti.CharClass = FSharpTokenCharKind.LineComment -> + Some t + | _ -> None + +let (|CommentChunk|_|) = function + | Comment t1 :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | NewLine t2 :: ts2 + | Comment t2 :: ts2 + | Space t2 :: ts2 -> loop ts2 (t2 :: acc) + | _ -> List.rev acc, ts + Some (loop moreOrigTokens [t1]) + | _ -> None + +/// Get all comment chunks before a token +let (|CommentChunks|_|) = function + | CommentChunk(ts1, moreOrigTokens) -> + let rec loop ts acc = + match ts with + | WhiteSpaces(_, CommentChunk(ts2, ts')) -> + // Just keep a newline between two comment chunks + loop ts' (ts2 :: [Environment.NewLine] :: acc) + | CommentChunk(ts2, ts') -> + loop ts' (ts2 :: acc) + | _ -> (List.rev acc |> List.map (String.concat "")), ts + Some (loop moreOrigTokens [ts1]) + | _ -> None + +/// Given a list of tokens, attach comments to appropriate positions +let collectComments tokens = + let rec loop origTokens (dic : Dictionary<_, _>) = + match origTokens with + | (Token origTok, _) :: moreOrigTokens + when origTok.CharClass <> FSharpTokenCharKind.Comment && origTok.CharClass <> FSharpTokenCharKind.LineComment -> + loop moreOrigTokens dic + | NewLine _ :: moreOrigTokens -> loop moreOrigTokens dic + | CommentChunks(ts, WhiteSpaces(_, (Tok(origTok, lineNo), _) :: moreOrigTokens)) + | CommentChunks(ts, (Tok(origTok, lineNo), _) :: moreOrigTokens) -> + dic.Add(mkPos lineNo origTok.LeftColumn, ts) + loop moreOrigTokens dic + | _ -> dic + loop tokens (Dictionary()) + +let (|RawIdent|_|) = function + | (Token ti, t) when ti.TokenName = "IDENT" -> + Some t + | _ -> None + +let (|SkipUntilIdent|_|) origTokens = + let rec loop = function + | RawIdent t :: moreOrigTokens -> Some(t, moreOrigTokens) + | NewLine _ :: _ -> None + | (Token ti, _) :: _ when ti.ColorClass = FSharpTokenColorKind.PreprocessorKeyword -> None + | _ :: moreOrigTokens -> loop moreOrigTokens + | [] -> None + loop origTokens + +let (|SkipUntilEOL|_|) origTokens = + let rec loop = function + | NewLine t :: moreOrigTokens -> Some(t, moreOrigTokens) + | (Token ti, _) :: _ when ti.ColorClass = FSharpTokenColorKind.PreprocessorKeyword -> None + | _ :: moreOrigTokens -> loop moreOrigTokens + | [] -> None + loop origTokens + +/// Skip all whitespaces or comments in an active block +let (|SkipWhiteSpaceOrComment|_|) origTokens = + let rec loop = function + | Space _ :: moreOrigTokens + | NewLine _ :: moreOrigTokens -> loop moreOrigTokens + | (Token ti, _) :: moreOrigTokens + when ti.CharClass = FSharpTokenCharKind.Comment || ti.CharClass = FSharpTokenCharKind.LineComment -> + loop moreOrigTokens + | (Token ti, _) :: _ when ti.ColorClass = FSharpTokenColorKind.PreprocessorKeyword -> None + | t :: moreOrigTokens -> Some(t, moreOrigTokens) + | [] -> None + loop origTokens + +/// Filter all directives +let collectDirectives tokens = + let rec loop origTokens (dic : Dictionary<_, _>) = + match origTokens with + | (Token _, "#if") :: + SkipUntilIdent(t, SkipUntilEOL(_, SkipWhiteSpaceOrComment((Tok(origTok, lineNo), _), moreOrigTokens))) -> + dic.Add(mkPos lineNo origTok.LeftColumn, t) |> ignore + loop moreOrigTokens dic + | _ :: moreOrigTokens -> loop moreOrigTokens dic + | [] -> dic + loop tokens (Dictionary()) + +/// Filter all constants to be used in lexing +let filterConstants content = + let rec loop origTokens (hs : HashSet<_>) = + match origTokens with + | (Token _, "#if") :: + SkipUntilIdent(t, SkipUntilEOL(_, moreOrigTokens)) -> + hs.Add(t) |> ignore + loop moreOrigTokens hs + | _ :: moreOrigTokens -> loop moreOrigTokens hs + | [] -> hs + let hs = loop (tokenize [] content |> Seq.toList) (HashSet()) + Seq.toList hs + +/// Filter all defined constants to be used in parsing +let filterDefines content = + filterConstants content + |> Seq.map (sprintf "--define:%s") + |> Seq.toArray + +/// Filter all comments and directives; assuming all constants are defined +let filterCommentsAndDirectives content = + let constants = filterConstants content + let tokens = tokenize constants content |> Seq.toList + (collectComments tokens, collectDirectives tokens) + +let rec (|RawLongIdent|_|) = function + | RawIdent t1 :: RawDelimiter "." :: RawLongIdent(toks, moreOrigTokens) -> + Some (t1 :: "." :: toks, moreOrigTokens) + | RawIdent t1 :: moreOrigTokens -> + Some ([t1], moreOrigTokens) + | _ -> None + +let (|RawOpenChunk|_|) = function + | (Token _, "open") :: + Space t :: + RawLongIdent(toks, moreOrigTokens) -> + Some ("open" :: t :: toks, moreOrigTokens) + | _ -> None + +let (|NewTokenAfterWhitespaceOrNewLine|_|) toks = + let rec loop toks acc = + match toks with + | (EOL, tt) :: more -> loop more (tt::acc) + | (Token tok, tt) :: more + when tok.CharClass = FSharpTokenCharKind.WhiteSpace && tok.ColorClass <> FSharpTokenColorKind.InactiveCode + && tok.ColorClass <> FSharpTokenColorKind.PreprocessorKeyword -> + loop more (tt::acc) + | newTok :: more -> + Some(List.rev acc, newTok, more) + | [] -> None + loop toks [] + +// This part processes the token stream post- pretty printing + +type LineCommentStickiness = + | StickyLeft + | StickyRight + | NotApplicable + override x.ToString() = + match x with + | StickyLeft -> "left" + | StickyRight -> "right" + | NotApplicable -> "unknown" + +type MarkedToken = + | Marked of Token * string * LineCommentStickiness + member x.Text = + let (Marked(_,t,_)) = x + t + override x.ToString() = + let (Marked(tok, s, stickiness)) = x + sprintf "Marked(%O, %A, %O)" tok s stickiness + +/// Decompose a marked token to a raw token +let (|Wrapped|) (Marked(origTok, origTokText, _)) = + (origTok, origTokText) + +let (|SpaceToken|_|) = function + | Wrapped(Space tokText) -> Some tokText + | _ -> None + +let (|NewLineToken|_|) = function + | Wrapped(NewLine tokText) -> Some tokText + | _ -> None + +let (|WhiteSpaceTokens|_|) = function + | SpaceToken t1 :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | NewLineToken t2 :: ts2 + | SpaceToken t2 :: ts2 -> loop ts2 (t2 :: acc) + | _ -> List.rev acc, ts + Some (loop moreOrigTokens [t1]) + | _ -> None + +let (|Delimiter|_|) = function + | Wrapped(RawDelimiter tokText) -> Some tokText + | _ -> None + +let (|Attribute|_|) = function + | Delimiter "[<" :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | Delimiter ">]" :: ts2 -> Some (List.rev(">]" :: acc), ts2) + | Marked(_, t2, _) :: ts2 -> loop ts2 (t2 :: acc) + | [] -> None + loop moreOrigTokens ["[<"] + | _ -> None + +let (|PreprocessorKeywordToken|_|) requiredText = function + | Marked(Token origTok, origTokText, _) + when origTok.ColorClass = FSharpTokenColorKind.PreprocessorKeyword && origTokText = requiredText -> + Some origTokText + | _ -> None + +let (|InactiveCodeToken|_|) = function + | Marked(Token origTok, origTokText, _) + when origTok.ColorClass = FSharpTokenColorKind.InactiveCode -> Some origTokText + | _ -> None + +let (|LineCommentToken|_|) wantStickyLeft = function + | Marked(Token origTok, origTokText, lcs) + when (not wantStickyLeft || (lcs = StickyLeft)) && + origTok.CharClass = FSharpTokenCharKind.LineComment -> Some origTokText + | _ -> None + +let (|BlockCommentToken|_|) = function + | Marked(Token origTok, origTokText, _) when origTok.CharClass = FSharpTokenCharKind.Comment -> + Some origTokText + | _ -> None + +let (|BlockCommentOrNewLineToken|_|) = function + | BlockCommentToken tokText -> Some tokText + | NewLineToken tokText -> Some tokText + | _ -> None + +let (|LineCommentChunk|_|) wantStickyLeft = function + | LineCommentToken wantStickyLeft t1 :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | LineCommentToken false t2 :: ts2 -> loop ts2 (t2 :: acc) + | _ -> List.rev acc, ts + Some (loop moreOrigTokens [t1]) + | _ -> None + +// TODO: does not cope with directives that have comments, e.g. +// #if (* hello *) FOOBAR +// or +// #endif // FOOBAR +// or ones with extra whitespace at the end of line + +let (|Ident|_|) = function + | Wrapped(RawIdent tokText) -> Some tokText + | _ -> None + +let (|PreprocessorDirectiveChunk|_|) = function + | PreprocessorKeywordToken "#if" t1 :: + SpaceToken t2 :: + Ident t3 :: + moreOrigTokens -> + Some ([t1; t2; t3], moreOrigTokens) + + | PreprocessorKeywordToken "#else" t1 :: moreOrigTokens -> + Some ([t1], moreOrigTokens) + + | PreprocessorKeywordToken "#endif" t1 :: moreOrigTokens -> + Some ([t1], moreOrigTokens) + + | _ -> None + +let (|InactiveCodeChunk|_|) = function + | InactiveCodeToken t1 :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | InactiveCodeToken t2 :: ts2 -> loop ts2 (t2 :: acc) + | NewLineToken t2 :: ts2 -> loop ts2 (t2 :: acc) + | _ -> List.rev acc, ts + Some (loop moreOrigTokens [t1]) + | _ -> None + +let (|BlockCommentChunk|_|) = function + | BlockCommentToken t1 :: moreOrigTokens -> + let rec loop ts acc = + match ts with + | BlockCommentOrNewLineToken t2 :: ts2 -> loop ts2 (t2 :: acc) + | _ -> List.rev acc, ts + Some (loop moreOrigTokens [t1]) + | _ -> None + +/// Add a flag into the token stream indicating if the first token in +/// the tokens of a line comment is sticky-to-the-left +/// text // comment +/// or sticky-to-the-right +/// // comment +/// +let markStickiness (tokens: seq) = + seq { let inWhiteSpaceAtStartOfLine = ref true + let inLineComment = ref false + for (tio, tt) in tokens do + match tio with + | Token ti when ti.CharClass = FSharpTokenCharKind.LineComment -> + if !inLineComment then + // Subsequent tokens in a line comment + yield Marked(tio, tt, NotApplicable) + else + // First token in a line comment. + inLineComment := true + yield Marked(tio, tt, if !inWhiteSpaceAtStartOfLine then StickyRight else StickyLeft) + + // Comments can't be attached to Delimiters + | Token ti + when !inWhiteSpaceAtStartOfLine + && (ti.CharClass = FSharpTokenCharKind.WhiteSpace || ti.CharClass = FSharpTokenCharKind.Delimiter) -> + // Whitespace at start of line + yield Marked(tio, tt, NotApplicable) + | Tok _ -> + // Some other token on a line + inWhiteSpaceAtStartOfLine := false + yield Marked(tio, tt, NotApplicable) + | EOL -> + // End of line marker + inLineComment := false + inWhiteSpaceAtStartOfLine := true + yield Marked(tio, tt, NotApplicable) } + +let rec (|LongIdent|_|) = function + | Ident t1 :: Delimiter "." :: LongIdent(toks, moreOrigTokens) -> + Some (t1 :: "." :: toks, moreOrigTokens) + | Ident t1 :: moreOrigTokens -> + Some ([t1], moreOrigTokens) + | _ -> None + +let (|OpenChunk|_|) = function + | Marked(Token _, "open", _) :: + SpaceToken t :: + LongIdent(toks, moreOrigTokens) -> + Some ("open" :: t :: toks, moreOrigTokens) + | _ -> None + +/// Assume that originalText and newText are derived from the same AST. +/// Pick all comments and directives from originalText to insert into newText +let integrateComments (originalText : string) (newText : string) = + let origTokens = tokenize (filterConstants originalText) originalText |> markStickiness |> Seq.toList + //Seq.iter (fun (Marked(_, s, t)) -> Console.WriteLine("sticky information: {0} -- {1}", s, t)) origTokens + let newTokens = tokenize [] newText |> Seq.toList + + let buffer = System.Text.StringBuilder() + let column = ref 0 + let indent = ref 0 + + let addText (text : string) = + //Debug.WriteLine("ADDING '{0}'", text) + buffer.Append text |> ignore + if text = Environment.NewLine then column := 0 + else column := !column + text.Length + + let maintainIndent f = + let c = !column + f() + Debug.WriteLine("maintain indent at {0}", c) + addText Environment.NewLine + addText (String.replicate c " ") + + let saveIndent c = + indent := c + + let restoreIndent f = + let c = !indent + Debug.WriteLine("set indent back to {0}", c) + addText Environment.NewLine + addText (String.replicate c " ") + f() + + // Assume that starting whitespaces after EOL give indentation of a chunk + let rec getIndent = function + | (Token _, _) :: moreNewTokens -> getIndent moreNewTokens + | NewLine _ :: moreNewTokens -> + match moreNewTokens with + | Space origTokText :: _ -> String.length origTokText + | _ -> 0 + | _ -> 0 + + let countStartingSpaces (lines: string []) = + if lines.Length = 0 then 0 + else + Seq.min [ for line in lines -> line.Length - line.TrimStart(' ').Length ] + + let tokensMatch t1 t2 = + match t1, t2 with + | Marked(Token origTok, origTokText, _), (Token newTok, newTokText) -> + origTok.CharClass = newTok.CharClass && origTokText = newTokText + // Use this pattern to avoid discrepancy between two versions of the same identifier + | Ident origTokText, RawIdent newTokText -> + DecompileOpName(origTokText.Trim('`')) = DecompileOpName(newTokText.Trim('`')) + | _ -> false + + let rec loop origTokens newTokens = + //Debug.WriteLine("*** Matching between {0} and {1}", sprintf "%A" <| tryHead origTokens, sprintf "%A" <| tryHead newTokens) + match origTokens, newTokens with + | (Marked(Token origTok, _, _) :: moreOrigTokens), _ + when origTok.CharClass = FSharpTokenCharKind.WhiteSpace && origTok.ColorClass <> FSharpTokenColorKind.InactiveCode + && origTok.ColorClass <> FSharpTokenColorKind.PreprocessorKeyword -> + Debug.WriteLine "dropping whitespace from orig tokens" + loop moreOrigTokens newTokens + + | (NewLineToken _ :: moreOrigTokens), _ -> + Debug.WriteLine "dropping newline from orig tokens" + loop moreOrigTokens newTokens + + // Not a comment, drop the original token text until something matches + | (Delimiter tokText :: moreOrigTokens), _ when tokText = ";" || tokText = ";;" -> + Debug.WriteLine("dropping '{0}' from original text", box tokText) + loop moreOrigTokens newTokens + + // Inject #if... #else or #endif directive + // These directives could occur inside an inactive code chunk + // Assume that only #endif directive follows by an EOL + | (PreprocessorDirectiveChunk (tokensText, moreOrigTokens)), newTokens -> + let text = String.concat "" tokensText + Debug.WriteLine("injecting preprocessor directive '{0}'", box text) + addText Environment.NewLine + for x in tokensText do addText x + let moreNewTokens = + if String.startsWithOrdinal "#endif" text then + match newTokens with + | WhiteSpaces(ws, moreNewTokens) -> + // There are some whitespaces, use them up + for s in ws do addText s + moreNewTokens + | _ :: _ -> + // This fixes the case where newTokens advance too fast + // and emit whitespaces even before #endif + restoreIndent id + newTokens + | [] -> [] + elif String.startsWithOrdinal "#if" text then + // Save current indentation for #else branch + let indent = getIndent newTokens + saveIndent indent + newTokens + else newTokens + match moreNewTokens with + | (Token t, _) :: _ when t.ColorClass = FSharpTokenColorKind.PreprocessorKeyword -> addText Environment.NewLine + | _ -> () + loop moreOrigTokens moreNewTokens + + // Inject inactive code + // These chunks come out from any #else branch in our scenarios + | (InactiveCodeChunk (tokensText, moreOrigTokens)), _ -> + Debug.WriteLine("injecting inactive code '{0}'", String.concat "" tokensText |> box) + let text = String.concat "" tokensText + let lines = (String.normalizeNewLine text).Split([|'\n'|], StringSplitOptions.RemoveEmptyEntries) + // What is current indentation of this chunk + let numSpaces = countStartingSpaces lines + Debug.WriteLine("the number of starting spaces is {0}", numSpaces) + // Write the chunk in the same indentation with #if branch + for line in lines do + if String.startsWithOrdinal "#" line.[numSpaces..] then + // Naive recognition of inactive preprocessors + addText Environment.NewLine + addText line.[numSpaces..] + else + restoreIndent (fun () -> addText line.[numSpaces..]) + loop moreOrigTokens newTokens + + | (LineCommentChunk true (commentTokensText, moreOrigTokens)), [] -> + Debug.WriteLine("injecting the last stick-to-the-left line comment '{0}'", String.concat "" commentTokensText |> box) + addText " " + for x in commentTokensText do addText x + loop moreOrigTokens newTokens + + // Inject line commment that is sticky-to-the-left, e.g. + // let f x = + // x + x // HERE + // Because it is sticky-to-the-left, we do it _before_ emitting end-of-line from the newText + | (LineCommentChunk true (commentTokensText, moreOrigTokens)), _ -> + let tokText = String.concat "" commentTokensText + Debug.WriteLine("injecting sticky-to-the-left line comment '{0}'", box tokText) + + match newTokens with + // If there is a new line coming, use it up + | Space _ :: (EOL, newTokText) :: moreNewTokens | (EOL, newTokText) :: moreNewTokens -> + addText " " + for x in commentTokensText do addText x + Debug.WriteLine "emitting newline for end of sticky-to-left comment" + addText newTokText + loop moreOrigTokens moreNewTokens + // Otherwise, skip a whitespace token and maintain the indentation + | Space _ :: moreNewTokens | moreNewTokens -> + addText " " + maintainIndent (fun () -> + for x in commentTokensText do addText x) + loop moreOrigTokens moreNewTokens + + // Emit end-of-line from new tokens + | _, (NewLine newTokText :: moreNewTokens) -> + Debug.WriteLine("emitting newline in new tokens '{0}'", newTokText) + addText newTokText + loop origTokens moreNewTokens + + | _, ((Token newTok, newTokText) :: moreNewTokens) + when newTok.CharClass = FSharpTokenCharKind.WhiteSpace && newTok.ColorClass <> FSharpTokenColorKind.InactiveCode -> + Debug.WriteLine("emitting whitespace '{0}' in new tokens", newTokText |> box) + addText newTokText + loop origTokens moreNewTokens + + | (Delimiter tokText :: newTokens), (RawDelimiter newTokText :: moreNewTokens) + when tokText = newTokText && newTokText <> "[<" && newTokText <> ">]" && newTokText <> "|" -> + Debug.WriteLine("emitting matching delimiter '{0}' in new tokens", newTokText |> box) + addText newTokText + loop newTokens moreNewTokens + + // Emit all unmatched RawDelimiter tokens + | _, (RawDelimiter newTokText :: moreNewTokens) + when newTokText <> "[<" && newTokText <> ">]" && newTokText <> "|" -> + Debug.WriteLine("emitting non-matching '{0}' in new tokens", newTokText |> box) + addText newTokText + loop origTokens moreNewTokens + + // Process the last line or block comments + | (LineCommentChunk false (commentTokensText, moreOrigTokens)), [] + | (BlockCommentChunk (commentTokensText, moreOrigTokens)), [] -> + Debug.WriteLine("injecting the last line or block comment '{0}'", String.concat "" commentTokensText |> box) + // Until block comments can't have new line in the beginning, add two consecutive new lines + addText Environment.NewLine + for x in commentTokensText do addText x + loop moreOrigTokens newTokens + + // Inject line commment, after all whitespace and newlines emitted, so + // the line comment will appear just before the subsequent text, e.g. + // let f x = + // // HERE + // x + x + | (LineCommentChunk false (commentTokensText, moreOrigTokens)), _ -> + Debug.WriteLine("injecting line comment '{0}'", String.concat "" commentTokensText |> box) + maintainIndent (fun () -> for x in commentTokensText do addText x) + loop moreOrigTokens newTokens + + // Inject block commment + | (BlockCommentChunk (commentTokensText, moreOrigTokens)), _ -> + Debug.WriteLine("injecting block comment '{0}'", String.concat "" commentTokensText |> box) + let comments = String.concat "" commentTokensText + if comments.IndexOf('\n') = -1 then + // This is an inline block comment + addText comments + addText " " + else + let len = List.length commentTokensText + maintainIndent (fun () -> + commentTokensText |> List.iteri (fun i x -> + // Drop the last newline + if i = len - 1 && x = Environment.NewLine then () + else addText x)) + loop moreOrigTokens newTokens + + // Consume attributes in the new text + | _, RawAttribute(newTokensText, moreNewTokens) -> + Debug.WriteLine("no matching of attribute tokens") + for x in newTokensText do addText x + loop origTokens moreNewTokens + + // Skip attributes in the old text + | (Attribute (tokensText, moreOrigTokens)), _ -> + Debug.WriteLine("skip matching of attribute tokens '{0}'", box tokensText) + loop moreOrigTokens newTokens + + // Open declarations may be reordered, so we match them even if two identifiers are different + | OpenChunk(tokensText, moreOrigTokens), RawOpenChunk(newTokensText, moreNewTokens) -> + Debug.WriteLine("matching two open chunks '{0}'", String.concat "" tokensText |> box) + for x in newTokensText do addText x + loop moreOrigTokens moreNewTokens + + // Matching tokens + | (origTok :: moreOrigTokens), (newTok :: moreNewTokens) when tokensMatch origTok newTok -> + Debug.WriteLine("matching token '{0}'", box origTok.Text) + addText (snd newTok) + loop moreOrigTokens moreNewTokens + + // Matching tokens, after one new token, compensating for insertions of "|", ";" and others + | (origTok :: moreOrigTokens), (newTok1 :: NewTokenAfterWhitespaceOrNewLine(whiteTokens, newTok2, moreNewTokens)) + when tokensMatch origTok newTok2 -> + Debug.WriteLine("fresh non-matching new token '{0}'", snd newTok1 |> box) + addText (snd newTok1) + Debug.WriteLine("matching token '{0}' (after one fresh new token)", snd newTok2 |> box) + for x in whiteTokens do addText x + addText (snd newTok2) + loop moreOrigTokens moreNewTokens + + // Not a comment, drop the original token text until something matches + | (origTok :: moreOrigTokens), _ -> + Debug.WriteLine("dropping '{0}' from original text", box origTok.Text) + loop moreOrigTokens newTokens + + // Dangling text at the end + | [], ((_, newTokText) :: moreNewTokens) -> + Debug.WriteLine("dangling new token '{0}'", box newTokText) + addText newTokText + loop [] moreNewTokens + + // Dangling input text - extra comments or whitespace + | (Marked(origTok, origTokText, _) :: moreOrigTokens), [] -> + Debug.WriteLine("dropping dangling old token '{0}'", box origTokText) + loop moreOrigTokens [] + + | [], [] -> + () + + loop origTokens newTokens + buffer.ToString() diff --git a/src/fsharp/vs/ServiceFormatting/Utils.fs b/src/fsharp/vs/ServiceFormatting/Utils.fs new file mode 100644 index 00000000000..49d40473e7e --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/Utils.fs @@ -0,0 +1,16 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting + +open System + +[] +module String = + let normalizeNewLine (str : string) = + str.Replace("\r\n", "\n").Replace("\r", "\n") + + let normalizeThenSplitNewLine (str : string) = + (normalizeNewLine str).Split('\n') + + let startsWithOrdinal (prefix : string) (str : string) = + str.StartsWith(prefix, StringComparison.Ordinal) \ No newline at end of file From 6b2f223bb892152c3d15275a0b9832c4aeb98280 Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 18:20:38 +0300 Subject: [PATCH 02/12] it compiles --- .../FSharp.Compiler.Private.fsproj | 96 +++++------- .../vs/ServiceFormatting/CodeFormatter.fs | 116 ++------------- .../vs/ServiceFormatting/CodeFormatter.fsi | 108 -------------- .../vs/ServiceFormatting/CodeFormatterImpl.fs | 139 ++++++++---------- .../vs/ServiceFormatting/FormatConfig.fs | 2 +- 5 files changed, 114 insertions(+), 347 deletions(-) delete mode 100644 src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 2e7933ce164..9a63aacae69 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -48,6 +48,43 @@ + + + + + $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Framework.dll + + + $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.dll + + + $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Utilities.Core.dll + + + $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Tasks.Core.dll + + + + + + + True + + + True + + + True + + + True + + + True + + + + $(FSharpSourcesRoot)\..\loc\lcl\{Lang}\$(AssemblyName).dll.lcl @@ -454,8 +491,6 @@ Logic\TypeChecker.fs - - Optimize\Optimizer.fsi @@ -486,8 +521,6 @@ CodeGen\IlxGen.fs - - Driver\CompileOps.fsi @@ -506,8 +539,6 @@ Driver\fsc.fs - - Symbols/SymbolHelpers.fsi @@ -526,8 +557,6 @@ Symbols/Exprs.fs - - Service/IncrementalBuild.fsi @@ -639,13 +668,9 @@ Service/ServiceFormatting/CodeFormatterImpl.fs - - Service/ServiceFormatting/CodeFormatter.fsi - Service/ServiceFormatting/CodeFormatter.fs - FSIstrings.txt @@ -655,25 +680,19 @@ InteractiveSession\fsi.fs - Misc/InternalsVisibleTo.fs Misc/MSBuildReferenceResolver.fs - Misc/LegacyHostedCompilerForTesting.fs - - - - - + @@ -695,45 +714,6 @@ ..\..\..\packages\System.ValueTuple.4.3.1\lib\netstandard1.0\System.ValueTuple.dll true - - - - - - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Framework.dll - - - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.dll - - - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Utilities.Core.dll - - - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Tasks.Core.dll - - - - - - - True - - - True - - - True - - - True - - - True - - - - - {DED3BBD7-53F4-428A-8C9F-27968E768605} FSharp.Core diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs index 0dfd629a7da..8f1b7b589d4 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs @@ -6,118 +6,24 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range [] -type CodeFormatter = - static member FormatDocumentAsync(fileName, source, config, projectOptions, checker) = - CodeFormatterImpl.createFormatContext fileName source projectOptions checker - |> CodeFormatterImpl.formatDocument config - - static member FormatDocument(fileName, source, config) = - CodeFormatterImpl.createFormatContextNoChecker fileName source - |> CodeFormatterImpl.formatDocument config - |> Async.RunSynchronously - - static member FormatSelectionAsync(fileName, selection, source, config, projectOptions, checker) = - CodeFormatterImpl.createFormatContext fileName source projectOptions checker - |> CodeFormatterImpl.formatSelection selection config - - static member FormatSelection(fileName, selection, source, config) = - CodeFormatterImpl.createFormatContextNoChecker fileName source - |> CodeFormatterImpl.formatSelection selection config - |> Async.RunSynchronously +type internal CodeFormatter = + static member FormatSelection(fileName, selection, source, config, ast) = + CodeFormatterImpl.formatSelection selection config fileName source ast - static member FormatAroundCursorAsync(fileName, cursorPos, source, config, projectOptions, checker) = - CodeFormatterImpl.createFormatContext fileName source projectOptions checker - |> CodeFormatterImpl.formatAroundCursor cursorPos config + static member FormatAroundCursor(fileName, cursorPos, source, config, ast) = + CodeFormatterImpl.formatAroundCursor cursorPos config fileName source ast static member InferSelectionFromCursorPos(fileName, cursorPos, source) = CodeFormatterImpl.inferSelectionFromCursorPos cursorPos fileName source - static member internal FormatSelectionInDocumentAsync(fileName, selection, source, config, projectOptions, checker) = - CodeFormatterImpl.createFormatContext fileName source projectOptions checker - |> CodeFormatterImpl.formatSelectionInDocument selection config + static member internal FormatSelectionInDocument(fileName, selection, source, config, ast) = + CodeFormatterImpl.formatSelectionInDocument selection config fileName source ast - static member FormatAST(ast, fileName, source, config) = - CodeFormatterImpl.formatAST ast fileName source config + static member FormatAST(ast, fileName, source, config) = CodeFormatterImpl.formatAST ast fileName source config - static member ParseAsync(fileName, source, projectOptions, checker) = - CodeFormatterImpl.createFormatContext fileName source projectOptions checker - |> CodeFormatterImpl.parse + static member IsValidAST ast = CodeFormatterImpl.isValidAST ast - static member Parse(fileName, source) = - CodeFormatterImpl.createFormatContextNoChecker fileName source - |> CodeFormatterImpl.parse - |> Async.RunSynchronously - - static member IsValidAST ast = - CodeFormatterImpl.isValidAST ast - - static member IsValidFSharpCodeAsync(fileName, source, projectOptions, checker) = - CodeFormatterImpl.createFormatContext fileName source projectOptions checker - |> CodeFormatterImpl.isValidFSharpCode - - static member IsValidFSharpCode(fileName, source) = - CodeFormatterImpl.createFormatContextNoChecker fileName source - |> CodeFormatterImpl.isValidFSharpCode - |> Async.RunSynchronously - - static member MakePos(line, col) = - CodeFormatterImpl.makePos line col + static member MakePos(line, col) = CodeFormatterImpl.makePos line col static member MakeRange(fileName, startLine, startCol, endLine, endCol) = - CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol - -[] -module CodeFormatter = - let internal createFormatContextNoFileName isFsiFile sourceCode = - let fileName = if isFsiFile then "/tmp.fsi" else "/tmp.fsx" - CodeFormatterImpl.createFormatContextNoChecker fileName sourceCode - - let parse isFsiFile sourceCode = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.parse - |> Async.RunSynchronously - - let isValidAST ast = - CodeFormatterImpl.isValidAST ast - - let isValidFSharpCode isFsiFile sourceCode = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.isValidFSharpCode - |> Async.RunSynchronously - - let formatSourceString isFsiFile sourceCode config = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.formatDocument config - |> Async.RunSynchronously - - let formatAST ast sourceCode config = - CodeFormatterImpl.formatAST ast "/tmp.fsx" sourceCode config - - let makeRange startLine startCol endLine endCol = - CodeFormatterImpl.makeRange "/tmp.fsx" startLine startCol endLine endCol - - let formatSelectionOnly isFsiFile (range : range) (sourceCode : string) config = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.formatSelection range config - |> Async.RunSynchronously - - let formatSelectionExpanded isFsiFile (range : range) (sourceCode : string) config = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.formatSelectionExpanded range config - |> Async.RunSynchronously - - let formatSelectionFromString isFsiFile (range : range) (sourceCode : string) config = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.formatSelectionInDocument range config - |> Async.RunSynchronously - - let makePos line col = - CodeFormatterImpl.makePos line col - - let formatAroundCursor isFsiFile (cursorPos : pos) (sourceCode : string) config = - createFormatContextNoFileName isFsiFile sourceCode - |> CodeFormatterImpl.formatAroundCursor cursorPos config - |> Async.RunSynchronously - - let inferSelectionFromCursorPos (cursorPos : pos) (sourceCode : string) = - CodeFormatterImpl.inferSelectionFromCursorPos cursorPos "/tmp.fsx" sourceCode + CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi deleted file mode 100644 index 19df03c3105..00000000000 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fsi +++ /dev/null @@ -1,108 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting - -open System -open Fantomas.FormatConfig -open Microsoft.FSharp.Compiler.Ast -open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.SourceCodeServices - -[] -type CodeFormatter = - /// Parse a source string using given config - static member Parse : fileName:string * source:string -> ParsedInput - /// Parse a source string using given config - static member ParseAsync : fileName:string * source:string * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async - /// Format an abstract syntax tree using an optional source for looking up literals - static member FormatAST : ast:ParsedInput * fileName:string * source:string option * config:FormatConfig -> string - - /// Infer selection around cursor by looking for a pair of '[' and ']', '{' and '}' or '(' and ')'. - static member InferSelectionFromCursorPos : fileName:string * cursorPos:pos * source:string -> range - - /// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. - /// (Only use in testing.) - static member internal FormatAroundCursorAsync : - fileName:string * cursorPos:pos * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async - - /// Format a source string using given config - static member FormatDocument : - fileName:string * source:string * config:FormatConfig -> string - - /// Format a source string using given config - static member FormatDocumentAsync : - fileName:string * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async - - /// Format a part of source string using given config, and return the (formatted) selected part only. - /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. - static member FormatSelection : - fileName:string * selection:range * source:string * config:FormatConfig -> string - - /// Format a part of source string using given config, and return the (formatted) selected part only. - /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. - static member FormatSelectionAsync : - fileName:string * selection:range * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async - - /// Format a selected part of source string using given config; keep other parts unchanged. - /// (Only use in testing.) - static member internal FormatSelectionInDocumentAsync : - fileName:string * selection:range * source:string * config:FormatConfig * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async - - /// Check whether an AST consists of parsing errors - static member IsValidAST : ast:ParsedInput -> bool - /// Check whether an input string is invalid in F# by looking for erroneous nodes in ASTs - static member IsValidFSharpCode : fileName:string * source:string -> bool - /// Check whether an input string is invalid in F# by looking for erroneous nodes in ASTs - static member IsValidFSharpCodeAsync : fileName:string * source:string * projectOptions:FSharpProjectOptions * checker:FSharpChecker -> Async - - static member MakePos : line:int * col:int -> pos - static member MakeRange : fileName:string * startLine:int * startCol:int * endLine:int * endCol:int -> range - -[] -module CodeFormatter = - /// Parse a source code string - [] - val parse : isFsiFile:bool -> sourceCode:string -> ParsedInput - - [] - val makePos : line:int -> col:int -> pos - - [] - val makeRange : startLine:int -> startCol:int -> endLine:int -> endCol:int -> range - - /// Check whether an AST consists of parsing errors - [] - val isValidAST : ast:ParsedInput -> bool - - /// Check whether an input string is invalid in F# by looking for erroneous nodes in ASTs - [] - val isValidFSharpCode : isFsiFile:bool -> sourceCode:string -> bool - - /// Format a source string using given config - [] - val formatSourceString : isFsiFile:bool -> sourceCode:string -> config:FormatConfig -> string - - /// Format an abstract syntax tree using given config - [] - val formatAST : ast:ParsedInput -> sourceCode:string option -> config:FormatConfig -> string - - /// Format a part of source string using given config, and return the (formatted) selected part only. - /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. - [] - val formatSelectionOnly : isFsiFile:bool -> range:range -> sourceCode:string -> config:FormatConfig -> string - - /// Format a selected part of source string using given config; expanded selected ranges to parsable ranges. - [] - val formatSelectionExpanded : isFsiFile:bool -> range:range -> sourceCode:string -> config:FormatConfig -> string * range - - /// Format a selected part of source string using given config; keep other parts unchanged. - [] - val formatSelectionFromString : isFsiFile:bool -> range:range -> sourceCode:string -> config:FormatConfig -> string - - /// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. - [] - val formatAroundCursor : isFsiFile:bool -> cursorPos:pos -> sourceCode:string -> config:FormatConfig -> string - - /// Infer selection around cursor by looking for a pair of '[' and ']', '{' and '}' or '(' and ')'. - [] - val inferSelectionFromCursorPos : cursorPos:pos -> sourceCode:string -> range \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs index b5693d1b748..873ab4afc1b 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs @@ -319,6 +319,8 @@ let formatWith ast moduleName input config = raise <| FormatException "Incomplete code fragment which is most likely due to parsing errors or the use of F# constructs newer than supported." else formattedSourceCode +let format config sourceCode filePath ast = formatWith ast (Path.GetFileNameWithoutExtension filePath) (Some sourceCode) config + /// Format an abstract syntax tree using given config let formatAST ast fileName sourceCode config = let formattedSourceCode = formatWith ast fileName sourceCode config @@ -410,7 +412,7 @@ let stringPos (r : range) (sourceCode : string) = if pos >= sourceCode.Length then sourceCode.Length - 1 else pos (start, finish) -let formatRange returnFormattedContentOnly (range : range) (lines : string[]) (sourceCode: string) config ast = +let formatRange returnFormattedContentOnly (range : range) (lines : string[]) (sourceCode: string) config fileName ast = let startLine = range.StartLine let startCol = range.StartColumn let endLine = range.EndLine @@ -448,19 +450,16 @@ let formatRange returnFormattedContentOnly (range : range) (lines : string[]) (s Debug.WriteLine("selection:\n'{0}'", box selection) Debug.WriteLine("post:\n'{0}'", box post) - let formatSelection (sourceCode: string) config = - async { - // From this point onwards, we focus on the current selection - let formatContext = { formatContext with Source = sourceCode } - let! formattedSourceCode = format config formatContext - // If the input is not inline, the output should not be inline as well - if sourceCode.EndsWith("\n") && not <| formattedSourceCode.EndsWith(Environment.NewLine) then - return formattedSourceCode + Environment.NewLine - elif not <| sourceCode.EndsWith("\n") && formattedSourceCode.EndsWith(Environment.NewLine) then - return formattedSourceCode.TrimEnd('\r', '\n') - else - return formattedSourceCode - } + let formatSelection (sourceCode: string) config fileName ast = + // From this point onwards, we focus on the current selection + let formattedSourceCode = format config sourceCode fileName ast + // If the input is not inline, the output should not be inline as well + if sourceCode.EndsWith("\n") && not <| formattedSourceCode.EndsWith(Environment.NewLine) then + formattedSourceCode + Environment.NewLine + elif not <| sourceCode.EndsWith("\n") && formattedSourceCode.EndsWith(Environment.NewLine) then + formattedSourceCode.TrimEnd('\r', '\n') + else + formattedSourceCode let reconstructSourceCode startCol formatteds pre post = Debug.WriteLine("Formatted parts: '{0}' at column {1}", sprintf "%A" formatteds, startCol) @@ -473,41 +472,39 @@ let formatRange returnFormattedContentOnly (range : range) (lines : string[]) (s |> if returnFormattedContentOnly then str String.Empty else str post |> dump - async { - match patch with - | TypeMember -> - // Get formatted selection with "type T = \n" patch - let! result = formatSelection selection config - // Remove the patch - let contents = String.normalizeThenSplitNewLine result - if Array.isEmpty contents then - if returnFormattedContentOnly then - return result - else - return String.Join(String.Empty, pre, result, post) - else - // Due to patching, the text has at least two lines - let first = contents.[1] - let column = first.Length - first.TrimStart().Length - let formatteds = contents.[1..] |> Seq.map (fun s -> s.[column..]) - return reconstructSourceCode startCol formatteds pre post - | RecType - | RecLet -> - // Get formatted selection with "type" or "let rec" replacement for "and" - let! result = formatSelection selection config - // Substitute by old contents - let pattern = if patch = RecType then Regex("type") else Regex("let rec") - let formatteds = String.normalizeThenSplitNewLine (pattern.Replace(result, "and", 1)) - return reconstructSourceCode startCol formatteds pre post - | Nothing -> - let! result = formatSelection selection config - let formatteds = String.normalizeThenSplitNewLine result - return reconstructSourceCode startCol formatteds pre post - } + match patch with + | TypeMember -> + // Get formatted selection with "type T = \n" patch + let result = formatSelection selection config fileName ast + // Remove the patch + let contents = String.normalizeThenSplitNewLine result + if Array.isEmpty contents then + if returnFormattedContentOnly then + result + else + String.Join(String.Empty, pre, result, post) + else + // Due to patching, the text has at least two lines + let first = contents.[1] + let column = first.Length - first.TrimStart().Length + let formatteds = contents.[1..] |> Seq.map (fun s -> s.[column..]) + reconstructSourceCode startCol formatteds pre post + | RecType + | RecLet -> + // Get formatted selection with "type" or "let rec" replacement for "and" + let result = formatSelection selection config fileName ast + // Substitute by old contents + let pattern = if patch = RecType then Regex("type") else Regex("let rec") + let formatteds = String.normalizeThenSplitNewLine (pattern.Replace(result, "and", 1)) + reconstructSourceCode startCol formatteds pre post + | Nothing -> + let result = formatSelection selection config fileName ast + let formatteds = String.normalizeThenSplitNewLine result + reconstructSourceCode startCol formatteds pre post /// Format a part of source string using given config, and return the (formatted) selected part only. /// Beware that the range argument is inclusive. If the range has a trailing newline, it will appear in the formatted result. -let formatSelection (range : range) config ({ Source = sourceCode; FileName = fileName } as formatContext) = +let formatSelection (range : range) config fileName sourceCode ast = let lines = String.normalizeThenSplitNewLine sourceCode // Move to the section with real contents @@ -538,24 +535,22 @@ let formatSelection (range : range) config ({ Source = sourceCode; FileName = f Debug.WriteLine("Original range: {0} --> content range: {1} --> modified range: {2}", sprintf "%O" range, sprintf "%O" contentRange, sprintf "%O" modifiedRange) - async { - let! formatted = formatRange true modifiedRange lines config formatContext + let formatted = formatRange true modifiedRange lines sourceCode config ast - let (start, finish) = stringPos range sourceCode - let (newStart, newFinish) = stringPos modifiedRange sourceCode - let pre = sourceCode.[start..newStart-1].TrimEnd('\r') - let post = - if newFinish + 1 >= sourceCode.Length || newFinish >= finish then - String.Empty - else - sourceCode.[newFinish+1..finish].Replace("\r", "\n") - Debug.WriteLine("Original index: {0} --> modified index: {1}", sprintf "%O" (start, finish), sprintf "%O" (newStart, newFinish)) - Debug.WriteLine("Join '{0}', '{1}' and '{2}'", pre, formatted, post) - return String.Join(String.Empty, pre, formatted, post) - } + let (start, finish) = stringPos range sourceCode + let (newStart, newFinish) = stringPos modifiedRange sourceCode + let pre = sourceCode.[start..newStart-1].TrimEnd('\r') + let post = + if newFinish + 1 >= sourceCode.Length || newFinish >= finish then + String.Empty + else + sourceCode.[newFinish+1..finish].Replace("\r", "\n") + Debug.WriteLine("Original index: {0} --> modified index: {1}", sprintf "%O" (start, finish), sprintf "%O" (newStart, newFinish)) + Debug.WriteLine("Join '{0}', '{1}' and '{2}'", pre, formatted, post) + String.Join(String.Empty, pre, formatted, post) /// Format a selected part of source string using given config; expanded selected ranges to parsable ranges. -let formatSelectionExpanded (range : range) config ({ FileName = fileName; Source = sourceCode } as formatContext) = +let formatSelectionExpanded (range : range) config fileName sourceCode ast = let lines = String.normalizeThenSplitNewLine sourceCode let sourceTokenizer = FSharpSourceTokenizer([], Some fileName) @@ -581,17 +576,13 @@ let formatSelectionExpanded (range : range) config ({ FileName = fileName; Sourc let endCol = getEndCol contentRange endTokenizer (ref 0L) let expandedRange = makeRange fileName contentRange.StartLine startCol contentRange.EndLine endCol - async { - let! result = formatRange false expandedRange lines config formatContext - return (result, expandedRange) - } + let result = formatRange false expandedRange lines sourceCode config fileName ast + result, expandedRange /// Format a selected part of source string using given config; keep other parts unchanged. -let formatSelectionInDocument (range : range) config formatContext = - async { - let! (formatted, _) = formatSelectionExpanded range config formatContext - return formatted - } +let formatSelectionInDocument (range : range) config fileName sourceCode ast = + let formatted, _ = formatSelectionExpanded range config fileName sourceCode ast + formatted type internal BlockType = | List @@ -721,8 +712,6 @@ let inferSelectionFromCursorPos (cursorPos : pos) fileName (sourceCode : string) makeRange fileName startLine startCol endLine endCol /// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. -let formatAroundCursor (cursorPos : pos) config ({ FileName = fileName; Source = sourceCode } as formatContext) = - async { - let selection = inferSelectionFromCursorPos cursorPos fileName sourceCode - return! formatSelectionInDocument selection config formatContext - } +let formatAroundCursor (cursorPos : pos) config fileName sourceCode ast = + let selection = inferSelectionFromCursorPos cursorPos fileName sourceCode + formatSelectionInDocument selection config fileName sourceCode ast \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs index 12c19e0748a..b7c2a7bc7f5 100644 --- a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs +++ b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -module Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig +module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig open System open System.IO From 0547c216ca95a0a7aa6ff4179219cdfabf736c68 Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 18:49:16 +0300 Subject: [PATCH 03/12] FSharpFormattingService skeleton --- .../src/FSharp.Editor/FSharp.Editor.fsproj | 1 + .../Formatting/FormattingService.fs | 29 +++++++++++++++++++ 2 files changed, 30 insertions(+) create mode 100644 vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs diff --git a/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj b/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj index f75476e319d..c17a69ad582 100644 --- a/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj +++ b/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj @@ -55,6 +55,7 @@ + diff --git a/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs b/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs new file mode 100644 index 00000000000..387445f6c18 --- /dev/null +++ b/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs @@ -0,0 +1,29 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.VisualStudio.FSharp.Editor + +#nowarn "1182" + +open System.Composition +open Microsoft.CodeAnalysis.Editor +open Microsoft.CodeAnalysis.Host.Mef +open Microsoft.CodeAnalysis.Text +open System.Threading.Tasks +open System.Collections.Generic + +[] +[, FSharpConstants.FSharpLanguageName)>] +type internal FSharpFormattingService() = + let emptyChange = Task.FromResult> [||] + + interface IEditorFormattingService with + member __.SupportsFormatDocument = true + member __.SupportsFormatSelection = true + member __.SupportsFormatOnPaste = false + member __.SupportsFormatOnReturn = false + member __.SupportsFormattingOnTypedCharacter (_document, _ch) = false + + member __.GetFormattingChangesAsync (document, textSpan, cancellationToken) = emptyChange + member __.GetFormattingChangesOnPasteAsync (document, textSpan, cancellationToken) = emptyChange + member __.GetFormattingChangesAsync (document, typedChar, position, cancellationToken) = emptyChange + member __.GetFormattingChangesOnReturnAsync (document, position, cancellationToken) = emptyChange \ No newline at end of file From f7b21f3958a5666dc293eb7c21c81a1698b712f4 Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 20:58:00 +0300 Subject: [PATCH 04/12] it works --- .../vs/ServiceFormatting/CodeFormatter.fs | 9 ----- .../vs/ServiceFormatting/CodeFormatterImpl.fs | 20 +--------- .../Formatting/FormattingService.fs | 38 +++++++++++++++---- 3 files changed, 32 insertions(+), 35 deletions(-) diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs index 8f1b7b589d4..71a752f9744 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs @@ -2,9 +2,6 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting -open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.Range - [] type internal CodeFormatter = static member FormatSelection(fileName, selection, source, config, ast) = @@ -19,11 +16,5 @@ type internal CodeFormatter = static member internal FormatSelectionInDocument(fileName, selection, source, config, ast) = CodeFormatterImpl.formatSelectionInDocument selection config fileName source ast - static member FormatAST(ast, fileName, source, config) = CodeFormatterImpl.formatAST ast fileName source config - - static member IsValidAST ast = CodeFormatterImpl.isValidAST ast - - static member MakePos(line, col) = CodeFormatterImpl.makePos line col - static member MakeRange(fileName, startLine, startCol, endLine, endCol) = CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs index 873ab4afc1b..e556dd3f43d 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs @@ -300,9 +300,6 @@ let isValidAST ast = | ParsedInput.ImplFile input -> validateImplFileInput input -/// Check whether an input AST is invalid in F# by looking for erroneous nodes. -let isValidFSharpCode ast = try isValidAST ast with _ -> false - let formatWith ast moduleName input config = // Use '\n' as the new line delimiter consistently // It would be easier for F# parser @@ -321,16 +318,6 @@ let formatWith ast moduleName input config = let format config sourceCode filePath ast = formatWith ast (Path.GetFileNameWithoutExtension filePath) (Some sourceCode) config -/// Format an abstract syntax tree using given config -let formatAST ast fileName sourceCode config = - let formattedSourceCode = formatWith ast fileName sourceCode config - - // When formatting the whole document, an EOL is required - if formattedSourceCode.EndsWith(Environment.NewLine) then - formattedSourceCode - else - formattedSourceCode + Environment.NewLine - /// Make a range from (startLine, startCol) to (endLine, endCol) to select some text let makeRange fileName startLine startCol endLine endCol = mkRange fileName (mkPos startLine startCol) (mkPos endLine endCol) @@ -528,14 +515,14 @@ let formatSelection (range : range) config fileName sourceCode ast = contentRange.StartColumn + line.Length - line.TrimStart().Length let endCol = - let line = lines.[contentRange.EndLine-1].[..contentRange.EndColumn] + let line = lines.[contentRange.EndLine-1].[..contentRange.EndColumn-1] contentRange.EndColumn - line.Length + line.TrimEnd().Length let modifiedRange = makeRange fileName range.StartLine startCol range.EndLine endCol Debug.WriteLine("Original range: {0} --> content range: {1} --> modified range: {2}", sprintf "%O" range, sprintf "%O" contentRange, sprintf "%O" modifiedRange) - let formatted = formatRange true modifiedRange lines sourceCode config ast + let formatted = formatRange true modifiedRange lines sourceCode config fileName ast let (start, finish) = stringPos range sourceCode let (newStart, newFinish) = stringPos modifiedRange sourceCode @@ -590,9 +577,6 @@ type internal BlockType = | SequenceOrRecord | Tuple -/// Make a position at (line, col) to denote cursor position -let makePos line col = mkPos line col - /// Infer selection around cursor by looking for a pair of '[' and ']', '{' and '}' or '(' and ')'. let inferSelectionFromCursorPos (cursorPos : pos) fileName (sourceCode : string) = let lines = String.normalizeThenSplitNewLine sourceCode diff --git a/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs b/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs index 387445f6c18..9d4b40fd5bf 100644 --- a/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs +++ b/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs @@ -10,20 +10,42 @@ open Microsoft.CodeAnalysis.Host.Mef open Microsoft.CodeAnalysis.Text open System.Threading.Tasks open System.Collections.Generic +open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting +open System.IO.Ports [] [, FSharpConstants.FSharpLanguageName)>] -type internal FSharpFormattingService() = +type internal FSharpFormattingService + [] + ( + checkerProvider: FSharpCheckerProvider, + projectInfoManager: FSharpProjectOptionsManager + ) = + + static let userOpName = "Formatting" let emptyChange = Task.FromResult> [||] interface IEditorFormattingService with member __.SupportsFormatDocument = true - member __.SupportsFormatSelection = true + member __.SupportsFormatSelection = false member __.SupportsFormatOnPaste = false member __.SupportsFormatOnReturn = false - member __.SupportsFormattingOnTypedCharacter (_document, _ch) = false - - member __.GetFormattingChangesAsync (document, textSpan, cancellationToken) = emptyChange - member __.GetFormattingChangesOnPasteAsync (document, textSpan, cancellationToken) = emptyChange - member __.GetFormattingChangesAsync (document, typedChar, position, cancellationToken) = emptyChange - member __.GetFormattingChangesOnReturnAsync (document, position, cancellationToken) = emptyChange \ No newline at end of file + member __.SupportsFormattingOnTypedCharacter (_, _) = false + member __.GetFormattingChangesOnPasteAsync (_, _, _) = emptyChange + member __.GetFormattingChangesAsync (_, _, _, _) = emptyChange + member __.GetFormattingChangesOnReturnAsync (_, _, _) = emptyChange + + member __.GetFormattingChangesAsync (document, textSpan, cancellationToken) = + asyncMaybe { + match Option.ofNullable textSpan with + | None -> + let! options = projectInfoManager.TryGetOptionsForEditingDocumentOrProject(document) + let! sourceText = document.GetTextAsync(cancellationToken) + let! parsedInput = checkerProvider.Checker.ParseDocument(document, options, sourceText, userOpName) + let changedSource = CodeFormatter.FormatAST(parsedInput, document.FilePath, Some (sourceText.ToString()), FormatConfig.FormatConfig.Default) + return [| TextChange(TextSpan(0, sourceText.Length), changedSource) |] + | Some _ -> + return [||] + } + |> Async.map (fun xs -> (match xs with Some changes -> changes | None -> [||]) :> IList) + |> RoslynHelpers.StartAsyncAsTask cancellationToken \ No newline at end of file From c6ee06a96351ab4100d870c5f378f5ff0f100f19 Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 21:02:26 +0300 Subject: [PATCH 05/12] fix compilation --- src/fsharp/vs/ServiceFormatting/CodeFormatter.fs | 2 ++ src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs | 9 +++++++++ 2 files changed, 11 insertions(+) diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs index 71a752f9744..68cf19d71d6 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs @@ -16,5 +16,7 @@ type internal CodeFormatter = static member internal FormatSelectionInDocument(fileName, selection, source, config, ast) = CodeFormatterImpl.formatSelectionInDocument selection config fileName source ast + static member FormatAST(ast, fileName, source, config) = CodeFormatterImpl.formatAST ast fileName source config + static member MakeRange(fileName, startLine, startCol, endLine, endCol) = CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol \ No newline at end of file diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs index e556dd3f43d..6248f46d4dc 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs @@ -318,6 +318,15 @@ let formatWith ast moduleName input config = let format config sourceCode filePath ast = formatWith ast (Path.GetFileNameWithoutExtension filePath) (Some sourceCode) config +let formatAST ast fileName sourceCode config = + let formattedSourceCode = formatWith ast fileName sourceCode config + + // When formatting the whole document, an EOL is required + if formattedSourceCode.EndsWith(Environment.NewLine) then + formattedSourceCode + else + formattedSourceCode + Environment.NewLine + /// Make a range from (startLine, startCol) to (endLine, endCol) to select some text let makeRange fileName startLine startCol endLine endCol = mkRange fileName (mkPos startLine startCol) (mkPos endLine endCol) From 797aa3935a7783ae313f00baa78fe6d5655dc5fd Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 22:23:30 +0300 Subject: [PATCH 06/12] port Fantomas tests --- .../vs/ServiceFormatting/CodeFormatter.fs | 4 +- .../vs/ServiceFormatting/CodeFormatterImpl.fs | 5 +- .../ServiceFormatting/ActivePatternTests.fs | 63 ++ .../ServiceFormatting/AttributeTests.fs | 121 +++ .../unittests/ServiceFormatting/ClassTests.fs | 282 +++++++ .../ServiceFormatting/CommentTests.fs | 363 ++++++++ .../ServiceFormatting/ComparisonTests.fs | 35 + .../CompilerDirectivesTests.fs | 219 +++++ .../ComputationExpressionTests.fs | 99 +++ .../ControlStructureTests.fs | 278 +++++++ .../ServiceFormatting/DataStructureTests.fs | 168 ++++ .../FormattingPropertyTests.fs | 579 +++++++++++++ .../FormattingSelectionOnlyTests.fs | 153 ++++ .../FormattingSelectionTests.fs | 265 ++++++ .../unittests/ServiceFormatting/FsUnit.fs | 52 ++ .../FunctionDefinitionTests.fs | 297 +++++++ .../ServiceFormatting/InterfaceTests.fs | 118 +++ .../ServiceFormatting/ModuleTests.fs | 240 ++++++ .../ServiceFormatting/OperatorTests.fs | 176 ++++ .../ServiceFormatting/PatternMatchingTests.fs | 310 +++++++ .../ServiceFormatting/PipingTests.fs | 63 ++ .../ServiceFormatting/QuotationTests.fs | 35 + .../ServiceFormatting/RecordTests.fs | 227 +++++ .../ServiceFormatting/SignatureTests.fs | 136 +++ .../ServiceFormatting/StringTests.fs | 118 +++ .../ServiceFormatting/TestHelpers.fs | 121 +++ .../ServiceFormatting/TypeDeclarationTests.fs | 787 ++++++++++++++++++ .../ServiceFormatting/TypeProviderTests.fs | 51 ++ .../unittests/ServiceFormatting/UnionTests.fs | 136 +++ .../VerboseSyntaxConversionTests.fs | 29 + .../unittests/VisualFSharp.Unittests.fsproj | 96 ++- 31 files changed, 5619 insertions(+), 7 deletions(-) create mode 100644 vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/StringTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs create mode 100644 vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs index 68cf19d71d6..0f260edaaac 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs @@ -18,5 +18,7 @@ type internal CodeFormatter = static member FormatAST(ast, fileName, source, config) = CodeFormatterImpl.formatAST ast fileName source config + static member MakePos(line, col) = CodeFormatterImpl.makePos line col + static member MakeRange(fileName, startLine, startCol, endLine, endCol) = - CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol \ No newline at end of file + CodeFormatterImpl.makeRange fileName startLine startCol endLine endCol diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs index 6248f46d4dc..b65ad288bc8 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs @@ -327,6 +327,9 @@ let formatAST ast fileName sourceCode config = else formattedSourceCode + Environment.NewLine +/// Make a position at (line, col) to denote cursor position +let makePos line col = mkPos line col + /// Make a range from (startLine, startCol) to (endLine, endCol) to select some text let makeRange fileName startLine startCol endLine endCol = mkRange fileName (mkPos startLine startCol) (mkPos endLine endCol) @@ -707,4 +710,4 @@ let inferSelectionFromCursorPos (cursorPos : pos) fileName (sourceCode : string) /// Format around cursor delimited by '[' and ']', '{' and '}' or '(' and ')' using given config; keep other parts unchanged. let formatAroundCursor (cursorPos : pos) config fileName sourceCode ast = let selection = inferSelectionFromCursorPos cursorPos fileName sourceCode - formatSelectionInDocument selection config fileName sourceCode ast \ No newline at end of file + formatSelectionInDocument selection config fileName sourceCode ast diff --git a/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs new file mode 100644 index 00000000000..7d47b282d6e --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs @@ -0,0 +1,63 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.ActivePatternTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should keep parens around active patterns``() = + formatSourceString false """let (|Boolean|_|) = Boolean.parse + """ config + |> should equal """let (|Boolean|_|) = Boolean.parse +""" + +[] +let ``should keep parens around active patterns in module``() = + formatSourceString false """module Interpreted = + let (|Match|_|) = (|Match|_|) RegexOptions.None + """ config + |> prepend newline + |> should equal """ +module Interpreted = + let (|Match|_|) = (|Match|_|) RegexOptions.None +""" + +[] +let ``should keep parens around active patterns in inlined functions``() = + formatSourceString false """let inline (|Match|_|) x = tryMatchWithOptions x + """ config + |> should equal """let inline (|Match|_|) x = tryMatchWithOptions x +""" + +[] +let ``active patterns``() = + formatSourceString false """ +let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd + +let (|Integer|_|) (str: string) = + let mutable intvalue = 0 + if System.Int32.TryParse(str, &intvalue) then Some(intvalue) + else None + +let (|ParseRegex|_|) regex str = + let m = Regex(regex).Match(str) + if m.Success + then Some (List.tail [ for x in m.Groups -> x.Value ]) + else None""" config + |> prepend newline + |> should equal """ +let (|Even|Odd|) input = + if input % 2 = 0 then Even + else Odd + +let (|Integer|_|) (str : string) = + let mutable intvalue = 0 + if System.Int32.TryParse(str, &intvalue) then Some(intvalue) + else None + +let (|ParseRegex|_|) regex str = + let m = Regex(regex).Match(str) + if m.Success then + Some(List.tail [ for x in m.Groups -> x.Value ]) + else None +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs b/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs new file mode 100644 index 00000000000..f6cb9057fe5 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs @@ -0,0 +1,121 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.AttributeTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should keep the attribute on top of the function``() = + formatSourceString false """[] +type Funcs = + [] + static member ToFunc (f: Action<_,_,_>) = + Func<_,_,_,_>(fun a b c -> f.Invoke(a,b,c)) + """ config + |> should equal """[] +type Funcs = + [] + static member ToFunc(f : Action<_, _, _>) = + Func<_, _, _, _>(fun a b c -> f.Invoke(a, b, c)) +""" + +[] +let ``attributes on expressions``() = + formatSourceString false """ + [] + do ()""" config + |> prepend newline + |> should equal """ +[] +do () +""" + +[] +let ``units of measures declaration``() = + formatSourceString false """ + [] type m + [] type kg + [] type s + [] type N = kg m / s^2 + [] type Pa = N * m^2""" config + |> prepend newline + |> should equal """ +[] +type m + +[] +type kg + +[] +type s + +[] +type N = kg m / s^2 + +[] +type Pa = N * m^2 +""" + +[] +let ``type params``() = + formatSourceString false """ +let genericSumUnits ( x : float<'u>) (y: float<'u>) = x + y +type vector3D<[] 'u> = { x : float<'u>; y : float<'u>; z : float<'u>}""" config + |> prepend newline + |> should equal """ +let genericSumUnits (x : float<'u>) (y : float<'u>) = x + y + +type vector3D<[] 'u> = + { x : float<'u> + y : float<'u> + z : float<'u> } +""" + +[] +let ``attributes on recursive functions``() = + formatSourceString false """ +let rec [] a () = 10 +and [] b () = 10""" config + |> prepend newline + |> should equal """ +[] +let rec a() = 10 + +and [] b() = 10 +""" + +[] +let ``attributes on implicit constructors``() = + formatSourceString false """ +[] +type Sample [] (dependency: IDependency) = class end +[] +type Sample [] internal () = class end""" config + |> prepend newline + |> should equal """ +[] +type Sample [] (dependency : IDependency) = + class + end + +[] +type Sample [] internal () = + class + end +""" + +[] +let ``should handle targets on attributes``() = + formatSourceString false """ +[] +type Foo = + { [] + Bar:string } +""" config + |> prepend newline + |> should equal """ +[] +type Foo = + { [] + Bar : string } +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs new file mode 100644 index 00000000000..881ac09c86a --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs @@ -0,0 +1,282 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.ClassTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``class signatures``() = + formatSourceString true """ +module Heap + +type Heap<'T when 'T : comparison> = + class + new : capacity:int -> Heap<'T> + member Clear : unit -> unit + member ExtractMin : unit -> 'T + member Insert : k:'T -> unit + member IsEmpty : unit -> bool + member PeekMin : unit -> 'T + override ToString : unit -> string + member Count : int + end""" config + |> prepend newline + |> should equal """ +module Heap + +type Heap<'T when 'T : comparison> = + class + new : capacity:int -> Heap<'T> + member Clear : unit -> unit + member ExtractMin : unit -> 'T + member Insert : k:'T -> unit + member IsEmpty : unit -> bool + member PeekMin : unit -> 'T + override ToString : unit -> string + member Count : int + end +""" + +[] +let ``type constraints complex``() = + formatSourceString false """ +type Class4<'T when 'T : (static member staticMethod1 : unit -> 'T) > = + class end + +type Class5<'T when 'T : (member Method1 : 'T -> int)> = + class end + +type Class6<'T when 'T : (member Property1 : int)> = + class end + +type Class7<'T when 'T : (new : unit -> 'T)>() = + member val Field = new 'T() + """ config + |> prepend newline + |> should equal """ +type Class4<'T when 'T : (static member staticMethod1 : unit -> 'T)> = + class + end + +type Class5<'T when 'T : (member Method1 : 'T -> int)> = + class + end + +type Class6<'T when 'T : (member Property1 : int)> = + class + end + +type Class7<'T when 'T : (new : unit -> 'T)>() = + member val Field = new 'T() +""" + +[] +let ``abstract classes``() = + formatSourceString false """ +[] +type Shape2D(x0 : float, y0 : float) = + let mutable x, y = x0, y0 + let mutable rotAngle = 0.0 + + member this.CenterX with get() = x and set xval = x <- xval + member this.CenterY with get() = y and set yval = y <- yval + + abstract Area : float with get + abstract Perimeter : float with get + abstract Name : string with get + + member this.Move dx dy = + x <- x + dx + y <- y + dy + + abstract member Rotate: float -> unit + default this.Rotate(angle) = rotAngle <- rotAngle + angle + """ config + |> prepend newline + |> should equal """ +[] +type Shape2D(x0 : float, y0 : float) = + let mutable x, y = x0, y0 + let mutable rotAngle = 0.0 + + member this.CenterX + with get () = x + and set xval = x <- xval + + member this.CenterY + with get () = y + and set yval = y <- yval + + abstract Area : float + abstract Perimeter : float + abstract Name : string + + member this.Move dx dy = + x <- x + dx + y <- y + dy + + abstract Rotate : float -> unit + override this.Rotate(angle) = rotAngle <- rotAngle + angle +""" + +[] +let ``class declaration``() = + formatSourceString false """ +type BaseClass = class + val string1 : string + new(str) = { string1 = str } + new() = { string1 = "" } +end + +type DerivedClass = + inherit BaseClass + val string2 : string + new (str1, str2) = { inherit BaseClass(str1); string2 = str2 } + new (str2) = { inherit BaseClass(); string2 = str2 }""" config + |> prepend newline + |> should equal """ +type BaseClass = + class + val string1 : string + new(str) = { string1 = str } + new() = { string1 = "" } + end + +type DerivedClass = + inherit BaseClass + val string2 : string + new(str1, str2) = { inherit BaseClass(str1); string2 = str2 } + new(str2) = { inherit BaseClass(); string2 = str2 } +""" + +[] +let ``classes and implicit constructors``() = + formatSourceString false """ + type MyClass2(dataIn) as self = + let data = dataIn + do self.PrintMessage() + member this.PrintMessage() = + printf "Creating MyClass2 with Data %d" data""" config + |> prepend newline + |> should equal """ +type MyClass2(dataIn) as self = + let data = dataIn + do self.PrintMessage() + member this.PrintMessage() = printf "Creating MyClass2 with Data %d" data +""" + +[] +let ``classes and private implicit constructors``() = + formatSourceString false """ + type MyClass2 private (dataIn) as self = + let data = dataIn + do self.PrintMessage() + member this.PrintMessage() = + printf "Creating MyClass2 with Data %d" data""" config + |> prepend newline + |> should equal """ +type MyClass2 private (dataIn) as self = + let data = dataIn + do self.PrintMessage() + member this.PrintMessage() = printf "Creating MyClass2 with Data %d" data +""" + +[] +let ``recursive classes``() = + formatSourceString false """ +type Folder(pathIn: string) = + let path = pathIn + let filenameArray : string array = System.IO.Directory.GetFiles(path) + member this.FileArray = Array.map (fun elem -> new File(elem, this)) filenameArray + +and File(filename: string, containingFolder: Folder) = + member __.Name = filename + member __.ContainingFolder = containingFolder""" config + |> prepend newline + |> should equal """ +type Folder(pathIn : string) = + let path = pathIn + let filenameArray : string array = System.IO.Directory.GetFiles(path) + member this.FileArray = + Array.map (fun elem -> new File(elem, this)) filenameArray + +and File(filename : string, containingFolder : Folder) = + member __.Name = filename + member __.ContainingFolder = containingFolder +""" + +[] +let ``classes and inheritance``() = + formatSourceString false """ +type MyClassBase2(x: int) = + let mutable z = x * x + do for i in 1..z do printf "%d " i + +type MyClassDerived2(y: int) = + inherit MyClassBase2(y * 2) + do for i in 1..y do printf "%d " i""" config + |> prepend newline + |> should equal """ +type MyClassBase2(x : int) = + let mutable z = x * x + do + for i in 1..z do + printf "%d " i + +type MyClassDerived2(y : int) = + inherit MyClassBase2(y * 2) + do + for i in 1..y do + printf "%d " i +""" + +[] +let ``should keep parens in class definition in the right place``() = + formatSourceString false """type DGMLClass() = class + let mutable currentState = System.String.Empty + end + """ config + |> should equal """type DGMLClass() = + class + let mutable currentState = System.String.Empty + end +""" + +[] +let ``should keep parens in class inheritance in the right place``() = + formatSourceString false """type StateMachine(makeAsync) as this = class + inherit DGMLClass() + + let functions = System.Collections.Generic.Dictionary() + end + """ config + |> should equal """type StateMachine(makeAsync) as this = + class + inherit DGMLClass() + let functions = System.Collections.Generic.Dictionary() + end +""" + +[] +let ``should keep type annotations on auto properties``() = + formatSourceString false """type Document(id : string, library : string, name : string option) = + member val ID = id + member val Library = library + member val Name = name with get, set + member val LibraryID : string option = None with get, set +""" config + |> should equal """type Document(id : string, library : string, name : string option) = + member val ID = id + member val Library = library + member val Name = name with get, set + member val LibraryID : string option = None with get, set +""" + +[] +let ``should work on static auto properties``() = + formatSourceString false """type A() = + static member val LastSchema = "" with get, set +""" config + |> should equal """type A() = + static member val LastSchema = "" with get, set +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs b/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs new file mode 100644 index 00000000000..4c7f441337d --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs @@ -0,0 +1,363 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.CommentTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should keep sticky-to-the-left comments after nowarn directives``() = + formatSourceString false """#nowarn "51" // address-of operator can occur in the code""" config + |> should equal """#nowarn "51" // address-of operator can occur in the code +""" + +[] +let ``should keep sticky-to-the-right comments before module definition``() = + formatSourceString false """ +// The original idea for this typeprovider is from Ivan Towlson +// some text +module FSharpx.TypeProviders.VectorTypeProvider + +let x = 1""" config + |> should equal """// The original idea for this typeprovider is from Ivan Towlson +// some text +module FSharpx.TypeProviders.VectorTypeProvider + +let x = 1 +""" + +[] +let ``comments on local let bindings``() = + formatSourceString false """ +let print_30_permut() = + + /// declare and initialize + let permutation : int array = Array.init n (fun i -> Console.Write(i+1); i) + permutation + """ config + |> prepend newline + |> should equal """ +let print_30_permut() = + /// declare and initialize + let permutation : int array = + Array.init n (fun i -> + Console.Write(i + 1) + i) + permutation +""" + +[] +let ``comments on local let bindings with desugared lambda``() = + formatSourceString false """ +let print_30_permut() = + + /// declare and initialize + let permutation : int array = Array.init n (fun (i,j) -> Console.Write(i+1); i) + permutation + """ config + |> prepend newline + |> should equal """ +let print_30_permut() = + /// declare and initialize + let permutation : int array = + Array.init n (fun (i, j) -> + Console.Write(i + 1) + i) + permutation +""" + + +[] +let ``xml documentation``() = + formatSourceString false """ +/// +/// Kill Weight Mud +/// +///description +///xdescription +///ydescription +let kwm sidpp tvd omw = + (sidpp / 0.052 / tvd) + omw + +/// Kill Weight Mud +let kwm sidpp tvd omw = 1.0""" config + |> prepend newline + |> should equal """ +/// +/// Kill Weight Mud +/// +///description +///xdescription +///ydescription +let kwm sidpp tvd omw = (sidpp / 0.052 / tvd) + omw + +/// Kill Weight Mud +let kwm sidpp tvd omw = 1.0 +""" + +[] +let ``should preserve comment-only source code``() = + formatSourceString false """(* + line1 + line2 +*) +""" config + |> should equal """ +(* + line1 + line2 +*) +""" + +[] +let ``should keep sticky-to-the-right comments``() = + formatSourceString false """ +let f() = + // COMMENT + x + x +""" config + |> prepend newline + |> should equal """ +let f() = + // COMMENT + x + x +""" + +[] +let ``should keep sticky-to-the-left comments``() = + formatSourceString false """ +let f() = + let x = 1 // COMMENT + x + x +""" config + |> prepend newline + |> should equal """ +let f() = + let x = 1 // COMMENT + x + x +""" + +[] +let ``should keep well-aligned comments``() = + formatSourceString false """ +/// XML COMMENT +// Other comment +let f() = + // COMMENT A + let y = 1 + (* COMMENT B *) + (* COMMENT C *) + x + x + x + +""" config + |> prepend newline + |> should equal """ +/// XML COMMENT +// Other comment +let f() = + // COMMENT A + let y = 1 + (* COMMENT B *) + (* COMMENT C *) + x + x + x +""" + +[] +let ``should align mis-aligned comments``() = + formatSourceString false """ + /// XML COMMENT A + // Other comment +let f() = + // COMMENT A + let y = 1 + /// XML COMMENT B + let z = 1 + // COMMENT B + x + x + x + +""" config + |> prepend newline + |> should equal """ +/// XML COMMENT A +// Other comment +let f() = + // COMMENT A + let y = 1 + /// XML COMMENT B + let z = 1 + // COMMENT B + x + x + x +""" + +[] +let ``should indent comments properly``() = + formatSourceString false """ +/// Non-local information related to internals of code generation within an assembly +type IlxGenIntraAssemblyInfo = + { /// A table recording the generated name of the static backing fields for each mutable top level value where + /// we may need to take the address of that value, e.g. static mutable module-bound values which are structs. These are + /// only accessible intra-assembly. Across assemblies, taking the address of static mutable module-bound values is not permitted. + /// The key to the table is the method ref for the property getter for the value, which is a stable name for the Val's + /// that come from both the signature and the implementation. + StaticFieldInfo : Dictionary } + +""" config + |> prepend newline + |> should equal """ +/// Non-local information related to internals of code generation within an assembly +type IlxGenIntraAssemblyInfo = + { /// A table recording the generated name of the static backing fields for each mutable top level value where + /// we may need to take the address of that value, e.g. static mutable module-bound values which are structs. These are + /// only accessible intra-assembly. Across assemblies, taking the address of static mutable module-bound values is not permitted. + /// The key to the table is the method ref for the property getter for the value, which is a stable name for the Val's + /// that come from both the signature and the implementation. + StaticFieldInfo : Dictionary } +""" + +[] +let ``shouldn't break on one-line comment``() = + formatSourceString false """ +1 + (* Comment *) 1""" config + |> prepend newline + |> should equal """ +1 + (* Comment *) 1 +""" + +[] +let ``should keep comments on DU cases``() = + formatSourceString false """ +/// XML comment +type X = + /// Hello + A + /// Goodbye + | B +""" config + |> prepend newline + |> should equal """ +/// XML comment +type X = + /// Hello + | A + /// Goodbye + | B +""" + +[] +let ``should keep comments before attributes``() = + formatSourceString false """ +[] +type IlxGenOptions = + { fragName: string + generateFilterBlocks: bool + workAroundReflectionEmitBugs: bool + emitConstantArraysUsingStaticDataBlobs: bool + // If this is set, then the last module becomes the "main" module and its toplevel bindings are executed at startup + mainMethodInfo: Tast.Attribs option + localOptimizationsAreOn: bool + generateDebugSymbols: bool + testFlagEmitFeeFeeAs100001: bool + ilxBackend: IlxGenBackend + /// Indicates the code is being generated in FSI.EXE and is executed immediately after code generation + /// This includes all interactively compiled code, including #load, definitions, and expressions + isInteractive: bool + // Indicates the code generated is an interactive 'it' expression. We generate a setter to allow clearing of the underlying + // storage, even though 'it' is not logically mutable + isInteractiveItExpr: bool + // Indicates System.SerializableAttribute is available in the target framework + netFxHasSerializableAttribute : bool + /// Whenever possible, use callvirt instead of call + alwaysCallVirt: bool} + +""" { config with SemicolonAtEndOfLine = true } + |> prepend newline + |> should equal """ +[] +type IlxGenOptions = + { fragName : string; + generateFilterBlocks : bool; + workAroundReflectionEmitBugs : bool; + emitConstantArraysUsingStaticDataBlobs : bool; + // If this is set, then the last module becomes the "main" module and its toplevel bindings are executed at startup + mainMethodInfo : Tast.Attribs option; + localOptimizationsAreOn : bool; + generateDebugSymbols : bool; + testFlagEmitFeeFeeAs100001 : bool; + ilxBackend : IlxGenBackend; + /// Indicates the code is being generated in FSI.EXE and is executed immediately after code generation + /// This includes all interactively compiled code, including #load, definitions, and expressions + isInteractive : bool; + // Indicates the code generated is an interactive 'it' expression. We generate a setter to allow clearing of the underlying + // storage, even though 'it' is not logically mutable + isInteractiveItExpr : bool; + // Indicates System.SerializableAttribute is available in the target framework + netFxHasSerializableAttribute : bool; + /// Whenever possible, use callvirt instead of call + alwaysCallVirt : bool } +""" + +[] +let ``should keep comments on else if``() = + formatSourceString false """ +if true then () +else + // Comment 1 + if true then () + // Comment 2 + else () +""" config + |> prepend newline + |> should equal """ +if true then () +else + // Comment 1 + if true then () + // Comment 2 + else () +""" + +[] +let ``should keep comments on almost-equal identifiers``() = + formatSourceString false """ +let zp = p1 lxor p2 +// Comment 1 +let b = zp land (zp) +(* Comment 2 *) +let p = p1 land (b - 1) +""" config + |> prepend newline + |> should equal """ +let zp = p1 ``lxor`` p2 +// Comment 1 +let b = zp ``land`` (zp) +(* Comment 2 *) +let p = p1 ``land`` (b - 1) +""" + +[] +let ``should not write sticky-to-the-left comments in a new line``() = + formatSourceString false """ +let moveFrom source = + getAllFiles source + |> Seq.filter (fun f -> Path.GetExtension(f).ToLower() <> ".db") //exlcude the thumbs.db files + |> move @"C:\_EXTERNAL_DRIVE\_Camera" +""" config + |> prepend newline + |> should equal """ +let moveFrom source = + getAllFiles source + |> Seq.filter (fun f -> Path.GetExtension(f).ToLower() <> ".db") //exlcude the thumbs.db files + |> move @"C:\_EXTERNAL_DRIVE\_Camera" +""" + +[] +let ``should handle comments at the end of file``() = + formatSourceString false """ +let hello() = "hello world" + +(* This is a comment. *) +""" config + |> prepend newline + |> should equal """ +let hello() = "hello world" +(* This is a comment. *) +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs new file mode 100644 index 00000000000..08e4b9d1ab5 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs @@ -0,0 +1,35 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.ComparisonTests + +open NUnit.Framework +open FsUnit +open TestHelper + +// the current behavior results in a compile error since the = is moved to the next line and not correctly indented +[] +let ``should keep the = on the same line in record def``() = + formatSourceString false """type UnionTypeConverter() = + inherit JsonConverter() + let doRead(reader : JsonReader) = reader.Read() |> ignore + override x.CanConvert(typ : Type) = + let result = + ((typ.GetInterface(typeof.FullName) = null) && FSharpType.IsUnion typ) + result + """ config + |> should equal """type UnionTypeConverter() = + inherit JsonConverter() + let doRead (reader : JsonReader) = reader.Read() |> ignore + override x.CanConvert(typ : Type) = + let result = + ((typ.GetInterface(typeof.FullName) = null) + && FSharpType.IsUnion typ) + result +""" + +// the current behavior results in a compile error since the = is moved to the next line and not correctly indented +[] +let ``should keep the = on the same line``() = + formatSourceString false """trimSpecialChars(controller.ServerName.ToUpper()) = trimSpecialChars(serverFilter.ToUpper()) + """ config + |> should equal """trimSpecialChars (controller.ServerName.ToUpper()) = trimSpecialChars + (serverFilter.ToUpper()) +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs b/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs new file mode 100644 index 00000000000..77b322dc68a --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs @@ -0,0 +1,219 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.CompilerDirectiveTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should use verbatim strings on some hash directives``() = + formatSourceString false """ + #r @"C:\foo\bar.dll" + """ config + |> prepend newline + |> should equal """ +#r @"C:\foo\bar.dll" +""" + +[] +let ``hash directives``() = + formatSourceString false """ + #r "Fantomas.Tests.dll" + #load "CodeFormatterTests.fs" + """ config + |> prepend newline + |> should equal """ +#r "Fantomas.Tests.dll" +#load "CodeFormatterTests.fs" +""" + +[] +let ``should support load directive multiple arguments``() = + formatSourceString false """ + #load "A.fs" "B.fs" + #load "C.fs" + "D.fs" + "E.fs" + """ config + |> prepend newline + |> should equal """ +#load "A.fs" "B.fs" +#load "C.fs" "D.fs" "E.fs" +""" + +[] +let ``should keep compiler directives``() = + formatSourceString false """ +#if INTERACTIVE +#load "../FSharpx.TypeProviders/SetupTesting.fsx" +SetupTesting.generateSetupScript __SOURCE_DIRECTORY__ +#load "__setup__.fsx" +#endif +""" config + |> should equal """ +#if INTERACTIVE +#load "../FSharpx.TypeProviders/SetupTesting.fsx" + +SetupTesting.generateSetupScript __SOURCE_DIRECTORY__ + +#load "__setup__.fsx" +#endif +""" + +[] +let ``should keep compiler directives 2``() = + formatSourceString false """ +#if INTERACTIVE +#else +#load "../FSharpx.TypeProviders/SetupTesting.fsx" +SetupTesting.generateSetupScript __SOURCE_DIRECTORY__ +#load "__setup__.fsx" +#endif +""" config + |> should equal """ +#if INTERACTIVE +#else +#load "../FSharpx.TypeProviders/SetupTesting.fsx" +SetupTesting.generateSetupScript __SOURCE_DIRECTORY__ +#load "__setup__.fsx" +#endif +""" + +[] +let ``line, file and path identifiers``() = + formatSourceString false """ + let printSourceLocation() = + printfn "Line: %s" __LINE__ + printfn "Source Directory: %s" __SOURCE_DIRECTORY__ + printfn "Source File: %s" __SOURCE_FILE__ + printSourceLocation() + """ config + |> prepend newline + |> should equal """ +let printSourceLocation() = + printfn "Line: %s" __LINE__ + printfn "Source Directory: %s" __SOURCE_DIRECTORY__ + printfn "Source File: %s" __SOURCE_FILE__ + +printSourceLocation() +""" + +[] +let ``should keep #if, #else and #endif on compiler directives``() = + formatSourceString false """ +let x = 1 +#if SILVERLIGHT +let useHiddenInitCode = false +#else +let useHiddenInitCode = true +#endif +let y = 2 +""" config + |> prepend newline + |> should equal """ +let x = 1 +#if SILVERLIGHT +let useHiddenInitCode = false +#else +let useHiddenInitCode = true +#endif + +let y = 2 +""" + +[] +let ``should handle nested compiler directives``() = + formatSourceString false """ +let [] private assemblyConfig = + #if DEBUG + #if TRACE + "DEBUG;TRACE" + #else + "DEBUG" + #endif + #else + #if TRACE + "TRACE" + #else + "" + #endif + #endif +""" config + |> prepend newline + |> should equal """ +[] +let private assemblyConfig = +#if DEBUG +#if TRACE + "DEBUG;TRACE" +#else + "DEBUG" +#endif +#else +#if TRACE + "TRACE" +#else + "" +#endif +#endif +""" + +[] +let ``should break lines before compiler directives``() = + formatSourceString false """ +let [] private assemblyConfig() = + #if TRACE + let x = "" + #else + let x = "x" + #endif + x +""" config + |> prepend newline + |> should equal """ +[] +let private assemblyConfig() = +#if TRACE + let x = "" +#else + let x = "x" +#endif + + x +""" + +[] +let ``should break line after single directive``() = + formatSourceString false """ +#nowarn "47" +namespace Internal.Utilities.Text.Lexing""" config + |> prepend newline + |> should equal """ +#nowarn "47" +namespace Internal.Utilities.Text.Lexing + +""" + +[] +let ``should handle endif directives with no newline``() = + formatSourceString false """ +namespace Internal.Utilities.Diagnostic + +#if EXTENSIBLE_DUMPER +#if DEBUG + +type ExtensibleDumper = A | B + +#endif +#endif""" config + |> prepend newline + |> should equal """ +namespace Internal.Utilities.Diagnostic +#if EXTENSIBLE_DUMPER +#if DEBUG +type ExtensibleDumper = A | B +#endif + +#endif + + +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs new file mode 100644 index 00000000000..061ed7f9ee0 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs @@ -0,0 +1,99 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.CodeFormatterExtTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``async workflows``() = + formatSourceString false """ +let fetchAsync(name, url:string) = + async { + try + let uri = new System.Uri(url) + let webClient = new WebClient() + let! html = webClient.AsyncDownloadString(uri) + printfn "Read %d characters for %s" html.Length name + with + | :? Exception -> () + | ex -> printfn "%s" (ex.Message); + } + """ config + |> prepend newline + |> should equal """ +let fetchAsync (name, url : string) = + async { + try + let uri = new System.Uri(url) + let webClient = new WebClient() + let! html = webClient.AsyncDownloadString(uri) + printfn "Read %d characters for %s" html.Length name + with + | :? Exception -> () + | ex -> printfn "%s" (ex.Message) + } +""" + +[] +let ``computation expressions``() = + formatSourceString false """ +let comp = + eventually { for x in 1 .. 2 do + printfn " x = %d" x + return 3 + 4 }""" config + |> prepend newline + |> should equal """ +let comp = + eventually { + for x in 1..2 do + printfn " x = %d" x + return 3 + 4 + } +""" + +[] +let ``sequence expressions``() = + formatSourceString false """ +let s1 = seq { for i in 1 .. 10 -> i * i } +let s2 = seq { 0 .. 10 .. 100 } +let rec inorder tree = + seq { + match tree with + | Tree(x, left, right) -> + yield! inorder left + yield x + yield! inorder right + | Leaf x -> yield x + } + """ config + |> prepend newline + |> should equal """ +let s1 = + seq { + for i in 1..10 -> i * i + } + +let s2 = seq { 0..10..100 } + +let rec inorder tree = + seq { + match tree with + | Tree(x, left, right) -> + yield! inorder left + yield x + yield! inorder right + | Leaf x -> yield x + } +""" + +[] +let ``range expressions``() = + formatSourceString false """ +let factors number = + {2L .. number / 2L} + |> Seq.filter (fun x -> number % x = 0L)""" config + |> prepend newline + |> should equal """ +let factors number = + { 2L..number / 2L } |> Seq.filter (fun x -> number % x = 0L) +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs new file mode 100644 index 00000000000..f86decb3b86 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs @@ -0,0 +1,278 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.ControlStructureTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``if/then/else block``() = + formatSourceString false """ +let rec tryFindMatch pred list = + match list with + | head :: tail -> if pred(head) + then Some(head) + else tryFindMatch pred tail + | [] -> None + +let test x y = + if x = y then "equals" + elif x < y then "is less than" + else if x > y then "is greater than" + else "Don't know" + +if age < 10 +then printfn "You are only %d years old and already learning F#? Wow!" age""" config + |> prepend newline + |> should equal """ +let rec tryFindMatch pred list = + match list with + | head :: tail -> + if pred (head) then Some(head) + else tryFindMatch pred tail + | [] -> None + +let test x y = + if x = y then "equals" + elif x < y then "is less than" + else if x > y then "is greater than" + else "Don't know" + +if age < 10 then + printfn "You are only %d years old and already learning F#? Wow!" age +""" + +[] +let ``for loops``() = + formatSourceString false """ + let function1() = + for i = 1 to 10 do + printf "%d " i + printfn "" + let function2() = + for i = 10 downto 1 do + printf "%d " i + printfn "" + """ config + |> prepend newline + |> should equal """ +let function1() = + for i = 1 to 10 do + printf "%d " i + printfn "" + +let function2() = + for i = 10 downto 1 do + printf "%d " i + printfn "" +""" + +[] +let ``while loop``() = + formatSourceString false """ +open System +let lookForValue value maxValue = + let mutable continueLooping = true + let randomNumberGenerator = new Random() + while continueLooping do + let rand = randomNumberGenerator.Next(maxValue) + printf "%d " rand + if rand = value then + printfn "\nFound a %d!" value + continueLooping <- false +lookForValue 10 20""" config + |> prepend newline + |> should equal """ +open System + +let lookForValue value maxValue = + let mutable continueLooping = true + let randomNumberGenerator = new Random() + while continueLooping do + let rand = randomNumberGenerator.Next(maxValue) + printf "%d " rand + if rand = value then + printfn "\nFound a %d!" value + continueLooping <- false + +lookForValue 10 20 +""" + +[] +let ``try/with block``() = + formatSourceString false """ +let divide1 x y = + try + Some (x / y) + with + | :? System.DivideByZeroException -> printfn "Division by zero!"; None + +let result1 = divide1 100 0 + """ config + |> prepend newline + |> should equal """ +let divide1 x y = + try + Some(x / y) + with :? System.DivideByZeroException -> + printfn "Division by zero!" + None + +let result1 = divide1 100 0 +""" + +[] +let ``try/with and finally``() = + formatSourceString false """ + let function1 x y = + try + try + if x = y then raise (InnerError("inner")) + else raise (OuterError("outer")) + with + | Failure _ -> () + | InnerError(str) -> printfn "Error1 %s" str + finally + printfn "Always print this." + """ config + |> prepend newline + |> should equal """ +let function1 x y = + try + try + if x = y then raise (InnerError("inner")) + else raise (OuterError("outer")) + with + | Failure _ -> () + | InnerError(str) -> printfn "Error1 %s" str + finally + printfn "Always print this." +""" + +[] +let ``range expressions``() = + formatSourceString false """ + let function2() = + for i in 1 .. 2 .. 10 do + printf "%d " i + printfn "" + function2()""" config + |> prepend newline + |> should equal """ +let function2() = + for i in 1..2..10 do + printf "%d " i + printfn "" + +function2() +""" + +[] +let ``use binding``() = + formatSourceString false """ + let writetofile filename obj = + use file1 = File.CreateText(filename) + file1.WriteLine("{0}", obj.ToString()) + """ config + |> prepend newline + |> should equal """ +let writetofile filename obj = + use file1 = File.CreateText(filename) + file1.WriteLine("{0}", obj.ToString()) +""" + +[] +let ``access modifiers``() = + formatSourceString false """ + let private myPrivateObj = new MyPrivateType() + let internal myInternalObj = new MyInternalType()""" config + |> prepend newline + |> should equal """ +let private myPrivateObj = new MyPrivateType() +let internal myInternalObj = new MyInternalType() +""" + +[] +let ``keyworded expressions``() = + formatSourceString false """ + assert (3 > 2) + let result = lazy (x + 10) + do printfn "Hello world" + """ config + |> prepend newline + |> should equal """ +assert (3 > 2) + +let result = lazy (x + 10) + +do printfn "Hello world" +""" + +[] +let ``should break lines on multiline if conditions``() = + formatSourceString false """ +let x = + if try + true + with + | Failure _ -> false + then () + else () + """ config + |> prepend newline + |> should equal """ +let x = + if try + true + with Failure _ -> false + then () + else () +""" + +[] +let ``should not escape some specific keywords``() = + formatSourceString false """ +base.Initializer() +global.Test() + """ config + |> prepend newline + |> should equal """ +base.Initializer() +global.Test() +""" + +[] +let ``should handle delimiters before comments``() = + formatSourceString false """ +let handle = + if n prepend newline + |> should equal """ +let handle = + if n < weakThreshhold then + assert onStrongDiscard.IsNone // it disappeared + Weak(WeakReference(v)) + else Strong(v) +""" + +[] +let ``should handle infix operators in pattern matching``() = + formatSourceString false """ +let url = + match x with + | A -> "a" + | B -> "b" + + "/c" + """ config + |> prepend newline + |> should equal """ +let url = + match x with + | A -> "a" + | B -> "b" + + "/c" +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs b/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs new file mode 100644 index 00000000000..817a8108aa7 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs @@ -0,0 +1,168 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.ListTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``array indices``() = + formatSourceString false """ +let array1 = [| 1; 2; 3 |] +array1.[0..2] +array2.[2.., 0..] +array2.[..3, ..1] +array1.[1] <- 3 + """ config + |> prepend newline + |> should equal """ +let array1 = [| 1; 2; 3 |] + +array1.[0..2] +array2.[2.., 0..] +array2.[..3, ..1] +array1.[1] <- 3 +""" + +[] +let ``array values``() = + formatSourceString false """ +let arr = [|(1, 1, 1); (1, 2, 2); (1, 3, 3); (2, 1, 2); (2, 2, 4); (2, 3, 6); (3, 1, 3); + (3, 2, 6); (3, 3, 9)|] + """ { config with SemicolonAtEndOfLine = true } + |> prepend newline + |> should equal """ +let arr = + [| (1, 1, 1); + (1, 2, 2); + (1, 3, 3); + (2, 1, 2); + (2, 2, 4); + (2, 3, 6); + (3, 1, 3); + (3, 2, 6); + (3, 3, 9) |] +""" + +[] +let ``cons and list patterns``() = + formatSourceString false """ +let rec printList l = + match l with + | head :: tail -> printf "%d " head; printList tail + | [] -> printfn "" + +let listLength list = + match list with + | [] -> 0 + | [ _ ] -> 1 + | [ _; _ ] -> 2 + | [ _; _; _ ] -> 3 + | _ -> List.length list""" config + |> prepend newline + |> should equal """ +let rec printList l = + match l with + | head :: tail -> + printf "%d " head + printList tail + | [] -> printfn "" + +let listLength list = + match list with + | [] -> 0 + | [ _ ] -> 1 + | [ _; _ ] -> 2 + | [ _; _; _ ] -> 3 + | _ -> List.length list +""" + +[] +let ``array patterns``() = + formatSourceString false """ +let vectorLength vec = + match vec with + | [| var1 |] -> var1 + | [| var1; var2 |] -> sqrt (var1*var1 + var2*var2) + | [| var1; var2; var3 |] -> sqrt (var1*var1 + var2*var2 + var3*var3) + | _ -> failwith "vectorLength called with an unsupported array size of %d." (vec.Length)""" config + |> prepend newline + |> should equal """ +let vectorLength vec = + match vec with + | [| var1 |] -> var1 + | [| var1; var2 |] -> sqrt (var1 * var1 + var2 * var2) + | [| var1; var2; var3 |] -> sqrt (var1 * var1 + var2 * var2 + var3 * var3) + | _ -> + failwith "vectorLength called with an unsupported array size of %d." + (vec.Length) +""" + +[] +let ``should keep -> notation``() = + formatSourceString false """let environVars target = + [for e in Environment.GetEnvironmentVariables target -> + let e1 = e :?> Collections.DictionaryEntry + e1.Key, e1.Value] + """ config + |> prepend newline + |> should equal """ +let environVars target = + [ for e in Environment.GetEnvironmentVariables target -> + let e1 = e :?> Collections.DictionaryEntry + e1.Key, e1.Value ] +""" + +[] +let ``list comprehensions``() = + formatSourceString false """ +let listOfSquares = [ for i in 1 .. 10 -> i*i ] +let list0to3 = [0 .. 3]""" config + |> prepend newline + |> should equal """ +let listOfSquares = + [ for i in 1..10 -> i * i ] + +let list0to3 = [ 0..3 ] +""" + +[] +let ``array comprehensions``() = + formatSourceString false """ +let a1 = [| for i in 1 .. 10 -> i * i |] +let a2 = [| 0 .. 99 |] +let a3 = [| for n in 1 .. 100 do if isPrime n then yield n |]""" config + |> prepend newline + |> should equal """ +let a1 = + [| for i in 1..10 -> i * i |] + +let a2 = [| 0..99 |] + +let a3 = + [| for n in 1..100 do + if isPrime n then yield n |] +""" + +[] +let ``should keep Array2D``() = + formatSourceString false """ +let cast<'a> (A:obj[,]):'a[,] = A |> Array2D.map unbox +let flatten (A:'a[,]) = A |> Seq.cast<'a> +let getColumn c (A:_[,]) = flatten A.[*,c..c] |> Seq.toArray""" config + |> prepend newline + |> should equal """ +let cast<'a> (A : obj [,]) : 'a [,] = A |> Array2D.map unbox +let flatten (A : 'a [,]) = A |> Seq.cast<'a> +let getColumn c (A : _ [,]) = flatten A.[*, c..c] |> Seq.toArray +""" + +[] +let ``should be able to support F# 3.1 slicing``() = + formatSourceString false """ +let x = matrix.[*, 3] +let y = matrix.[3, *]""" config + |> prepend newline + |> should equal """ +let x = matrix.[*, 3] +let y = matrix.[3, *] +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs new file mode 100644 index 00000000000..57d8ae7ebe2 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs @@ -0,0 +1,579 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingPropertyTests + +open NUnit.Framework +open System +open FsCheck +open FsUnit +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.Range +open TestHelper +open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig + +let internal formatConfig = { FormatConfig.Default with StrictMode = true } + +let internal generateSynMeasure = + Gen.constant SynMeasure.One + +let internal generateRange = + Gen.constant range.Zero + +let internal zero = range.Zero + +let internal generateBasicConst _ = + Gen.oneof + [ + Gen.constant SynConst.Unit + Gen.map SynConst.Bool Arb.generate<_> + Gen.map SynConst.SByte Arb.generate<_> + Gen.map SynConst.Byte Arb.generate<_> + Gen.map SynConst.Int16 Arb.generate<_> + Gen.map SynConst.UInt16 Arb.generate<_> + Gen.map SynConst.Int32 Arb.generate<_> + Gen.map SynConst.UInt32 Arb.generate<_> + Gen.map SynConst.Int64 Arb.generate<_> + Gen.map SynConst.UInt64 Arb.generate<_> + Gen.map SynConst.IntPtr Arb.generate<_> + Gen.map SynConst.UIntPtr Arb.generate<_> + Gen.map SynConst.Single Arb.generate<_> + Gen.map SynConst.Double Arb.generate<_> + Gen.map SynConst.Char Arb.generate<_> + Gen.map SynConst.Decimal Arb.generate<_> + Gen.map SynConst.UserNum Arb.generate<_> + Gen.map (fun x -> SynConst.String(x, zero)) Arb.generate<_> + Gen.map (fun x -> SynConst.Bytes(x, zero)) Arb.generate<_> + Gen.map SynConst.UInt16s Arb.generate<_> + ] + +/// Constant is not really recursive. +/// Unit of Measure constant is only one-level deep. +let internal generateSynConst size = + let genBasicConst = generateBasicConst size + Gen.oneof + [ + Gen.constant SynConst.Unit + Gen.map SynConst.Bool Arb.generate<_> + Gen.map SynConst.SByte Arb.generate<_> + Gen.map SynConst.Byte Arb.generate<_> + Gen.map SynConst.Int16 Arb.generate<_> + Gen.map SynConst.UInt16 Arb.generate<_> + Gen.map SynConst.Int32 Arb.generate<_> + Gen.map SynConst.UInt32 Arb.generate<_> + Gen.map SynConst.Int64 Arb.generate<_> + Gen.map SynConst.UInt64 Arb.generate<_> + Gen.map SynConst.IntPtr Arb.generate<_> + Gen.map SynConst.UIntPtr Arb.generate<_> + Gen.map SynConst.Single Arb.generate<_> + Gen.map SynConst.Double Arb.generate<_> + Gen.map SynConst.Char Arb.generate<_> + Gen.map SynConst.Decimal Arb.generate<_> + Gen.map SynConst.UserNum Arb.generate<_> + Gen.map (fun x -> SynConst.String(x, zero)) Arb.generate<_> + Gen.map (fun x -> SynConst.Bytes(x, zero)) Arb.generate<_> + Gen.map SynConst.UInt16s Arb.generate<_> + Gen.map2 (fun x y -> SynConst.Measure(x, y)) genBasicConst generateSynMeasure + ] + +let internal alphaFreqList = + [ + (26, Gen.elements <| seq {'a'..'z'}); + (26, Gen.elements <| seq {'A'..'Z'}); + (1, Gen.elements <| seq ['_']) + ] + +let internal digitFreqList = [ (10, Gen.elements <| seq {'0'..'9'}) ] + +let internal letter = Gen.frequency alphaFreqList +let letterOrDigit = Gen.frequency <| alphaFreqList @ digitFreqList + +let internal generateIdent size = + (letter, Gen.listOfLength size letterOrDigit) + ||> Gen.map2 (fun c cs -> String(c::cs |> List.toArray)) + +let internal generateLongIdentWithDots size = + let genSubIdent = generateIdent (size/2) + Gen.map (fun s -> LongIdentWithDots([Ident(s, zero)], [zero])) genSubIdent + +let internal generateSynType size = + let genSubLongIdentWithDots = generateLongIdentWithDots (size/2) + Gen.oneof + [ + Gen.map SynType.LongIdent genSubLongIdentWithDots + ] + +let rec internal generateSynPat size = + let genSubLongIdentWithDots = generateLongIdentWithDots (size/2) + if size <= 2 then + let genConstructorArgs = (Gen.constant (SynConstructorArgs.Pats [])) + Gen.map2 (fun ident args -> SynPat.LongIdent(ident, None, None, args, None, zero)) genSubLongIdentWithDots genConstructorArgs + else + let genConstructorArgs = Gen.map SynConstructorArgs.Pats (Gen.listOf (generateSynPat (size/2))) + Gen.oneof + [ + Gen.constant (SynPat.Wild zero) + Gen.map2 (fun ident args -> SynPat.LongIdent(ident, None, None, args, None, zero)) genSubLongIdentWithDots genConstructorArgs + ] + +and internal generateSynSimplePats size = + let genSubSynPat = generateSynPat (size/2) + Gen.map (fun pat -> fst <| SimplePatsOfPat (SynArgNameGenerator()) pat) genSubSynPat + +and internal generateSynMatchClause size = + let genSubSynPat = generateSynPat (size/2) + let genSubSynExpr = generateSynExpr (size/2) + Gen.oneof + [ + Gen.map2 (fun pat expr -> SynMatchClause.Clause(pat, None, expr, zero, SequencePointAtTarget)) genSubSynPat genSubSynExpr + Gen.map3 (fun pat expr1 expr2 -> SynMatchClause.Clause(pat, Some expr1, expr2, zero, SequencePointAtTarget)) genSubSynPat genSubSynExpr genSubSynExpr + ] + +and internal generateSynBinding size = + let genSubSynExpr = generateSynExpr (size/2) + let genSubSynPat = generateSynPat (size/2) + Gen.map2 (fun expr pat -> SynBinding.Binding(None, SynBindingKind.NormalBinding, false, false, [], PreXmlDoc.Empty, SynInfo.emptySynValData, pat, None, expr, zero, NoSequencePointAtLetBinding)) + genSubSynExpr genSubSynPat + +and internal generateIdentExpr size = + let genSubIdent = generateIdent (size/2) + Gen.map (fun s -> SynExpr.Ident(Ident(s, zero))) genSubIdent + +/// Complex expressions are only nested for function definitions and some control-flow constructs. +and internal generateSynExpr size = + if size <= 2 then + generateIdentExpr size + else + let genSubSynExpr = generateSynExpr (size/2) + let genSubBasicExpr = generateBasicExpr (size/2) + let genSubBasicExprList = Gen.listOf genSubBasicExpr + let genSubIdentExpr = generateIdentExpr (size/2) + let genSubSynType = generateSynType (size/2) + let genSubSynTypeList = Gen.listOf genSubSynType + let genSubSynSimplePats = generateSynSimplePats (size/2) + let genSubSynMatchClauseList = Gen.listOf (generateSynMatchClause (size/2)) + let genSubSynPat = generateSynPat (size/2) + let genSubIdent = generateIdent (size/2) + let genSubLongIdentWithDots = generateLongIdentWithDots (size/2) + let genSubSynConst = generateSynConst (size/2) + let generateSynBindingList = Gen.listOf (generateSynBinding (size/2)) + Gen.frequency + [ + 1, Gen.map (fun c -> SynExpr.Const(c, zero)) genSubSynConst + 1, Gen.map2 (fun expr typ -> SynExpr.Typed(expr, typ, zero)) genSubBasicExpr genSubSynType + 2, Gen.map (fun exprs -> SynExpr.Tuple(exprs, exprs |> List.map (fun _ -> zero), zero)) genSubBasicExprList + 2, Gen.map2 (fun b exprs -> SynExpr.ArrayOrList(b, exprs, zero)) Arb.generate<_> genSubBasicExprList + 1, Gen.map3 (fun b typ expr -> SynExpr.New(b, typ, SynExpr.Paren(expr, zero, None, zero), zero)) Arb.generate<_> genSubSynType genSubBasicExpr + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.While(NoSequencePointAtWhileLoop, expr1, expr2, zero)) genSubBasicExpr genSubBasicExpr + 1, Gen.map2 (fun b expr -> SynExpr.ArrayOrListOfSeqExpr(b, expr, zero)) Arb.generate<_> genSubBasicExpr + 1, Gen.map2 (fun b expr -> SynExpr.CompExpr(b, ref true, expr, zero)) Arb.generate<_> genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Do(expr, zero)) genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Assert(expr, zero)) genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Paren(expr, zero, None, zero)) genSubBasicExpr + 1, genSubIdentExpr + 1, Gen.map2 (fun b expr -> SynExpr.AddressOf(b, expr, zero, zero)) Arb.generate<_> genSubIdentExpr + 1, Gen.constant (SynExpr.Null zero) + 1, Gen.map (fun expr -> SynExpr.InferredDowncast(expr, zero)) genSubIdentExpr + 1, Gen.map (fun expr -> SynExpr.InferredUpcast(expr, zero)) genSubIdentExpr + 1, Gen.map2 (fun expr typ -> SynExpr.Upcast(expr, typ, zero)) genSubIdentExpr genSubSynType + 1, Gen.map2 (fun expr typ -> SynExpr.Downcast(expr, typ, zero)) genSubIdentExpr genSubSynType + 1, Gen.map2 (fun expr typ -> SynExpr.TypeTest(expr, typ, zero)) genSubIdentExpr genSubSynType + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.DotIndexedGet(expr1, [SynIndexerArg.One expr2], zero, zero)) genSubBasicExpr genSubBasicExpr + 1, Gen.map3 (fun expr1 expr2 expr3 -> SynExpr.DotIndexedSet(expr1, [SynIndexerArg.One expr3], expr2, zero, zero, zero)) genSubBasicExpr genSubBasicExpr genSubBasicExpr + 1, Gen.map2 (fun expr longIdent -> SynExpr.DotGet(expr, zero, longIdent, zero)) genSubBasicExpr genSubLongIdentWithDots + 1, Gen.map3 (fun expr1 expr2 longIdent -> SynExpr.DotSet(expr1, longIdent, expr2, zero)) genSubBasicExpr genSubBasicExpr genSubLongIdentWithDots + 1, Gen.map2 (fun expr longIdent -> SynExpr.LongIdentSet(longIdent, expr, zero)) genSubBasicExpr genSubLongIdentWithDots + 1, Gen.map2 (fun b longIdent -> SynExpr.LongIdent(b, longIdent, None, zero)) Arb.generate<_> genSubLongIdentWithDots + 2, Gen.map3 (fun expr1 expr2 expr3 -> SynExpr.IfThenElse(expr1, expr2, Some expr3, NoSequencePointAtDoBinding, false, zero, zero)) genSubBasicExpr genSubBasicExpr genSubBasicExpr + 2, Gen.map2 (fun expr1 expr2 -> SynExpr.Sequential(SequencePointsAtSeq, true, expr1, expr2, zero)) genSubBasicExpr genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Lazy(expr, zero)) genSubBasicExpr + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.TryFinally(expr1, expr2, zero, NoSequencePointAtTry, NoSequencePointAtFinally)) genSubSynExpr genSubSynExpr + 1, Gen.map2 (fun expr clauses -> SynExpr.TryWith(expr, zero, clauses, zero, zero, NoSequencePointAtTry, NoSequencePointAtWith)) genSubSynExpr genSubSynMatchClauseList + 1, Gen.map2 (fun expr typs -> SynExpr.TypeApp(expr, zero, typs, typs |> List.map (fun _ -> zero), None, zero, zero)) genSubBasicExpr genSubSynTypeList + 4, Gen.map3 (fun b expr1 expr2 -> SynExpr.App(ExprAtomicFlag.NonAtomic, b, expr1, expr2, zero)) Arb.generate<_> genSubBasicExpr genSubBasicExpr + 4, Gen.map2 (fun expr clauses -> SynExpr.Match(NoSequencePointAtDoBinding, expr, clauses, false, zero)) genSubSynExpr genSubSynMatchClauseList + 2, Gen.map2 (fun b clauses -> SynExpr.MatchLambda(b, zero, clauses, NoSequencePointAtDoBinding, zero)) Arb.generate<_> genSubSynMatchClauseList + 2, Gen.map3 (fun b pat expr -> SynExpr.Lambda(b, false, pat, expr, zero)) Arb.generate<_> genSubSynSimplePats genSubSynExpr + 2, Gen.map5 (fun b expr1 expr2 expr3 s -> SynExpr.For(NoSequencePointAtForLoop, Ident(s, zero), expr1, b, expr2, expr3, zero)) Arb.generate<_> genSubBasicExpr genSubBasicExpr genSubBasicExpr genSubIdent + 2, Gen.map4 (fun b1 expr1 expr2 pat -> SynExpr.ForEach(NoSequencePointAtForLoop, SeqExprOnly false, b1, pat, expr1, expr2, zero)) Arb.generate<_> genSubBasicExpr genSubBasicExpr genSubSynPat + 8, Gen.map3 (fun b bindings expr -> SynExpr.LetOrUse(b, not b, bindings, expr, zero)) Arb.generate<_> generateSynBindingList genSubSynExpr + ] + +and internal generateBasicExpr size = + if size <= 2 then + generateIdentExpr size + else + let genSubBasicExpr = generateBasicExpr (size/2) + let genSubBasicExprList = Gen.listOf genSubBasicExpr + let genSubIdentExpr = generateIdentExpr (size/2) + let genSubSynType = generateSynType (size/2) + let genSubSynTypeList = Gen.listOf genSubSynType + let genSubSynPat = generateSynPat (size/2) + let genSubIdent = generateIdent (size/2) + let genSubLongIdentWithDots = generateLongIdentWithDots (size/2) + let genSubSynConst = generateSynConst (size/2) + Gen.frequency + [ + 1, Gen.map (fun c -> SynExpr.Const(c, zero)) genSubSynConst + 1, Gen.map2 (fun expr typ -> SynExpr.Typed(expr, typ, zero)) genSubBasicExpr genSubSynType + 2, Gen.map (fun exprs -> SynExpr.Tuple(exprs, exprs |> List.map (fun _ -> zero), zero)) genSubBasicExprList + 2, Gen.map2 (fun b exprs -> SynExpr.ArrayOrList(b, exprs, zero)) Arb.generate<_> genSubBasicExprList + 1, Gen.map3 (fun b typ expr -> SynExpr.New(b, typ, SynExpr.Paren(expr, zero, None, zero), zero)) Arb.generate<_> genSubSynType genSubBasicExpr + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.While(NoSequencePointAtWhileLoop, expr1, expr2, zero)) genSubBasicExpr genSubBasicExpr + 1, Gen.map2 (fun b expr -> SynExpr.ArrayOrListOfSeqExpr(b, expr, zero)) Arb.generate<_> genSubBasicExpr + 1, Gen.map2 (fun b expr -> SynExpr.CompExpr(b, ref true, expr, zero)) Arb.generate<_> genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Do(expr, zero)) genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Assert(expr, zero)) genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Paren(expr, zero, None, zero)) genSubBasicExpr + 1, genSubIdentExpr + 1, Gen.map2 (fun b expr -> SynExpr.AddressOf(b, expr, zero, zero)) Arb.generate<_> genSubIdentExpr + 1, Gen.constant (SynExpr.Null zero) + 1, Gen.map (fun expr -> SynExpr.InferredDowncast(expr, zero)) genSubIdentExpr + 1, Gen.map (fun expr -> SynExpr.InferredUpcast(expr, zero)) genSubIdentExpr + 1, Gen.map2 (fun expr typ -> SynExpr.Upcast(expr, typ, zero)) genSubIdentExpr genSubSynType + 1, Gen.map2 (fun expr typ -> SynExpr.Downcast(expr, typ, zero)) genSubIdentExpr genSubSynType + 1, Gen.map2 (fun expr typ -> SynExpr.TypeTest(expr, typ, zero)) genSubIdentExpr genSubSynType + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.DotIndexedGet(expr1, [SynIndexerArg.One expr2], zero, zero)) genSubBasicExpr genSubBasicExpr + 1, Gen.map3 (fun expr1 expr2 expr3 -> SynExpr.DotIndexedSet(expr1, [SynIndexerArg.One expr3], expr2, zero, zero, zero)) genSubBasicExpr genSubBasicExpr genSubBasicExpr + 1, Gen.map2 (fun expr longIdent -> SynExpr.DotGet(expr, zero, longIdent, zero)) genSubBasicExpr genSubLongIdentWithDots + 1, Gen.map3 (fun expr1 expr2 longIdent -> SynExpr.DotSet(expr1, longIdent, expr2, zero)) genSubBasicExpr genSubBasicExpr genSubLongIdentWithDots + 1, Gen.map2 (fun expr longIdent -> SynExpr.LongIdentSet(longIdent, expr, zero)) genSubBasicExpr genSubLongIdentWithDots + 1, Gen.map2 (fun b longIdent -> SynExpr.LongIdent(b, longIdent, None, zero)) Arb.generate<_> genSubLongIdentWithDots + 2, Gen.map2 (fun expr1 expr2 -> SynExpr.Sequential(SequencePointsAtSeq, true, expr1, expr2, zero)) genSubBasicExpr genSubBasicExpr + 1, Gen.map (fun expr -> SynExpr.Lazy(expr, zero)) genSubBasicExpr + 1, Gen.map2 (fun expr typs -> SynExpr.TypeApp(expr, zero, typs, typs |> List.map (fun _ -> zero), None, zero, zero)) genSubBasicExpr genSubSynTypeList + 4, Gen.map3 (fun b expr1 expr2 -> SynExpr.App(ExprAtomicFlag.NonAtomic, b, expr1, expr2, zero)) Arb.generate<_> genSubBasicExpr genSubBasicExpr + 2, Gen.map5 (fun b expr1 expr2 expr3 s -> SynExpr.For(NoSequencePointAtForLoop, Ident(s, zero), expr1, b, expr2, expr3, zero)) Arb.generate<_> genSubBasicExpr genSubBasicExpr genSubBasicExpr genSubIdent + 2, Gen.map5 (fun b1 b2 expr1 expr2 pat -> SynExpr.ForEach(NoSequencePointAtForLoop, SeqExprOnly b1, b2, pat, expr1, expr2, zero)) Arb.generate<_> Arb.generate<_> genSubBasicExpr genSubBasicExpr genSubSynPat + ] + +/// Generate a subset of SynExpr that is permitted as inputs to FSI. +/// The grammar is described at https://github.com/fsharp/FSharp.Compiler.Service/blob/21e88fea087e182b99b7658684cc6e1ae98e85d8/src/fsharp/pars.fsy#L2900 +let rec internal generateTypedSeqExpr size = + if size <= 2 then + generateIdentExpr size + else + let genSubSeqExpr = generateSeqExpr (size/2) + let genSubSynType = generateSynType (size/2) + Gen.oneof + [ + // Typed expressions should have parenthesis on the top level + Gen.map2 (fun expr typ -> SynExpr.Paren(SynExpr.Typed(SynExpr.Paren(expr, zero, None, zero), typ, zero), zero, None, zero)) genSubSeqExpr genSubSynType + genSubSeqExpr + ] + +and internal generateSeqExpr size = + if size <= 2 then + generateIdentExpr size + else + let genSubSeqExpr = generateSeqExpr (size/2) + let genSubDeclExpr = generateDeclExpr (size/2) + let generateSynBindingList = Gen.listOf (generateSynBinding (size/2)) + let genSubBasicExpr = generateBasicExpr (size/2) + Gen.oneof + [ + Gen.map3 (fun b expr1 expr2 -> SynExpr.Sequential(SequencePointsAtSeq, b, expr1, expr2, zero)) Arb.generate<_> genSubDeclExpr genSubSeqExpr + // Should not have 'use' keywords on the top level + Gen.map3 (fun b bindings expr -> SynExpr.LetOrUse(b, false, bindings, expr, zero)) Arb.generate<_> generateSynBindingList genSubBasicExpr + ] + +and internal generateDeclExpr size = + if size <= 2 then + generateIdentExpr size + else + let genSubDeclExpr = generateDeclExpr (size/2) + let genSubDeclExprList = Gen.listOf genSubDeclExpr + let genSubIdentExpr = generateIdentExpr (size/2) + let genSubSynType = generateSynType (size/2) + let genSubSynTypeList = Gen.listOf genSubSynType + let genSubSynPat = generateSynPat (size/2) + let genSubIdent = generateIdent (size/2) + let genSubLongIdentWithDots = generateLongIdentWithDots (size/2) + let genSubSynConst = generateSynConst (size/2) + let generateSynBindingList = Gen.listOf (generateSynBinding (size/2)) + let genSubSynMatchClauseList = Gen.listOf (generateSynMatchClause (size/2)) + let genSubSynSimplePats = generateSynSimplePats (size/2) + Gen.frequency + [ + 8, Gen.map3 (fun b bindings expr -> SynExpr.LetOrUse(b, false, bindings, expr, zero)) Arb.generate<_> generateSynBindingList genSubDeclExpr // + 4, Gen.map2 (fun expr clauses -> SynExpr.Match(NoSequencePointAtDoBinding, expr, clauses, false, zero)) genSubDeclExpr genSubSynMatchClauseList // + 4, Gen.map2 (fun b clauses -> SynExpr.MatchLambda(b, zero, clauses, NoSequencePointAtDoBinding, zero)) Arb.generate<_> genSubSynMatchClauseList // + 4, Gen.map3 (fun b pat expr -> SynExpr.Lambda(b, false, pat, expr, zero)) Arb.generate<_> genSubSynSimplePats genSubDeclExpr // + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.TryFinally(expr1, expr2, zero, NoSequencePointAtTry, NoSequencePointAtFinally)) genSubDeclExpr genSubDeclExpr // + 1, Gen.map2 (fun expr clauses -> SynExpr.TryWith(expr, zero, clauses, zero, zero, NoSequencePointAtTry, NoSequencePointAtWith)) genSubDeclExpr genSubSynMatchClauseList // + 1, Gen.map (fun c -> SynExpr.Const(c, zero)) genSubSynConst // + 1, Gen.map2 (fun expr typ -> SynExpr.Typed(expr, typ, zero)) genSubDeclExpr genSubSynType + 2, Gen.map (fun exprs -> SynExpr.Tuple(exprs, exprs |> List.map (fun _ -> zero), zero)) genSubDeclExprList // + 2, Gen.map2 (fun b exprs -> SynExpr.ArrayOrList(b, exprs, zero)) Arb.generate<_> genSubDeclExprList + 1, Gen.map3 (fun b typ expr -> SynExpr.New(b, typ, SynExpr.Paren(expr, zero, None, zero), zero)) Arb.generate<_> genSubSynType genSubDeclExpr + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.While(NoSequencePointAtWhileLoop, expr1, expr2, zero)) genSubDeclExpr genSubDeclExpr // + 1, Gen.map2 (fun b expr -> SynExpr.ArrayOrListOfSeqExpr(b, expr, zero)) Arb.generate<_> genSubDeclExpr + 1, Gen.map2 (fun b expr -> SynExpr.CompExpr(b, ref true, expr, zero)) Arb.generate<_> genSubDeclExpr + 1, Gen.map (fun expr -> SynExpr.Do(expr, zero)) genSubDeclExpr // + 1, Gen.map (fun expr -> SynExpr.Assert(expr, zero)) genSubDeclExpr // + 1, Gen.map (fun expr -> SynExpr.Paren(expr, zero, None, zero)) genSubDeclExpr + 1, genSubIdentExpr + 1, Gen.map2 (fun b expr -> SynExpr.AddressOf(b, expr, zero, zero)) Arb.generate<_> genSubIdentExpr + 1, Gen.constant (SynExpr.Null zero) + 1, Gen.map (fun expr -> SynExpr.InferredDowncast(expr, zero)) genSubIdentExpr + 1, Gen.map (fun expr -> SynExpr.InferredUpcast(expr, zero)) genSubIdentExpr + 1, Gen.map2 (fun expr typ -> SynExpr.Upcast(expr, typ, zero)) genSubIdentExpr genSubSynType // + 1, Gen.map2 (fun expr typ -> SynExpr.Downcast(expr, typ, zero)) genSubIdentExpr genSubSynType // + 1, Gen.map2 (fun expr typ -> SynExpr.TypeTest(expr, typ, zero)) genSubIdentExpr genSubSynType // + 1, Gen.map2 (fun expr1 expr2 -> SynExpr.DotIndexedGet(expr1, [SynIndexerArg.One expr2], zero, zero)) genSubDeclExpr genSubDeclExpr + 1, Gen.map3 (fun expr1 expr2 expr3 -> SynExpr.DotIndexedSet(expr1, [SynIndexerArg.One expr3], expr2, zero, zero, zero)) genSubDeclExpr genSubDeclExpr genSubDeclExpr + 1, Gen.map2 (fun expr longIdent -> SynExpr.DotGet(expr, zero, longIdent, zero)) genSubDeclExpr genSubLongIdentWithDots + 1, Gen.map3 (fun expr1 expr2 longIdent -> SynExpr.DotSet(expr1, longIdent, expr2, zero)) genSubDeclExpr genSubDeclExpr genSubLongIdentWithDots + 1, Gen.map2 (fun expr longIdent -> SynExpr.LongIdentSet(longIdent, expr, zero)) genSubDeclExpr genSubLongIdentWithDots + 1, Gen.map2 (fun b longIdent -> SynExpr.LongIdent(b, longIdent, None, zero)) Arb.generate<_> genSubLongIdentWithDots + 2, Gen.map2 (fun expr1 expr2 -> SynExpr.Sequential(SequencePointsAtSeq, true, expr1, expr2, zero)) genSubDeclExpr genSubDeclExpr + 1, Gen.map (fun expr -> SynExpr.Lazy(expr, zero)) genSubDeclExpr // + 1, Gen.map2 (fun expr typs -> SynExpr.TypeApp(expr, zero, typs, typs |> List.map (fun _ -> zero), None, zero, zero)) genSubDeclExpr genSubSynTypeList + 4, Gen.map3 (fun b expr1 expr2 -> SynExpr.App(ExprAtomicFlag.NonAtomic, b, expr1, expr2, zero)) Arb.generate<_> genSubDeclExpr genSubDeclExpr + 2, Gen.map5 (fun b expr1 expr2 expr3 s -> SynExpr.For(NoSequencePointAtForLoop, Ident(s, zero), expr1, b, expr2, expr3, zero)) Arb.generate<_> genSubDeclExpr genSubDeclExpr genSubDeclExpr genSubIdent // + 2, Gen.map5 (fun b1 b2 expr1 expr2 pat -> SynExpr.ForEach(NoSequencePointAtForLoop, SeqExprOnly b1, b2, pat, expr1, expr2, zero)) Arb.generate<_> Arb.generate<_> genSubDeclExpr genSubDeclExpr genSubSynPat // + ] + +let internal generateParsedInput = + let generateAST expr = + let ident = Ident("Tmp", zero) + ParsedInput.ImplFile + (ParsedImplFileInput + ("/tmp.fsx", true, + QualifiedNameOfFile ident, [], [], + [SynModuleOrNamespace + ([ident], false, true, + [SynModuleDecl.DoExpr(NoSequencePointAtDoBinding, expr, zero)], PreXmlDocEmpty, [], None, + zero)], (true, true))) + Gen.sized <| fun size -> Gen.map generateAST (generateTypedSeqExpr size) + +type internal Input = Input of string + +let internal tryFormatAST ast sourceCode config = + try + formatAST ast sourceCode config + with _ -> + "" + +let internal generateInput = + Gen.map (fun ast -> Input (tryFormatAST ast None formatConfig)) generateParsedInput + +// Regenerate inputs from expression ASTs +// Might suffer from bugs in formatting phase +let internal fromSynExpr expr = + let ast = + let ident = Ident("Tmp", zero) + ParsedInput.ImplFile + (ParsedImplFileInput + ("/tmp.fsx", true, + QualifiedNameOfFile ident, [], [], + [SynModuleOrNamespace + ([ident], false, true, + [SynModuleDecl.DoExpr(NoSequencePointAtDoBinding, expr, zero)], PreXmlDocEmpty, [], None, + zero)], (true, true))) + Input (tryFormatAST ast None formatConfig) + +// Look up original source in order to reconstruct smaller counterexamples +let internal fromExprRange (originalSource: string) (expr: SynExpr) = + let r = expr.Range + let source = originalSource.Replace("\r\n", "\n").Replace("\r", "\n") + let positions = + source.Split('\n') + |> Seq.map (fun s -> String.length s + 1) + |> Seq.scan (+) 0 + |> Seq.toArray + let startIndex = positions.[r.StartLine-1] + r.StartColumn + let endIndex = positions.[r.EndLine-1] + r.EndColumn-1 + let sample = source.[startIndex..endIndex] + // Avoid to recreate the same source + // because it may cause the shrinker to loop forever + if (sample.Trim()) = (originalSource.Trim()) then + None + else Some (Input sample) + +let internal toSynExprs (Input s) = + match (try parse false s with _ -> None) with + | Some + (ParsedInput.ImplFile + (ParsedImplFileInput + ("/tmp.fsx", _, + QualifiedNameOfFile _, [], [], + [SynModuleOrNamespace + (_, false, true, exprs, _, _, _, _)], _))) -> + List.choose (function (SynModuleDecl.DoExpr(_, expr, _)) -> Some expr | _ -> None) exprs + | _ -> + //stdout.WriteLine("Can't convert {0}.", sprintf "%A" ast) + [] + +let rec internal shrinkSynExpr = function + | SynExpr.LongIdentSet(_, expr, _) + | SynExpr.DotIndexedGet(expr, _, _, _) + | SynExpr.DotGet(expr, _, _, _) + | SynExpr.DotSet(expr, _, _, _) + | SynExpr.TypeTest(expr, _, _) + | SynExpr.Upcast(expr, _, _) + | SynExpr.Downcast(expr, _, _) + | SynExpr.InferredUpcast(expr, _) + | SynExpr.InferredDowncast(expr, _) + | SynExpr.Lazy(expr, _) + | SynExpr.TypeApp(expr, _, _, _, _, _, _) + | SynExpr.Do(expr, _) + | SynExpr.Assert(expr, _) + | SynExpr.Lambda(_, _, _, expr, _) + | SynExpr.CompExpr(_, _, expr, _) + | SynExpr.ArrayOrListOfSeqExpr(_, expr, _) + | SynExpr.New(_, _, expr, _) + | SynExpr.Typed(expr, _, _) + | SynExpr.Paren(expr, _, _, _) + | SynExpr.AddressOf(_, expr, _, _) -> + collectSynExpr expr + + | SynExpr.IfThenElse(expr1, expr2, None, _, _, _, _) + | SynExpr.DotIndexedSet(expr1, _, expr2, _, _, _) + | SynExpr.NamedIndexedPropertySet(_, expr1, expr2, _) + | SynExpr.Sequential(_, _, expr1, expr2, _) + | SynExpr.TryFinally(expr1, expr2, _, _, _) + | SynExpr.App(_, _, expr1, expr2, _) + | SynExpr.ForEach(_, _, _, _, expr1, expr2, _) + | SynExpr.While(_, expr1, expr2, _) + | SynExpr.Quote(expr1, _, expr2, _, _) -> + seq { yield! collectSynExpr expr1; yield! collectSynExpr expr2 } + | SynExpr.Const(_, _) -> Seq.empty + | SynExpr.ArrayOrList(_, exprs, _) + | SynExpr.Tuple(exprs, _, _) -> + seq { yield! Seq.collect collectSynExpr exprs } + | SynExpr.Record(_, _, _, _) -> Seq.empty + | SynExpr.ObjExpr(_, _, _, _, _, _) -> Seq.empty + + | SynExpr.IfThenElse(expr1, expr2, Some expr3, _, _, _, _) + | SynExpr.DotNamedIndexedPropertySet(expr1, _, expr2, expr3, _) + | SynExpr.For(_, _, expr1, _, expr2, expr3, _) -> + seq { yield! collectSynExpr expr1; yield! collectSynExpr expr2; yield! collectSynExpr expr3 } + | SynExpr.MatchLambda(_, _, clauses, _, _) -> + seq { yield! Seq.collect collectSynMatchClause clauses } + | SynExpr.TryWith(expr, _, clauses, _, _, _, _) + | SynExpr.Match(_, expr, clauses, _, _) -> + seq { yield! collectSynExpr expr; yield! Seq.collect collectSynMatchClause clauses } + | SynExpr.LetOrUse(_, _, bindings, expr, _) -> + seq { yield! Seq.collect collectSynBinding bindings; yield! collectSynExpr expr } + | SynExpr.Ident _ + | SynExpr.LongIdent _ + | SynExpr.Null _ + | SynExpr.TraitCall _ + | SynExpr.JoinIn _ + | SynExpr.ImplicitZero _ + | SynExpr.YieldOrReturn _ + | SynExpr.YieldOrReturnFrom _ + | SynExpr.LetOrUseBang _ + | SynExpr.DoBang _ + | SynExpr.LibraryOnlyILAssembly _ + | SynExpr.LibraryOnlyStaticOptimization _ + | SynExpr.LibraryOnlyUnionCaseFieldGet _ + | SynExpr.LibraryOnlyUnionCaseFieldSet _ + | SynExpr.ArbitraryAfterError _ + | SynExpr.FromParseError _ + | SynExpr.DiscardAfterMissingQualificationAfterDot _ + | SynExpr.Fixed _ + | SynExpr.StructTuple _ -> Seq.empty + +and internal collectSynExpr expr = + seq { yield expr + yield! shrinkSynExpr expr } + +and internal collectSynMatchClause (SynMatchClause.Clause(_, exprOpt, expr, _, _)) = + seq { yield! exprOpt |> Option.map collectSynExpr |> fun arg -> defaultArg arg Seq.empty + yield! collectSynExpr expr } + +and internal collectSynBinding (SynBinding.Binding(_, _, _, _, _, _, _, _, _, expr, _, _)) = + collectSynExpr expr + +let internal shrinkInput input = + match toSynExprs input with + | [] -> + //stdout.WriteLine("Can't shrink {0} further.", sprintf "%A" input) + Seq.empty + | exprs -> + let (Input source) = input + Seq.collect shrinkSynExpr exprs + |> Seq.choose (fromExprRange source) + |> Seq.distinct + +type internal Generators = + static member range() = + Arb.fromGen generateRange + static member Input() = + Arb.fromGenShrink (generateInput, shrinkInput) + +[] +let internal registerFsCheckGenerators() = + Arb.register() |> ignore + +/// An FsCheck runner which reports FsCheck test results to NUnit. +type private NUnitRunner () = + interface IRunner with + member __.OnStartFixture _ = () + member __.OnArguments (_ntest, _args, _every) = + //stdout.Write(every ntest args) + () + + member __.OnShrink(_args, _everyShrink) = + //stdout.Write(everyShrink args) + () + + member __.OnFinished (name, result) = + match result with + | TestResult.True(_, _data) -> + // TODO : Log the result data. + Runner.onFinishedToString name result + |> stdout.WriteLine + + | TestResult.Exhausted _data -> + // TODO : Log the result data. + Runner.onFinishedToString name result + |> Assert.Inconclusive + + | TestResult.False (_,_,_,_,_) -> + // TODO : Log more information about the test failure. + Runner.onFinishedToString name result + |> Assert.Fail + +let private verboseConf = + { + Config.Verbose with + MaxTest = 500 + EndSize = 20 + Runner = NUnitRunner () + } + +let internal tryFormatSourceString isFsi sourceCode config = + try + if sourceCode = null then sourceCode + else formatSourceString isFsi sourceCode config + with _ -> + sourceCode + +[] +let ``running formatting twice should produce the same results``() = + Check.One(verboseConf, + fun (Input sourceCode) -> + let formatted = tryFormatSourceString false sourceCode formatConfig + tryFormatSourceString false formatted formatConfig = formatted) + +[] +let ``should be able to convert inputs to SynExpr``() = + "x" |> Input |> toSynExprs |> fun opt -> not opt.IsEmpty |> should equal true + """let rec W = M +and b = V +and K = a +for jf = d downto p do + u""" |> Input |> toSynExprs |> fun opt -> not opt.IsEmpty |> should equal true + +[] +let ``should be able to shrink inputs``() = + "fun x -> x" |> Input |> shrinkInput |> Seq.map (fun (Input x) -> x.TrimEnd('\r', '\n')) |> Seq.toArray |> should equal [|"x"|] + """fun Q -> C +C +H +""" |> Input |> shrinkInput |> Seq.map (fun (Input x) -> x.TrimEnd('\r', '\n')) |> Seq.toArray |> should equal [|"Q -> C"; "Q"; "C"|] + + + + + diff --git a/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs new file mode 100644 index 00000000000..cf0752a3b4d --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs @@ -0,0 +1,153 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingSelectionOnlyTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should format a part of a line correctly``() = + formatSelectionOnly false (makeRange 3 8 3 10) """ +let x = 2 + 3 +let y = 1+2 +let z = x + y""" config + |> should equal """1 + 2""" + +[] +let ``should format a whole line correctly and preserve indentation``() = + formatSelectionOnly false (makeRange 3 0 3 36) """ + let base1 = d1 :> Base1 + let derived1 = base1 :?> Derived1""" config + |> should equal """ let derived1 = base1 :?> Derived1""" + +[] +let ``should format a few lines correctly and preserve indentation``() = + formatSelectionOnly false (makeRange 3 4 5 51) """ +let rangeTest testValue mid size = + match testValue with + | var1 when var1 >= mid - size/2 && var1 <= mid + size/2 -> printfn "The test value is in range." + | _ -> printfn "The test value is out of range." + +let (var1, var2) as tuple1 = (1, 2)""" config + |> append newline + |> should equal """match testValue with + | var1 when var1 >= mid - size / 2 && var1 <= mid + size / 2 -> + printfn "The test value is in range." + | _ -> printfn "The test value is out of range." +""" + +[] +let ``should format a top-level let correctly``() = + formatSelectionOnly false (makeRange 3 0 3 10) """ +let x = 2 + 3 +let y = 1+2 +let z = x + y""" config + |> should equal """let y = 1 + 2""" + +[] +let ``should skip whitespace at the beginning of lines``() = + formatSelectionOnly false (makeRange 3 3 3 27) """ +type Product' (backlogItemId) = + let mutable ordering = 0 + let mutable version = 0 + let backlogItems = []""" config + |> should equal """ let mutable ordering = 0""" + +[] +let ``should parse a complete expression correctly``() = + formatSelectionOnly false (makeRange 4 0 5 35) """ +open Fantomas.CodeFormatter + +let config = { FormatConfig.Default with + IndentSpaceNum = 2 } + +let source = " + let Multiple9x9 () = + for i in 1 .. 9 do + printf \"\\n\"; + for j in 1 .. 9 do + let k = i * j in + printf \"%d x %d = %2d \" i j k; + done; + done;; + Multiple9x9 ();;" +""" config + |> should equal """let config = { FormatConfig.Default with IndentSpaceNum = 2 }""" + +[] +let ``should format the selected pipeline correctly``() = + formatSelectionOnly false (makeRange 3 4 7 18) """ +let r = + [ "abc" + "a" + "b" + "" ] + |> List.map id""" config + |> should equal """[ "abc"; "a"; "b"; "" ] |> List.map id""" + +[] +let ``should preserve line breaks before and after selection``() = + formatSelectionOnly false (makeRange 3 0 4 25) """ +assert (3 > 2) + +let result = lazy (x + 10) + +do printfn "Hello world" +""" config + |> should equal """let result = lazy (x + 10)""" + +[] +let ``should detect members and format appropriately``() = + formatSelectionOnly false (makeRange 4 0 5 32) """ +type T () = + let items = [] + override x.Reorder () = + items |> List.iter ignore +""" config + |> should equal """ override x.Reorder() = items |> List.iter ignore""" + +[] +let ``should format the and branch of recursive functions``() = + formatSelectionOnly false (makeRange 3 0 4 34) """ +let rec createJArray x = createJObject + +and createJObject y = createJArray +""" config + |> should equal """and createJObject y = createJArray +""" + +[] +let ``should format recursive types correctly``() = + formatSelectionOnly false (makeRange 7 0 10 48) """ +type Folder(pathIn : string) = + let path = pathIn + let filenameArray : string array = System.IO.Directory.GetFiles(path) + member this.FileArray = + Array.map (fun elem -> new File(elem, this)) filenameArray + +and File(filename: string, containingFolder: Folder) = + member __.Name = filename + member __.ContainingFolder = containingFolder +""" config + |> prepend newline + |> should equal """ +and File(filename : string, containingFolder : Folder) = + member __.Name = filename + member __.ContainingFolder = containingFolder +""" + +[] +let ``should not add trailing whitespaces and preserve indentation``() = + formatSelectionOnly false (makeRange 4 0 7 15) """ +module Enums = + // Declaration of an enumeration. + type Colour = + | Red = 0 + | Green = 1 + | Blue = 2 +""" config + |> prepend newline + |> should equal """ + type Colour = + | Red = 0 + | Green = 1 + | Blue = 2""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs new file mode 100644 index 00000000000..d81d203ee10 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs @@ -0,0 +1,265 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingSelectionTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should format a part of a line correctly``() = + formatSelectionFromString false (makeRange 3 8 3 10) """ +let x = 2 + 3 +let y = 1+2 +let z = x + y""" config + |> should equal """ +let x = 2 + 3 +let y = 1 + 2 +let z = x + y""" + +[] +let ``should format a whole line correctly and preserve indentation``() = + formatSelectionFromString false (makeRange 3 4 3 34) """ + let base1 = d1 :> Base1 + let derived1 = base1 :?> Derived1""" config + |> should equal """ + let base1 = d1 :> Base1 + let derived1 = base1 :?> Derived1""" + +[] +let ``should format a few lines correctly and preserve indentation``() = + formatSelectionFromString false (makeRange 3 5 5 51) """ +let rangeTest testValue mid size = + match testValue with + | var1 when var1 >= mid - size/2 && var1 <= mid + size/2 -> printfn "The test value is in range." + | _ -> printfn "The test value is out of range." + +let (var1, var2) as tuple1 = (1, 2)""" config + |> should equal """ +let rangeTest testValue mid size = + match testValue with + | var1 when var1 >= mid - size / 2 && var1 <= mid + size / 2 -> + printfn "The test value is in range." + | _ -> printfn "The test value is out of range." + +let (var1, var2) as tuple1 = (1, 2)""" + +[] +let ``should format a top-level let correctly``() = + formatSelectionFromString false (makeRange 3 0 3 11) """ +let x = 2 + 3 +let y = 1+2 +let z = x + y""" config + |> should equal """ +let x = 2 + 3 +let y = 1 + 2 +let z = x + y""" + +[] +let ``should skip whitespace at the beginning of lines``() = + formatSelectionFromString false (makeRange 3 3 3 27) """ +type Product' (backlogItemId) = + let mutable ordering = 0 + let mutable version = 0 + let backlogItems = []""" config + |> should equal """ +type Product' (backlogItemId) = + let mutable ordering = 0 + let mutable version = 0 + let backlogItems = []""" + +[] +let ``should parse a complete expression correctly``() = + formatSelectionFromString false (makeRange 4 0 5 35) """ +open Fantomas.CodeFormatter + +let config = { FormatConfig.Default with + IndentSpaceNum = 2 } + +let source = " + let Multiple9x9 () = + for i in 1 .. 9 do + printf \"\\n\"; + for j in 1 .. 9 do + let k = i * j in + printf \"%d x %d = %2d \" i j k; + done; + done;; + Multiple9x9 ();;" +""" config + |> should equal """ +open Fantomas.CodeFormatter + +let config = { FormatConfig.Default with IndentSpaceNum = 2 } + +let source = " + let Multiple9x9 () = + for i in 1 .. 9 do + printf \"\\n\"; + for j in 1 .. 9 do + let k = i * j in + printf \"%d x %d = %2d \" i j k; + done; + done;; + Multiple9x9 ();;" +""" + +[] +let ``should format the selected pipeline correctly``() = + formatSelectionFromString false (makeRange 3 4 7 16) """ +let r = + [ "abc" + "a" + "b" + "" ] + |> List.map id""" config + |> should equal """ +let r = + [ "abc"; "a"; "b"; "" ] |> List.map id""" + +[] +let ``should preserve line breaks before and after selection``() = + formatSelectionFromString false (makeRange 3 0 5 0) """ +assert (3 > 2) + +let result = lazy (x + 10) + +do printfn "Hello world" +""" config + |> should equal """ +assert (3 > 2) + +let result = lazy (x + 10) + +do printfn "Hello world" +""" + +[] +let ``should detect members and format appropriately``() = + formatSelectionFromString false (makeRange 4 0 5 32) """ +type T () = + let items = [] + override x.Reorder () = + items |> List.iter ignore +""" config + |> should equal """ +type T () = + let items = [] + override x.Reorder() = items |> List.iter ignore +""" + +[] +let ``should format the and branch of recursive functions``() = + formatSelectionFromString false (makeRange 3 0 4 34) """ +let rec createJArray x = createJObject + +and createJObject y = createJArray +""" config + |> should equal """ +let rec createJArray x = createJObject + +and createJObject y = createJArray +""" + +[] +let ``should format recursive types correctly``() = + formatSelectionFromString false (makeRange 7 0 10 48) """ +type Folder(pathIn : string) = + let path = pathIn + let filenameArray : string array = System.IO.Directory.GetFiles(path) + member this.FileArray = + Array.map (fun elem -> new File(elem, this)) filenameArray + +and File(filename: string, containingFolder: Folder) = + member __.Name = filename + member __.ContainingFolder = containingFolder +""" config + |> should equal """ +type Folder(pathIn : string) = + let path = pathIn + let filenameArray : string array = System.IO.Directory.GetFiles(path) + member this.FileArray = + Array.map (fun elem -> new File(elem, this)) filenameArray + +and File(filename : string, containingFolder : Folder) = + member __.Name = filename + member __.ContainingFolder = containingFolder +""" + +[] +let ``should format around the cursor inside a list``() = + formatAroundCursor false (makePos 4 4) """ +let r = + [ "abc" + "a" + "b" + "" ] + |> List.map id""" config + |> should equal """ +let r = + [ "abc"; "a"; "b"; "" ] + |> List.map id""" + +[] +let ``should format around the cursor inside a tuple``() = + formatAroundCursor false (makePos 4 8) """ +let r = + [ ("abc",1) + ("a",2) + ("b",3) + ("",4) ] + |> List.map id""" config + |> should equal """ +let r = + [ ("abc",1) + ("a", 2) + ("b",3) + ("",4) ] + |> List.map id""" + +[] +let ``should format around the cursor inside an array``() = + formatAroundCursor false (makePos 3 20) """ +let a3 = + [| for n in 1 .. 100 do if isPrime n then yield n |]""" config + |> should equal """ +let a3 = + [| for n in 1..100 do + if isPrime n then yield n |]""" + +[] +let ``should format around the cursor inside an object expression``() = + formatAroundCursor false (makePos 2 20) """let obj1 = + { new System.Object() with member x.ToString() = "F#" }""" config + |> prepend newline + |> should equal """ +let obj1 = + { new System.Object() with + member x.ToString() = "F#" }""" + +[] +let ``should format around the cursor inside a computation expression``() = + formatAroundCursor false (makePos 4 20) """ +let comp = + eventually { for x in 1 .. 2 do + printfn " x = %d" x + return 3 + 4 }""" config + |> should equal """ +let comp = + eventually { + for x in 1..2 do + printfn " x = %d" x + return 3 + 4 + }""" + +[] +let ``should format around the cursor inside a record``() = + formatAroundCursor false (makePos 3 10) """ +type Car = { + Make : string; + Model : string; + mutable Odometer : int; + }""" config + |> should equal """ +type Car = + { Make : string + Model : string + mutable Odometer : int }""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs b/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs new file mode 100644 index 00000000000..4c29680892c --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs @@ -0,0 +1,52 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.FsUnit + +open NUnit.Framework +open NUnit.Framework.Constraints + +[] +module TopLevelOperators = + let Null = NullConstraint() + let Empty = EmptyConstraint() + let EmptyString = EmptyStringConstraint() + let True = TrueConstraint() + let False = FalseConstraint() + let NaN = NaNConstraint() + let unique = UniqueItemsConstraint() + + let should (f : 'a -> #Constraint) x (y : obj) = + let c = f x + let y = + match y with + | :? (unit -> unit) -> box (TestDelegate(y :?> unit -> unit)) + | _ -> y + Assert.That(y, c) + + let equal x = EqualConstraint(x) + let equalWithin tolerance x = equal(x).Within tolerance + let contain x = ContainsConstraint(x) + let haveLength n = Has.Length.EqualTo(n) + let haveCount n = Has.Count.EqualTo(n) + let be = id + let sameAs x = SameAsConstraint(x) + let throw = Throws.TypeOf + let throwWithMessage (m:string) (t:System.Type) = Throws.TypeOf(t).And.Message.EqualTo(m) + let greaterThan x = GreaterThanConstraint(x) + let greaterThanOrEqualTo x = GreaterThanOrEqualConstraint(x) + let lessThan x = LessThanConstraint(x) + let lessThanOrEqualTo x = LessThanOrEqualConstraint(x) + + let shouldFail (f : unit -> unit) = + TestDelegate(f) |> should throw typeof + + let endWith (s:string) = EndsWithConstraint s + let startWith (s:string) = StartsWithConstraint s + let ofExactType<'a> = ExactTypeConstraint(typeof<'a>) + let instanceOfType<'a> = InstanceOfTypeConstraint(typeof<'a>) + let ascending = Is.Ordered + let descending = Is.Ordered.Descending + let not' x = NotConstraint(x) + + /// Deprecated operators. These will be removed in a future version of FsUnit. + module FsUnitDepricated = + [] + let not x = not' x \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs new file mode 100644 index 00000000000..d13836f4234 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs @@ -0,0 +1,297 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.FunctionDefinitionTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``recursive functions``() = + formatSourceString false """ + let rec f x = g x + and g x = x""" config + |> prepend newline + |> should equal """ +let rec f x = g x + +and g x = x +""" + +[] +let ``recursive functions in type definition``() = + formatSourceString false """ +type C () = + let rec g x = h x + and h x = g x + + member x.P = g 3""" config + |> prepend newline + |> should equal """ +type C() = + + let rec g x = h x + and h x = g x + + member x.P = g 3 +""" + +[] +let ``should keep mutually recursive functions``() = + formatSourceString false """ +let rec createJArray x = createJObject + +and createJObject y = createJArray + """ config + |> should equal """let rec createJArray x = createJObject + +and createJObject y = createJArray +""" + +[] +let ``should keep mutually recursive functions in nested function``() = + formatSourceString false """let f = + let rec createJArray x = createJObject x + + and createJObject y = createJArray y + createJArray + """ config + |> should equal """let f = + let rec createJArray x = createJObject x + and createJObject y = createJArray y + createJArray +""" + +[] +let ``should keep identifiers with whitespace in double backticks``() = + formatSourceString false """let ``should keep identifiers in double backticks``() = x + """ config + |> should equal """let ``should keep identifiers in double backticks``() = x +""" + +[] +let ``should remove backticks from shouldn't identifier``() = + formatSourceString false """let ``shouldn't``() = x + """ config + |> should equal """let shouldn't() = x +""" + +[] +let ``should keep identifiers with + in double backticks``() = + formatSourceString false """let ``Foo+Bar``() = x + """ config + |> should equal """let ``Foo+Bar``() = x +""" + +[] +let ``let bindings with return types``() = + formatSourceString false """ + let divide x y = + let stream : System.IO.FileStream = System.IO.File.Create("test.txt") + let writer : System.IO.StreamWriter = new System.IO.StreamWriter(stream) + try + writer.WriteLine("test1"); + Some( x / y ) + finally + writer.Flush() + printfn "Closing stream" + stream.Close()""" config + |> prepend newline + |> should equal """ +let divide x y = + let stream : System.IO.FileStream = System.IO.File.Create("test.txt") + let writer : System.IO.StreamWriter = new System.IO.StreamWriter(stream) + try + writer.WriteLine("test1") + Some(x / y) + finally + writer.Flush() + printfn "Closing stream" + stream.Close() +""" + +[] +let ``type constraints and inline``() = + formatSourceString false """ +let inline add(value1 : ^T when ^T : (static member (+) : ^T * ^T -> ^T), value2: ^T) = + value1 + value2 + +let inline heterogenousAdd(value1 : ^T when (^T or ^U) : (static member (+) : ^T * ^U -> ^T), value2 : ^U) = + value1 + value2""" config + |> prepend newline + |> should equal """ +let inline add (value1 : ^T when ^T : (static member (+) : ^T * ^T -> ^T), + value2 : ^T) = value1 + value2 +let inline heterogenousAdd (value1 : ^T when (^T or ^U) : (static member (+) : ^T * ^U + -> ^T), + value2 : ^U) = value1 + value2 +""" + +[] +let ``should keep whitespace after function call``() = + formatSourceString false """let relative = (toRelativePath fileName).TrimStart '.' + """ config + |> should equal """let relative = (toRelativePath fileName).TrimStart '.' +""" + +[] +let ``should keep type annotations``() = + formatSourceString false """let empty<'T> : LazyList<'T> = EmptyValue<'T>.Value""" config + |> should equal """let empty<'T> : LazyList<'T> = EmptyValue<'T>.Value +""" + +[] +let ``should add spaces between multiline nested let bindings``() = + formatSourceString false """let f1 = + let f2 x = + let _ = () + x + 1 + let f3 y = + let _ = () + y + 1 + x + y""" config + |> should equal """let f1 = + let f2 x = + let _ = () + x + 1 + + let f3 y = + let _ = () + y + 1 + + x + y +""" + +[] +let ``should indent fun blocks``() = + formatSourceString false """let f = + fun x -> + let y = 1 + x""" config + |> should equal """let f = + fun x -> + let y = 1 + x +""" +[] +let ``should not add spaces into a series of function application``() = + formatSourceString false """let f x = "d" +f(1).Contains("3")""" config + |> should equal """let f x = "d" + +f(1).Contains("3") +""" + +[] +let ``should handle external functions``() = + formatSourceString false """[] +extern ReturnCode GetParent (System.IntPtr inRef, byref outParentRef)""" config + |> prepend newline + |> should equal """ +[] +extern ReturnCode GetParent(System.IntPtr inRef, byref outParentRef) +""" + +[] +let ``should handle simple external functions``() = + formatSourceString false """module InteropWithNative = + [] + extern IntPtr setCallbridgeSupportTarget(IntPtr newTarget)""" config + |> prepend newline + |> should equal """ +module InteropWithNative = + [] + extern IntPtr setCallbridgeSupportTarget(IntPtr newTarget) +""" + +[] +let ``should handle external functions with fully-qualified attributes``() = + formatSourceString false """[] +extern int GetWindowLong(System.IntPtr hwnd, int index)""" config + |> prepend newline + |> should equal """ +[] +extern int GetWindowLong(System.IntPtr hwnd, int index) +""" + +[] +let ``should handle external functions with special types``() = + formatSourceString false """open System +open System.Runtime.InteropServices +open Accessibility + +[] +extern int AccessibleChildren( + IAccessible paccContainer, + int iChildStart, + int cChildren, + [] [] System.Object [] rgvarChildren, + int* pcObtained)""" config + |> prepend newline + |> should equal """ +open System +open System.Runtime.InteropServices +open Accessibility + +[] +extern int AccessibleChildren(IAccessible paccContainer, int iChildStart, int cChildren, [] System.Object [] rgvarChildren, int* pcObtained) +""" + +[] +let ``should handle desugared matches correctly``() = + formatSourceString false """ +type U = X of int +let f = fun x -> match x with X (x) -> x +""" config + |> prepend newline + |> should equal """ +type U = + | X of int + +let f = + fun x -> + match x with + | X(x) -> x +""" + +[] +let ``should handle member constraints and generic params correctly``() = + formatSourceString false """ +let inline implicit< ^a,^b when ^a : (static member op_Implicit : ^b -> ^a)> arg = + (^a : (static member op_Implicit : ^b -> ^a) arg) +""" config + |> prepend newline + |> should equal """ +let inline implicit< ^a, ^b when ^a : (static member op_Implicit : ^b -> ^a)> arg = + (^a : (static member op_Implicit : ^b -> ^a) arg) +""" + +[] +let ``don't add spaces for function application inside dot access``() = + formatSourceString false """ +let f x = "foo" +f(42).Length +""" config + |> prepend newline + |> should equal """ +let f x = "foo" + +f(42).Length +""" + +[] +let ``do add spaces for function application inside parentheses inside dot access``() = + formatSourceString false """let inputBlah = "So, I was like, Visual Studio did wat!?" +let someBlahing = (Blah.TryCreate inputBlah).Value""" config + |> prepend newline + |> should equal """ +let inputBlah = "So, I was like, Visual Studio did wat!?" +let someBlahing = (Blah.TryCreate inputBlah).Value +""" + +[] +let ``don't create redundant parentheses outside trait calls``() = + formatSourceString false """let f (arg : 'T) = (^T : (member Value : string) arg)""" config + |> prepend newline + |> should equal """ +let f (arg : 'T) = (^T : (member Value : string) arg) +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs b/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs new file mode 100644 index 00000000000..4a36aa285f8 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs @@ -0,0 +1,118 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.InterfaceTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``interfaces and inheritance``() = + formatSourceString false """ +type IPrintable = + abstract member Print : unit -> unit + +type SomeClass1(x: int, y: float) = + interface IPrintable with + member this.Print() = printfn "%d %f" x y +type Interface3 = + inherit Interface1 + inherit Interface2 + abstract member Method3 : int -> int""" config + |> prepend newline + |> should equal """ +type IPrintable = + abstract Print : unit -> unit + +type SomeClass1(x : int, y : float) = + interface IPrintable with + member this.Print() = printfn "%d %f" x y + +type Interface3 = + inherit Interface1 + inherit Interface2 + abstract Method3 : int -> int +""" + +[] +let ``should not add with to interface definitions with no members``() = + formatSourceString false """type Text(text : string) = + interface IDocument + + interface Infrastucture with + member this.Serialize sb = sb.AppendFormat("\"{0}\"", escape v) + member this.ToXml() = v :> obj + """ config + |> should equal """type Text(text : string) = + interface IDocument + interface Infrastucture with + member this.Serialize sb = sb.AppendFormat("\"{0}\"", escape v) + member this.ToXml() = v :> obj +""" + +[] +let ``object expressions``() = + formatSourceString false """let obj1 = { new System.Object() with member x.ToString() = "F#" }""" config + |> prepend newline + |> should equal """ +let obj1 = + { new System.Object() with + member x.ToString() = "F#" } +""" + +[] +let ``object expressions and interfaces``() = + formatSourceString false """ + let implementer() = + { new ISecond with + member this.H() = () + member this.J() = () + interface IFirst with + member this.F() = () + member this.G() = () }""" config + |> prepend newline + |> should equal """ +let implementer() = + { new ISecond with + member this.H() = () + member this.J() = () + interface IFirst with + member this.F() = () + member this.G() = () } +""" + +[] +let ``should not add with to interfaces with no members in object expressions``() = + formatSourceString false """ +let f () = + { new obj() with + member x.ToString() = "INotifyEnumerableInternal" + interface INotifyEnumerableInternal<'T> + interface IEnumerable<_> with + member x.GetEnumerator() = null }""" config + |> prepend newline + |> should equal """ +let f() = + { new obj() with + member x.ToString() = "INotifyEnumerableInternal" + interface INotifyEnumerableInternal<'T> + interface IEnumerable<_> with + member x.GetEnumerator() = null } +""" + +[] +let ``should keep named arguments on abstract members``() = + formatSourceString false """type IThing = + abstract Foo : name:string * age:int -> bool +""" config + |> should equal """type IThing = + abstract Foo : name:string * age:int -> bool +""" + +[] +let ``should not skip 'with get()' in indexers``() = + formatSourceString false """type Interface = + abstract Item : int -> char with get +""" config + |> should equal """type Interface = + abstract Item : int -> char with get +""" + diff --git a/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs new file mode 100644 index 00000000000..233e45843d1 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs @@ -0,0 +1,240 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.ModuleTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``module abbreviation``() = + formatSourceString false "module ES = Microsoft.FSharp.Quotations.ExprShape" config + |> should equal """module ES = Microsoft.FSharp.Quotations.ExprShape +""" + +[] +let ``module with functions``() = + formatSourceString false "module internal MyModule = let x = 42" config + |> prepend newline + |> should equal """ +module internal MyModule = + let x = 42 +""" + +[] +let ``open modules``() = + formatSourceString false """ + // comment1 + open System.IO + // comment2 + open System""" { config with ReorderOpenDeclaration = true } + |> prepend newline + |> should equal """ +// comment1 +open System +// comment2 +open System.IO +""" + +[] +let ``sort open modules doesn't mess comments up``() = + formatSourceString false """ +module internal Fantomas.CodePrinter + +// comment0 +let x = 0 + +open System +open System.Collections.Generic +open Microsoft.FSharp.Compiler.Ast +open Fantomas.FormatConfig +open Fantomas.SourceParser +open Fantomas.SourceTransformer + +// comment1 +let sortAndDedup by l = + // comment2 + l |> Seq.distinctBy by |> Seq.sortBy by |> List.ofSeq""" { config with ReorderOpenDeclaration = true } + |> prepend newline + |> should equal """ +module internal Fantomas.CodePrinter + +// comment0 +let x = 0 + +open Fantomas.FormatConfig +open Fantomas.SourceParser +open Fantomas.SourceTransformer +open Microsoft.FSharp.Compiler.Ast +open System +open System.Collections.Generic + +// comment1 +let sortAndDedup by l = + // comment2 + l + |> Seq.distinctBy by + |> Seq.sortBy by + |> List.ofSeq +""" + +[] +let ``nested modules``() = + formatSourceString false """ +module Y = + let x = 1 + + module Z = + let z = 5""" config + |> prepend newline + |> should equal """ +module Y = + let x = 1 + + module Z = + let z = 5 +""" + +[] +let ``sibling modules``() = + formatSourceString false """ +module TopLevel + +let topLevelX = 5 + +module Inner1 = + let inner1X = 1 +module Inner2 = + let inner2X = 5""" config + |> prepend newline + |> should equal """ +module TopLevel + +let topLevelX = 5 + +module Inner1 = + let inner1X = 1 + +module Inner2 = + let inner2X = 5 +""" + +[] +let ``module signatures``() = + formatSourceString true """ +module Utils + +val turnTracingOn : unit -> unit +val turnTracingOff : unit -> unit +val isTraced : unit -> bool + +module Random = begin + val exponential : mean:float -> float + val nextInt : max:int -> int + val nextInt64 : max:int64 -> int64 + val next : max:float -> float +end""" config + |> prepend newline + |> should equal """ +module Utils + +val turnTracingOn : unit -> unit +val turnTracingOff : unit -> unit +val isTraced : unit -> bool + +module Random = + val exponential : mean:float -> float + val nextInt : max:int -> int + val nextInt64 : max:int64 -> int64 + val next : max:float -> float +""" + +[] +let ``namespace declaration``() = + formatSourceString false """ +namespace Widgets + +type MyWidget1 = + member this.WidgetName = "Widget1" + +module WidgetsModule = + let widgetName = "Widget2" + """ config + |> prepend newline + |> should equal """ +namespace Widgets + +type MyWidget1 = + member this.WidgetName = "Widget1" + +module WidgetsModule = + let widgetName = "Widget2" +""" + +[] +let ``should preserve global keyword``() = + formatSourceString false """ +namespace global + +type SomeType() = + member this.Print() = + global.System.Console.WriteLine("Hello World!") + """ config + |> prepend newline + |> should equal """ +namespace global + +type SomeType() = + member this.Print() = global.System.Console.WriteLine("Hello World!") +""" + +[] +let ``should escape keywords correctly``() = + formatSourceString false """ +module ``member`` + +let ``abstract`` = "abstract" + +type SomeType() = + member this.``new``() = + System.Console.WriteLine("Hello World!") + """ config + |> prepend newline + |> should equal """ +module ``member`` + +let ``abstract`` = "abstract" + +type SomeType() = + member this.``new``() = System.Console.WriteLine("Hello World!") +""" + +[] +let ``should escape base keyword correctly``() = + formatSourceString false """ +open System +open RDotNet +open RDotNet.NativeLibrary +open RDotNet.Internals +open RProvider +open RProvider.``base`` +open RProvider.stats + +[] +let main argv = + let a = R.rnorm(1000) + 0 + """ config + |> prepend newline + |> should equal """ +open System +open RDotNet +open RDotNet.NativeLibrary +open RDotNet.Internals +open RProvider +open RProvider.``base`` +open RProvider.stats + +[] +let main argv = + let a = R.rnorm (1000) + 0 +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs b/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs new file mode 100644 index 00000000000..d21645b579a --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs @@ -0,0 +1,176 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.OperatorTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``should format prefix operators``() = + formatSourceString false """let x = -y +let z = !!x + """ config + |> should equal """let x = -y +let z = !!x +""" + +[] +let ``should keep triple ~~~ operator``() = + formatSourceString false """x ~~~FileAttributes.ReadOnly + """ config + |> should equal """x ~~~FileAttributes.ReadOnly +""" + +[] +let ``should keep single triple ~~~ operator``() = + formatSourceString false """~~~FileAttributes.ReadOnly + """ config + |> should equal """~~~FileAttributes.ReadOnly +""" + +[] +let ``should keep parens around ? operator definition``() = + formatSourceString false """let (?) f s = f s + """ config + |> should equal """let (?) f s = f s +""" + +[] +let ``should keep parens around ?<- operator definition``() = + formatSourceString false """let (?<-) f s = f s + """ config + |> should equal """let (?<-) f s = f s +""" + +[] +let ``should keep parens around !+ prefix operator definition``() = + formatSourceString false """let (!+) x = Include x + """ config + |> should equal """let (!+) x = Include x +""" + +[] +let ``should keep parens around ++ infix operator definition``() = + formatSourceString false """let (++) x y = { x with Includes = y :: x.Includes } + """ config + |> should equal """let (++) x y = { x with Includes = y :: x.Includes } +""" + +[] +let ``should keep parens around inlined ==> operator definition``() = + formatSourceString false """let inline (==>) x y = f x y + """ config + |> should equal """let inline (==>) x y = f x y +""" + +[] +let ``should keep parens around inlined operator definition``() = + formatSourceString false """let inline (@@) path1 path2 = Path.Combine(path1, path2) + """ config + |> should equal """let inline (@@) path1 path2 = Path.Combine(path1, path2) +""" + +[] +let ``should pattern match on quotation expression``() = + formatSourceString false """let rec print expr = + match expr with + | SpecificCall <@@ (+) @@> (_, _, exprList) -> + print exprList.Head + printf " + " + print exprList.Tail.Head + | _ -> ()""" config + |> should equal """let rec print expr = + match expr with + | SpecificCall <@@ (+) @@> (_, _, exprList) -> + print exprList.Head + printf " + " + print exprList.Tail.Head + | _ -> () +""" + +[] +let ``should break on . operator``() = + formatSourceString false """pattern.Replace(".", @"\.").Replace("$", @"\$").Replace("^", @"\^").Replace("{", @"\{").Replace("[", @"\[").Replace("(", @"\(").Replace(")", @"\)").Replace("+", @"\+") + + """ config + |> prepend newline + |> should equal """ +pattern.Replace(".", @"\.").Replace("$", @"\$").Replace("^", @"\^") + .Replace("{", @"\{").Replace("[", @"\[").Replace("(", @"\(") + .Replace(")", @"\)").Replace("+", @"\+") +""" + +// the current behavior results in a compile error since line break is before the parens and not before the . +[] +let ``should break on . operator and keep indentation``() = + formatSourceString false """let pattern = + (x + y) + .Replace(seperator + "**" + seperator, replacementSeparator + "(.|?" + replacementSeparator + ")?" ) + .Replace("**" + seperator, ".|(?<=^|" + replacementSeparator + ")" ) + """ config + |> should equal """let pattern = + (x + y) + .Replace(seperator + "**" + seperator, + replacementSeparator + "(.|?" + replacementSeparator + ")?") + .Replace("**" + seperator, ".|(?<=^|" + replacementSeparator + ")") +""" + +[] +let ``should keep space between ( and * in *** operator definition``() = + formatSourceString false """let inline ( ***) l1 l2 = pair l2 l1 + """ config + |> should equal """let inline ( *** ) l1 l2 = pair l2 l1 +""" + +[] +let ``should keep space between ( and * in *= operator definition``() = + formatSourceString false """let inline ( *=) l v = update (( *) v) l + """ config + |> should equal """let inline ( *= ) l v = update ((*) v) l +""" + +[] +let ``should not add space around ? operator``() = + formatSourceString false """let x = y?z.d?c.[2]?d.xpto()""" config + |> should equal """let x = y?z.d?c.[2]?d.xpto() +""" + +[] +let ``should understand ? as an infix operator``() = + formatSourceString false """try + item.MethodInfo.Method.Invoke(null, ipa) + |> (fun x -> x?Invoke (true)) + |> fun (t : Task) -> t.Wait() +with _ -> ()""" config + |> should equal """try + item.MethodInfo.Method.Invoke(null, ipa) + |> (fun x -> x?Invoke (true)) + |> fun (t : Task) -> t.Wait() +with _ -> () +""" + +[] +let ``should not mess up ?<- operator``() = + formatSourceString false """x?v <- 2""" config + |> should equal """x?v <- 2 +""" + + +[] +let ``should pipeline monadic bind``() = + formatSourceString false """strToInt "1" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +""" + config + |> should equal """strToInt "1" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +>>= strAddLong "A long argument that is ignored" "2" +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs b/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs new file mode 100644 index 00000000000..155d2187035 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs @@ -0,0 +1,310 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.PatternMatchingTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``match expressions``() = + formatSourceString false """ + let filter123 x = + match x with + | 1 | 2 | 3 -> printfn "Found 1, 2, or 3!" + | a -> printfn "%d" a""" config + |> prepend newline + |> should equal """ +let filter123 x = + match x with + | 1 | 2 | 3 -> printfn "Found 1, 2, or 3!" + | a -> printfn "%d" a +""" + +[] +let ``function keyword``() = + formatSourceString false """ + let filterNumbers = + function | 1 | 2 | 3 -> printfn "Found 1, 2, or 3!" + | a -> printfn "%d" a""" config + |> prepend newline + |> should equal """ +let filterNumbers = + function + | 1 | 2 | 3 -> printfn "Found 1, 2, or 3!" + | a -> printfn "%d" a +""" + +[] +let ``when clauses and as patterns``() = + formatSourceString false """ +let rangeTest testValue mid size = + match testValue with + | var1 when var1 >= mid - size/2 && var1 <= mid + size/2 -> printfn "The test value is in range." + | _ -> printfn "The test value is out of range." + +let (var1, var2) as tuple1 = (1, 2) +printfn "%d %d %A" var1 var2 tuple1""" config + |> prepend newline + |> should equal """ +let rangeTest testValue mid size = + match testValue with + | var1 when var1 >= mid - size / 2 && var1 <= mid + size / 2 -> + printfn "The test value is in range." + | _ -> printfn "The test value is out of range." + +let (var1, var2) as tuple1 = (1, 2) + +printfn "%d %d %A" var1 var2 tuple1 +""" + +[] +let ``and & or patterns``() = + formatSourceString false """ +let detectZeroOR point = + match point with + | (0, 0) | (0, _) | (_, 0) -> printfn "Zero found." + | _ -> printfn "Both nonzero." + +let detectZeroAND point = + match point with + | (0, 0) -> printfn "Both values zero." + | (var1, var2) & (0, _) -> printfn "First value is 0 in (%d, %d)" var1 var2 + | (var1, var2) & (_, 0) -> printfn "Second value is 0 in (%d, %d)" var1 var2 + | _ -> printfn "Both nonzero." +""" config + |> prepend newline + |> should equal """ +let detectZeroOR point = + match point with + | (0, 0) | (0, _) | (_, 0) -> printfn "Zero found." + | _ -> printfn "Both nonzero." + +let detectZeroAND point = + match point with + | (0, 0) -> printfn "Both values zero." + | (var1, var2) & (0, _) -> printfn "First value is 0 in (%d, %d)" var1 var2 + | (var1, var2) & (_, 0) -> printfn "Second value is 0 in (%d, %d)" var1 var2 + | _ -> printfn "Both nonzero." +""" + +[] +let ``paren and tuple patterns``() = + formatSourceString false """ +let countValues list value = + let rec checkList list acc = + match list with + | (elem1 & head) :: tail when elem1 = value -> checkList tail (acc + 1) + | head :: tail -> checkList tail acc + | [] -> acc + checkList list 0 + +let detectZeroTuple point = + match point with + | (0, 0) -> printfn "Both values zero." + | (0, var2) -> printfn "First value is 0 in (0, %d)" var2 + | (var1, 0) -> printfn "Second value is 0 in (%d, 0)" var1 + | _ -> printfn "Both nonzero." +""" config + |> prepend newline + |> should equal """ +let countValues list value = + let rec checkList list acc = + match list with + | (elem1 & head) :: tail when elem1 = value -> checkList tail (acc + 1) + | head :: tail -> checkList tail acc + | [] -> acc + checkList list 0 + +let detectZeroTuple point = + match point with + | (0, 0) -> printfn "Both values zero." + | (0, var2) -> printfn "First value is 0 in (0, %d)" var2 + | (var1, 0) -> printfn "Second value is 0 in (%d, 0)" var1 + | _ -> printfn "Both nonzero." +""" + +[] +let ``type test and null patterns``() = + formatSourceString false """ +let detect1 x = + match x with + | 1 -> printfn "Found a 1!" + | (var1 : int) -> printfn "%d" var1 + +let RegisterControl(control:Control) = + match control with + | :? Button as button -> button.Text <- "Registered." + | :? CheckBox as checkbox -> checkbox.Text <- "Registered." + | _ -> () + +let ReadFromFile (reader : System.IO.StreamReader) = + match reader.ReadLine() with + | null -> printfn "\n"; false + | line -> printfn "%s" line; true""" config + |> prepend newline + |> should equal """ +let detect1 x = + match x with + | 1 -> printfn "Found a 1!" + | (var1 : int) -> printfn "%d" var1 + +let RegisterControl(control : Control) = + match control with + | :? Button as button -> button.Text <- "Registered." + | :? CheckBox as checkbox -> checkbox.Text <- "Registered." + | _ -> () + +let ReadFromFile(reader : System.IO.StreamReader) = + match reader.ReadLine() with + | null -> + printfn "\n" + false + | line -> + printfn "%s" line + true +""" + +[] +let ``record patterns``() = + formatSourceString false """ +type MyRecord = { Name: string; ID: int } + +let IsMatchByName record1 (name: string) = + match record1 with + | { MyRecord.Name = nameFound; ID = _; } when nameFound = name -> true + | _ -> false """ config + |> prepend newline + |> should equal """ +type MyRecord = + { Name : string + ID : int } + +let IsMatchByName record1 (name : string) = + match record1 with + | { MyRecord.Name = nameFound; ID = _ } when nameFound = name -> true + | _ -> false +""" + +[] +let ``desugared lambdas``() = + formatSourceString false """ +try + fst(find (fun (s, (s', ty): int * int) -> + s' = s0 && can (type_match ty ty0) []) (!the_interface)) +with +| Failure _ -> s0""" config + |> prepend newline + |> should equal """ +try + fst + (find + (fun (s, (s', ty) : int * int) -> + s' = s0 && can (type_match ty ty0) []) (!the_interface)) +with Failure _ -> s0 +""" + +[] +let ``another case of desugared lambdas``() = + formatSourceString false """ +find (fun (Ident op) x y -> Combp(Combp(Varp(op,dpty),x),y)) "term after binary operator" inp +""" config + |> prepend newline + |> should equal """ +find (fun (Ident op) x y -> Combp(Combp(Varp(op, dpty), x), y)) + "term after binary operator" inp +""" + +[] +let ``yet another case of desugared lambdas``() = + formatSourceString false """ +let UNIFY_ACCEPT_TAC mvs th (asl, w) = + let insts = term_unify mvs (concl th) w + ([], insts), [], + let th' = INSTANTIATE insts th + fun i [] -> INSTANTIATE i th'""" config + |> prepend newline + |> should equal """ +let UNIFY_ACCEPT_TAC mvs th (asl, w) = + let insts = term_unify mvs (concl th) w + ([], insts), [], + let th' = INSTANTIATE insts th + fun i [] -> INSTANTIATE i th' +""" + +[] +let ``desugared lambdas again``() = + formatSourceString false """ +fun P -> T""" config + |> prepend newline + |> should equal """ +fun P -> T +""" + +[] +let ``should consume spaces before inserting comments``() = + formatSourceString false """ +let f x = + a || // other case + match n with + | 17 -> false + | _ -> true""" config + |> prepend newline + |> should equal """ +let f x = + a || // other case + match n with + | 17 -> false + | _ -> true +""" + +[] +let ``should not remove parentheses in patterns``() = + formatSourceString false """ +let x = + match y with + | Start(-1) -> true + | _ -> false""" config + |> prepend newline + |> should equal """ +let x = + match y with + | Start(-1) -> true + | _ -> false +""" + +[] +let ``should indent function keyword in function application``() = + formatSourceString false """ +let v = + List.tryPick (function 1 -> Some 1 | _ -> None) [1; 2; 3]""" config + |> prepend newline + |> should equal """ +let v = + List.tryPick (function + | 1 -> Some 1 + | _ -> None) [ 1; 2; 3 ] +""" + +[] +let ``should put brackets around tuples in type tests``() = + formatSourceString false """ +match item.Item with +| :? FSharpToolTipText as titem -> () +| :? (string * XmlDoc) as tip -> () +| _ -> ()""" config + |> prepend newline + |> should equal """ +match item.Item with +| :? FSharpToolTipText as titem -> () +| :? (string * XmlDoc) as tip -> () +| _ -> () +""" + +[] +let ``should support rational powers on units of measures``() = + formatSourceString false """ +[] type X = cm^(1/2)/W""" config + |> prepend newline + |> should equal """ +[] +type X = cm^(1/2) / W +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs b/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs new file mode 100644 index 00000000000..5d2a9cd078f --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs @@ -0,0 +1,63 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.PipingTests + +open NUnit.Framework +open FsUnit +open TestHelper + +// the current behavior results in a compile error since the |> is merged to the last line +[] +let ``should keep the pipe after infix operator``() = + formatSourceString false """ +let f x = + someveryveryveryverylongexpression + <|> if someveryveryveryverylongexpression then someveryveryveryverylongexpression else someveryveryveryverylongexpression + <|> if someveryveryveryverylongexpression then someveryveryveryverylongexpression else someveryveryveryverylongexpression + |> f + """ config + |> prepend newline + |> should equal """ +let f x = + someveryveryveryverylongexpression + <|> if someveryveryveryverylongexpression then + someveryveryveryverylongexpression + else someveryveryveryverylongexpression + <|> if someveryveryveryverylongexpression then + someveryveryveryverylongexpression + else someveryveryveryverylongexpression + |> f +""" + +// the current behavior results in a compile error since the |> is merged to the last line +[] +let ``should keep the pipe after pattern matching``() = + formatSourceString false """let m = + match x with + | y -> ErrorMessage msg + | _ -> LogMessage(msg, true) + |> console.Write + """ config + |> prepend newline + |> should equal """ +let m = + match x with + | y -> ErrorMessage msg + | _ -> LogMessage(msg, true) + |> console.Write +""" + +[] +let ``should break new lines on piping``() = + formatSourceString false """ +let runAll() = + urlList + |> Seq.map fetchAsync |> Async.Parallel + |> Async.RunSynchronously |> ignore""" config + |> prepend newline + |> should equal """ +let runAll() = + urlList + |> Seq.map fetchAsync + |> Async.Parallel + |> Async.RunSynchronously + |> ignore +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs b/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs new file mode 100644 index 00000000000..f426cde9f49 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs @@ -0,0 +1,35 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.QuotationTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``typed quotations``() = + formatSourceString false """ + <@ + let f x = x + 10 + f 20 + @>""" config + |> prepend newline + |> should equal """ +<@ let f x = x + 10 + f 20 @> +""" + +[] +let ``untyped quotations``() = + formatSourceString false "<@@ 2 + 3 @@>" config + |> should equal """<@@ 2 + 3 @@> +""" + +[] +let ``should preserve unit literal``() = + formatSourceString false """ + let logger = Mock().Setup(fun log -> <@ log.Log(error) @>).Returns(()).Create() + """ config + |> prepend newline + |> should equal """ +let logger = + Mock().Setup(fun log -> <@ log.Log(error) @>).Returns(()).Create() +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs b/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs new file mode 100644 index 00000000000..da7d2d25fa7 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs @@ -0,0 +1,227 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.RecordTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``record declaration``() = + formatSourceString false "type AParameters = { a : int }" config + |> prepend newline + |> should equal """ +type AParameters = + { a : int } +""" + +[] +let ``record declaration with implementation visibility attribute``() = + formatSourceString false "type AParameters = private { a : int; b: float }" config + |> prepend newline + |> should equal """ +type AParameters = + private { a : int + b : float } +""" + +[] +let ``record signatures``() = + formatSourceString true """ +module RecordSignature +/// Represents simple XML elements. +type Element = + { + /// The attribute collection. + Attributes : IDictionary + + /// The children collection. + Children : seq + + /// The qualified name. + Name : Name + } + + interface INode + + /// Constructs an new empty Element. + static member Create : name: string * ?uri: string -> Element + + /// Replaces the children. + static member WithChildren : children: #seq<#INode> -> self: Element -> Element + + /// Replaces the children. + static member ( - ) : self: Element * children: #seq<#INode> -> Element + + /// Replaces the attributes. + static member WithAttributes : attrs: #seq -> self: Element -> Element + + /// Replaces the attributes. + static member ( + ) : self: Element * attrs: #seq -> Element + + /// Replaces the children with a single text node. + static member WithText : text: string -> self: Element-> Element + + /// Replaces the children with a single text node. + static member ( -- ) : self: Element * text: string -> Element""" { config with SemicolonAtEndOfLine = true } + |> prepend newline + |> should equal """ +module RecordSignature + +/// Represents simple XML elements. +type Element = + { /// The attribute collection. + Attributes : IDictionary; + /// The children collection. + Children : seq; + /// The qualified name. + Name : Name } + interface INode + /// Constructs an new empty Element. + static member Create : name:string * ?uri:string -> Element + /// Replaces the children. + static member WithChildren : children:#seq<#INode> + -> self:Element -> Element + /// Replaces the children. + static member (-) : self:Element * children:#seq<#INode> -> Element + /// Replaces the attributes. + static member WithAttributes : attrs:#seq + -> self:Element -> Element + /// Replaces the attributes. + static member (+) : self:Element * attrs:#seq -> Element + /// Replaces the children with a single text node. + static member WithText : text:string -> self:Element -> Element + /// Replaces the children with a single text node. + static member (--) : self:Element * text:string -> Element +""" + +[] +let ``records with update``() = + formatSourceString false """ +type Car = { + Make : string + Model : string + mutable Odometer : int + } + +let myRecord3 = { myRecord2 with Y = 100; Z = 2 }""" config + |> prepend newline + |> should equal """ +type Car = + { Make : string + Model : string + mutable Odometer : int } + +let myRecord3 = + { myRecord2 with Y = 100 + Z = 2 } +""" + +// the current behavior results in a compile error since the if is not aligned properly +[] +let ``should not break inside of if statements in records``() = + formatSourceString false """let XpkgDefaults() = + { + ToolPath = "./tools/xpkg/xpkg.exe" + WorkingDir = "./"; + TimeOut = TimeSpan.FromMinutes 5. + Package = null + Version = if not isLocalBuild then buildVersion else "0.1.0.0" + OutputPath = "./xpkg" + Project = null + Summary = null + Publisher = null + Website = null + Details = "Details.md" + License = "License.md" + GettingStarted = "GettingStarted.md" + Icons = [] + Libraries = [] + Samples = []; + } + + """ { config with SemicolonAtEndOfLine = true } + |> should equal """let XpkgDefaults() = + { ToolPath = "./tools/xpkg/xpkg.exe"; + WorkingDir = "./"; + TimeOut = TimeSpan.FromMinutes 5.; + Package = null; + Version = + if not isLocalBuild then buildVersion + else "0.1.0.0"; + OutputPath = "./xpkg"; + Project = null; + Summary = null; + Publisher = null; + Website = null; + Details = "Details.md"; + License = "License.md"; + GettingStarted = "GettingStarted.md"; + Icons = []; + Libraries = []; + Samples = [] } +""" + +[] +let ``should not add redundant newlines when using a record in a DU``() = + formatSourceString false """ +let rec make item depth = + if depth > 0 then + Tree({ Left = make (2 * item - 1) (depth - 1) + Right = make (2 * item) (depth - 1) }, item) + else Tree(defaultof<_>, item)""" config + |> prepend newline + |> should equal """ +let rec make item depth = + if depth > 0 then + Tree({ Left = make (2 * item - 1) (depth - 1) + Right = make (2 * item) (depth - 1) }, item) + else Tree(defaultof<_>, item) +""" + +[] +let ``should keep unit of measures in record and DU declaration``() = + formatSourceString false """ +type rate = {Rate:float} +type rate2 = Rate of float +""" config + |> prepend newline + |> should equal """ +type rate = + { Rate : float } + +type rate2 = + | Rate of float +""" + +[] +let ``should keep comments on records``() = + formatSourceString false """ +let newDocument = //somecomment + { program = Encoding.Default.GetBytes(document.Program) |> Encoding.UTF8.GetString + content = Encoding.Default.GetBytes(document.Content) |> Encoding.UTF8.GetString + created = document.Created.ToLocalTime() } + |> JsonConvert.SerializeObject +""" config + |> prepend newline + |> should equal """ +let newDocument = //somecomment + { program = + Encoding.Default.GetBytes(document.Program) |> Encoding.UTF8.GetString + content = + Encoding.Default.GetBytes(document.Content) |> Encoding.UTF8.GetString + created = document.Created.ToLocalTime() } + |> JsonConvert.SerializeObject +""" + +[] +let ``should preserve inherit parts in records``() = + formatSourceString false """ +type MyExc = + inherit Exception + new(msg) = {inherit Exception(msg)} +""" config + |> prepend newline + |> should equal """ +type MyExc = + inherit Exception + new(msg) = { inherit Exception(msg) } +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs b/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs new file mode 100644 index 00000000000..be4c6da87b5 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs @@ -0,0 +1,136 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.SignatureTests + +open NUnit.Framework +open FsUnit +open TestHelper + +// the current behavior results in a compile error since "(string * string) list" is converted to "string * string list" +[] +let ``should keep the (string * string) list type signature in records``() = + formatSourceString false """type MSBuildParams = + { Targets : string list + Properties : (string * string) list + MaxCpuCount : int option option + ToolsVersion : string option + Verbosity : MSBuildVerbosity option + FileLoggers : MSBuildFileLoggerConfig list option } + + """ config + |> should equal """type MSBuildParams = + { Targets : string list + Properties : (string * string) list + MaxCpuCount : int option option + ToolsVersion : string option + Verbosity : MSBuildVerbosity option + FileLoggers : MSBuildFileLoggerConfig list option } +""" + +[] +let ``should keep the (string * string) list type signature in functions``() = + formatSourceString false """let MSBuildWithProjectProperties outputPath (targets : string) + (properties : string -> (string * string) list) projects = doingsomstuff + + """ config + |> should equal """let MSBuildWithProjectProperties outputPath (targets : string) + (properties : string -> (string * string) list) projects = doingsomstuff +""" + + +[] +let ``should keep the string * string list type signature in functions``() = + formatSourceString false """let MSBuildWithProjectProperties outputPath (targets : string) + (properties : (string -> string) * string list) projects = doingsomstuff + + """ config + |> should equal """let MSBuildWithProjectProperties outputPath (targets : string) + (properties : (string -> string) * string list) projects = doingsomstuff +""" + +[] +let ``should not add parens in signature``() = + formatSourceString false """type Route = + { Verb : string + Path : string + Handler : Map -> HttpListenerContext -> string } + override x.ToString() = sprintf "%s %s" x.Verb x.Path + + """ config + |> should equal """type Route = + { Verb : string + Path : string + Handler : Map -> HttpListenerContext -> string } + override x.ToString() = sprintf "%s %s" x.Verb x.Path +""" + +[] +let ``should keep the string * string * string option type signature``() = + formatSourceString false """type DGML = + | Node of string + | Link of string * string * (string option) + + """ config + |> should equal """type DGML = + | Node of string + | Link of string * string * string option +""" + +[] +let ``should keep the (string option * Node) list type signature``() = + formatSourceString false """type Node = + { Name : string; + NextNodes : (string option * Node) list } + + """ { config with SemicolonAtEndOfLine = true } + |> should equal """type Node = + { Name : string; + NextNodes : (string option * Node) list } +""" + +[] +let ``should keep parentheses on the left of type signatures``() = + formatSourceString false """type IA = + abstract F: (unit -> Option<'T>) -> Option<'T> + +type A () = + interface IA with + member x.F (f: unit -> _) = f () + """ config + |> should equal """type IA = + abstract F : (unit -> Option<'T>) -> Option<'T> + +type A() = + interface IA with + member x.F(f : unit -> _) = f() +""" + +[] +let ``should not add parentheses around bare tuples``() = + formatSourceString true """ +namespace TupleType +type C = + member P1 : int * string + /// def + member P2 : int +""" config + |> prepend newline + |> should equal """ +namespace TupleType + +type C = + member P1 : int * string + /// def + member P2 : int +""" + +[] +let ``should keep global constraints in type signature``() = + formatSourceString true """ +module Tainted +val GetHashCodeTainted : (Tainted<'T> -> int) when 'T : equality +""" config + |> prepend newline + |> should equal """ +module Tainted + +val GetHashCodeTainted : Tainted<'T> -> int when 'T : equality +""" diff --git a/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs b/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs new file mode 100644 index 00000000000..0e1c65e8981 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs @@ -0,0 +1,118 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.StringTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``triple-quoted strings``() = + formatSourceString false "let xmlFragment2 = \"\"\"\"\"\"" config + |> should equal "let xmlFragment2 = \"\"\"\"\"\" +" + +[] +let ``string literals``() = + formatSourceString false """ +let xmlFragment1 = @"" +let str1 = "abc" + """ config + |> prepend newline + |> should equal """ +let xmlFragment1 = @"" +let str1 = "abc" +""" + +[] +let ``multiline strings``() = + formatSourceString false """ +let alu = + "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG\ + GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA\ + CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT\ + ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA\ + GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG\ + AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC\ + AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"B + """ config + |> prepend newline + |> should equal """ +let alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG\ + GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA\ + CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT\ + ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA\ + GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG\ + AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC\ + AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"B +""" + +[] +let ``preserve uncommon literals``() = + formatSourceString false """ +let a = 0xFFy +let c = 0b0111101us +let d = 0o0777 +let e = 1.40e10f +let f = 23.4M +let g = '\n' + """ config + |> prepend newline + |> should equal """ +let a = 0xFFy +let c = 0b0111101us +let d = 0o0777 +let e = 1.40e10f +let f = 23.4M +let g = '\n' +""" + +[] +let ``should preserve triple-quote strings``() = + formatSourceString false " + type GetList() = + let switchvox_users_voicemail_getList_response = \"\"\" + \"\"\" + + let switchvox_users_voicemail_getList = \"\"\" + \"\"\" + + member self.X = switchvox_users_voicemail_getList_response +" config + |> prepend newline + |> should equal " +type GetList() = + let switchvox_users_voicemail_getList_response = \"\"\" + \"\"\" + let switchvox_users_voicemail_getList = \"\"\" + \"\"\" + member self.X = switchvox_users_voicemail_getList_response +" + +[] +let ``should keep triple-quote strings``() = + formatSourceString false " +[] +let main argv = + use fun1 = R.eval(R.parse(text = \"\"\" + function(i) { + x <- rnorm(1000) + y <- rnorm(1000) + m <- lm(y~x) + m$coefficients[[2]] + } + \"\"\")) + 0 +" config + |> prepend newline + |> should equal " +[] +let main argv = + use fun1 = R.eval (R.parse (text = \"\"\" + function(i) { + x <- rnorm(1000) + y <- rnorm(1000) + m <- lm(y~x) + m$coefficients[[2]] + } + \"\"\")) + 0 +" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs b/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs new file mode 100644 index 00000000000..8e95069eefd --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs @@ -0,0 +1,121 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.TestHelper + +open FsUnit + +open System +open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig +open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting +open Microsoft.FSharp.Compiler.SourceCodeServices +open Microsoft.VisualStudio.FSharp.Editor.Pervasive + +let internal config = FormatConfig.Default +let newline = "\n" + +let argsDotNET451 = + [|"--noframework"; "--debug-"; "--optimize-"; "--tailcalls-"; + // Some constants are used in unit tests + "--define:DEBUG"; "--define:TRACE"; "--define:SILVERLIGHT"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.3.1.0\FSharp.Core.dll"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5.1\mscorlib.dll"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5.1\System.dll"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5.1\System.Core.dll"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5.1\System.Drawing.dll"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5.1\System.Numerics.dll"; + @"-r:C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.5.1\System.Windows.Forms.dll"|] + +let internal projectOptions fileName = + { ProjectFileName = @"C:\Project.fsproj" + SourceFiles = [| fileName |] + OtherOptions = argsDotNET451 + ReferencedProjects = Array.empty + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = true + LoadTime = DateTime.UtcNow + UnresolvedReferences = None + OriginalLoadReferences = List.empty + ExtraProjectInfo = None + Stamp = None } + +let private sharedChecker = lazy (FSharpChecker.Create()) + +let internal formatSourceString isFsiFile (s: string) config = + asyncMaybe { + // On Linux/Mac this will exercise different line endings + let s = s.Replace("\r\n", Environment.NewLine) + let fileName = if isFsiFile then "/src.fsi" else "/src.fsx" + let! result = sharedChecker.Value.ParseFileInProject(fileName, s, projectOptions fileName) |> liftAsync + let! ast = result.ParseTree + return CodeFormatter.FormatAST(ast, fileName, Some s, config).Replace("\r\n", "\n") + } + |> Async.RunSynchronously + |> function Some x -> x | None -> "" + +let internal formatSelectionFromString isFsiFile r (s: string) config = + asyncMaybe { + let s = s.Replace("\r\n", Environment.NewLine) + let fileName = if isFsiFile then "/tmp.fsi" else "/tmp.fsx" + let! result = sharedChecker.Value.ParseFileInProject(fileName, s, projectOptions fileName) |> liftAsync + let! ast = result.ParseTree + return CodeFormatter.FormatSelectionInDocument(fileName, r, s, config, ast).Replace("\r\n", "\n") + } + |> Async.RunSynchronously + |> function Some x -> x | None -> "" + +let internal formatSelectionOnly isFsiFile r (s : string) config = + asyncMaybe { + let s = s.Replace("\r\n", Environment.NewLine) + let fileName = if isFsiFile then "/tmp.fsi" else "/tmp.fsx" + let! result = sharedChecker.Value.ParseFileInProject(fileName, s, projectOptions fileName) |> liftAsync + let! ast = result.ParseTree + return CodeFormatter.FormatSelection(fileName, r, s, config, ast).Replace("\r\n", "\n") + } + |> Async.RunSynchronously + |> function Some x -> x | None -> "" + +let internal formatAroundCursor isFsiFile p (s : string) config = + asyncMaybe { + let s = s.Replace("\r\n", Environment.NewLine) + let fileName = if isFsiFile then "/tmp.fsi" else "/tmp.fsx" + let! result = sharedChecker.Value.ParseFileInProject(fileName, s, projectOptions fileName) |> liftAsync + let! ast = result.ParseTree + return CodeFormatter.FormatAroundCursor(fileName, p, s, config, ast).Replace("\r\n", "\n") + } + |> Async.RunSynchronously + |> function Some x -> x | None -> "" + +let internal parse isFsiFile s = + asyncMaybe { + let fileName = if isFsiFile then "/tmp.fsi" else "/tmp.fsx" + // Run the first phase (untyped parsing) of the compiler + let projectOptions = projectOptions fileName + let! untypedRes = sharedChecker.Value.ParseFileInProject(fileName, s, projectOptions) |> liftAsync + if untypedRes.ParseHadErrors then + let errors = + untypedRes.Errors + |> Array.filter (fun e -> e.Severity = FSharpErrorSeverity.Error) + if not <| Array.isEmpty errors then + raise <| FormatException (sprintf "Parsing failed with errors: %A\nAnd options: %A" errors projectOptions.OtherOptions) + match untypedRes.ParseTree with + | Some tree -> return tree + | None -> return raise <| FormatException "Parsing failed. Please select a complete code fragment to format." + } + |> Async.RunSynchronously + +let internal formatAST a s c = + CodeFormatter.FormatAST(a, "/tmp.fsx",s, c) + +let internal makeRange l1 c1 l2 c2 = + CodeFormatter.MakeRange("/tmp.fsx", l1, c1, l2, c2) + +let internal makePos l1 c1 = + CodeFormatter.MakePos(l1, c1) + +let internal equal x = + let x = + match box x with + | :? String as s -> s.Replace("\r\n", "\n") |> box + | x -> x + equal x + +let inline prepend s content = s + content +let inline append s content = content + s diff --git a/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs b/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs new file mode 100644 index 00000000000..2042c810a29 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs @@ -0,0 +1,787 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.TypeDeclarationTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``exception declarations``() = + formatSourceString false "exception Error2 of string * int" config + |> should equal """exception Error2 of string * int +""" + +[] +let ``exception declarations with members``() = + formatSourceString false """/// An exception type to signal build errors. +exception BuildException of string*list + with + override x.ToString() = x.Data0.ToString() + "\r\n" + (separated "\r\n" x.Data1)""" config + |> should equal """/// An exception type to signal build errors. +exception BuildException of string * list with + override x.ToString() = + x.Data0.ToString() + "\r\n" + (separated "\r\n" x.Data1) +""" + +[] +let ``type annotations``() = + formatSourceString false """ + let iterate1 (f : unit -> seq) = + for e in f() do printfn "%d" e + let iterate2 (f : unit -> #seq) = + for e in f() do printfn "%d" e""" config + |> prepend newline + |> should equal """ +let iterate1 (f : unit -> seq) = + for e in f() do + printfn "%d" e + +let iterate2 (f : unit -> #seq) = + for e in f() do + printfn "%d" e +""" + +[] +let ``upcast and downcast``() = + formatSourceString false """ + let base1 = d1 :> Base1 + let derived1 = base1 :?> Derived1""" config + |> prepend newline + |> should equal """ +let base1 = d1 :> Base1 +let derived1 = base1 :?> Derived1 +""" + +[] +let ``optional arguments``() = + formatSourceString false """ +type Connection(?rate0 : int, ?duplex0 : DuplexType, ?parity0 : bool) = + let duplex = defaultArg duplex0 Full + let parity = defaultArg parity0 false + let mutable rate = match rate0 with + | Some rate1 -> rate1 + | None -> match duplex with + | Full -> 9600 + | Half -> 4800 + do printfn "Baud Rate: %d Duplex: %A Parity: %b" rate duplex parity""" config + |> prepend newline + |> should equal """ +type Connection(?rate0 : int, ?duplex0 : DuplexType, ?parity0 : bool) = + let duplex = defaultArg duplex0 Full + let parity = defaultArg parity0 false + + let mutable rate = + match rate0 with + | Some rate1 -> rate1 + | None -> + match duplex with + | Full -> 9600 + | Half -> 4800 + + do printfn "Baud Rate: %d Duplex: %A Parity: %b" rate duplex parity +""" + +[] +let ``method params``() = + formatSourceString false """ +type Test() = + member this.Function1<'a>(x, y) = + printfn "%A, %A" x y + + abstract AbstractMethod<'a, 'b> : 'a * 'b -> unit + override this.AbstractMethod<'a, 'b>(x:'a, y:'b) = + printfn "%A, %A" x y""" config + |> prepend newline + |> should equal """ +type Test() = + member this.Function1<'a>(x, y) = printfn "%A, %A" x y + abstract AbstractMethod<'a, 'b> : 'a * 'b -> unit + override this.AbstractMethod<'a, 'b>(x : 'a, y : 'b) = printfn "%A, %A" x y +""" + +[] +let ``params arguments``() = + formatSourceString false """ +type X() = + member this.F([] args: Object []) = + for arg in args do + printfn "%A" arg""" config + |> prepend newline + |> should equal """ +type X() = + member this.F([] args : Object []) = + for arg in args do + printfn "%A" arg +""" + +[] +let ``generic types``() = + formatSourceString false """ +type public MyClass<'a> public (x, y) as this = + static let PI = 3.14 + static do printfn "static constructor" + let mutable z = x + y + do printfn "%s" (this.ToString()) + printfn "more constructor effects" + internal new (a) = MyClass(a,a) + static member StaticProp = PI + static member StaticMethod a = a + 1 + member internal self.Prop1 = x + member self.Prop2 with get() = z + and set(a) = z <- a + member self.Method(a,b) = x + y + z + a + b""" config + |> prepend newline + |> should equal """ +type public MyClass<'a> public (x, y) as this = + static let PI = 3.14 + static do printfn "static constructor" + let mutable z = x + y + + do + printfn "%s" (this.ToString()) + printfn "more constructor effects" + + internal new(a) = MyClass(a, a) + static member StaticProp = PI + static member StaticMethod a = a + 1 + member internal self.Prop1 = x + + member self.Prop2 + with get () = z + and set (a) = z <- a + + member self.Method(a, b) = x + y + z + a + b +""" + +[] +let ``struct declaration``() = + formatSourceString false """ + type Point2D = + struct + val X: float + val Y: float + new(x: float, y: float) = { X = x; Y = y } + end""" config + |> prepend newline + |> should equal """ +type Point2D = + struct + val X : float + val Y : float + new(x : float, y : float) = + { X = x + Y = y } + end +""" + +[] +let ``abstract and override keywords``() = + formatSourceString false """ + type MyClassBase1() = + let mutable z = 0 + abstract member Function1 : int -> int + default u.Function1(a : int) = z <- z + a; z + + type MyClassDerived1() = + inherit MyClassBase1() + override u.Function1(a: int) = a + 1""" config + |> prepend newline + |> should equal """ +type MyClassBase1() = + let mutable z = 0 + abstract Function1 : int -> int + override u.Function1(a : int) = + z <- z + a + z + +type MyClassDerived1() = + inherit MyClassBase1() + override u.Function1(a : int) = a + 1 +""" + +[] +let ``intrinsic type extensions``() = + formatSourceString false """ +type MyClass() = + member this.F() = 100 + +type MyClass with + member this.G() = 200""" config + |> prepend newline + |> should equal """ +type MyClass() = + member this.F() = 100 + +type MyClass with + member this.G() = 200 +""" + +[] +let ``optional type extensions``() = + formatSourceString false """ +/// Define a new member method FromString on the type Int32. +type System.Int32 with + member this.FromString( s : string ) = + System.Int32.Parse(s)""" config + |> prepend newline + |> should equal """ +/// Define a new member method FromString on the type Int32. +type System.Int32 with + member this.FromString(s : string) = System.Int32.Parse(s) +""" + +[] +let ``auto property``() = + formatSourceString false """ +type MyClass(property1 : int) = + member val Property1 = property1 + member val Property2 = "" with get, set""" config + |> prepend newline + |> should equal """ +type MyClass(property1 : int) = + member val Property1 = property1 + member val Property2 = "" with get, set +""" + +[] +let ``property handling``() = + formatSourceString false """ +type Derived1() = + inherit AbstractBase() + let mutable value = 10 + override this.Property1 with get() = value and set(v : int) = value <- v""" config + |> prepend newline + |> should equal """ +type Derived1() = + inherit AbstractBase() + let mutable value = 10 + + override this.Property1 + with get () = value + and set (v : int) = value <- v +""" + +[] +let ``access modifiers on properties``() = + formatSourceString false """ +type Foo() = + member x.Get with get () = 1 + member x.Set with private set (v : int) = value <- v + member x.GetSet with internal get () = value and private set (v : bool) = value <- v + member x.GetI with internal get (key1, key2) = false + member x.SetI with private set (key1, key2) value = () + member x.GetSetI with internal get (key1, key2) = true and private set (key1, key2) value = ()""" config + |> prepend newline + |> should equal """ +type Foo() = + member x.Get = 1 + member x.Set + with private set (v : int) = value <- v + + member x.GetSet + with internal get () = value + and private set (v : bool) = value <- v + + member x.GetI + with internal get (key1, key2) = false + member x.SetI + with private set (key1, key2) value = () + + member x.GetSetI + with internal get (key1, key2) = true + and private set (key1, key2) value = () +""" + +[] +let ``types with attributes``() = + formatSourceString false """ +type MyType() = + let mutable myInt1 = 10 + [] val mutable myInt2 : int + [] val mutable myString : string + member this.SetValsAndPrint( i: int, str: string) = + myInt1 <- i + this.myInt2 <- i + 1 + this.myString <- str + printfn "%d %d %s" myInt1 (this.myInt2) (this.myString)""" config + |> prepend newline + |> should equal """ +type MyType() = + let mutable myInt1 = 10 + [] + val mutable myInt2 : int + [] + val mutable myString : string + member this.SetValsAndPrint(i : int, str : string) = + myInt1 <- i + this.myInt2 <- i + 1 + this.myString <- str + printfn "%d %d %s" myInt1 (this.myInt2) (this.myString) +""" + +[] +let ``named arguments``() = + formatSourceString false """ +type SpeedingTicket() = + member this.GetMPHOver(speed: int, limit: int) = speed - limit + +let CalculateFine (ticket : SpeedingTicket) = + let delta = ticket.GetMPHOver(limit = 55, speed = 70) + if delta < 20 then 50.0 else 100.0""" config + |> prepend newline + |> should equal """ +type SpeedingTicket() = + member this.GetMPHOver(speed : int, limit : int) = speed - limit + +let CalculateFine(ticket : SpeedingTicket) = + let delta = ticket.GetMPHOver(limit = 55, speed = 70) + if delta < 20 then 50.0 + else 100.0 +""" + +[] +let ``indexed properties``() = + formatSourceString false """ +type NumberStrings() = + let mutable ordinals = [| "one"; |] + let mutable cardinals = [| "first"; |] + member this.Item + with get index = ordinals.[index] + and set index value = ordinals.[index] <- value + member this.Ordinal + with get(index) = ordinals.[index] + and set index value = ordinals.[index] <- value + member this.Cardinal + with get(index) = cardinals.[index] + and set index value = cardinals.[index] <- value""" config + |> prepend newline + |> should equal """ +type NumberStrings() = + let mutable ordinals = [| "one" |] + let mutable cardinals = [| "first" |] + + member this.Item + with get index = ordinals.[index] + and set index value = ordinals.[index] <- value + + member this.Ordinal + with get (index) = ordinals.[index] + and set index value = ordinals.[index] <- value + + member this.Cardinal + with get (index) = cardinals.[index] + and set index value = cardinals.[index] <- value +""" + +[] +let ``complex indexed properties``() = + formatSourceString false """ +open System.Collections.Generic +type SparseMatrix() = + let mutable table = new Dictionary() + member this.Item + with get(key1, key2) = table.[(key1, key2)] + and set (key1, key2) value = table.[(key1, key2)] <- value + +let matrix1 = new SparseMatrix() +for i in 1..1000 do + matrix1.[i, i] <- float i * float i + """ config + |> prepend newline + |> should equal """ +open System.Collections.Generic + +type SparseMatrix() = + let mutable table = new Dictionary() + + member this.Item + with get (key1, key2) = table.[(key1, key2)] + and set (key1, key2) value = table.[(key1, key2)] <- value + +let matrix1 = new SparseMatrix() + +for i in 1..1000 do + matrix1.[i, i] <- float i * float i +""" + +[] +let ``type constraints simple``() = + formatSourceString false """ +type Class1<'T when 'T :> System.Exception> = + class end + +type Class2<'T when 'T :> System.IComparable> = + class end + +type Class3<'T when 'T : null> = + class end + +type Class8<'T when 'T : not struct> = + class end + +type Class9<'T when 'T : enum> = + class end + +type Class10<'T when 'T : comparison> = + class end + +type Class11<'T when 'T : equality> = + class end + +type Class12<'T when 'T : delegate> = + class end + +type Class13<'T when 'T : unmanaged> = + class end + +type Class14<'T,'U when 'T : equality and 'U : equality> = + class end""" config + |> prepend newline + |> should equal """ +type Class1<'T when 'T :> System.Exception> = + class + end + +type Class2<'T when 'T :> System.IComparable> = + class + end + +type Class3<'T when 'T : null> = + class + end + +type Class8<'T when 'T : not struct> = + class + end + +type Class9<'T when 'T : enum> = + class + end + +type Class10<'T when 'T : comparison> = + class + end + +type Class11<'T when 'T : equality> = + class + end + +type Class12<'T when 'T : delegate> = + class + end + +type Class13<'T when 'T : unmanaged> = + class + end + +type Class14<'T, 'U when 'T : equality and 'U : equality> = + class + end +""" + +[] +let ``then blocks after constructors``() = + formatSourceString false """ +type Person(nameIn : string, idIn : int) = + let mutable name = nameIn + let mutable id = idIn + do printfn "Created a person object." + member this.Name with get() = name and set(v) = name <- v + member this.ID with get() = id and set(v) = id <- v + new() = + Person("Invalid Name", -1) + then printfn "Created an invalid person object." + """ config + |> prepend newline + |> should equal """ +type Person(nameIn : string, idIn : int) = + let mutable name = nameIn + let mutable id = idIn + do printfn "Created a person object." + + member this.Name + with get () = name + and set (v) = name <- v + + member this.ID + with get () = id + and set (v) = id <- v + + new() = + Person("Invalid Name", -1) + then printfn "Created an invalid person object." +""" + +[] +let ``associativity of types``() = + formatSourceString false """ +type Delegate1 = delegate of (int * int) * (int * int) -> int +type Delegate2 = delegate of int * int -> int +type Delegate3 = delegate of int -> (int -> int) +type Delegate4 = delegate of int -> int -> int +type U = U of (int * int) + """ config + |> prepend newline + |> should equal """ +type Delegate1 = delegate of (int * int) * (int * int) -> int + +type Delegate2 = delegate of int * int -> int + +type Delegate3 = delegate of int -> (int -> int) + +type Delegate4 = delegate of int -> int -> int + +type U = + | U of (int * int) +""" + +[] +let ``should keep the ? in optional parameters``() = + formatSourceString false """type Shell() = + static member private GetParams(cmd, ?args) = doStuff + static member Exec(cmd, ?args) = + shellExec(Shell.GetParams(cmd, ?args = args)) + + """ config + |> should equal """type Shell() = + static member private GetParams(cmd, ?args) = doStuff + static member Exec(cmd, ?args) = + shellExec (Shell.GetParams(cmd, ?args = args)) +""" + +[] +let ``should add space before argument on given config``() = + formatSourceString false """ +let f(x: int) = x + +type t(x : int) = + class + end + """ { config with SpaceBeforeColon = false } + |> prepend newline + |> should equal """ +let f (x: int) = x + +type t(x: int) = + class + end +""" + +[] +let ``should keep brackets around type signatures``() = + formatSourceString false """ +let user_printers = ref([] : (string * (term -> unit)) list) +let the_interface = ref([] : (string * (string * hol_type)) list) + """ config + |> prepend newline + |> should equal """ +let user_printers = ref ([] : (string * (term -> unit)) list) +let the_interface = ref ([] : (string * (string * hol_type)) list) +""" + +[] +let ``should print named patterns on explicit constructors``() = + formatSourceString false """ +type StateMachine(makeAsync) = + new(fileName, makeAsync, initState) as secondCtor = + new StateMachine(makeAsync) + then + secondCtor.Init(fileName, initState) + """ config + |> prepend newline + |> should equal """ +type StateMachine(makeAsync) = + new(fileName, makeAsync, initState) as secondCtor = + new StateMachine(makeAsync) + then secondCtor.Init(fileName, initState) +""" + +[] +let ``should not misrecognize sequential expressions as a then block``() = + formatSourceString false """ +type BlobHelper(Account : CloudStorageAccount) = + new(configurationSettingName, hostedService) = + CloudStorageAccount.SetConfigurationSettingPublisher(fun configName configSettingPublisher -> + let connectionString = + if hostedService then RoleEnvironment.GetConfigurationSettingValue(configName) + else ConfigurationManager.ConnectionStrings.[configName].ConnectionString + configSettingPublisher.Invoke(connectionString) |> ignore) + BlobHelper(CloudStorageAccount.FromConfigurationSetting(configurationSettingName)) + """ config + |> prepend newline + |> should equal """ +type BlobHelper(Account : CloudStorageAccount) = + new(configurationSettingName, hostedService) = + CloudStorageAccount.SetConfigurationSettingPublisher(fun configName configSettingPublisher -> + let connectionString = + if hostedService then + RoleEnvironment.GetConfigurationSettingValue(configName) + else + ConfigurationManager.ConnectionStrings.[configName].ConnectionString + configSettingPublisher.Invoke(connectionString) |> ignore) + BlobHelper + (CloudStorageAccount.FromConfigurationSetting + (configurationSettingName)) +""" + +[] +let ``^a needs spaces when used as a type parameter``() = + formatSourceString false """ +let inline tryAverage(seq: seq< ^a >): ^a option = 1""" config + |> prepend newline + |> should equal """ +let inline tryAverage (seq : seq< ^a >) : ^a option = 1 +""" + +[] +let ``should preserve orders on field declarations``() = + formatSourceString false """ +type CustomGraphControl() = + inherit UserControl() + [] + static val mutable private GraphProperty : DependencyProperty + """ config + |> prepend newline + |> should equal """ +type CustomGraphControl() = + inherit UserControl() + [] + static val mutable private GraphProperty : DependencyProperty +""" + +[] +let ``should indent properly on getters and setters``() = + formatSourceString false """ +type A() = + override this.Address with set v = + let x = + match _kbytes.GetAddress(8) with + | Some(x) -> x + | None -> null + ignore x""" config + |> prepend newline + |> should equal """ +type A() = + override this.Address + with set v = + let x = + match _kbytes.GetAddress(8) with + | Some(x) -> x + | None -> null + ignore x +""" + +[] +let ``should go to new lines on long property bodies``() = + formatSourceString false """ +type A() = + member x.B with set v = "[] extern int GetWindowLong(System.IntPtr hwnd, int index)" + |> ignore""" config + |> prepend newline + |> should equal """ +type A() = + member x.B + with set v = + "[] extern int GetWindowLong(System.IntPtr hwnd, int index)" + |> ignore +""" + +[] +let ``should not remove identifier on getter ... except '()'``() = + formatSourceString false """ +type Bar = + member this.Item + with get(i : int) = + match mo with + | Some(m) when m.Groups.[i].Success -> m.Groups.[i].Value + | _ -> null + + member this.Item + with get(i : string) = + match mo with + | Some(m) when m.Groups.[i].Success -> m.Groups.[i].Value + | _ -> null""" config + |> prepend newline + |> should equal """ +type Bar = + + member this.Item + with get (i : int) = + match mo with + | Some(m) when m.Groups.[i].Success -> m.Groups.[i].Value + | _ -> null + + member this.Item + with get (i : string) = + match mo with + | Some(m) when m.Groups.[i].Success -> m.Groups.[i].Value + | _ -> null +""" + +[] +let ``should not add dubious new line inside call chains``() = + formatSourceString false """ +let x = + JobCollectionCreateParameters + (Label = "Test", + IntrinsicSettings = JobCollectionIntrinsicSettings + (Plan = JobCollectionPlan.Standard, + Quota = new JobCollectionQuota(MaxJobCount = Nullable(50))))""" { config with PageWidth = 120 } + |> prepend newline + |> should equal """ +let x = + JobCollectionCreateParameters + (Label = "Test", + IntrinsicSettings = JobCollectionIntrinsicSettings + (Plan = JobCollectionPlan.Standard, + Quota = new JobCollectionQuota(MaxJobCount = Nullable(50)))) +""" + +[] +let ``should preserve attributes on member parameters``() = + formatSourceString false """ +type ILogger = + abstract DebugFormat : format:String * []args:Object [] -> unit""" config + |> prepend newline + |> should equal """ +type ILogger = + abstract DebugFormat : format:String * [] args:Object [] -> unit +""" + +[] +let ``should preserve brackets on type signatures``() = + formatSourceString false """ +type A = + abstract member M : int -> (int -> unit) + abstract member M : float -> int""" config + |> prepend newline + |> should equal """ +type A = + abstract M : int -> (int -> unit) + abstract M : float -> int +""" + +[] +let ``should preserve brackets on type signatures 2``() = + formatSourceString false """ +type A = + abstract member M : (int -> int) -> unit + abstract member M : float -> int""" config + |> prepend newline + |> should equal """ +type A = + abstract M : (int -> int) -> unit + abstract M : float -> int +""" + +[] +let ``should handle overridden auto properties``() = + formatSourceString false """ +type Entity() = + abstract Id : int with get, set + default val Id = 0 with get, set""" config + |> prepend newline + |> should equal """ +type Entity() = + abstract Id : int with get, set + override val Id = 0 with get, set +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs b/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs new file mode 100644 index 00000000000..c95f54358f4 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs @@ -0,0 +1,51 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.TypeProviderTests + +open NUnit.Framework +open FsUnit +open TestHelper +open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig + +[] +let ``type providers``() = + formatSourceString false """ +type Northwind = ODataService<"http://services.odata.org/Northwind/Northwind.svc/">""" config + |> prepend newline + |> should equal """ +type Northwind = ODataService< "http://services.odata.org/Northwind/Northwind.svc/" > +""" + +[] +let ``should add space before type provider params``() = + formatSourceString false """ +type IntegerRegex = FSharpx.Regex< @"(?\d+)" >""" config + |> prepend newline + |> should equal """ +type IntegerRegex = FSharpx.Regex< @"(?\d+)" > +""" + +[] +let ``should throw FormatException on unparsed input``() = + Assert.Throws(fun () -> + formatSourceString false """ +type GeoResults = JsonProvider""" config + |> ignore) + +[] +let ``should handle lines with more than 512 characters``() = + formatSourceString false """ +(new CsvFile(new Func(fun (parent : obj) (row : string[]) -> CommonRuntime.GetNonOptionalValue("Name", CommonRuntime.ConvertString(TextConversions.AsOption(row.[0])), TextConversions.AsOption(row.[0])), CommonRuntime.GetNonOptionalValue("Distance", CommonRuntime.ConvertDecimal("", TextConversions.AsOption(row.[1])), TextConversions.AsOption(row.[1])), CommonRuntime.GetNonOptionalValue("Time", CommonRuntime.ConvertDecimal("", TextConversions.AsOption(row.[2])), TextConversions.AsOption(row.[2]))), new Func(fun (row : string * decimal * decimal) -> [| CommonRuntime.ConvertStringBack(CommonRuntime.GetOptionalValue((let x, _, _ = row in x))); CommonRuntime.ConvertDecimalBack("", CommonRuntime.GetOptionalValue((let _, x, _ = row in x))); CommonRuntime.ConvertDecimalBack("", CommonRuntime.GetOptionalValue((let _, _, x = row in x))) |]), (ProviderFileSystem.readTextAtRunTimeWithDesignTimeOptions @"C:\Dev\FSharp.Data-master\src\..\tests\FSharp.Data.Tests\Data" "" "SmallTest.csv"), "", '"', true, false)).Cache() +""" config + |> prepend newline + |> should equal """ +(new CsvFile(new Func(fun (parent : obj) (row : string []) -> CommonRuntime.GetNonOptionalValue("Name", CommonRuntime.ConvertString(TextConversions.AsOption(row.[0])), TextConversions.AsOption(row.[0])), CommonRuntime.GetNonOptionalValue("Distance", CommonRuntime.ConvertDecimal("", TextConversions.AsOption(row.[1])), TextConversions.AsOption(row.[1])), CommonRuntime.GetNonOptionalValue("Time", CommonRuntime.ConvertDecimal("", TextConversions.AsOption(row.[2])), TextConversions.AsOption(row.[2]))), + new Func(fun (row : string * decimal * decimal) -> + [| CommonRuntime.ConvertStringBack(CommonRuntime.GetOptionalValue((let x, _, _ = row + x))) + CommonRuntime.ConvertDecimalBack("", + CommonRuntime.GetOptionalValue((let _, x, _ = row + x))) + CommonRuntime.ConvertDecimalBack("", + CommonRuntime.GetOptionalValue((let _, _, x = row + x))) |]), (ProviderFileSystem.readTextAtRunTimeWithDesignTimeOptions @"C:\Dev\FSharp.Data-master\src\..\tests\FSharp.Data.Tests\Data" "" "SmallTest.csv"), "", '"', true, false)) + .Cache() +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs new file mode 100644 index 00000000000..8b793d61d41 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs @@ -0,0 +1,136 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.UnionsTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``enums declaration``() = + formatSourceString false """ + type FontVariant = + | [] SmallCaps = 0""" config + |> prepend newline + |> should equal """ +type FontVariant = + | [] SmallCaps = 0 +""" + +[] +let ``discriminated unions declaration``() = + formatSourceString false "type X = private | A of AParameters | B" config + |> prepend newline + |> should equal """ +type X = + private + | A of AParameters + | B +""" + +[] +let ``enums conversion``() = + formatSourceString false """ +type uColor = + | Red = 0u + | Green = 1u + | Blue = 2u +let col3 = Microsoft.FSharp.Core.LanguagePrimitives.EnumOfValue(2u)""" config + |> prepend newline + |> should equal """ +type uColor = + | Red = 0u + | Green = 1u + | Blue = 2u + +let col3 = + Microsoft.FSharp.Core.LanguagePrimitives.EnumOfValue(2u) +""" + +[] +let ``discriminated unions with members``() = + formatSourceString false """ +type Type + = TyLam of Type * Type + | TyVar of string + | TyCon of string * Type list + with override this.ToString() = + match this with + | TyLam (t1, t2) -> sprintf "(%s -> %s)" (t1.ToString()) (t2.ToString()) + | TyVar a -> a + | TyCon (s, ts) -> s""" config + |> prepend newline + |> should equal """ +type Type = + | TyLam of Type * Type + | TyVar of string + | TyCon of string * Type list + override this.ToString() = + match this with + | TyLam(t1, t2) -> sprintf "(%s -> %s)" (t1.ToString()) (t2.ToString()) + | TyVar a -> a + | TyCon(s, ts) -> s +""" + +[] +let ``should keep attributes on union cases``() = + formatSourceString false """ +type Argument = + | [] Action of string + | [] ProjectFile of string + | PackageId of string + | Version of string""" config + |> prepend newline + |> should equal """ +type Argument = + | [] Action of string + | [] ProjectFile of string + | PackageId of string + | Version of string +""" + +[] +let ``should be able to define named unions``() = + formatSourceString false """ +type Thing = +| Human of Name:string * Age:int +| Cat of Name:string * HoursSleptADay:int + +type Strategy = + | Adaptive + | Fundamental + | ShortAR of p:int // F# 3.1 syntax + | BuyHold""" config + |> prepend newline + |> should equal """ +type Thing = + | Human of Name : string * Age : int + | Cat of Name : string * HoursSleptADay : int + +type Strategy = + | Adaptive + | Fundamental + | ShortAR of p : int // F# 3.1 syntax + | BuyHold +""" + +[] +let ``should be able to pattern match on unions``() = + formatSourceString false """ +type TestUnion = Test of A : int * B : int +[] +let main argv = + let d = Test(B = 1, A = 2) + match d with + | Test(A = a; B = b) -> a + b + | _ -> 0""" config + |> prepend newline + |> should equal """ +type TestUnion = + | Test of A : int * B : int + +[] +let main argv = + let d = Test(B = 1, A = 2) + match d with + | Test (A = a; B = b) -> a + b + | _ -> 0 +""" \ No newline at end of file diff --git a/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs new file mode 100644 index 00000000000..c39a3dbdf93 --- /dev/null +++ b/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs @@ -0,0 +1,29 @@ +module FSharp.Compiler.Service.Tests.ServiceFormatting.VerboseSyntaxConversionTests + +open NUnit.Framework +open FsUnit +open TestHelper + +[] +let ``verbose syntax``() = + formatSourceString false """ + #light "off" + + let div2 = 2;; + + let f x = + let r = x % div2 in + if r = 1 then + begin "Odd" end + else + begin "Even" end + """ config + |> prepend newline + |> should equal """ +let div2 = 2 + +let f x = + let r = x % div2 + if r = 1 then ("Odd") + else ("Even") +""" diff --git a/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj b/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj index 0f6196e82d8..7ae2e3aff01 100644 --- a/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj +++ b/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj @@ -131,6 +131,90 @@ Roslyn\DocumentHighlightsServiceTests.fs + + ServiceFormatting\FsUnit.fs + + + ServiceFormatting\TestHelpers.fs + + + ServiceFormatting\StringTests.fs + + + ServiceFormatting\CommentTests.fs + + + ServiceFormatting\OperatorTests.fs + + + ServiceFormatting\ComparisonTests.fs + + + ServiceFormatting\ControlStructureTests.fs + + + ServiceFormatting\PipingTests.fs + + + ServiceFormatting\ModuleTests.fs + + + ServiceFormatting\UnionTests.fs + + + ServiceFormatting\RecordTests.fs + + + ServiceFormatting\TypeDeclarationTests.fs + + + ServiceFormatting\InterfaceTests.fs + + + ServiceFormatting\ClassTests.fs + + + ServiceFormatting\SignatureTests.fs + + + ServiceFormatting\PatternMatchingTests.fs + + + ServiceFormatting\ActivePatternTests.fs + + + ServiceFormatting\QuotationTests.fs + + + ServiceFormatting\FunctionDefinitionTests.fs + + + ServiceFormatting\AttributeTests.fs + + + ServiceFormatting\DataStructureTests.fs + + + ServiceFormatting\CompilerDirectivesTests.fs + + + ServiceFormatting\ComputationExpressionTests.fs + + + ServiceFormatting\TypeProviderTests.fs + + + ServiceFormatting\VerboseSyntaxConversionTests.fs + + + ServiceFormatting\FormattingSelectionTests.fs + + + ServiceFormatting\FormattingSelectionOnlyTests.fs + + + ServiceFormatting\FormattingPropertyTests.fs + VisualFSharp.Unittests.dll.config {VisualStudioVersion} @@ -138,9 +222,8 @@ {FinalDir} $([System.IO.Path]::GetFullPath('$(OutputPath)'))\ - + - @@ -156,7 +239,6 @@ - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Msbuild.15.0.1.0.1\lib\net45\Microsoft.Build.Framework.dll @@ -177,7 +259,7 @@ $(FSharpSourcesRoot)\..\packages\EnvDTE80.8.0.1\lib\net10\EnvDTE80.dll True - + $(FSharpSourcesRoot)\..\packages\VSSDK.VSLangProj.7.0.4\lib\net20\VSLangProj.dll True @@ -272,7 +354,6 @@ $(FSharpSourcesRoot)\..\packages\Microsoft.VisualStudio.TextManager.Interop.8.0.8.0.50727\lib\Microsoft.VisualStudio.TextManager.Interop.8.0.dll True - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualStudio.Shell.Immutable.10.0.10.0.30319\lib\net40\Microsoft.VisualStudio.Shell.Immutable.10.0.dll @@ -291,6 +372,11 @@ True $(NUnitLibDir)\nunit.framework.dll + + True + $(FsCheckLibDir)\FsCheck.dll + + $(FSharpSourcesRoot)\..\packages\Microsoft.CodeAnalysis.Common.$(RoslynVersion)\lib\netstandard1.3\Microsoft.CodeAnalysis.dll True From af439632bb027eeb129667945684bea1b3f32096 Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sat, 2 Sep 2017 22:49:15 +0300 Subject: [PATCH 07/12] fix FsCheck hint path --- src/FSharpSource.targets | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/FSharpSource.targets b/src/FSharpSource.targets index 060dca9d272..fe7e0e5f74e 100644 --- a/src/FSharpSource.targets +++ b/src/FSharpSource.targets @@ -105,7 +105,7 @@ $(FSharpSourcesRoot)\..\packages\NUnit.ConsoleRunner\$(NUnitVersion)\tools\ 2.6.2 2.6.2.0 - $(FSharpSourcesRoot)\..\packages\FsCheck.$(FsCheckVersion)\lib\ + $(FSharpSourcesRoot)\..\packages\FsCheck.$(FsCheckVersion)\lib\net45 From e2b56b340d5f5e70d55e9b777a596fa88439f79b Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sun, 3 Sep 2017 11:32:03 +0300 Subject: [PATCH 08/12] fix FsCheck path hint --- src/FSharpSource.targets | 2 +- vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/FSharpSource.targets b/src/FSharpSource.targets index fe7e0e5f74e..f32b3f501bd 100644 --- a/src/FSharpSource.targets +++ b/src/FSharpSource.targets @@ -105,7 +105,7 @@ $(FSharpSourcesRoot)\..\packages\NUnit.ConsoleRunner\$(NUnitVersion)\tools\ 2.6.2 2.6.2.0 - $(FSharpSourcesRoot)\..\packages\FsCheck.$(FsCheckVersion)\lib\net45 + $(FSharpSourcesRoot)\..\packages\FsCheck.$(FsCheckVersion)\lib diff --git a/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj b/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj index 7ae2e3aff01..0132a13a506 100644 --- a/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj +++ b/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj @@ -372,11 +372,11 @@ True $(NUnitLibDir)\nunit.framework.dll - + + true True - $(FsCheckLibDir)\FsCheck.dll + $(FsCheckLibDir)\net45\FsCheck.dll - $(FSharpSourcesRoot)\..\packages\Microsoft.CodeAnalysis.Common.$(RoslynVersion)\lib\netstandard1.3\Microsoft.CodeAnalysis.dll True From cab536f1685228e5a14417f7c57b8665b803890e Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sun, 3 Sep 2017 17:48:50 +0300 Subject: [PATCH 09/12] making it compilable on Core --- .../FSharp.Compiler.Private.fsproj | 3 + .../vs/ServiceFormatting/CodePrinter.fs | 4 +- .../vs/ServiceFormatting/FormatConfig.fs | 92 +++++---- .../ServiceFormatting/IndentedTextWriter.fs | 189 ++++++++++++++++++ 4 files changed, 242 insertions(+), 46 deletions(-) create mode 100644 src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 9a63aacae69..14b610b3107 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -653,6 +653,9 @@ Service/ServiceFormatting/TokenMatcher.fs + + Service/ServiceFormatting/IndentedTextWriter.fs + Service/ServiceFormatting/FormatConfig.fs diff --git a/src/fsharp/vs/ServiceFormatting/CodePrinter.fs b/src/fsharp/vs/ServiceFormatting/CodePrinter.fs index 74e91008ee6..d7c66e0adb1 100644 --- a/src/fsharp/vs/ServiceFormatting/CodePrinter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodePrinter.fs @@ -81,7 +81,7 @@ and genParsedHashDirective (ParsedHashDirective(h, s)) = and genModuleOrNamespace astContext (ModuleOrNamespace(ats, px, ao, s, mds, isModule)) = genPreXmlDoc px +> genAttributes astContext ats - +> ifElse (String.Equals(s, astContext.TopLevelModuleName, StringComparison.InvariantCultureIgnoreCase)) sepNone + +> ifElse (String.Equals(s, astContext.TopLevelModuleName, StringComparison.OrdinalIgnoreCase)) sepNone (ifElse isModule (!- "module ") (!- "namespace ") +> opt sepSpace ao genAccess +> ifElse (s = "") (!- "global") (!- s) +> rep 2 sepNln) +> genModuleDeclList astContext mds @@ -89,7 +89,7 @@ and genModuleOrNamespace astContext (ModuleOrNamespace(ats, px, ao, s, mds, isMo and genSigModuleOrNamespace astContext (SigModuleOrNamespace(ats, px, ao, s, mds, isModule)) = genPreXmlDoc px +> genAttributes astContext ats - +> ifElse (String.Equals(s, astContext.TopLevelModuleName, StringComparison.InvariantCultureIgnoreCase)) sepNone + +> ifElse (String.Equals(s, astContext.TopLevelModuleName, StringComparison.OrdinalIgnoreCase)) sepNone (ifElse isModule (!- "module ") (!- "namespace ") +> opt sepSpace ao genAccess -- s +> rep 2 sepNln) +> genSigModuleDeclList astContext mds diff --git a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs index b7c2a7bc7f5..a55d404f30d 100644 --- a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs +++ b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs @@ -6,8 +6,6 @@ open System open System.IO open System.Collections.Generic open System.Text.RegularExpressions -open System.CodeDom.Compiler - open Microsoft.FSharp.Compiler.Range open TokenMatcher @@ -18,55 +16,61 @@ type Num = int type FormatConfig = { /// Number of spaces for each indentation - IndentSpaceNum : Num; + IndentSpaceNum : Num /// The column where we break to new lines - PageWidth : Num; - SemicolonAtEndOfLine : bool; - SpaceBeforeArgument : bool; - SpaceBeforeColon : bool; - SpaceAfterComma : bool; - SpaceAfterSemicolon : bool; - IndentOnTryWith : bool; + PageWidth : Num + SemicolonAtEndOfLine : bool + SpaceBeforeArgument : bool + SpaceBeforeColon : bool + SpaceAfterComma : bool + SpaceAfterSemicolon : bool + IndentOnTryWith : bool /// Reordering and deduplicating open statements - ReorderOpenDeclaration : bool; - SpaceAroundDelimiter : bool; + ReorderOpenDeclaration : bool + SpaceAroundDelimiter : bool /// Prettyprinting based on ASTs only StrictMode : bool } static member Default = - { IndentSpaceNum = 4; PageWidth = 80; - SemicolonAtEndOfLine = false; SpaceBeforeArgument = true; SpaceBeforeColon = true; - SpaceAfterComma = true; SpaceAfterSemicolon = true; - IndentOnTryWith = false; ReorderOpenDeclaration = false; - SpaceAroundDelimiter = true; StrictMode = false } + { IndentSpaceNum = 4 + PageWidth = 80 + SemicolonAtEndOfLine = false + SpaceBeforeArgument = true + SpaceBeforeColon = true + SpaceAfterComma = true + SpaceAfterSemicolon = true + IndentOnTryWith = false + ReorderOpenDeclaration = false + SpaceAroundDelimiter = true + StrictMode = false } static member create(indentSpaceNum, pageWith, semicolonAtEndOfLine, spaceBeforeArgument, spaceBeforeColon, spaceAfterComma, spaceAfterSemicolon, indentOnTryWith, reorderOpenDeclaration) = { FormatConfig.Default with - IndentSpaceNum = indentSpaceNum; - PageWidth = pageWith; - SemicolonAtEndOfLine = semicolonAtEndOfLine; - SpaceBeforeArgument = spaceBeforeArgument; - SpaceBeforeColon = spaceBeforeColon; - SpaceAfterComma = spaceAfterComma; - SpaceAfterSemicolon = spaceAfterSemicolon; - IndentOnTryWith = indentOnTryWith; + IndentSpaceNum = indentSpaceNum + PageWidth = pageWith + SemicolonAtEndOfLine = semicolonAtEndOfLine + SpaceBeforeArgument = spaceBeforeArgument + SpaceBeforeColon = spaceBeforeColon + SpaceAfterComma = spaceAfterComma + SpaceAfterSemicolon = spaceAfterSemicolon + IndentOnTryWith = indentOnTryWith ReorderOpenDeclaration = reorderOpenDeclaration } static member create(indentSpaceNum, pageWith, semicolonAtEndOfLine, spaceBeforeArgument, spaceBeforeColon, spaceAfterComma, spaceAfterSemicolon, indentOnTryWith, reorderOpenDeclaration, spaceAroundDelimiter) = { FormatConfig.Default with - IndentSpaceNum = indentSpaceNum; - PageWidth = pageWith; - SemicolonAtEndOfLine = semicolonAtEndOfLine; - SpaceBeforeArgument = spaceBeforeArgument; - SpaceBeforeColon = spaceBeforeColon; - SpaceAfterComma = spaceAfterComma; - SpaceAfterSemicolon = spaceAfterSemicolon; - IndentOnTryWith = indentOnTryWith; - ReorderOpenDeclaration = reorderOpenDeclaration; + IndentSpaceNum = indentSpaceNum + PageWidth = pageWith + SemicolonAtEndOfLine = semicolonAtEndOfLine + SpaceBeforeArgument = spaceBeforeArgument + SpaceBeforeColon = spaceBeforeColon + SpaceAfterComma = spaceAfterComma + SpaceAfterSemicolon = spaceAfterSemicolon + IndentOnTryWith = indentOnTryWith + ReorderOpenDeclaration = reorderOpenDeclaration SpaceAroundDelimiter = spaceAroundDelimiter } static member create(indentSpaceNum, pageWith, semicolonAtEndOfLine, @@ -74,16 +78,16 @@ type FormatConfig = spaceAfterSemicolon, indentOnTryWith, reorderOpenDeclaration, spaceAroundDelimiter, strictMode) = { FormatConfig.Default with - IndentSpaceNum = indentSpaceNum; - PageWidth = pageWith; - SemicolonAtEndOfLine = semicolonAtEndOfLine; - SpaceBeforeArgument = spaceBeforeArgument; - SpaceBeforeColon = spaceBeforeColon; - SpaceAfterComma = spaceAfterComma; - SpaceAfterSemicolon = spaceAfterSemicolon; - IndentOnTryWith = indentOnTryWith; - ReorderOpenDeclaration = reorderOpenDeclaration; - SpaceAroundDelimiter = spaceAroundDelimiter; + IndentSpaceNum = indentSpaceNum + PageWidth = pageWith + SemicolonAtEndOfLine = semicolonAtEndOfLine + SpaceBeforeArgument = spaceBeforeArgument + SpaceBeforeColon = spaceBeforeColon + SpaceAfterComma = spaceAfterComma + SpaceAfterSemicolon = spaceAfterSemicolon + IndentOnTryWith = indentOnTryWith + ReorderOpenDeclaration = reorderOpenDeclaration + SpaceAroundDelimiter = spaceAroundDelimiter StrictMode = strictMode } /// Wrapping IndentedTextWriter with current column position diff --git a/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs b/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs new file mode 100644 index 00000000000..ca6f1ce0507 --- /dev/null +++ b/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs @@ -0,0 +1,189 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting + +open System.Diagnostics +open System +open System.IO +open System.Globalization + +/// Provides a text writer that can indent new lines by a tabString token. +type internal IndentedTextWriter(writer: TextWriter, tabString: string) = + inherit TextWriter (CultureInfo.InvariantCulture) + let mutable indentLevel = 0 + let mutable tabsPending = false + + let outputTabs() = + if tabsPending then + for i = 0 to indentLevel - 1 do + writer.Write(tabString) + + tabsPending <- false + + override __.Encoding = writer.Encoding + override __.NewLine with get() = writer.NewLine and set value = writer.NewLine <- value + + /// Gets or sets the number of spaces to indent. + member __.Indent with get() = indentLevel + and set value = + Debug.Assert(value >= 0, "Bogus Indent... probably caused by mismatched Indent++ and Indent--") + indentLevel <- max 0 value + + /// Gets or sets the TextWriter to use. + member __.InnerWriter = writer + member __.TabString = tabString + + /// Closes the document being written to. + override __.Close() = writer.Close() + override __.Flush() = writer.Flush() + + /// Writes a string to the text stream. + override __.Write(s: string) = + outputTabs() + writer.Write(s) + + /// Writes the text representation of a Boolean value to the text stream. + override __.Write(value: bool) = + outputTabs() + writer.Write(value) + + /// Writes a character to the text stream. + override __.Write(value: char) = + outputTabs() + writer.Write(value) + + /// Writes a character array to the text stream. + override __.Write(buffer: char[]) = + outputTabs() + writer.Write(buffer) + + /// Writes a subarray of characters to the text stream. + override __.Write(buffer: char[], index: int, count: int) = + outputTabs() + writer.Write(buffer, index, count) + + /// Writes the text representation of a Double to the text stream. + override __.Write(value: float) = + outputTabs() + writer.Write(value) + + /// Writes the text representation of a Single to the text + override __.Write(value: float32) = + outputTabs() + writer.Write(value) + + /// Writes the text representation of an integer to the text stream. + override __.Write(value: int) = + outputTabs() + writer.Write(value) + + /// Writes the text representation of an 8-byte integer to the text stream. + override __.Write(value: int64) = + outputTabs() + writer.Write(value) + + /// Writes the text representation of an object to the text stream. + override __.Write(value: obj) = + outputTabs() + writer.Write(value) + + /// Writes out a formatted string, using the same semantics as specified. + override __.Write(format: string, value: obj) = + outputTabs() + writer.Write(format, value) + + /// Writes out a formatted string, using the same semantics as specified. + override __.Write(format: string, arg0: obj, arg1: obj) = + outputTabs() + writer.Write(format, arg0, arg1) + + /// Writes out a formatted string, using the same semantics as specified. + override __.Write(format: string, [] arg: obj[]) = + outputTabs() + writer.Write(format, arg) + + /// Writes the specified string to a line without tabs. + member __.WriteLineNoTabs(s: string) = writer.WriteLine(s) + + /// Writes the specified string followed by a line terminator to the text stream. + override __.WriteLine(s: string) = + outputTabs() + writer.WriteLine(s) + tabsPending <- true + + /// Writes a line terminator. + override __.WriteLine() = + outputTabs() + writer.WriteLine() + tabsPending <- true + + /// Writes the text representation of a Boolean followed by a line terminator to the text stream. + override __.WriteLine(value: bool) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(value: char) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(buffer: char[]) = + outputTabs() + writer.WriteLine(buffer) + tabsPending <- true + + override __.WriteLine(buffer: char[], index: int, count: int) = + outputTabs() + writer.WriteLine(buffer, index, count) + tabsPending <- true + + override __.WriteLine(value: float) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(value: float32) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(value: int) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(value: int64) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(value: obj) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + override __.WriteLine(format: string, arg0: obj) = + outputTabs() + writer.WriteLine(format, arg0) + tabsPending <- true + + override __.WriteLine(format: string, arg0: obj, arg1: obj) = + outputTabs() + writer.WriteLine(format, arg0, arg1) + tabsPending <- true + + override __.WriteLine(format: string, [] arg: obj[]) = + outputTabs() + writer.WriteLine(format, arg) + tabsPending <- true + + [] + override __.WriteLine(value: UInt32) = + outputTabs() + writer.WriteLine(value) + tabsPending <- true + + member internal __.InternalOutputTabs() = + for i = 0 to indentLevel - 1 do + writer.Write(tabString) \ No newline at end of file From 2ac0d224970c6e02b45b0afc07833aafdd7b70bf Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Sun, 3 Sep 2017 19:04:35 +0300 Subject: [PATCH 10/12] fix compilation for .net standard 1.6 --- src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs b/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs index ca6f1ce0507..585b96dfe91 100644 --- a/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs +++ b/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs @@ -34,7 +34,7 @@ type internal IndentedTextWriter(writer: TextWriter, tabString: string) = member __.TabString = tabString /// Closes the document being written to. - override __.Close() = writer.Close() + override __.Dispose(_disposing: bool) = writer.Dispose() override __.Flush() = writer.Flush() /// Writes a string to the text stream. @@ -98,7 +98,7 @@ type internal IndentedTextWriter(writer: TextWriter, tabString: string) = writer.Write(format, arg0, arg1) /// Writes out a formatted string, using the same semantics as specified. - override __.Write(format: string, [] arg: obj[]) = + override __.Write(format: string, arg: obj[]) = outputTabs() writer.Write(format, arg) @@ -173,7 +173,7 @@ type internal IndentedTextWriter(writer: TextWriter, tabString: string) = writer.WriteLine(format, arg0, arg1) tabsPending <- true - override __.WriteLine(format: string, [] arg: obj[]) = + override __.WriteLine(format: string, arg: obj[]) = outputTabs() writer.WriteLine(format, arg) tabsPending <- true @@ -186,4 +186,4 @@ type internal IndentedTextWriter(writer: TextWriter, tabString: string) = member internal __.InternalOutputTabs() = for i = 0 to indentLevel - 1 do - writer.Write(tabString) \ No newline at end of file + writer.Write(tabString) From 2c644ed0817e3139077bae16d5d3fdd2ba4eaadd Mon Sep 17 00:00:00 2001 From: Vasily Kirichenko Date: Mon, 4 Sep 2017 16:08:26 +0300 Subject: [PATCH 11/12] remove MS copyright --- src/fsharp/vs/ServiceFormatting/CodeFormatter.fs | 2 +- src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs | 2 +- src/fsharp/vs/ServiceFormatting/CodePrinter.fs | 2 +- src/fsharp/vs/ServiceFormatting/FormatConfig.fs | 2 +- src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs | 2 +- src/fsharp/vs/ServiceFormatting/SourceParser.fs | 2 +- src/fsharp/vs/ServiceFormatting/SourceTransformer.fs | 2 +- src/fsharp/vs/ServiceFormatting/TokenMatcher.fs | 2 +- src/fsharp/vs/ServiceFormatting/Utils.fs | 2 +- .../tests/unittests/ServiceFormatting/ActivePatternTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/AttributeTests.fs | 4 +++- vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/CommentTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/ComparisonTests.fs | 4 +++- .../unittests/ServiceFormatting/CompilerDirectivesTests.fs | 4 +++- .../unittests/ServiceFormatting/ComputationExpressionTests.fs | 4 +++- .../unittests/ServiceFormatting/ControlStructureTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/DataStructureTests.fs | 4 +++- .../unittests/ServiceFormatting/FormattingPropertyTests.fs | 4 +++- .../ServiceFormatting/FormattingSelectionOnlyTests.fs | 4 +++- .../unittests/ServiceFormatting/FormattingSelectionTests.fs | 4 +++- vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs | 4 +++- .../unittests/ServiceFormatting/FunctionDefinitionTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/InterfaceTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/ModuleTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/OperatorTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/PatternMatchingTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/PipingTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/QuotationTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/RecordTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/SignatureTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/StringTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/TestHelpers.fs | 4 +++- .../tests/unittests/ServiceFormatting/TypeDeclarationTests.fs | 4 +++- .../tests/unittests/ServiceFormatting/TypeProviderTests.fs | 4 +++- vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs | 4 +++- .../ServiceFormatting/VerboseSyntaxConversionTests.fs | 4 +++- 37 files changed, 93 insertions(+), 37 deletions(-) diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs index 0f260edaaac..93b98f11b50 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatter.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting diff --git a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs index b65ad288bc8..c7d4047fe4a 100644 --- a/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs +++ b/src/fsharp/vs/ServiceFormatting/CodeFormatterImpl.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko [] module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.CodeFormatterImpl diff --git a/src/fsharp/vs/ServiceFormatting/CodePrinter.fs b/src/fsharp/vs/ServiceFormatting/CodePrinter.fs index d7c66e0adb1..7561dc7cb34 100644 --- a/src/fsharp/vs/ServiceFormatting/CodePrinter.fs +++ b/src/fsharp/vs/ServiceFormatting/CodePrinter.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.CodePrinter diff --git a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs index a55d404f30d..e753678756d 100644 --- a/src/fsharp/vs/ServiceFormatting/FormatConfig.fs +++ b/src/fsharp/vs/ServiceFormatting/FormatConfig.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.FormatConfig diff --git a/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs b/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs index 585b96dfe91..43c8c003dc7 100644 --- a/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs +++ b/src/fsharp/vs/ServiceFormatting/IndentedTextWriter.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting diff --git a/src/fsharp/vs/ServiceFormatting/SourceParser.fs b/src/fsharp/vs/ServiceFormatting/SourceParser.fs index 77347c3f1e9..454e98833af 100644 --- a/src/fsharp/vs/ServiceFormatting/SourceParser.fs +++ b/src/fsharp/vs/ServiceFormatting/SourceParser.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.SourceParser diff --git a/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs b/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs index 2c1733b826e..e3104b8d32e 100644 --- a/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs +++ b/src/fsharp/vs/ServiceFormatting/SourceTransformer.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.SourceTransformer diff --git a/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs b/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs index 59e28852610..0d0af9f2d4f 100644 --- a/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs +++ b/src/fsharp/vs/ServiceFormatting/TokenMatcher.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko module internal Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting.TokenMatcher diff --git a/src/fsharp/vs/ServiceFormatting/Utils.fs b/src/fsharp/vs/ServiceFormatting/Utils.fs index 49d40473e7e..4176335f904 100644 --- a/src/fsharp/vs/ServiceFormatting/Utils.fs +++ b/src/fsharp/vs/ServiceFormatting/Utils.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko namespace Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting diff --git a/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs index 7d47b282d6e..952f8c9b01a 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/ActivePatternTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.ActivePatternTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.ActivePatternTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs b/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs index f6cb9057fe5..72d5b9c6415 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/AttributeTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.AttributeTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.AttributeTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs index 881ac09c86a..4c4ae7a5a45 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/ClassTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.ClassTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.ClassTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs b/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs index 4c7f441337d..26db7c827cc 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/CommentTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.CommentTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.CommentTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs index 08e4b9d1ab5..5fdec8b075d 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/ComparisonTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.ComparisonTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.ComparisonTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs b/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs index 77b322dc68a..80333906d57 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/CompilerDirectivesTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.CompilerDirectiveTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.CompilerDirectiveTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs index 061ed7f9ee0..80c17261855 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/ComputationExpressionTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.CodeFormatterExtTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.CodeFormatterExtTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs index f86decb3b86..f145ba6d19d 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/ControlStructureTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.ControlStructureTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.ControlStructureTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs b/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs index 817a8108aa7..67b37f39a05 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/DataStructureTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.ListTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.ListTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs index 57d8ae7ebe2..42e4c53bc27 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/FormattingPropertyTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingPropertyTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingPropertyTests open NUnit.Framework open System diff --git a/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs index cf0752a3b4d..7c89b7aa4b4 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionOnlyTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingSelectionOnlyTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingSelectionOnlyTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs index d81d203ee10..bde52a599e9 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/FormattingSelectionTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingSelectionTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.FormattingSelectionTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs b/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs index 4c29680892c..5c76fa96887 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/FsUnit.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.FsUnit +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.FsUnit open NUnit.Framework open NUnit.Framework.Constraints diff --git a/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs index d13836f4234..c449bdf011a 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/FunctionDefinitionTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.FunctionDefinitionTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.FunctionDefinitionTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs b/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs index 4a36aa285f8..cbb7674a604 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/InterfaceTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.InterfaceTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.InterfaceTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs b/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs index 233e45843d1..5107fe9ef34 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/ModuleTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.ModuleTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.ModuleTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs b/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs index d21645b579a..66dd1aee28a 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/OperatorTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.OperatorTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.OperatorTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs b/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs index 155d2187035..709d390457d 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/PatternMatchingTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.PatternMatchingTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.PatternMatchingTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs b/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs index 5d2a9cd078f..e43f3bfe9b0 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/PipingTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.PipingTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.PipingTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs b/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs index f426cde9f49..a15bf6e8eef 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/QuotationTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.QuotationTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.QuotationTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs b/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs index da7d2d25fa7..c027238e0f0 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/RecordTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.RecordTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.RecordTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs b/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs index be4c6da87b5..b7433109df2 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/SignatureTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.SignatureTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.SignatureTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs b/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs index 0e1c65e8981..1faacde43ae 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/StringTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.StringTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.StringTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs b/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs index 8e95069eefd..93b97e82193 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/TestHelpers.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.TestHelper +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.TestHelper open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs b/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs index 2042c810a29..28d5d194074 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/TypeDeclarationTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.TypeDeclarationTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.TypeDeclarationTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs b/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs index c95f54358f4..27aac0814cf 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/TypeProviderTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.TypeProviderTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.TypeProviderTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs index 8b793d61d41..d9863892004 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/UnionTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.UnionsTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.UnionsTests open NUnit.Framework open FsUnit diff --git a/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs b/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs index c39a3dbdf93..226f84af694 100644 --- a/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs +++ b/vsintegration/tests/unittests/ServiceFormatting/VerboseSyntaxConversionTests.fs @@ -1,4 +1,6 @@ -module FSharp.Compiler.Service.Tests.ServiceFormatting.VerboseSyntaxConversionTests +// Copied from https://github.com/dungpa/fantomas and modified by Vasily Kirichenko + +module FSharp.Compiler.Service.Tests.ServiceFormatting.VerboseSyntaxConversionTests open NUnit.Framework open FsUnit From 8cb11667d62c1c0a1b47cecaa7b5a3121eb88861 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 8 Sep 2017 15:56:17 +0100 Subject: [PATCH 12/12] one formatting service --- .../src/FSharp.Editor/FSharp.Editor.fsproj | 1 - .../Formatting/EditorFormattingService.fs | 39 ++++++++++---- .../Formatting/FormattingService.fs | 51 ------------------- 3 files changed, 28 insertions(+), 63 deletions(-) delete mode 100644 vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs diff --git a/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj b/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj index cff9d404357..ae38f48257e 100644 --- a/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj +++ b/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj @@ -55,7 +55,6 @@ - diff --git a/vsintegration/src/FSharp.Editor/Formatting/EditorFormattingService.fs b/vsintegration/src/FSharp.Editor/Formatting/EditorFormattingService.fs index 0abbd0abddf..a48b54c4caf 100644 --- a/vsintegration/src/FSharp.Editor/Formatting/EditorFormattingService.fs +++ b/vsintegration/src/FSharp.Editor/Formatting/EditorFormattingService.fs @@ -12,6 +12,7 @@ open Microsoft.CodeAnalysis.Host.Mef open Microsoft.CodeAnalysis.Text open Microsoft.FSharp.Compiler.SourceCodeServices +open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting open System.Threading [] @@ -23,7 +24,8 @@ type internal FSharpEditorFormattingService projectInfoManager: FSharpProjectOptionsManager ) = - static member GetFormattingChanges(documentId: DocumentId, sourceText: SourceText, filePath: string, checker: FSharpChecker, indentStyle: FormattingOptions.IndentStyle, projectOptions: FSharpProjectOptions option, position: int) = + static let userOpName = "Formatting" + static let getFormattingChanges(documentId: DocumentId, sourceText: SourceText, filePath: string, checker: FSharpChecker, indentStyle: FormattingOptions.IndentStyle, projectOptions: FSharpProjectOptions option, position: int) = // Logic for determining formatting changes: // If first token on the current line is a closing brace, // match the indent with the indent on the line that opened it @@ -69,13 +71,13 @@ type internal FSharpEditorFormattingService return! None } - member __.GetFormattingChangesAsync (document: Document, position: int, cancellationToken: CancellationToken) = + let getFormattingChangesAsync (document: Document, position: int, cancellationToken: CancellationToken) = async { let! sourceText = document.GetTextAsync(cancellationToken) |> Async.AwaitTask let! options = document.GetOptionsAsync(cancellationToken) |> Async.AwaitTask let indentStyle = options.GetOption(FormattingOptions.SmartIndent, FSharpConstants.FSharpLanguageName) let projectOptionsOpt = projectInfoManager.TryGetOptionsForEditingDocumentOrProject document - let! textChange = FSharpEditorFormattingService.GetFormattingChanges(document.Id, sourceText, document.FilePath, checkerProvider.Checker, indentStyle, projectOptionsOpt, position) + let! textChange = getFormattingChanges(document.Id, sourceText, document.FilePath, checkerProvider.Checker, indentStyle, projectOptionsOpt, position) return match textChange with @@ -87,10 +89,10 @@ type internal FSharpEditorFormattingService } interface IEditorFormattingService with - member val SupportsFormatDocument = false - member val SupportsFormatSelection = false - member val SupportsFormatOnPaste = false - member val SupportsFormatOnReturn = true + member __.SupportsFormatDocument = true + member __.SupportsFormatSelection = false + member __.SupportsFormatOnPaste = false + member __.SupportsFormatOnReturn = true override __.SupportsFormattingOnTypedCharacter (document, ch) = if FSharpIndentationService.IsSmartIndentEnabled document.Project.Solution.Workspace.Options then @@ -100,18 +102,33 @@ type internal FSharpEditorFormattingService else false - override __.GetFormattingChangesAsync (_document, _span, cancellationToken) = - async { return ResizeArray() :> IList<_> } + // On 'dormat document' or 'format span' + member __.GetFormattingChangesAsync (document, textSpan, cancellationToken) = + asyncMaybe { + match Option.ofNullable textSpan with + | None -> + let! options = projectInfoManager.TryGetOptionsForEditingDocumentOrProject(document) + let! sourceText = document.GetTextAsync(cancellationToken) + let! parsedInput = checkerProvider.Checker.ParseDocument(document, options, sourceText, userOpName) + let changedSource = CodeFormatter.FormatAST(parsedInput, document.FilePath, Some (sourceText.ToString()), FormatConfig.FormatConfig.Default) + return [| TextChange(TextSpan(0, sourceText.Length), changedSource) |] + | Some _ -> + return [||] + } + |> Async.map (fun xs -> (match xs with Some changes -> changes | None -> [||]) :> IList) |> RoslynHelpers.StartAsyncAsTask cancellationToken + // On 'paste' override __.GetFormattingChangesOnPasteAsync (_document, _span, cancellationToken) = async { return ResizeArray() :> IList<_> } |> RoslynHelpers.StartAsyncAsTask cancellationToken + // On typed character override this.GetFormattingChangesAsync (document, _typedChar, position, cancellationToken) = - this.GetFormattingChangesAsync (document, position, cancellationToken) + getFormattingChangesAsync (document, position, cancellationToken) |> RoslynHelpers.StartAsyncAsTask cancellationToken + // On 'return' override this.GetFormattingChangesOnReturnAsync (document, position, cancellationToken) = - this.GetFormattingChangesAsync (document, position, cancellationToken) + getFormattingChangesAsync (document, position, cancellationToken) |> RoslynHelpers.StartAsyncAsTask cancellationToken diff --git a/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs b/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs deleted file mode 100644 index 9d4b40fd5bf..00000000000 --- a/vsintegration/src/FSharp.Editor/Formatting/FormattingService.fs +++ /dev/null @@ -1,51 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.VisualStudio.FSharp.Editor - -#nowarn "1182" - -open System.Composition -open Microsoft.CodeAnalysis.Editor -open Microsoft.CodeAnalysis.Host.Mef -open Microsoft.CodeAnalysis.Text -open System.Threading.Tasks -open System.Collections.Generic -open Microsoft.FSharp.Compiler.SourceCodeServices.ServiceFormatting -open System.IO.Ports - -[] -[, FSharpConstants.FSharpLanguageName)>] -type internal FSharpFormattingService - [] - ( - checkerProvider: FSharpCheckerProvider, - projectInfoManager: FSharpProjectOptionsManager - ) = - - static let userOpName = "Formatting" - let emptyChange = Task.FromResult> [||] - - interface IEditorFormattingService with - member __.SupportsFormatDocument = true - member __.SupportsFormatSelection = false - member __.SupportsFormatOnPaste = false - member __.SupportsFormatOnReturn = false - member __.SupportsFormattingOnTypedCharacter (_, _) = false - member __.GetFormattingChangesOnPasteAsync (_, _, _) = emptyChange - member __.GetFormattingChangesAsync (_, _, _, _) = emptyChange - member __.GetFormattingChangesOnReturnAsync (_, _, _) = emptyChange - - member __.GetFormattingChangesAsync (document, textSpan, cancellationToken) = - asyncMaybe { - match Option.ofNullable textSpan with - | None -> - let! options = projectInfoManager.TryGetOptionsForEditingDocumentOrProject(document) - let! sourceText = document.GetTextAsync(cancellationToken) - let! parsedInput = checkerProvider.Checker.ParseDocument(document, options, sourceText, userOpName) - let changedSource = CodeFormatter.FormatAST(parsedInput, document.FilePath, Some (sourceText.ToString()), FormatConfig.FormatConfig.Default) - return [| TextChange(TextSpan(0, sourceText.Length), changedSource) |] - | Some _ -> - return [||] - } - |> Async.map (fun xs -> (match xs with Some changes -> changes | None -> [||]) :> IList) - |> RoslynHelpers.StartAsyncAsTask cancellationToken \ No newline at end of file