From 441e7732593604d998d7cbdcfd0009b89506a120 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 5 Oct 2022 16:58:46 +0200 Subject: [PATCH] Extract helper functions from pars.fsy to ParseHelpers. --- src/Compiler/SyntaxTree/ParseHelpers.fs | 196 +++++++++++++++++++++++ src/Compiler/SyntaxTree/ParseHelpers.fsi | 53 ++++++ src/Compiler/pars.fsy | 161 ------------------- 3 files changed, 249 insertions(+), 161 deletions(-) diff --git a/src/Compiler/SyntaxTree/ParseHelpers.fs b/src/Compiler/SyntaxTree/ParseHelpers.fs index f3e3fcdfdaf..7cbd282ba4c 100644 --- a/src/Compiler/SyntaxTree/ParseHelpers.fs +++ b/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) diff --git a/src/Compiler/SyntaxTree/ParseHelpers.fsi b/src/Compiler/SyntaxTree/ParseHelpers.fsi index e345dc68a3a..b5f9bac57f9 100644 --- a/src/Compiler/SyntaxTree/ParseHelpers.fsi +++ b/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 diff --git a/src/Compiler/pars.fsy b/src/Compiler/pars.fsy index c9dd108bf2d..faed93d0728 100644 --- a/src/Compiler/pars.fsy +++ b/src/Compiler/pars.fsy @@ -27,172 +27,11 @@ open FSharp.Compiler.Text.Position open FSharp.Compiler.Text.Range open FSharp.Compiler.Xml -#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 = lidwd, true - -// Used for 'do expr' in a class. -let mkSynDoBinding (vis, 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) - - // This function is called by the generated parser code. Returning initiates error recovery // It must be called precisely "parse_error_rich" let parse_error_rich = Some (fun (ctxt: ParseErrorContext<_>) -> errorR(SyntaxError(box ctxt, ctxt.ParseState.LexBuffer.LexemeRange))) -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) - %} // Producing these changes the lex state, e.g. string --> token, or nesting level of braces in interpolated strings