Extract helper functions from pars.fsy to ParseHelpers.

Author: nojaf

src/Compiler/SyntaxTree/ParseHelpers.fs

@@ -13,6 +13,7 @@ open FSharp.Compiler.Text
 open FSharp.Compiler.Text.Position
 open FSharp.Compiler.Text.Range
 open FSharp.Compiler.Xml
+open Internal.Utilities.Library
 open Internal.Utilities.Text.Lexing
 open Internal.Utilities.Text.Parsing
 
@@ -857,3 +858,198 @@ let mkSynTypeTuple (elementTypes: SynTupleTypeSegment list) : SynType =
             ||> List.fold (fun acc segment -> unionRanges acc segment.Range)
 
     SynType.Tuple(false, elementTypes, range)
+
+#if DEBUG
+let debugPrint s =
+    if Internal.Utilities.Text.Parsing.Flags.debug then
+        printfn "\n%s" s
+#else
+let debugPrint s = ignore s
+#endif
+
+let exprFromParseError (e: SynExpr) = SynExpr.FromParseError(e, e.Range)
+
+let patFromParseError (e: SynPat) = SynPat.FromParseError(e, e.Range)
+
+// record bindings returned by the recdExprBindings rule has shape:
+// (binding, separator-before-this-binding)
+// this function converts arguments from form
+// binding1 (binding2*sep1, binding3*sep2...) sepN
+// to form
+// binding1*sep1, binding2*sep2
+let rebindRanges first fields lastSep =
+    let rec run (name, mEquals, value) l acc =
+        match l with
+        | [] -> List.rev (SynExprRecordField(name, mEquals, value, lastSep) :: acc)
+        | (f, m) :: xs -> run f xs (SynExprRecordField(name, mEquals, value, m) :: acc)
+
+    run first fields []
+
+let mkUnderscoreRecdField m =
+    SynLongIdent([ ident ("_", m) ], [], [ None ]), false
+
+let mkRecdField (lidwd: SynLongIdent) = lidwd, true
+
+// Used for 'do expr' in a class.
+let mkSynDoBinding (vis: SynAccess option, expr, m) =
+    match vis with
+    | Some vis -> errorR (Error(FSComp.SR.parsDoCannotHaveVisibilityDeclarations (vis.ToString()), m))
+    | None -> ()
+
+    SynBinding(
+        None,
+        SynBindingKind.Do,
+        false,
+        false,
+        [],
+        PreXmlDoc.Empty,
+        SynInfo.emptySynValData,
+        SynPat.Const(SynConst.Unit, m),
+        None,
+        expr,
+        m,
+        DebugPointAtBinding.NoneAtDo,
+        SynBindingTrivia.Zero
+    )
+
+let mkSynExprDecl (e: SynExpr) = SynModuleDecl.Expr(e, e.Range)
+
+let addAttribs attrs p = SynPat.Attrib(p, attrs, p.Range)
+
+let unionRangeWithPos (r: range) p =
+    let r2 = mkRange r.FileName p p
+    unionRanges r r2
+
+/// Report a good error at the end of file, e.g. for non-terminated strings
+let checkEndOfFileError t =
+    match t with
+    | LexCont.IfDefSkip (_, _, _, m) -> reportParseErrorAt m (FSComp.SR.parsEofInHashIf ())
+
+    | LexCont.String (_, _, LexerStringStyle.SingleQuote, kind, m) ->
+        if kind.IsInterpolated then
+            reportParseErrorAt m (FSComp.SR.parsEofInInterpolatedString ())
+        else
+            reportParseErrorAt m (FSComp.SR.parsEofInString ())
+
+    | LexCont.String (_, _, LexerStringStyle.TripleQuote, kind, m) ->
+        if kind.IsInterpolated then
+            reportParseErrorAt m (FSComp.SR.parsEofInInterpolatedTripleQuoteString ())
+        else
+            reportParseErrorAt m (FSComp.SR.parsEofInTripleQuoteString ())
+
+    | LexCont.String (_, _, LexerStringStyle.Verbatim, kind, m) ->
+        if kind.IsInterpolated then
+            reportParseErrorAt m (FSComp.SR.parsEofInInterpolatedVerbatimString ())
+        else
+            reportParseErrorAt m (FSComp.SR.parsEofInVerbatimString ())
+
+    | LexCont.Comment (_, _, _, m) -> reportParseErrorAt m (FSComp.SR.parsEofInComment ())
+
+    | LexCont.SingleLineComment (_, _, _, m) -> reportParseErrorAt m (FSComp.SR.parsEofInComment ())
+
+    | LexCont.StringInComment (_, _, LexerStringStyle.SingleQuote, _, m) -> reportParseErrorAt m (FSComp.SR.parsEofInStringInComment ())
+
+    | LexCont.StringInComment (_, _, LexerStringStyle.Verbatim, _, m) ->
+        reportParseErrorAt m (FSComp.SR.parsEofInVerbatimStringInComment ())
+
+    | LexCont.StringInComment (_, _, LexerStringStyle.TripleQuote, _, m) ->
+        reportParseErrorAt m (FSComp.SR.parsEofInTripleQuoteStringInComment ())
+
+    | LexCont.MLOnly (_, _, m) -> reportParseErrorAt m (FSComp.SR.parsEofInIfOcaml ())
+
+    | LexCont.EndLine (_, _, LexerEndlineContinuation.Skip (_, m)) -> reportParseErrorAt m (FSComp.SR.parsEofInDirective ())
+
+    | LexCont.EndLine (endifs, nesting, LexerEndlineContinuation.Token)
+    | LexCont.Token (endifs, nesting) ->
+        match endifs with
+        | [] -> ()
+        | (_, m) :: _ -> reportParseErrorAt m (FSComp.SR.parsNoHashEndIfFound ())
+
+        match nesting with
+        | [] -> ()
+        | (_, _, m) :: _ -> reportParseErrorAt m (FSComp.SR.parsEofInInterpolatedStringFill ())
+
+type BindingSet = BindingSetPreAttrs of range * bool * bool * (SynAttributes -> SynAccess option -> SynAttributes * SynBinding list) * range
+
+let mkClassMemberLocalBindings
+    (
+        isStatic,
+        initialRangeOpt,
+        attrs,
+        vis,
+        BindingSetPreAttrs (_, isRec, isUse, declsPreAttrs, bindingSetRange)
+    ) =
+    let ignoredFreeAttrs, decls = declsPreAttrs attrs vis
+
+    let mWhole =
+        match initialRangeOpt with
+        | None -> bindingSetRange
+        | Some m -> unionRanges m bindingSetRange
+        // decls could have a leading attribute
+        |> fun m -> (m, decls) ||> unionRangeWithListBy (fun (SynBinding (range = m)) -> m)
+
+    if not (isNil ignoredFreeAttrs) then
+        warning (Error(FSComp.SR.parsAttributesIgnored (), mWhole))
+
+    if isUse then
+        errorR (Error(FSComp.SR.parsUseBindingsIllegalInImplicitClassConstructors (), mWhole))
+
+    SynMemberDefn.LetBindings(decls, isStatic, isRec, mWhole)
+
+let mkLocalBindings (mWhole, BindingSetPreAttrs (_, isRec, isUse, declsPreAttrs, _), mIn, body: SynExpr) =
+    let ignoredFreeAttrs, decls = declsPreAttrs [] None
+
+    let mWhole =
+        match decls with
+        | SynBinding (xmlDoc = xmlDoc) :: _ -> unionRangeWithXmlDoc xmlDoc mWhole
+        | _ -> mWhole
+
+    if not (isNil ignoredFreeAttrs) then
+        warning (Error(FSComp.SR.parsAttributesIgnored (), mWhole))
+
+    let mIn =
+        mIn
+        |> Option.bind (fun (mIn: range) ->
+            if Position.posEq mIn.Start body.Range.Start then
+                None
+            else
+                Some mIn)
+
+    SynExpr.LetOrUse(isRec, isUse, decls, body, mWhole, { InKeyword = mIn })
+
+let mkDefnBindings (mWhole, BindingSetPreAttrs (_, isRec, isUse, declsPreAttrs, _bindingSetRange), attrs, vis, attrsm) =
+    if isUse then
+        warning (Error(FSComp.SR.parsUseBindingsIllegalInModules (), mWhole))
+
+    let freeAttrs, decls = declsPreAttrs attrs vis
+    // decls might have an extended range due to leading attributes
+    let mWhole =
+        (mWhole, decls) ||> unionRangeWithListBy (fun (SynBinding (range = m)) -> m)
+
+    let letDecls = [ SynModuleDecl.Let(isRec, decls, mWhole) ]
+
+    let attrDecls =
+        if not (isNil freeAttrs) then
+            [ SynModuleDecl.Attributes(freeAttrs, attrsm) ]
+        else
+            []
+
+    attrDecls @ letDecls
+
+let idOfPat (parseState: IParseState) m p =
+    match p with
+    | SynPat.Wild r when parseState.LexBuffer.SupportsFeature LanguageFeature.WildCardInForLoop -> mkSynId r "_"
+    | SynPat.Named (SynIdent (id, _), false, _, _) -> id
+    | SynPat.LongIdent (longDotId = SynLongIdent ([ id ], _, _); typarDecls = None; argPats = SynArgPats.Pats []; accessibility = None) ->
+        id
+    | _ -> raiseParseErrorAt m (FSComp.SR.parsIntegerForLoopRequiresSimpleIdentifier ())
+
+let checkForMultipleAugmentations m a1 a2 =
+    if not (isNil a1) && not (isNil a2) then
+        raiseParseErrorAt m (FSComp.SR.parsOnlyOneWithAugmentationAllowed ())
+
+    a1 @ a2
+
+let rangeOfLongIdent (lid: LongIdent) =
+    System.Diagnostics.Debug.Assert(not lid.IsEmpty, "the parser should never produce a long-id that is the empty list")
+    (lid.Head.idRange, lid) ||> unionRangeWithListBy (fun id -> id.idRange)

src/Compiler/SyntaxTree/ParseHelpers.fsi

@@ -180,3 +180,56 @@ val mkSynMemberDefnGetSet:
 val adjustHatPrefixToTyparLookup: mFull: range -> rightExpr: SynExpr -> SynExpr
 
 val mkSynTypeTuple: elementTypes: SynTupleTypeSegment list -> SynType
+
+#if DEBUG
+val debugPrint: s: string -> unit
+#else
+val debugPrint: s: 'a -> unit
+#endif
+
+val exprFromParseError: e: SynExpr -> SynExpr
+
+val patFromParseError: e: SynPat -> SynPat
+
+val rebindRanges:
+    first: (RecordFieldName * range option * SynExpr option) ->
+    fields: ((RecordFieldName * range option * SynExpr option) * BlockSeparator option) list ->
+    lastSep: BlockSeparator option ->
+        SynExprRecordField list
+
+val mkUnderscoreRecdField: m: range -> SynLongIdent * bool
+
+val mkRecdField: lidwd: SynLongIdent -> SynLongIdent * bool
+
+val mkSynDoBinding: vis: SynAccess option * expr: SynExpr * m: range -> SynBinding
+
+val mkSynExprDecl: e: SynExpr -> SynModuleDecl
+
+val addAttribs: attrs: SynAttributes -> p: SynPat -> SynPat
+
+val unionRangeWithPos: r: range -> p: pos -> range
+
+val checkEndOfFileError: t: LexerContinuation -> unit
+
+type BindingSet =
+    | BindingSetPreAttrs of
+        range *
+        bool *
+        bool *
+        (SynAttributes -> SynAccess option -> SynAttributes * SynBinding list) *
+        range
+
+val mkClassMemberLocalBindings:
+    isStatic: bool * initialRangeOpt: range option * attrs: SynAttributes * vis: SynAccess option * BindingSet ->
+        SynMemberDefn
+
+val mkLocalBindings: mWhole: range * BindingSet * mIn: range option * body: SynExpr -> SynExpr
+
+val mkDefnBindings:
+    mWhole: range * BindingSet * attrs: SynAttributes * vis: SynAccess option * attrsm: range -> SynModuleDecl list
+
+val idOfPat: parseState: IParseState -> m: range -> p: SynPat -> Ident
+
+val checkForMultipleAugmentations: m: range -> a1: 'a list -> a2: 'a list -> 'a list
+
+val rangeOfLongIdent: lid: LongIdent -> range