From 509d5be69c7507ba5d0a5f39ffd1613a59e73eea Mon Sep 17 00:00:00 2001 From: Shayan-Najd Date: Thu, 22 Nov 2018 01:23:29 +0000 Subject: [TTG: Handling Source Locations] Foundation and Pat This patch removes the ping-pong style from HsPat (only, for now), using the plan laid out at https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution A). - the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced - some instances of `HasSrcSpan` are introduced - some constructors `L` are replaced with `cL` - some patterns `L` are replaced with `dL->L` view pattern - some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`) Phab diff: D5036 Trac Issues #15495 Updates haddock submodule --- compiler/parser/Lexer.x | 32 +-- compiler/parser/Parser.y | 378 +++++++++++++------------ compiler/parser/RdrHsSyn.hs | 658 ++++++++++++++++++++++++-------------------- 3 files changed, 566 insertions(+), 502 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 9597f10b0a..a75566ea39 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -48,7 +48,7 @@ module Lexer ( Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), - P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc, + P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getRealSrcLoc, getPState, extopt, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, getMessages, @@ -1155,7 +1155,7 @@ parseNestedPragma input@(AI _ buf) = do setExts (.&. complement (xbit InNestedCommentBit)) postInput@(AI _ postBuf) <- getInput setInput origInput - case unLoc lt of + case unRealSrcSpan lt of ITcomment_line_prag -> do let bytes = byteDiff buf postBuf diff = lexemeToString buf bytes @@ -1570,9 +1570,9 @@ alrInitialLoc file = mkRealSrcSpan loc loc lex_string_prag :: (String -> Token) -> Action lex_string_prag mkTok span _buf _len = do input <- getInput - start <- getSrcLoc + start <- getRealSrcLoc tok <- go [] input - end <- getSrcLoc + end <- getRealSrcLoc return (L (mkRealSrcSpan start end) tok) where go acc input = if isString input "#-}" @@ -1844,9 +1844,9 @@ getCharOrFail i = do lex_qquasiquote_tok :: Action lex_qquasiquote_tok span buf len = do let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getSrcLoc + quoteStart <- getRealSrcLoc quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc + end <- getRealSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITqQuasiQuote (qual, quoter, @@ -1858,9 +1858,9 @@ lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) -- 'tail' drops the initial '[', -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc + quoteStart <- getRealSrcLoc quote <- lex_quasiquote quoteStart "" - end <- getSrcLoc + end <- getRealSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), @@ -2074,8 +2074,8 @@ setExts f = P $ \s -> POk s { setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () -getSrcLoc :: P RealSrcLoc -getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc +getRealSrcLoc :: P RealSrcLoc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc addSrcFile :: FastString -> P () addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () @@ -2626,7 +2626,7 @@ srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, -- not over a token range. lexError :: String -> P a lexError str = do - loc <- getSrcLoc + loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc end buf str @@ -2664,8 +2664,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken alternativeLayoutRuleToken t Just t -> return t - setAlrLastLoc (getLoc t) - case unLoc t of + setAlrLastLoc (getRealSrcSpan t) + case unRealSrcSpan t of ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) @@ -2684,10 +2684,10 @@ alternativeLayoutRuleToken t transitional <- getALRTransitional justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock setJustClosedExplicitLetBlock False - let thisLoc = getLoc t + let thisLoc = getRealSrcSpan t thisCol = srcSpanStartCol thisLoc newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc - case (unLoc t, context, mExpectingOCurly) of + case (unRealSrcSpan t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... (ITocurly, _, Just alrLayout) -> @@ -2895,7 +2895,7 @@ lexToken = do let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes lt <- t span buf bytes - case unLoc lt of + case unRealSrcSpan lt of ITlineComment _ -> return lt ITblockComment _ -> return lt lt' -> do diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index f5082174ab..cd41da53eb 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -9,6 +9,9 @@ -- --------------------------------------------------------------------------- { +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + -- | This module provides the generated Happy parser for Haskell. It exports -- a number of parsers which may be used in any library that uses the GHC API. -- A common usage pattern is to initialize the parser state with a given string @@ -747,7 +750,7 @@ unitdecl :: { LHsUnitDecl PackageName } signature :: { Located (HsModule GhcPs) } : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } @@ -755,13 +758,13 @@ signature :: { Located (HsModule GhcPs) } module :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } | body2 {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule Nothing Nothing + ams (cL loc (HsModule Nothing Nothing (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) (fst $1) } @@ -812,15 +815,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } header :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $1 [] Nothing + return (cL loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl GhcPs] } @@ -842,7 +845,7 @@ header_top_importdecls :: { [LImportDecl GhcPs] } -- The Export List maybeexports :: { (Maybe (Located [LIE GhcPs])) } - : '(' exportlist ')' {% ams (sLL $1 $> ()) [mop $1,mcp $3] >> + : '(' exportlist ')' {% amsL (comb2 $1 $>) [mop $1,mcp $3] >> return (Just (sLL $1 $> (fromOL $2))) } | {- empty -} { Nothing } @@ -892,7 +895,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(L _ ImpExpQcWildcard) -> + l@(dL->L _ ImpExpQcWildcard) -> return ([mj AnnComma $2, mj AnnDotdot l] ,(snd (unLoc $3) : snd $1)) l -> (ams (head (snd $1)) [mj AnnComma $2] >> @@ -952,7 +955,7 @@ importdecls_semi importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - {% ams (L (comb4 $1 $6 (snd $7) $8) $ + {% ams (cL (comb4 $1 $6 (snd $7) $8) $ ImportDecl { ideclExt = noExt , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 @@ -995,7 +998,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> - return (L (gl $1) (Just (b, checkedIe))) } + return (cL (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, Located [LIE GhcPs]) } @@ -1129,7 +1132,7 @@ inst_decl :: { LInstDecl GhcPs } , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) + ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1216,24 +1219,24 @@ where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] ,Just (unLoc $2)) } - | vocurly ty_fam_inst_eqns close { let L loc _ = $2 in - L loc ([],Just (unLoc $2)) } + | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in + cL loc ([],Just (unLoc $2)) } | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 ,mcc $3],Nothing) } - | vocurly '..' close { let L loc _ = $2 in - L loc ([mj AnnDotdot $2],Nothing) } + | vocurly '..' close { let (dL->L loc _) = $2 in + cL loc ([mj AnnDotdot $2],Nothing) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% let L loc (anns, eqn) = $3 in - asl (unLoc $1) $2 (L loc eqn) + {% let (dL->L loc (anns, eqn)) = $3 in + asl (unLoc $1) $2 (cL loc eqn) >> ams $3 anns - >> return (sLL $1 $> (L loc eqn : unLoc $1)) } + >> return (sLL $1 $> (cL loc eqn : unLoc $1)) } | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% let L loc (anns, eqn) = $1 in + | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in ams $1 anns - >> return (sLL $1 $> [L loc eqn]) } + >> return (sLL $1 $> [cL loc eqn]) } | {- empty -} { noLoc [] } ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } @@ -1485,7 +1488,7 @@ where_decls :: { Located ([AddAnn] , Located (OrdList (LHsDecl GhcPs))) } : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } - | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) + | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) ,sL1 $3 (snd $ unLoc $3)) } pattern_synonym_sig :: { LSig GhcPs } @@ -1568,7 +1571,7 @@ decllist_inst :: { Located ([AddAnn] , OrdList (LHsDecl GhcPs)) } -- Reversed : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } - | vocurly decls_inst close { L (gl $2) (unLoc $2) } + | vocurly decls_inst close { cL (gl $2) (unLoc $2) } -- Instance body -- @@ -1604,7 +1607,7 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) } : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) ,sL1 $2 $ snd $ unLoc $2) } - | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } + | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- @@ -1618,7 +1621,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } - | vocurly dbinds close { L (getLoc $2) ([] + | vocurly dbinds close { cL (getLoc $2) ([] ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } @@ -1644,7 +1647,7 @@ rules :: { OrdList (LRuleDecl GhcPs) } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_foralls infixexp '=' exp {%ams (sLL $1 $> $ HsRule { rd_ext = noExt - , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1) + , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 , rd_lhs = $4, rd_rhs = $6 }) @@ -1739,14 +1742,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) } (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } - : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } + : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) } | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } stringlist :: { Located (OrdList (Located StringLiteral)) } : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (unLoc $1 `snocOL` - (L (gl $3) (getStringLiteral $3)))) } - | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } + (cL (gl $3) (getStringLiteral $3)))) } + | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) } | {- empty -} { noLoc nilOL } ----------------------------------------------------------------------------- @@ -1797,7 +1800,7 @@ safety :: { Located Safety } fspec :: { Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] - ,(L (getLoc $1) + ,(cL (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } @@ -1953,13 +1956,13 @@ typedoc :: { LHsType GhcPs } [mu AnnRarrow $2] } | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExt (L (comb2 $1 $2) + HsFunTy noExt (cL (comb2 $1 $2) (HsDocTy noExt $1 $2)) $4) [mu AnnRarrow $3] } | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExt (L (comb2 $1 $2) + HsFunTy noExt (cL (comb2 $1 $2) (HsDocTy noExt $2 $1)) $4) [mu AnnRarrow $3] } @@ -2102,7 +2105,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] } | fd { sL1 $1 [$1] } fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) + : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3) (reverse (unLoc $1), reverse (unLoc $3))) [mu AnnRarrow $2] } @@ -2145,13 +2148,13 @@ gadt_constrlist :: { Located ([AddAnn] ,[LConDecl GhcPs]) } -- Returned in order : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ - L (comb2 $1 $3) + cL (comb2 $1 $3) ([mj AnnWhere $1 ,moc $2 ,mcc $4] , unLoc $3) } | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ - L (comb2 $1 $3) + cL (comb2 $1 $3) ([mj AnnWhere $1] , unLoc $3) } | {- empty -} { noLoc ([],[]) } @@ -2159,8 +2162,8 @@ gadt_constrlist :: { Located ([AddAnn] gadt_constrs :: { Located [LConDecl GhcPs] } : gadt_constr_with_doc ';' gadt_constrs {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr_with_doc { L (gl $1) [$1] } + >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) } + | gadt_constr_with_doc { cL (gl $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -2197,7 +2200,7 @@ allowed in usual data constructors, but not in GADTs). -} constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } - : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] + : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2] ,addConDocs (unLoc $3) $1)} constrs1 :: { Located [LConDecl GhcPs] } @@ -2261,7 +2264,7 @@ They must be kept identical except for their treatment of 'docprev'. constr :: { LConDecl GhcPs } : maybe_docnext forall constr_context '=>' constr_stuff {% ams (let (con,details,doc_prev) = unLoc $5 in - addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con + addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) (Just $3) details)) @@ -2269,7 +2272,7 @@ constr :: { LConDecl GhcPs } (mu AnnDarrow $4:(fst $ unLoc $2)) } | maybe_docnext forall constr_stuff {% ams ( let (con,details,doc_prev) = unLoc $3 in - addConDoc (L (comb2 $2 $3) (mkConDeclH98 con + addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con (snd $ unLoc $2) Nothing -- No context details)) @@ -2297,8 +2300,8 @@ fielddecls1 :: { [LConDeclField GhcPs] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (L (comb2 $2 $4) - (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) + {% ams (cL (comb2 $2 $4) + (ConDeclField noExt (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2316,17 +2319,17 @@ derivings :: { HsDeriving GhcPs } deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt Nothing $2) + in ams (cL full_loc $ HsDerivingClause noExt Nothing $2) [mj AnnDeriving $1] } | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3) + in ams (cL full_loc $ HsDerivingClause noExt (Just $2) $3) [mj AnnDeriving $1] } | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2) + in ams (cL full_loc $ HsDerivingClause noExt (Just $3) $2) [mj AnnDeriving $1] } deriv_clause_types :: { Located [LHsSigType GhcPs] } @@ -2384,11 +2387,11 @@ decl_no_th :: { LHsDecl GhcPs } -- [FunBind vs PatBind] case r of { (FunBind _ n _ _ _) -> - ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind _ (L lh _lhs) _rhs _) -> - ams (L lh ()) [] >> return () } ; + amsL l [mj AnnFunId n] >> return () ; + (PatBind _ (dL->L l _) _rhs _) -> + amsL l [] >> return () } ; - _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; + _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; return $! (sL l $ ValD noExt r) } } | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3; @@ -2398,10 +2401,10 @@ decl_no_th :: { LHsDecl GhcPs } -- [FunBind vs PatBind] case r of { (FunBind _ n _ _ _) -> - ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (L lh _lhs) _rhs _) -> - ams (L lh ()) (fst $2) >> return () } ; - _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); + amsL l (mj AnnFunId n:(fst $2)) >> return () ; + (PatBind _ (dL->L lh _lhs) _rhs _) -> + amsL lh (fst $2) >> return () } ; + _ <- amsL l (ann ++ (fst $ unLoc $3)); return $! (sL l $ ValD noExt r) } } | pattern_synonym_decl { $1 } | docdecl { $1 } @@ -2435,10 +2438,10 @@ sigdecl :: { LHsDecl GhcPs } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp_top '::' sigtypedoc - {% do v <- checkValSigLhs $1 - ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD noExt $ - TypeSig noExt [v] (mkLHsSigWcType $3)) } + {% do { v <- checkValSigLhs $1 + ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] + ; return (sLL $1 $> $ SigD noExt $ + TypeSig noExt [v] (mkLHsSigWcType $3))} } | var ',' sig_vars '::' sigtypedoc {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3)) @@ -2664,15 +2667,15 @@ aexp :: { LHsExpr GhcPs } ams (sLL $1 $> $ HsMultiIf noExt (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (L (comb3 $1 $3 $4) $ + | 'case' exp 'of' altslist {% ams (cL (comb3 $1 $3 $4) $ HsCase noExt $2 (mkMatchGroup FromSource (snd $ unLoc $4))) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } - | 'do' stmtlist {% ams (L (comb2 $1 $2) + | 'do' stmtlist {% ams (cL (comb2 $1 $2) (mkHsDo DoExpr (snd $ unLoc $2))) (mj AnnDo $1:(fst $ unLoc $2)) } - | 'mdo' stmtlist {% ams (L (comb2 $1 $2) + | 'mdo' stmtlist {% ams (cL (comb2 $1 $2) (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp @@ -2687,7 +2690,7 @@ aexp :: { LHsExpr GhcPs } aexp1 :: { LHsExpr GhcPs } : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) (snd $3) - ; _ <- ams (sLL $1 $> ()) (moc $2:mcc $4:(fst $3)) + ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3)) ; checkRecordSyntax (sLL $1 $> r) }} | aexp2 { $1 } @@ -2712,7 +2715,7 @@ aexp2 :: { LHsExpr GhcPs } | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2) (Present noExt $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) @@ -2815,7 +2818,7 @@ tup_exprs :: { ([AddAnn],SumOrTuple) } | commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> L l missingTupArg) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } } | bars texp bars0 { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } @@ -2826,13 +2829,13 @@ commas_tup_tail : commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma tup_tail :: { [LHsTupArg GhcPs] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Present noExt $1)) : snd $2) } - | texp { [L (gl $1) (Present noExt $1)] } + return ((cL (gl $1) (Present noExt $1)) : snd $2) } + | texp { [cL (gl $1) (Present noExt $1)] } | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- @@ -2886,19 +2889,19 @@ pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } : squals '|' pquals {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } - | squals { L (getLoc $1) [reverse (unLoc $1)] } + | squals { cL (getLoc $1) [reverse (unLoc $1)] } squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - ams (sLL $1 $> ()) (fst $ unLoc $3) >> + amsL (comb2 $1 $>) (fst $ unLoc $3) >> return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } | squals ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } + return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) } | qual { sL1 $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } -- | '{|' pquals '|}' { sL1 $1 [$2] } @@ -2927,7 +2930,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- Guards guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } + : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) } guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma @@ -2941,7 +2944,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } - | vocurly alts close { L (getLoc $2) (fst $ unLoc $2 + | vocurly alts close { cL (getLoc $2) (fst $ unLoc $2 ,(reverse (snd $ unLoc $2))) } | '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { noLoc ([],[]) } @@ -3033,7 +3036,7 @@ apats :: { [LPat GhcPs] } stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? - | vocurly stmts close { L (gl $2) (fst $ unLoc $2 + | vocurly stmts close { cL (gl $2) (fst $ unLoc $2 ,reverse $ snd $ unLoc $2) } -- do { ;; s ; s ; ; s ;; } @@ -3254,11 +3257,14 @@ oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mi -- for variable constructor in export lists -- see Note [Type constructors in export list] : qtycon { $1 } - | '(' QCONSYM ')' {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) + | '(' QCONSYM ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' CONSYM ')' {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) + | '(' CONSYM ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' ':' ')' {% let name = sL1 $2 $! consDataCon_RDR + | '(' ':' ')' {% let { name :: Located RdrName + ; name = sL1 $2 $! consDataCon_RDR } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] } @@ -3572,89 +3578,89 @@ maybe_docnext :: { Maybe LHsDocString } happyError :: P a happyError = srcParseFail -getVARID (L _ (ITvarid x)) = x -getCONID (L _ (ITconid x)) = x -getVARSYM (L _ (ITvarsym x)) = x -getCONSYM (L _ (ITconsym x)) = x -getQVARID (L _ (ITqvarid x)) = x -getQCONID (L _ (ITqconid x)) = x -getQVARSYM (L _ (ITqvarsym x)) = x -getQCONSYM (L _ (ITqconsym x)) = x -getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid x)) = x -getCHAR (L _ (ITchar _ x)) = x -getSTRING (L _ (ITstring _ x)) = x -getINTEGER (L _ (ITinteger x)) = x -getRATIONAL (L _ (ITrational x)) = x -getPRIMCHAR (L _ (ITprimchar _ x)) = x -getPRIMSTRING (L _ (ITprimstring _ x)) = x -getPRIMINTEGER (L _ (ITprimint _ x)) = x -getPRIMWORD (L _ (ITprimword _ x)) = x -getPRIMFLOAT (L _ (ITprimfloat x)) = x -getPRIMDOUBLE (L _ (ITprimdouble x)) = x -getTH_ID_SPLICE (L _ (ITidEscape x)) = x -getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x -getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) -getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x - -getDOCNEXT (L _ (ITdocCommentNext x)) = x -getDOCPREV (L _ (ITdocCommentPrev x)) = x -getDOCNAMED (L _ (ITdocCommentNamed x)) = x -getDOCSECTION (L _ (ITdocSection n x)) = (n, x) - -getINTEGERs (L _ (ITinteger (IL src _ _))) = src -getCHARs (L _ (ITchar src _)) = src -getSTRINGs (L _ (ITstring src _)) = src -getPRIMCHARs (L _ (ITprimchar src _)) = src -getPRIMSTRINGs (L _ (ITprimstring src _)) = src -getPRIMINTEGERs (L _ (ITprimint src _)) = src -getPRIMWORDs (L _ (ITprimword src _)) = src +getVARID (dL->L _ (ITvarid x)) = x +getCONID (dL->L _ (ITconid x)) = x +getVARSYM (dL->L _ (ITvarsym x)) = x +getCONSYM (dL->L _ (ITconsym x)) = x +getQVARID (dL->L _ (ITqvarid x)) = x +getQCONID (dL->L _ (ITqconid x)) = x +getQVARSYM (dL->L _ (ITqvarsym x)) = x +getQCONSYM (dL->L _ (ITqconsym x)) = x +getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x +getLABELVARID (dL->L _ (ITlabelvarid x)) = x +getCHAR (dL->L _ (ITchar _ x)) = x +getSTRING (dL->L _ (ITstring _ x)) = x +getINTEGER (dL->L _ (ITinteger x)) = x +getRATIONAL (dL->L _ (ITrational x)) = x +getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x +getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x +getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x +getPRIMWORD (dL->L _ (ITprimword _ x)) = x +getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x +getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x +getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x +getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x +getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x + +getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x +getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x +getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x +getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x) + +getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src +getCHARs (dL->L _ (ITchar src _)) = src +getSTRINGs (dL->L _ (ITstring src _)) = src +getPRIMCHARs (dL->L _ (ITprimchar src _)) = src +getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src +getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src +getPRIMWORDs (dL->L _ (ITprimword src _)) = src -- See Note [Pragma source text] in BasicTypes for the following -getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src -getSPEC_PRAGs (L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (L _ (ITsource_prag src)) = src -getRULES_PRAGs (L _ (ITrules_prag src)) = src -getWARNING_PRAGs (L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (L _ (ITscc_prag src)) = src -getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src -getCORE_PRAGs (L _ (ITcore_prag src)) = src -getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src -getANN_PRAGs (L _ (ITann_prag src)) = src -getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src -getCTYPEs (L _ (ITctype src)) = src +getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src +getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src +getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src +getANN_PRAGs (dL->L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src +getCTYPEs (dL->L _ (ITctype src)) = src getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) isUnicode :: Located Token -> Bool -isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode _ = False hasE :: Located Token -> Bool -hasE (L _ (ITopenExpQuote HasE _)) = True -hasE (L _ (ITopenTExpQuote HasE)) = True +hasE (dL->L _ (ITopenExpQuote HasE _)) = True +hasE (dL->L _ (ITopenTExpQuote HasE)) = True hasE _ = False getSCC :: Located Token -> P FastString @@ -3666,36 +3672,39 @@ getSCC lt = do let s = getSTRING lt else return s -- Utilities for combining source spans -comb2 :: Located a -> Located b -> SrcSpan +comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b -comb3 :: Located a -> Located b -> Located c -> SrcSpan +comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> c -> SrcSpan comb3 a b c = a `seq` b `seq` c `seq` combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) -comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan +comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => + a -> b -> c -> d -> SrcSpan comb4 a b c d = a `seq` b `seq` c `seq` d `seq` (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ combineSrcSpans (getLoc c) (getLoc d)) -- strict constructor version: {-# INLINE sL #-} -sL :: SrcSpan -> a -> Located a -sL span a = span `seq` a `seq` L span a +sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +sL span a = span `seq` a `seq` cL span a -- See Note [Adding location info] for how these utility functions are used -- replaced last 3 CPP macros in this file {-# INLINE sL0 #-} -sL0 :: a -> Located a -sL0 = L noSrcSpan -- #define L0 L noSrcSpan +sL0 :: HasSrcSpan a => SrcSpanLess a -> a +sL0 = cL noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 :: Located a -> b -> Located b +sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} -sLL :: Located a -> Located b -> c -> Located c +sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> SrcSpanLess c -> c sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) {- Note [Adding location info] @@ -3739,7 +3748,7 @@ incorrect. -- try to find the span of the whole file (ToDo). fileSrcSpan :: P SrcSpan fileSrcSpan = do - l <- getSrcLoc; + l <- getRealSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) @@ -3770,7 +3779,7 @@ hintExplicitForall span = do ] -- Hint about explicit-forall, assuming UnicodeSyntax is off -hintExplicitForall' :: SrcSpan -> P (GenLocated SrcSpan RdrName) +hintExplicitForall' :: SrcSpan -> P (Located RdrName) hintExplicitForall' span = do forall <- extension explicitForallEnabled let illegalDot = "Illegal symbol '.' in type" @@ -3786,7 +3795,7 @@ hintExplicitForall' span = do ] checkIfBang :: LHsExpr GhcPs -> Bool -checkIfBang (L _ (HsVar _ (L _ op))) = op == bang_RDR +checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR checkIfBang _ = False -- | Warn about missing space after bang @@ -3803,7 +3812,7 @@ warnSpaceAfterBang span = do -- When two single quotes don't followed by tyvar or gtycon, we report the -- error as empty character literal, or TH quote that missing proper type -- variable or constructor. See Trac #13450. -reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs)) +reportEmptyDoubleQuotes :: SrcSpan -> P (Located (HsExpr GhcPs)) reportEmptyDoubleQuotes span = do thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState if thEnabled @@ -3832,31 +3841,37 @@ in ApiAnnotation.hs -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword itself -mj :: AnnKeywordId -> Located e -> AddAnn +mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn mj a l s = addAnnotation s a (gl l) +mjL :: AnnKeywordId -> SrcSpan -> AddAnn +mjL a l s = addAnnotation s a l + + + -- |Construct an AddAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) +mu a lt@(dL->L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a +gl :: HasSrcSpan a => a -> SrcSpan gl = getLoc -- |Add an annotation to the located element, and return the located -- element as a pass through -aa :: Located a -> (AnnKeywordId,Located c) -> P (Located a) -aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a +aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a +aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a -- |Add an annotation to a located element resulting from a monadic action -am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) +am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a am a (b,s) = do - av@(L l _) <- a + av@(dL->L l _) <- a addAnnotation l b (gl s) return av @@ -3874,26 +3889,25 @@ am a (b,s) = do -- and closing braces if they are used to delimit the let expressions. -- ams :: Located a -> [AddAnn] -> P (Located a) -ams a@(L l _) bs = addAnnsAt l bs >> return a +ams a@(dL->L l _) bs = addAnnsAt l bs >> return a --- |Add all [AddAnn] to an AST element wrapped in a Just -aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a)) -aljs a@(L l _) bs = addAnnsAt l bs >> return a +amsL :: SrcSpan -> [AddAnn] -> P () +amsL sp bs = addAnnsAt sp bs >> return () -- |Add all [AddAnn] to an AST element wrapped in a Just -ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a +ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action -amms :: P (Located a) -> [AddAnn] -> P (Located a) -amms a bs = do { av@(L l _) <- a +amms :: HasSrcSpan a => P a -> [AddAnn] -> P a +amms a bs = do { av@(dL->L l _) <- a ; addAnnsAt l bs ; return av } -- |Add a list of AddAnns to the AST element, and return the element as a -- OrdList -amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) -amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) +amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) +amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) -- |Synonyms for AddAnn versions of AnnOpen and AnnClose mo,mc :: Located Token -> AddAnn @@ -3915,22 +3929,22 @@ mcs ll = mj AnnCloseS ll -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma -- entry for each SrcSpan mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss +mcommas ss = map (mjL AnnCommaTuple) ss -- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar -- entry for each SrcSpan mvbars :: [SrcSpan] -> [AddAnn] -mvbars ss = map (\s -> mj AnnVbar (L s ())) ss +mvbars ss = map (mjL AnnVbar) ss -- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: OrdList (Located a) -> SrcSpan +oll :: HasSrcSpan a => OrdList a -> SrcSpan oll l = if isNilOL l then noSrcSpan else getLoc (lastOL l) -- |Add a semicolon annotation in the right place in a list. If the -- leading list is empty, add it to the tail -asl :: [Located a] -> Located b -> Located a -> P() -asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls -asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls +asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P() +asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 1ac21c6c2d..8c78fb5a0e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} module RdrHsSyn ( mkHsOpApp, @@ -36,8 +37,8 @@ module RdrHsSyn ( mkImport, parseCImport, mkExport, - mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkConDeclH98, mkATDefault, @@ -136,10 +137,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -- *** See Note [The Naming story] in HsDecls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (L loc d) = L loc (TyClD noExt d) +mkTyClD (dL->L loc d) = cL loc (TyClD noExt d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (L loc d) = L loc (InstD noExt d) +mkInstD (dL->L loc d) = cL loc (InstD noExt d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -147,7 +148,7 @@ mkClassDecl :: SrcSpan -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) -mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls +mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr @@ -155,14 +156,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts ; sequence_ anns - ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt - , tcdLName = cls, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdFDs = snd (unLoc fds) - , tcdSigs = mkClassOpSigs sigs - , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs - , tcdDocs = docs })) } + ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } mkATDefault :: LTyFamInstDecl GhcPs -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ()) @@ -175,20 +176,22 @@ mkATDefault :: LTyFamInstDecl GhcPs -- The @P ()@ we return corresponds represents an action which will add -- some necessary paren annotations to the parsing context. Naturally, this -- is not something that the "Convert" use cares about. -mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) +mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats , feqn_fixity = fixity, feqn_rhs = rhs } <- e = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats - ; let f = L loc (FamEqn { feqn_ext = noExt - , feqn_tycon = tc - , feqn_bndrs = ASSERT( isNothing bndrs ) - Nothing - , feqn_pats = tvs - , feqn_fixity = fixity - , feqn_rhs = rhs }) + ; let f = cL loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc + , feqn_bndrs = ASSERT( isNothing bndrs ) + Nothing + , feqn_pats = tvs + , feqn_fixity = fixity + , feqn_rhs = rhs }) ; pure (f, anns) } -mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" -mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" +mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" +mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" +mkATDefault _ = panic "mkATDefault: Impossible Match" + -- due to #15884 mkTyData :: SrcSpan -> NewOrData @@ -198,15 +201,16 @@ mkTyData :: SrcSpan -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) + ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdDExt = noExt, - tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn })) } + ; return (cL loc (DataDecl { tcdDExt = noExt, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) @@ -234,10 +238,10 @@ mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams - ; return (L loc (SynDecl { tcdSExt = noExt - , tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs })) } + ; return (cL loc (SynDecl { tcdSExt = noExt + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] -> LHsType GhcPs @@ -257,16 +261,18 @@ mkTyFamInstEqn bndrs lhs rhs mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> Located (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs) + -> Located ( Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] + , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LInstDecl GhcPs) -mkDataFamInst loc new_or_data cType (L _ (mcxt, bndrs, tycl_hdr)) ksig data_cons maybe_deriv +mkDataFamInst loc new_or_data cType (dL->L _ (mcxt, bndrs, tycl_hdr)) + ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs + ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs (FamEqn { feqn_ext = noExt , feqn_tycon = tc , feqn_bndrs = bndrs @@ -278,7 +284,7 @@ mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn - = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn))) + = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -290,7 +296,7 @@ mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams - ; return (L loc (FamDecl noExt (FamilyDecl + ; return (cL loc (FamDecl noExt (FamilyDecl { fdExt = noExt , fdInfo = info, fdLName = tc , fdTyVars = tyvars @@ -313,15 +319,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 -mkSpliceDecl lexpr@(L loc expr) +mkSpliceDecl lexpr@(dL->L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice) + = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice) + = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) | otherwise - = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr)) + = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan @@ -330,21 +336,25 @@ mkRoleAnnotDecl :: SrcSpan -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles - ; return $ L loc $ RoleAnnotDecl noExt tycon roles' } + ; return $ cL loc $ RoleAnnotDecl noExt tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type possible_roles = [(fsFromRole role, role) | role <- all_roles] - parse_role (L loc_role Nothing) = return $ L loc_role Nothing - parse_role (L loc_role (Just role)) + parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing + parse_role (dL->L loc_role (Just role)) = case lookup role possible_roles of - Just found_role -> return $ L loc_role $ Just found_role + Just found_role -> return $ cL loc_role $ Just found_role Nothing -> - let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in + let nearby = fuzzyLookup (unpackFS role) + (mapFst unpackFS possible_roles) + in parseErrorSDoc loc_role (text "Illegal role name" <+> quotes (ppr role) $$ suggestions nearby) + parse_role _ = panic "parse_role: Impossible Match" + -- due to #15884 suggestions [] = empty suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) @@ -369,14 +379,16 @@ cvTopDecls decls = go (fromOL decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] - go (L l (ValD x b) : ds) = L l' (ValD x b') : go ds' - where (L l' b', ds') = getMonoBind (L l b) ds - go (d : ds) = d : go ds + go ((dL->L l (ValD x b)) : ds) + = cL l' (ValD x b') : go ds' + where (dL->L l' b', ds') = getMonoBind (cL l b) ds + go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding + = do { (mbs, sigs, fam_ds, tfam_insts + , dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) return $ ValBinds noExt mbs sigs } @@ -389,24 +401,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs) cvBindsAndSigs fb = go (fromOL fb) where go [] = return (emptyBag, [], [], [], [], []) - go (L l (ValD _ b) : ds) + go ((dL->L l (ValD _ b)) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } where - (b', ds') = getMonoBind (L l b) ds - go (L l decl : ds) + (b', ds') = getMonoBind (cL l b) ds + go ((dL->L l decl) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds ; case decl of SigD _ s - -> return (bs, L l s : ss, ts, tfis, dfis, docs) + -> return (bs, cL l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) - -> return (bs, ss, L l t : ts, tfis, dfis, docs) + -> return (bs, ss, cL l t : ts, tfis, dfis, docs) InstD _ (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) + -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) InstD _ (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) + -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) DocD _ d - -> return (bs, ss, ts, tfis, dfis, L l d : docs) + -> return (bs, ss, ts, tfis, dfis, cL l d : docs) SpliceD _ d -> parseErrorSDoc l $ hang (text "Declaration splices are allowed only" <+> @@ -432,23 +444,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), - fun_matches - = MG { mg_alts = L _ mtchs1 } })) binds +getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) + , fun_matches = + MG { mg_alts = (dL->L _ mtchs1) } })) + binds | has_args mtchs1 = go mtchs1 loc1 binds [] where go mtchs loc - (L loc2 (ValD _ (FunBind { fun_id = L _ f2, - fun_matches - = MG { mg_alts = L _ mtchs2 } })) : binds) _ + ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) + , fun_matches = + MG { mg_alts = (dL->L _ mtchs2) } }))) + : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls + go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls in go mtchs (combineSrcSpans loc loc2) binds doc_decls' go mtchs loc binds doc_decls - = ( L loc (makeFunBind fun_id1 (reverse mtchs)) + = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) , (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order -- Do the same thing with the trailing doc comments @@ -457,12 +471,13 @@ getMonoBind bind binds = (bind, binds) has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = panic "RdrHsSyn:has_args" -has_args ((L _ (Match { m_pats = args })) : _) = not (null args) +has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). -has_args ((L _ (XMatch _)) : _) = panic "has_args" +has_args ((dL->L _ (XMatch _)) : _) = panic "has_args" +has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 {- ********************************************************************** @@ -554,7 +569,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) - = return (L loc (setRdrNameSpace tc srcDataName)) + = return (cL loc (setRdrNameSpace tc srcDataName)) | otherwise = Left (loc, msg $$ extra) @@ -569,13 +584,13 @@ tyConToDataCon loc tc mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = +mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where - fromDecl (L loc decl@(ValD _ (PatBind _ - pat@(L _ (ConPatIn ln@(L _ name) details)) + fromDecl (dL->L loc decl@(ValD _ (PatBind _ + pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl @@ -584,18 +599,22 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where - ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict } + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict } InfixCon p1 p2 -> return $ Match { m_ext = noExt , m_ctxt = ctxt , m_pats = [p1, p2] , m_grhss = rhs } where - ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict } + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Infix + , mc_strictness = NoSrcStrict } RecCon{} -> recordPatSynErr loc pat - ; return $ L loc match } - fromDecl (L loc decl) = extraDeclErr loc decl + ; return $ cL loc match } + fromDecl (dL->L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = parseErrorSDoc loc $ @@ -603,9 +622,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = ppr decl wrongNameBindingErr loc decl = - parseErrorSDoc loc $ - text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> - quotes (ppr patsyn_name) $$ ppr decl + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" + <+> quotes (ppr patsyn_name) $$ ppr decl wrongNumberErr loc = parseErrorSDoc loc $ @@ -639,7 +658,7 @@ mkGadtDecl :: [Located RdrName] mkGadtDecl names ty = (ConDeclGADT { con_g_ext = noExt , con_names = names - , con_forall = L l $ isLHsForAllTy ty' + , con_forall = cL l $ isLHsForAllTy ty' , con_qvars = mkHsQTvs tvs , con_mb_cxt = mcxt , con_args = args' @@ -647,24 +666,27 @@ mkGadtDecl names ty , con_doc = Nothing } , anns1 ++ anns2) where - (ty'@(L l _),anns1) = peel_parens ty [] + (ty'@(dL->L l _),anns1) = peel_parens ty [] (tvs, rho) = splitLHsForAllTy ty' (mcxt, tau, anns2) = split_rho rho [] - split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann - = (Just cxt, tau, ann) - split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l) - split_rho tau ann = (Nothing, tau, ann) + split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann + = (Just cxt, tau, ann) + split_rho (dL->L l (HsParTy _ ty)) ann + = split_rho ty (ann++mkParensApiAnn l) + split_rho tau ann + = (Nothing, tau, ann) (args, res_ty) = split_tau tau args' = nudgeHsSrcBangs args -- See Note [GADT abstract syntax] in HsDecls - split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) - = (RecCon (L loc rf), res_ty) - split_tau tau = (PrefixCon [], tau) + split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) + = (RecCon (cL loc rf), res_ty) + split_tau tau + = (PrefixCon [], tau) - peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty + peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty (ann++mkParensApiAnn l) peel_parens ty ann = (ty, ann) @@ -685,8 +707,8 @@ nudgeHsSrcBangs details RecCon r -> RecCon r InfixCon a1 a2 -> InfixCon (go a1) (go a2) where - go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) = - L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds))) + go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) = + cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds))) go lty = lty @@ -811,24 +833,29 @@ checkTyVars pp_what equals_or_where tc tparms -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ()) - chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty + chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l + ++ acc) ty chkParens acc ty = case chk ty of Left err -> Left err - Right tv@(L l _) -> Right (tv, addAnnsAt l (reverse acc)) + Right tv@(dL->L l _) -> Right (tv, addAnnsAt l (reverse acc)) -- Check that the name space is correct! - chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) - | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k)) - chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv))) - chk t@(L loc _) + chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) + | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) + chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) + | isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv))) + chk t@(dL->L loc _) = Left (loc, vcat [ text "Unexpected type" <+> quotes (ppr t) - , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc' - , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form")) - , nest 2 (pp_what <+> tc' - <+> hsep (map text (takeList tparms allNameStrings)) - <+> equals_or_where) ] ]) + , text "In the" <+> pp_what + <+> ptext (sLit "declaration for") <+> quotes tc' + , vcat[ (text "A" <+> pp_what + <+> ptext (sLit "declaration should have form")) + , nest 2 + (pp_what + <+> tc' + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) -- Avoid printing a constraint tuple in the error message. Print -- a plain old tuple instead (since that's what the user probably @@ -844,7 +871,7 @@ equalsDots = text "= ..." checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () -checkDatatypeContext (Just (L loc c)) +checkDatatypeContext (Just (dL->L loc c)) = do allowed <- extension datatypeContextsEnabled unless allowed $ parseErrorSDoc loc @@ -859,39 +886,42 @@ data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v - cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExt v (mkLHsSigWcType sig) + cvt_one (RuleTyTmVar v (Just sig)) = + RuleBndrSig noExt v (mkLHsSigWcType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] mkRuleTyVarBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v) - cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExt (fmap tm_to_ty v) sig - -- takes something in namespace 'varName' to something in namespace 'tvName' + cvt_one (RuleTyTmVar v (Just sig)) + = KindedTyVar noExt (fmap tm_to_ty v) sig + -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (L loc (Unqual occ)) = do + where check (dL->L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) - (parseErrorSDoc loc (text $ "parse error on input " ++ occNameString occ)) + (parseErrorSDoc loc (text $ "parse error on input " + ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: Outputable a => Located a -> P (Located a) -checkRecordSyntax lr@(L loc r) +checkRecordSyntax lr@(dL->L loc r) = do allowed <- extension traditionalRecordSyntaxEnabled if allowed then return lr else parseErrorSDoc loc - (text "Illegal record syntax (use TraditionalRecordSyntax):" <+> - ppr r) + (text "Illegal record syntax (use TraditionalRecordSyntax):" + <+> ppr r) -- | Check if the gadt_constrlist is empty. Only raise parse error for -- `data T where` to avoid affecting existing error message, see #8258. checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) -checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. +checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. = do opts <- fmap options getPState if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax then return gadts @@ -916,28 +946,28 @@ checkTyClHdr :: Bool -- True <=> class header checkTyClHdr is_cls ty = goL ty [] [] Prefix where - goL (L l ty) acc ann fix = go l ty acc ann fix + goL (dL->L l ty) acc ann fix = go l ty acc ann fix -- workaround to define '*' despite StarIsType - go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix + go _ (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix = do { warnStarBndr l ; let name = mkOccName tcClsName (if isUni then "★" else "*") - ; return (L l (Unqual name), acc, fix, ann) } + ; return (cL l (Unqual name), acc, fix, ann) } - go l (HsTyVar _ _ (L _ tc)) acc ann fix - | isRdrTc tc = return (L l tc, acc, fix, ann) - go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix + go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix + | isRdrTc tc = return (cL l tc, acc, fix, ann) + go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (L l (nameRdrName tup_name), ts, fix, ann) + = return (cL l (nameRdrName tup_name), ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity | otherwise = getName (tupleTyCon Boxed arity) - -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) + -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) go l _ _ _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) @@ -975,22 +1005,22 @@ checkBlockArguments expr = case unLoc expr of -- (((Eq a))) --> [Eq a] -- @ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (L l orig_t) - = check [] (L l orig_t) +checkContext (dL->L l orig_t) + = check [] (cL l orig_t) where - check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. - = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () + = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () - check anns (L lp1 (HsParTy _ ty)) + check anns (dL->L lp1 (HsParTy _ ty)) -- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns else (anns ++ mkParensApiAnn lp1) -- no need for anns, returning original - check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t]) + check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) msg = text "data constructor context" @@ -999,8 +1029,8 @@ checkContext (L l orig_t) checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs msg ty = go ty where - go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 - go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep + go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 + go (dL->L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep [ text "Unexpected haddock", quotes (ppr ds) , text "on", msg, quotes (ppr t) ] go _ = pure () @@ -1018,12 +1048,12 @@ checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs] checkPatterns msg es = mapM (checkPattern msg) es checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) -checkLPat msg e@(L l _) = checkPat msg l e [] +checkLPat msg e@(dL->L l _) = checkPat msg l e [] checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs) -checkPat _ loc (L l e@(HsVar _ (L _ c))) args - | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) +checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args + | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) | not (null args) && patIsRec c = patFail (text "Perhaps you intended to use RecursiveDo") l e checkPat msg loc e args -- OK to let this happen even if bang-patterns @@ -1032,12 +1062,12 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns | Just (e', args') <- splitBang e = do { args'' <- checkPatterns msg args' ; checkPat msg loc e' (args'' ++ args) } -checkPat msg loc (L _ (HsApp _ f e)) args +checkPat msg loc (dL->L _ (HsApp _ f e)) args = do p <- checkLPat msg e checkPat msg loc f (p : args) -checkPat msg loc (L _ e) [] +checkPat msg loc (dL->L _ e) [] = do p <- checkAPat msg loc e - return (L loc p) + return (cL loc p) checkPat msg loc e _ = patFail msg loc (unLoc e) @@ -1049,18 +1079,19 @@ checkAPat msg loc e0 = do EWildPat _ -> return (WildPat noExt) HsVar _ x -> return (VarPat noExt x) HsLit _ (HsStringPrim _ _) -- (#13260) - -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) + -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" + $$ ppr e0) HsLit _ l -> return (LitPat noExt l) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing) - NegApp _ (L l (HsOverLit _ pos_lit)) _ - -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) + HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) + NegApp _ (dL->L l (HsOverLit _ pos_lit)) _ + -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr)) - SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x) + SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) | bang == bang_RDR -> do { hintBangPat loc e0 ; e' <- checkLPat msg e @@ -1076,16 +1107,16 @@ checkAPat msg loc e0 = do return (SigPat noExt e t) -- n+k patterns - OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus))) - (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) + (dL->L _ (HsVar _ (dL->L _ plus))) + (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - - OpApp _ l (L cl (HsVar _ (L _ c))) r + -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) + OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r | isDataOcc (rdrNameOcc c) -> do l <- checkLPat msg l r <- checkLPat msg r - return (ConPatIn (L cl c) (InfixCon l r)) + return (ConPatIn (cL cl c) (InfixCon l r)) OpApp {} -> patFail msg loc e0 @@ -1096,9 +1127,10 @@ checkAPat msg loc e0 = do ExplicitTuple _ es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) - [e | L _ (Present _ e) <- es] + [e | (dL->L _ (Present _ e)) <- es] return (TuplePat noExt ps b) - | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) + | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" + $$ ppr e0) ExplicitSum _ alt arity expr -> do p <- checkLPat msg expr @@ -1113,7 +1145,8 @@ checkAPat msg loc e0 = do placeHolderPunRhs :: LHsExpr GhcPs -- The RHS of a punned record field will be filled in by the renamer --- It's better not to make it an error, in case we want to print it when debugging +-- It's better not to make it an error, in case we want to print it when +-- debugging placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) plus_RDR, bang_RDR, pun_RDR :: RdrName @@ -1123,8 +1156,8 @@ pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs) -> P (LHsRecField GhcPs (LPat GhcPs)) -checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) - return (L l (fld { hsRecFieldArg = p })) +checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) + return (cL l (fld { hsRecFieldArg = p })) patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a patFail msg loc e = parseErrorSDoc loc err @@ -1147,15 +1180,15 @@ checkValDef :: SDoc checkValDef msg _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding - = checkPatBind msg (L (combineLocs lhs sig) + = checkPatBind msg (cL (combineLocs lhs sig) (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss -checkValDef msg strictness lhs Nothing g@(L l (_,grhss)) +checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> checkFunBind msg strictness ann (getLoc lhs) - fun is_infix pats (L l grhss) + fun is_infix pats (cL l grhss) Nothing -> checkPatBind msg lhs g } checkFunBind :: SDoc @@ -1167,18 +1200,19 @@ checkFunBind :: SDoc -> [LHsExpr GhcPs] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) +checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) = do ps <- checkPatterns msg pats let match_span = combineSrcSpans lhs_loc rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun - [L match_span (Match { m_ext = noExt - , m_ctxt = FunRhs { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) + [cL match_span (Match { m_ext = noExt + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. @@ -1196,18 +1230,18 @@ checkPatBind :: SDoc -> LHsExpr GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkPatBind msg lhs (L _ (_,grhss)) +checkPatBind msg lhs (dL->L _ (_,grhss)) = do { lhs <- checkPattern msg lhs ; return ([],PatBind noExt lhs grhss ([],[])) } checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) +checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr -checkValSigLhs lhs@(L l _) +checkValSigLhs lhs@(dL->L l _) = parseErrorSDoc l ((text "Invalid type signature:" <+> ppr lhs <+> text ":: ...") $$ text hint) @@ -1223,9 +1257,10 @@ checkValSigLhs lhs@(L l _) -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 - -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar _ (L _ v))) = v == s - looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs + -- Sadly 'foreign import' still barfs 'parse error' because + -- 'import' is a keyword + looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s + looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") @@ -1259,13 +1294,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- not be any OpApps inside the e's splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg)) - | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns) +splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg)) + | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) where l' = combineLocs bang arg1 (arg1,argns) = split_bang r_arg [] - split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es) - split_bang e es = (e,es) + split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang e es = (e,es) splitBang _ = Nothing -- See Note [isFunLhs vs mergeDataCon] @@ -1285,47 +1320,47 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (L loc (HsVar _ (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) - go (L _ (HsApp _ f e)) es ann = go f (e:es) ann - go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (dL->L loc (HsVar _ (dL->L _ f))) es ann + | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) + go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann + go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var))))) - [] ann + go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) + (dL->L l (HsVar _ (L _ var))))) [] ann | bang == bang_RDR - , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann)) - - -- For infix function defns, there should be only one infix *function* - -- (though there may be infix *datacons* involved too). So we don't - -- need fixity info to figure out which function is being defined. - -- a `K1` b `op` c `K2` d - -- must parse as - -- (a `K1` b) `op` (c `K2` d) - -- The renamer checks later that the precedences would yield such a parse. - -- - -- There is a complication to deal with bang patterns. - -- - -- ToDo: what about this? - -- x + 1 `op` y = ... - - go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann + , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) + + -- For infix function defns, there should be only one infix *function* + -- (though there may be infix *datacons* involved too). So we don't + -- need fixity info to figure out which function is being defined. + -- a `K1` b `op` c `K2` d + -- must parse as + -- (a `K1` b) `op` (c `K2` d) + -- The renamer checks later that the precedences would yield such a parse. + -- + -- There is a complication to deal with bang patterns. + -- + -- ToDo: what about this? + -- x + 1 `op` y = ... + + go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann - else return (Just (L loc' op, Infix, (l:r:es), ann)) } + else return (Just (cL loc' op, Infix, (l:r:es), ann)) } -- No bangs; behave just like the next case | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), ann)) + = return (Just (cL loc' op, Infix, (l:r:es), ann)) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = L loc (OpApp noExt k - (L loc' (HsVar noExt (L loc' op))) r) + op_app = cL loc (OpApp noExt k + (cL loc' (HsVar noExt (cL loc' op))) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1355,20 +1390,20 @@ pStrictMark -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} , [AddAnn] , [Located TyEl] {- remaining TyEl -}) -pStrictMark (L l1 x1 : L l2 x2 : xs) +pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) | Just (strAnnId, str) <- tyElStrictness x1 , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 - = Just ( L (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) + = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) , unpkAnns ++ [\s -> addAnnotation s strAnnId l1] , xs ) -pStrictMark (L l x1 : xs) +pStrictMark ((dL->L l x1) : xs) | Just (strAnnId, str) <- tyElStrictness x1 - = Just ( L l (HsSrcBang NoSourceText NoSrcUnpack str) + = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) , [\s -> addAnnotation s strAnnId l] , xs ) -pStrictMark (L l x1 : xs) +pStrictMark ((dL->L l x1) : xs) | TyElUnpackedness (anns, prag, unpk) <- x1 - = Just ( L l (HsSrcBang prag unpk NoSrcStrict) + = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) , anns , xs ) pStrictMark _ = Nothing @@ -1380,13 +1415,13 @@ pBangTy , LHsType GhcPs {- the resulting BangTy -} , P () {- add annotations -} , [Located TyEl] {- remaining TyEl -}) -pBangTy lt@(L l1 _) xs = +pBangTy lt@(dL->L l1 _) xs = case pStrictMark xs of Nothing -> (False, lt, pure (), xs) - Just (L l2 strictMark, anns, xs') -> + Just (dL->L l2 strictMark, anns, xs') -> let bl = combineSrcSpans l1 l2 bt = HsBangTy noExt strictMark lt - in (True, L bl bt, addAnnsAt bl anns, xs') + in (True, cL bl bt, addAnnsAt bl anns, xs') -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a type. @@ -1401,8 +1436,8 @@ pBangTy lt@(L l1 _) xs = -- -- See Note [Parsing data constructors is hard] mergeOps :: [Located TyEl] -> P (LHsType GhcPs) -mergeOps (L l1 (TyElOpd t) : xs) - | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs +mergeOps ((dL->L l1 (TyElOpd t)) : xs) + | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs , null xs' -- We accept a BangTy only when there are no preceding TyEl. = addAnns >> return t' mergeOps all_xs = go (0 :: Int) [] id all_xs @@ -1412,14 +1447,14 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [unpk]: -- handle (NO)UNPACK pragmas - go k acc ops_acc (L l (TyElUnpackedness (anns, unpkSrc, unpk)):xs) = + go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = if not (null acc) && null xs then do { let a = ops_acc (mergeAcc acc) strictMark = HsSrcBang unpkSrc unpk NoSrcStrict bl = combineSrcSpans l (getLoc a) bt = HsBangTy noExt strictMark a ; addAnnsAt bl anns - ; return (L bl bt) } + ; return (cL bl bt) } else parseErrorSDoc l unpkError where unpkSDoc = case unpkSrc of @@ -1434,57 +1469,63 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [doc]: -- we do not expect to encounter any docs - go _ _ _ (L l (TyElDocPrev _):_) = + go _ _ _ ((dL->L l (TyElDocPrev _)):_) = failOpDocPrev l -- to improve error messages, we do a bit of guesswork to determine if the -- user intended a '!' or a '~' as a strictness annotation - go k acc ops_acc (L l x : xs) + go k acc ops_acc ((dL->L l x) : xs) | Just (_, str) <- tyElStrictness x , let guess [] = True - guess (L _ (TyElOpd _):_) = False - guess (L _ (TyElOpr _):_) = True - guess (L _ (TyElTilde):_) = True - guess (L _ (TyElBang):_) = True - guess (L _ (TyElUnpackedness _):_) = True - guess (L _ (TyElDocPrev _):xs') = guess xs' + guess ((dL->L _ (TyElOpd _)):_) = False + guess ((dL->L _ (TyElOpr _)):_) = True + guess ((dL->L _ (TyElTilde)):_) = True + guess ((dL->L _ (TyElBang)):_) = True + guess ((dL->L _ (TyElUnpackedness _)):_) = True + guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' + guess _ = panic "mergeOps.go.guess: Impossible Match" + -- due to #15884 in guess xs = if not (null acc) && (k > 1 || length acc > 1) - then failOpStrictnessCompound (L l str) (ops_acc (mergeAcc acc)) - else failOpStrictnessPosition (L l str) + then failOpStrictnessCompound (cL l str) (ops_acc (mergeAcc acc)) + else failOpStrictnessPosition (cL l str) -- clause [opr]: -- when we encounter an operator, we must have accumulated -- something for its rhs, and there must be something left -- to build its lhs. - go k acc ops_acc (L l (TyElOpr op):xs) = + go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = if null acc || null (filter isTyElOpd xs) - then failOpFewArgs (L l op) + then failOpFewArgs (cL l op) else do { let a = mergeAcc acc - ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs } + ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc a)) xs } where - isTyElOpd (L _ (TyElOpd _)) = True + isTyElOpd (dL->L _ (TyElOpd _)) = True isTyElOpd _ = False -- clause [opr.1]: interpret 'TyElTilde' as an operator - go k acc ops_acc (L l TyElTilde:xs) = + go k acc ops_acc ((dL->L l TyElTilde):xs) = let op = eqTyCon_RDR - in go k acc ops_acc (L l (TyElOpr op):xs) + in go k acc ops_acc (cL l (TyElOpr op):xs) -- clause [opr.2]: interpret 'TyElBang' as an operator - go k acc ops_acc (L l TyElBang:xs) = + go k acc ops_acc ((dL->L l TyElBang):xs) = let op = mkUnqual tcClsName (fsLit "!") - in go k acc ops_acc (L l (TyElOpr op):xs) + in go k acc ops_acc (cL l (TyElOpr op):xs) -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator - go k acc ops_acc (L l (TyElOpd a):xs) = go k (L l a:acc) ops_acc xs + go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (cL l a:acc) ops_acc xs -- clause [end]: -- See Note [Non-empty 'acc' in mergeOps clause [end]] go _ acc ops_acc [] = return (ops_acc (mergeAcc acc)) + go _ _ _ _ = panic "mergeOps.go: Impossible Match" + -- due to #15884 + + mergeAcc [] = panic "mergeOps.mergeAcc: empty input" mergeAcc (x:xs) = mkHsAppTys x xs @@ -1542,12 +1583,12 @@ Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause -} pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) -pInfixSide (L l (TyElOpd t):xs) - | (True, t', addAnns, xs') <- pBangTy (L l t) xs +pInfixSide ((dL->L l (TyElOpd t)):xs) + | (True, t', addAnns, xs') <- pBangTy (cL l t) xs = Just (t', addAnns, xs') -pInfixSide (L l1 (TyElOpd t1):xs1) = go [L l1 t1] xs1 +pInfixSide ((dL->L l1 (TyElOpd t1)):xs1) = go [cL l1 t1] xs1 where - go acc (L l (TyElOpd t):xs) = go (L l t:acc) xs + go acc ((dL->L l (TyElOpd t)):xs) = go (cL l t:acc) xs go acc xs = Just (mergeAcc acc, pure (), xs) mergeAcc [] = panic "pInfixSide.mergeAcc: empty input" mergeAcc (x:xs) = mkHsAppTys x xs @@ -1556,8 +1597,8 @@ pInfixSide _ = Nothing pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) pDocPrev = go Nothing where - go mTrailingDoc (L l (TyElDocPrev doc):xs) = - go (mTrailingDoc `mplus` Just (L l doc)) xs + go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = + go (mTrailingDoc `mplus` Just (cL l doc)) xs go mTrailingDoc xs = (mTrailingDoc, xs) orErr :: Maybe a -> b -> Either b a @@ -1655,7 +1696,7 @@ mergeDataCon all_xs = -- A -- ^ Comment on A -- B -- ^ Comment on B (singleDoc == False) singleDoc = isJust mTrailingDoc && - null [ () | L _ (TyElDocPrev _) <- all_xs' ] + null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. @@ -1677,36 +1718,36 @@ mergeDataCon all_xs = trailingFieldDoc | singleDoc = Nothing | otherwise = mTrailingDoc - goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } - goFirst (L l (TyElOpd (HsRecTy _ fields)):xs) + goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) | (mConDoc, xs') <- pDocPrev xs - , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs' + , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' = do { data_con <- tyConToDataCon l' tc ; let mDoc = mTrailingDoc `mplus` mConDoc - ; return (pure (), (data_con, RecCon (L l fields), mDoc)) } - goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] + ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } + goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () - , ( L l (getRdrName (tupleDataCon Boxed (length ts))) + , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) , PrefixCon ts , mTrailingDoc ) ) - goFirst (L l (TyElOpd t):xs) - | (_, t', addAnns, xs') <- pBangTy (L l t) xs + goFirst ((dL->L l (TyElOpd t)):xs) + | (_, t', addAnns, xs') <- pBangTy (cL l t) xs = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' goFirst xs = go (pure ()) mTrailingDoc [] xs - go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } - go addAnns mLastDoc ts (L l (TyElDocPrev doc):xs) = - go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs - go addAnns mLastDoc ts (L l (TyElOpd t):xs) - | (_, t', addAnns', xs') <- pBangTy (L l t) xs + go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = + go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs + go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) + | (_, t', addAnns', xs') <- pBangTy (cL l t) xs , t'' <- mkLHsDocTyMaybe t' mLastDoc = go (addAnns >> addAnns') Nothing (t'':ts) xs' - go _ _ _ (L _ (TyElOpr _):_) = + go _ _ _ ((dL->L _ (TyElOpr _)):_) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix @@ -1723,7 +1764,7 @@ mergeDataCon all_xs = ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr ; let (mOpDoc, xs2) = pDocPrev xs1 ; (op, xs3) <- case xs2 of - L l (TyElOpr op) : xs3 -> + (dL->L l (TyElOpr op)) : xs3 -> do { data_con <- tyConToDataCon l op ; return (data_con, xs3) } _ -> Left malformedErr @@ -1764,7 +1805,7 @@ checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs) checkCommand lc = locMap checkCmd lc locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) -locMap f (L l a) = f l a >>= (\b -> return $ L l b) +locMap f (dL->L l a) = f l a >>= (\b -> return $ cL l b) checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) checkCmd _ (HsArrApp _ e1 e2 haat b) = @@ -1785,16 +1826,16 @@ checkCmd _ (HsIf _ cf ep et ee) = do return $ HsCmdIf noExt cf ep pt pe checkCmd _ (HsLet _ lb e) = checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c) -checkCmd _ (HsDo _ DoExpr (L l stmts)) = +checkCmd _ (HsDo _ DoExpr (dL->L l stmts)) = mapM checkCmdLStmt stmts >>= - (\ss -> return $ HsCmdDo noExt (L l ss) ) + (\ss -> return $ HsCmdDo noExt (cL l ss) ) checkCmd _ (OpApp _ eLeft op eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop noExt c1 - arg2 = L (getLoc c2) $ HsCmdTop noExt c2 + let arg1 = cL (getLoc c1) $ HsCmdTop noExt c1 + arg2 = cL (getLoc c2) $ HsCmdTop noExt c2 return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e @@ -1818,9 +1859,10 @@ checkCmdStmt l stmt = cmdStmtFail l stmt checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> P (MatchGroup GhcPs (LHsCmd GhcPs)) -checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do +checkCmdMatchGroup mg@(MG { mg_alts = (dL->L l ms) }) = do ms' <- mapM (locMap $ const convert) ms - return $ mg { mg_ext = noExt, mg_alts = L l ms' } + return $ mg { mg_ext = noExt + , mg_alts = cL l ms' } where convert match@(Match { m_grhss = grhss }) = do grhss' <- checkCmdGRHSs grhss return $ match { m_ext = noExt, m_grhss = grhss'} @@ -1858,7 +1900,7 @@ checkPrecP :: Located (SourceText,Int) -- ^ precedence -> Located (OrdList (Located RdrName)) -- ^ operators -> P () -checkPrecP (L l (_,i)) (L _ ol) +checkPrecP (dL->L l (_,i)) (dL->L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) @@ -1872,10 +1914,10 @@ mkRecConstrOrUpdate -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) -> P (HsExpr GhcPs) -mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c - = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) + = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp@(dL->L l _) _ (fs,dd) | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) @@ -1891,13 +1933,16 @@ mkRdrRecordCon con flds mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } -mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } +mk_rec_fields fs True = HsRecFields { rec_flds = fs + , rec_dotdot = Just (length fs) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) +mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExt rdr)) arg pun -mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _) +mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _) = panic "mk_rec_upd_field" +mk_rec_upd_field (HsRecField _ _ _) + = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -1927,12 +1972,12 @@ mkImport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = - case cconv of - L _ CCallConv -> mkCImport - L _ CApiConv -> mkCImport - L _ StdCallConv -> mkCImport - L _ PrimCallConv -> mkOtherImport - L _ JavaScriptCallConv -> mkOtherImport + case unLoc cconv of + CCallConv -> mkCImport + CApiConv -> mkCImport + StdCallConv -> mkCImport + PrimCallConv -> mkOtherImport + JavaScriptCallConv -> mkOtherImport where -- Parse a C-like entity string of the following form: -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" @@ -1940,7 +1985,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = -- name (cf section 8.5.1 in Haskell 2010 report). mkCImport = do let e = unpackFS entity - case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of + case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> returnSpec importSpec @@ -1952,7 +1997,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) + importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) returnSpec spec = return $ ForD noExt $ ForeignImport { fd_i_ext = noExt @@ -1997,20 +2042,21 @@ parseCImport cconv safety nm str sourceText = mk h n = CImport cconv safety h n sourceText - hdr_char c = not (isSpace c) -- header files are filenames, which can contain - -- pretty much any char (depending on the platform), - -- so just accept any non-space character + hdr_char c = not (isSpace c) + -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character id_first_char c = isAlpha c || c == '_' id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ (do isFun <- case cconv of - L _ CApiConv -> + +++ (do isFun <- case unLoc cconv of + CApiConv -> option True (do token "value" skipSpaces return False) - _ -> return True + _ -> return True cid' <- cid return (CFunction (StaticTarget NoSourceText cid' Nothing isFun))) @@ -2026,11 +2072,11 @@ parseCImport cconv safety nm str sourceText = mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) -mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) +mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) = return $ ForD noExt $ ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) - (L le esrc) } + , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) + (cL le esrc) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -2057,16 +2103,16 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcWildcard mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (L l specname) subs = +mkModuleImpExp (dL->L l specname) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExt (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExt . L l <$> nameT - ImpExpAll -> IEThingAll noExt . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) []) - <$> nameT + -> return $ IEVar noExt (cL l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExt . cL l <$> nameT + ImpExpAll -> IEThingAll noExt . cL l <$> nameT + ImpExpList xs -> + (\newName -> IEThingWith noExt (cL l newName) + NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- extension patternSynonymsEnabled if allowed @@ -2076,7 +2122,8 @@ mkModuleImpExp (L l specname) subs = (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExt (L l newName) pos ies []) <$> nameT + -> IEThingWith noExt (cL l newName) pos ies []) + <$> nameT else parseErrorSDoc l (text "Illegal export form (use PatternSynonyms to enable)") where @@ -2087,8 +2134,9 @@ mkModuleImpExp (L l specname) subs = (text "Expecting a type constructor but found a variable," <+> quotes (ppr name) <> text "." $$ if isSymOcc $ rdrNameOcc name - then text "If" <+> quotes (ppr name) <+> text "is a type constructor" - <+> text "then enable ExplicitNamespaces and use the 'type' keyword." + then text "If" <+> quotes (ppr name) + <+> text "is a type constructor" + <+> text "then enable ExplicitNamespaces and use the 'type' keyword." else empty) else return $ ieNameFromSpec specname @@ -2100,7 +2148,7 @@ mkModuleImpExp (L l specname) subs = ieNameFromSpec (ImpExpQcType ln) = IEType ln ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - wrapped = map (\(L l x) -> L l (ieNameFromSpec x)) + wrapped = map (onHasSrcSpan ieNameFromSpec) mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) @@ -2112,8 +2160,8 @@ mkTypeImpExp name = (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) -checkImportSpec ie@(L _ specs) = - case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of +checkImportSpec ie@(dL->L _ specs) = + case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where @@ -2125,7 +2173,7 @@ checkImportSpec ie@(L _ specs) = -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L _ ImpExpQcWildcard] = +mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = return ([], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) @@ -2160,7 +2208,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg $$ text " including the definition module, you must qualify it." failOpFewArgs :: Located RdrName -> P a -failOpFewArgs (L loc op) = +failOpFewArgs (dL->L loc op) = do { star_is_type <- extension starIsTypeEnabled ; let msg = too_few $$ starInfo star_is_type op ; parseErrorSDoc loc msg } @@ -2173,14 +2221,14 @@ failOpDocPrev loc = parseErrorSDoc loc msg msg = text "Unexpected documentation comment." failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a -failOpStrictnessCompound (L _ str) (L loc ty) = parseErrorSDoc loc msg +failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = parseErrorSDoc loc msg where msg = text "Strictness annotation applied to a compound type." $$ text "Did you mean to add parentheses?" $$ nest 2 (ppr str <> parens (ppr ty)) failOpStrictnessPosition :: Located SrcStrictness -> P a -failOpStrictnessPosition (L loc _) = parseErrorSDoc loc msg +failOpStrictnessPosition (dL->L loc _) = parseErrorSDoc loc msg where msg = text "Strictness annotation cannot appear in this position." @@ -2210,24 +2258,26 @@ mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) -- Sum mkSumOrTuple Unboxed _ (Sum alt arity e) = return (ExplicitSum noExt alt arity e) -mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = - parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) +mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = + parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 + (ppr_boxed_sum alt arity e)) where ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc ppr_boxed_sum alt arity e = - text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" + text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> text ")" ppr_bars n = hsep (replicate n (Outputable.char '|')) mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y - in L loc (mkHsOpTy x op y) + in cL loc (mkHsOpTy x op y) mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs mkLHsDocTy t doc = let loc = getLoc t `combineSrcSpans` getLoc doc - in L loc (HsDocTy noExt t doc) + in cL loc (HsDocTy noExt t doc) mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) -- cgit v1.2.1