diff options
| author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2019-11-20 15:44:49 +0300 |
|---|---|---|
| committer | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2019-11-29 16:33:28 +0300 |
| commit | 9b6d1a35f1a78bde60800a1eba516cfa45b1b7b9 (patch) | |
| tree | 9cea5d59d51873e2d6df68a9dc67e8ee0030b69a | |
| parent | e921c90fec6754414e97bfabaeeb4eaf0241472d (diff) | |
| download | haskell-wip/no-hassrcspan.tar.gz | |
Remove HasSrcSpan (#17494)wip/no-hassrcspan
Metric Decrease:
haddock.compiler
52 files changed, 1440 insertions, 1599 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 8a8eb775cd..9955efaeb1 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -920,7 +920,7 @@ ppr_expr (SectionR _ op expr) ppr_expr (ExplicitTuple _ exprs boxity) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Unit x`, not `(x)` - | [dL -> L _ (Present _ expr)] <- exprs + | [L _ (Present _ expr)] <- exprs , Boxed <- boxity = hsep [text (mkTupleStr Boxed 1), ppr expr] | otherwise diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index cae7144a8c..d8ae451ee9 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -710,7 +710,7 @@ isIrrefutableHsPat go (ConPatIn {}) = False -- Conservative go (ConPatOut - { pat_con = (dL->L _ (RealDataCon con)) + { pat_con = L _ (RealDataCon con) , pat_args = details }) = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) @@ -718,9 +718,8 @@ isIrrefutableHsPat -- the latter is false of existentials. See #4439 && all goL (hsConPatArgs details) go (ConPatOut - { pat_con = (dL->L _ (PatSynCon _pat)) }) + { pat_con = L _ (PatSynCon _pat) }) = False -- Conservative - go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False @@ -790,8 +789,8 @@ conPatNeedsParens p = go -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) -parenthesizePat p lpat@(dL->L loc pat) - | patNeedsParens p pat = cL loc (ParPat noExtField lpat) +parenthesizePat p lpat@(L loc pat) + | patNeedsParens p pat = L loc (ParPat noExtField lpat) | otherwise = lpat {- diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 7af0a1ee4e..e92928c78f 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -1063,14 +1063,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) -hsLTyVarLocName = onHasSrcSpan hsTyVarName +hsLTyVarLocName = mapLoc hsTyVarName hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) -hsLTyVarBndrToType = onHasSrcSpan cvt +hsLTyVarBndrToType = mapLoc cvt where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n cvt (KindedTyVar _ (L name_loc n) kind) = HsKindSig noExtField diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index bac4dff9d9..b0d66c66d3 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -147,13 +147,13 @@ just attach 'noSrcSpan' to everything. -- | e => (e) mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = cL (getLoc e) (HsPar noExtField e) +mkHsPar e = L (getLoc e) (HsPar noExtField e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs - = cL loc $ + = L loc $ Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where @@ -163,12 +163,12 @@ mkSimpleMatch ctxt pats rhs unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) -unguardedGRHSs rhs@(dL->L loc _) +unguardedGRHSs rhs@(L loc _) = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] +unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)] mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] @@ -179,7 +179,7 @@ mkMatchGroup origin matches = MG { mg_ext = noExtField mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] -mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms +mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) @@ -196,7 +196,7 @@ mkHsAppTypes = foldl' mkHsAppType mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats' body] @@ -225,13 +225,13 @@ nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs -- | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsPar le@(dL->L loc e) - | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) +mkLHsPar le@(L loc e) + | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(dL->L loc p) - | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) +mkParPat lp@(L loc p) + | patNeedsParens appPrec p = L loc (ParPat noExtField lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) @@ -277,7 +277,7 @@ mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where - last_stmt = cL (getLoc expr) $ mkLastStmt expr + last_stmt = L (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) @@ -531,7 +531,7 @@ missingTupArg = Missing noExtField mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed +mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -620,12 +620,12 @@ mkHsSigEnv get_info sigs -- of which use this function where (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True - is_gen_dm_sig _ = False + is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs - , (dL->L _ n) <- ns ] + , L _ n <- ns ] mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] -- ^ Convert TypeSig to ClassOpSig @@ -634,8 +634,8 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] mkClassOpSigs sigs = map fiddle sigs where - fiddle (dL->L loc (TypeSig _ nms ty)) - = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) + fiddle (L loc (TypeSig _ nms ty)) + = L loc (ClassOpSig noExtField False nms (dropWildCards ty)) fiddle sig = sig typeToLHsType :: Type -> LHsType GhcPs @@ -753,7 +753,7 @@ positions in the kind of the tycon. ********************************************************************* -} mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- | Avoid (HsWrap co (HsWrap co' _)). -- See Note [Detecting forced eta expansion] in DsExpr @@ -771,14 +771,14 @@ mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) +mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd | otherwise = HsCmdWrap noExtField w cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) +mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p @@ -824,7 +824,7 @@ mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) -mkVarBind var rhs = cL (getLoc rhs) $ +mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_ext = noExtField, var_id = var, var_rhs = rhs, var_inline = False } @@ -852,8 +852,8 @@ isInfixFunBind _ = False mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr - = cL loc $ mkFunBind Generated (cL loc fun) - [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr + = L loc $ mkFunBind Generated (L loc fun) + [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr (noLoc emptyLocalBinds)] -- | Make a prefix, non-strict function 'HsMatchContext' @@ -873,8 +873,8 @@ mkMatch ctxt pats expr lbinds , m_pats = map paren pats , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(dL->L l p) - | patNeedsParens appPrec p = cL l (ParPat noExtField lp) + paren lp@(L l p) + | patNeedsParens appPrec p = L l (ParPat noExtField lp) | otherwise = lp {- @@ -954,7 +954,7 @@ isBangedHsBind :: HsBind GhcTc -> Bool isBangedHsBind (AbsBinds { abs_binds = binds }) = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) - | [dL->L _ match] <- unLoc $ mg_alts matches + | [L _ match] <- unLoc $ mg_alts matches , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match = True isBangedHsBind (PatBind {pat_lhs = pat}) @@ -976,8 +976,8 @@ collectHsIdBinders, collectHsValBinders collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False -collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> - HsBindLR p idR -> [IdP p] +collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) => + HsBindLR pass idR -> [IdP pass] -- ^ Collect both Ids and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] @@ -1003,16 +1003,17 @@ collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> -- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds -collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] +collect_bind :: XRec pass Pat ~ Located (Pat pass) => + Bool -> HsBindLR pass idR -> + [IdP pass] -> [IdP pass] collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc +collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc +collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc | otherwise = ps : acc collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc @@ -1066,8 +1067,8 @@ collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] collectPatsBinders pats = foldr collect_lpat [] pats ------------- -collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - LPat p -> [IdP p] -> [IdP p] +collect_lpat :: XRec pass Pat ~ Located (Pat pass) => + LPat pass -> [IdP pass] -> [IdP pass] collect_lpat p bndrs = go (unLoc p) where @@ -1160,39 +1161,37 @@ hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) -- Each returned (Located name) has a SrcSpan for the /whole/ declaration. -- See Note [SrcSpan for binders] -hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl - { fdLName = (dL->L _ name) } })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) +hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (L _ name) } })) + = ([L loc name], []) +hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl nec })) = noExtCon nec -hsLTyClDeclBinders (dL->L loc (SynDecl - { tcdLName = (dL->L _ name) })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L loc (ClassDecl - { tcdLName = (dL->L _ cls_name) +hsLTyClDeclBinders (L loc (SynDecl + { tcdLName = (L _ name) })) + = ([L loc name], []) +hsLTyClDeclBinders (L loc (ClassDecl + { tcdLName = (L _ cls_name) , tcdSigs = sigs , tcdATs = ats })) - = (cL loc cls_name : - [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl + = (L loc cls_name : + [ L fam_loc fam_name | (L fam_loc (FamilyDecl { fdLName = L _ fam_name })) <- ats ] ++ - [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs - , (dL->L _ mem_name) <- ns ] + [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (L _ mem_name) <- ns ] , []) -hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) - , tcdDataDefn = defn })) - = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec -hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" - -- due to #15884 +hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) + , tcdDataDefn = defn })) + = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn +hsLTyClDeclBinders (L _ (XTyClDecl nec)) = noExtCon nec ------------------- hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] -- ^ See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls - = [ cL decl_loc n - | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) + = [ L decl_loc n + | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] @@ -1213,24 +1212,22 @@ addPatSynSelector bind sels getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] + , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- hsLInstDeclBinders :: LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsLInstDeclBinders (dL->L _ (ClsInstD +hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) = foldMap (hsDataFamInstBinders . unLoc) dfis -hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) +hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi -hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) +hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty +hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec -hsLInstDeclBinders (dL->L _ (XInstDecl nec)) +hsLInstDeclBinders (L _ (XInstDecl nec)) = noExtCon nec -hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" - -- due to #15884 ------------------- -- | the SrcLoc returned are for the whole declarations, not just the names @@ -1278,13 +1275,13 @@ hsConDeclsBinders cons -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_args = args } - -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) + -> (map (L loc . unLoc) names ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs ConDeclH98 { con_name = name, con_args = args } - -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) + -> ([L loc (unLoc name)] ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 1467ef07f4..86a9717c02 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -282,7 +282,7 @@ checkSingle' locn var p = do (Covered , _ ) -> plain -- useful (NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant (NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs - where m = [cL locn [cL locn p]] + where m = [L locn [L locn p]] -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. @@ -293,7 +293,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do dflags <- getDynFlags let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc - match = cL combinedLoc $ + match = L combinedLoc $ Match { m_ext = noExtField , m_ctxt = hs_ctx , m_pats = [] @@ -360,8 +360,8 @@ checkMatches' vars matches = do (NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2) hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats - hsLMatchToLPats _ = panic "checkMatches'" + hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats + hsLMatchToLPats _ = panic "checkMatches'" getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta] getNFirstUncovered _ 0 _ = pure [] @@ -465,7 +465,7 @@ translatePat fam_insts x pat = case pat of -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var - AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p + AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p SigPat _ p _ty -> translateLPat fam_insts x p @@ -481,7 +481,7 @@ translatePat fam_insts x pat = case pat of pure (PmLet y (wrap_rhs_y (Var x)) : grds) -- (n + k) ===> let b = x >= k, True <- b, let n = x-k - NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do + NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do b <- mkPmId boolTy let grd_b = vanillaConGrd b trueDataCon [] [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2] @@ -527,14 +527,14 @@ translatePat fam_insts x pat = case pat of -- -- See #14547, especially comment#9 and comment#10. - ConPatOut { pat_con = (dL->L _ con) + ConPatOut { pat_con = L _ con , pat_arg_tys = arg_tys , pat_tvs = ex_tvs , pat_dicts = dicts , pat_args = ps } -> do translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps - NPat ty (dL->L _ olit) mb_neg _ -> do + NPat ty (L _ olit) mb_neg _ -> do -- See Note [Literal short cut] in MatchLit.hs -- We inline the Literal short cut for @ty@ here, because @ty@ is more -- precise than the field of OverLitTc, which is all that dsOverLit (which @@ -657,7 +657,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case -- Translate a single match translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (GrdVec, [GrdVec]) -translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) +translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats guards' <- mapM (translateGuards fam_insts) guards @@ -665,8 +665,8 @@ translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss } return (pats', guards') where extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] - extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs - extractGuards _ = panic "translateMatch" + extractGuards (L _ (GRHS _ gs _)) = map unLoc gs + extractGuards _ = panic "translateMatch" guards = map extractGuards (grhssGRHSs grhss) translateMatch _ _ _ = panic "translateMatch" @@ -1247,10 +1247,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_r $ forM_ redundant $ \(dL->L l q) -> do + when exists_r $ forM_ redundant $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do + when exists_i $ forM_ inaccessible $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ @@ -1366,7 +1366,7 @@ pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs { mc_fun = (dL->L _ fun) } + FunRhs { mc_fun = L _ fun } -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index eb38d36319..2a813344df 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -118,15 +118,14 @@ getL = CvtM (\_ loc -> Right (loc,loc)) setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a -returnL x = CvtM (\_ loc -> Right (loc, cL loc x)) +returnL :: a -> CvtM (Located a) +returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) +returnJustL :: a -> CvtM (Maybe (Located a)) returnJustL = fmap Just . returnL -wrapParL :: HasSrcSpan a => - (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) -wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x))) +wrapParL :: (Located a -> a) -> a -> CvtM a +wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing @@ -142,10 +141,10 @@ wrapMsg what item (CvtM m) then text (show item) else text (pprint item)) -wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a +wrapL :: CvtM a -> CvtM (Located a) wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of Left err -> Left err - Right (loc',v) -> Right (loc',cL loc v) + Right (loc', v) -> Right (loc', L loc v) ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] @@ -279,14 +278,14 @@ cvtDec (InstanceD o ctxt ty decs) ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' + ; (L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (cL loc . overlap) o } } + , cid_overlap_mode = fmap (L loc . overlap) o } } where overlap pragma = case pragma of @@ -350,7 +349,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) , feqn_fixity = Prefix } }}} cvtDec (TySynInstD eqn) - = do { (dL->L _ eqn') <- cvtTySynEqn eqn + = do { (L _ eqn') <- cvtTySynEqn eqn ; returnJustL $ InstD noExtField $ TyFamInstD { tfid_ext = noExtField , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } @@ -376,8 +375,8 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext funPrec cxt ; ds' <- traverse cvtDerivStrategy ds - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' + ; (L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustL $ DerivD noExtField $ DerivDecl { deriv_ext =noExtField , deriv_strategy = ds' @@ -523,29 +522,29 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) ------------------------------------------------------------------- is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) -is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) +is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d) is_fam_decl decl = Right decl is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) -is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) - = Left (cL loc d) +is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (L loc d) is_tyfam_inst decl = Right decl is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) -is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) - = Left (cL loc d) +is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (L loc d) is_datafam_inst decl = Right decl is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) -is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) -is_sig decl = Right decl +is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig) +is_sig decl = Right decl is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) -is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) -is_bind decl = Right decl +is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind) +is_bind decl = Right decl is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) @@ -582,12 +581,12 @@ cvtConstr (InfixC st1 c st2) cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L _ con') <- cvtConstr con + ; L _ con' <- cvtConstr con ; returnL $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = Just lcxt - add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) - = Just (cL loc (cxt1 ++ cxt2)) + add_cxt (L loc cxt1) (Just (L _ cxt2)) + = Just (L loc (cxt1 ++ cxt2)) add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) @@ -611,7 +610,7 @@ cvtConstr (GadtC [] _strtys _ty) cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys - ; (dL->L _ ty') <- cvtType ty + ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' ; returnL $ fst $ mkGadtDecl c' c_ty} @@ -646,12 +645,12 @@ cvt_arg (Bang su ss, ty) cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) - = do { (dL->L li i') <- vNameL i + = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_ext = noExtField , cd_fld_names - = [cL li $ FieldOcc noExtField (cL li i')] + = [L li $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -1132,8 +1131,8 @@ cvtHsDo do_or_lc stmts ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of - (dL->L loc (BodyStmt _ body _ _)) - -> return (cL loc (mkLastStmt body)) + (L loc (BodyStmt _ body _ _)) + -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } @@ -1162,8 +1161,8 @@ cvtMatch :: HsMatchContext RdrName cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of - (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 - _ -> p' + (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875 + _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } @@ -1298,10 +1297,10 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) - = do { (dL->L ls s') <- vNameL s + = do { L ls s' <- vNameL s ; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl - = cL ls $ mkFieldOcc (cL ls s') + = L ls $ mkFieldOcc (L ls s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1503,7 +1502,7 @@ cvtTypeKind ty_str ty PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax | Just normals <- m_normals - , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals + , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals -> do returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise @@ -1576,7 +1575,7 @@ mk_apps head_ty type_args = do go type_args where -- See Note [Adding parens for splices] - add_parens lt@(dL->L _ t) + add_parens lt@(L _ t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) | otherwise = return lt @@ -1680,9 +1679,9 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null exis, null provs = cvtType (ForallT univs reqs ty) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) - ; return $ cL l (HsQualTy { hst_ctxt = cL l [] - , hst_xqual = noExtField - , hst_body = ty' }) } + ; return $ L l (HsQualTy { hst_ctxt = L l [] + , hst_xqual = noExtField + , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) @@ -1690,11 +1689,11 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) { hst_fvf = ForallInvis , hst_bndrs = univs' , hst_xforall = noExtField - , hst_body = cL l cxtTy } - cxtTy = HsQualTy { hst_ctxt = cL l [] + , hst_body = L l cxtTy } + cxtTy = HsQualTy { hst_ctxt = L l [] , hst_xqual = noExtField , hst_body = ty' } - ; return $ cL l forTy } + ; return $ L l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtType ty @@ -1753,10 +1752,10 @@ mkHsForAllTy :: [TH.TyVarBndr] -- ^ The complete type, quantified with a forall if necessary mkHsForAllTy tvs loc fvf tvs' rho_ty | null tvs = rho_ty - | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf - , hst_bndrs = hsQTvExplicit tvs' - , hst_xforall = noExtField - , hst_body = rho_ty } + | otherwise = L loc $ HsForAllTy { hst_fvf = fvf + , hst_bndrs = hsQTvExplicit tvs' + , hst_xforall = noExtField + , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided @@ -1778,9 +1777,9 @@ mkHsQualTy :: TH.Cxt -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField - , hst_ctxt = ctxt' - , hst_body = ty } + | otherwise = L loc $ HsQualTy { hst_xqual = noExtField + , hst_ctxt = ctxt' + , hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 445606dc69..221c76327e 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -205,12 +205,6 @@ nameOccName name = n_occ name nameSrcLoc name = srcSpanStart (n_loc name) nameSrcSpan name = n_loc name -type instance SrcSpanLess Name = Name -instance HasSrcSpan Name where - composeSrcSpan (L sp n) = n {n_loc = sp} - decomposeSrcSpan n = L (n_loc n) n - - {- ************************************************************************ * * diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index bcf2fcbd6e..57915fd666 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -85,9 +85,7 @@ module SrcLoc ( leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf, sortLocated, - -- ** HasSrcSpan - HasSrcSpan(..), SrcSpanLess, dL, cL, - pattern LL, onHasSrcSpan, liftL + liftL ) where import GhcPrelude @@ -182,7 +180,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) ************************************************************************ -} -sortLocated :: HasSrcSpan a => [a] -> [a] +sortLocated :: [Located a] -> [Located a] sortLocated things = sortBy (comparing getLoc) things instance Outputable RealSrcLoc where @@ -533,36 +531,35 @@ type RealLocated = GenLocated RealSrcSpan mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b mapLoc = fmap -unLoc :: HasSrcSpan a => a -> SrcSpanLess a -unLoc (dL->L _ e) = e +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e -getLoc :: HasSrcSpan a => a -> SrcSpan -getLoc (dL->L l _) = l +getLoc :: GenLocated l e -> l +getLoc (L l _) = l -noLoc :: HasSrcSpan a => SrcSpanLess a -> a -noLoc e = cL noSrcSpan e +noLoc :: e -> Located e +noLoc e = L noSrcSpan e -mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e -mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e -combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan +combineLocs :: Located a -> Located b -> SrcSpan combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) -- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> SrcSpanLess c -> c -addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c -- not clear whether to add a general Eq instance, but this is useful sometimes: -- | Tests whether the two located things are equal -eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool +eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool eqLocated a b = unLoc a == unLoc b -- not clear whether to add a general Ord instance, but this is useful sometimes: -- | Tests the ordering of the two located things -cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering +cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where @@ -604,90 +601,10 @@ isSubspanOf src parent | otherwise = srcSpanStart parent <= srcSpanStart src && srcSpanEnd parent >= srcSpanEnd src - -{- -************************************************************************ -* * -\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans} -* * -************************************************************************ --} - -{- -Note [HasSrcSpan Typeclass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To be able to uniformly set/get source location spans (of `SrcSpan`) in -syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`. -More details can be found at the following wiki page - ImplementingTreesThatGrow/HandlingSourceLocations - -For most syntactic entities, the source location spans are stored in -a syntactic entity by a wapper constuctor (introduced by TTG's -new constructor extension), e.g., by `NewPat (WrapperPat sp pat)` -for a source location span `sp` and a pattern `pat`. --} - --- | Determines the type of undecorated syntactic entities --- For most syntactic entities `E`, where source location spans are --- introduced by a wrapper construtor of the same syntactic entity, --- we have `SrcSpanLess E = E`. --- However, some syntactic entities have a different type compared to --- a syntactic entity `e :: E` may have the type `Located E` when --- decorated by wrapping it with `L sp e` for a source span `sp`. -type family SrcSpanLess a - --- | A typeclass to set/get SrcSpans -class HasSrcSpan a where - -- | Composes a `SrcSpan` decoration with an undecorated syntactic - -- entity to form its decorated variant - composeSrcSpan :: Located (SrcSpanLess a) -> a - - -- | Decomposes a decorated syntactic entity into its `SrcSpan` - -- decoration and its undecorated variant - decomposeSrcSpan :: a -> Located (SrcSpanLess a) - {- laws: - composeSrcSpan . decomposeSrcSpan = id - decomposeSrcSpan . composeSrcSpan = id - - in other words, `HasSrcSpan` defines an iso relation between - a `SrcSpan`-decorated syntactic entity and its undecorated variant - (together with the `SrcSpan`). - -} - -type instance SrcSpanLess (GenLocated l e) = e -instance HasSrcSpan (Located a) where - composeSrcSpan = id - decomposeSrcSpan = id - - --- | An abbreviated form of decomposeSrcSpan, --- mainly to be used in ViewPatterns -dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) -dL = decomposeSrcSpan - --- | An abbreviated form of composeSrcSpan, --- mainly to replace the hardcoded `L` -cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -cL sp e = composeSrcSpan (L sp e) - --- | A Pattern Synonym to Set/Get SrcSpans -pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -pattern LL sp e <- (dL->L sp e) - where - LL sp e = cL sp e - --- | Lifts a function of undecorated entities to one of decorated ones -onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) => - (SrcSpanLess a -> SrcSpanLess b) -> a -> b -onHasSrcSpan f (dL->L l e) = cL l (f e) - -liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) => - (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b -liftL f (dL->L loc a) = do +liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) +liftL f (L loc a) = do a' <- f a - return $ cL loc a' - + return $ L loc a' getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan (L l _) = l diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index cfff423037..8a823906af 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -121,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest -> + let top_pos = catMaybes $ foldr (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of @@ -255,12 +255,12 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds, +addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do withEnv add_inlines $ do binds' <- addTickLHsBinds binds - return $ cL pos $ bind { abs_binds = binds' } + return $ L pos $ bind { abs_binds = binds' } where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports @@ -280,7 +280,7 @@ addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } -addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity @@ -292,7 +292,7 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do -- See Note [inline sccs] tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (cL pos funBind) else do + if inline && tickish == ProfNotes then return (L pos funBind) else do (fvs, mg) <- getFreeVars $ @@ -321,8 +321,8 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do return Nothing let mbCons = maybe Prelude.id (:) - return $ cL pos $ funBind { fun_matches = mg - , fun_tick = tick `mbCons` fun_tick funBind } + return $ L pos $ funBind { fun_matches = mg + , fun_tick = tick `mbCons` fun_tick funBind } where -- a binding is a simple pattern binding if it is a funbind with @@ -331,8 +331,8 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 -- TODO: Revisit this -addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs - , pat_rhs = rhs }))) = do +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs }))) = do let name = "(...)" (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs let pat' = pat { pat_rhs = rhs'} @@ -342,7 +342,7 @@ addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs decl_path <- getPathEntry let top_lev = null decl_path if not (shouldTickPatBind density top_lev) - then return (cL pos pat') + then return (L pos pat') else do -- Allocate the ticks @@ -355,14 +355,12 @@ addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') patvar_tickss = zipWith mbCons patvar_ticks (snd (pat_ticks pat') ++ repeat []) - return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } + return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } -- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind -addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind -addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884 - +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind +addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind bindTick @@ -397,7 +395,7 @@ bindTick density name pos fvs = do -- selectively add ticks to interesting expressions addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExpr e@(dL->L pos e0) = do +addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it @@ -413,7 +411,7 @@ addTickLHsExpr e@(dL->L pos e0) = do -- (because the body will definitely have a tick somewhere). ToDo: perhaps -- we should treat 'case' and 'if' the same way? addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprRHS e@(dL->L pos e0) = do +addTickLHsExprRHS e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it @@ -442,7 +440,7 @@ addTickLHsExprEvalInner e = do -- break012. This gives the user the opportunity to inspect the -- values of the let-bound variables. addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprLetBody e@(dL->L pos e0) = do +addTickLHsExprLetBody e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it @@ -456,9 +454,9 @@ addTickLHsExprLetBody e@(dL->L pos e0) = do -- because the scope of this tick is completely subsumed by -- another. addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprNever (dL->L pos e0) = do +addTickLHsExprNever (L pos e0) = do e1 <- addTickHsExpr e0 - return $ cL pos e1 + return $ L pos e1 -- general heuristic: expressions which do not denote values are good -- break points @@ -475,16 +473,16 @@ isCallSite OpApp{} = True isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany (dL->L pos e0) +addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) - (addTickLHsExpr (cL pos e0)) + (addTickLHsExpr (L pos e0)) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (dL->L pos e0) +addBinTickLHsExpr boxLabel (L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel pos $ addTickHsExpr e0) - (addTickLHsExpr (cL pos e0)) + (addTickLHsExpr (L pos e0)) -- ----------------------------------------------------------------------------- @@ -493,7 +491,7 @@ addBinTickLHsExpr boxLabel (dL->L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e +addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut _ con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e @@ -552,14 +550,14 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (dL->L l binds) e) = +addTickHsExpr (HsLet x (L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet x . cL l) + liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo srcloc cxt (dL->L l stmts)) +addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (cL l stmts')) } + ; return (HsDo srcloc cxt (L l stmts')) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -606,7 +604,7 @@ addTickHsExpr (HsTick x t e) = addTickHsExpr (HsBinTick x t0 t1 e) = liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsPragE _ HsPragTick{} (dL->L pos e0)) = do +addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 @@ -629,19 +627,18 @@ addTickHsExpr (HsWrap x w e) = addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (cL l (Present x e')) } -addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty)) -addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec -addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884 +addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present x e')) } +addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) +addTickTupArg (L _ (XTupArg nec)) = noExtCon nec addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = cL l matches' } + return $ mg { mg_alts = L l matches' } addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) @@ -655,11 +652,11 @@ addTickMatch _ _ (XMatch nec) = noExtCon nec addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' (cL l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec @@ -673,7 +670,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do addTickGRHS _ _ (XGRHS nec) = noExtCon nec addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do +addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do d <- getDensity case d of TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr @@ -716,13 +713,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = do (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do - liftM (LetStmt x . cL l) +addTickStmt _isGuard (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr)) + (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args @@ -737,7 +734,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr)) + t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } @@ -770,7 +767,7 @@ addTickApplicativeArg isGuard (op, arg) = addTickArg (ApplicativeArgMany x stmts ret pat) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret)) + <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat addTickArg (XApplicativeArg nec) = noExtCon nec @@ -823,7 +820,7 @@ addTickIPBind (XIPBind x) = return (XIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do - x' <- fmap unLoc (addTickLHsExpr (cL pos x)) + x' <- fmap unLoc (addTickLHsExpr (L pos x)) return $ syn { syn_expr = x' } -- we do not walk into patterns. addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) @@ -837,9 +834,9 @@ addTickHsCmdTop (HsCmdTop x cmd) = addTickHsCmdTop (XCmdTop nec) = noExtCon nec addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) -addTickLHsCmd (dL->L pos c0) = do +addTickLHsCmd (L pos c0) = do c1 <- addTickHsCmd c0 - return $ cL pos c1 + return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) addTickHsCmd (HsCmdLam x matchgroup) = @@ -864,14 +861,14 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (dL->L l binds) c) = +addTickHsCmd (HsCmdLet x (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet x . cL l) + liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo srcloc (dL->L l stmts)) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (cL l stmts')) } + ; return (HsCmdDo srcloc (L l stmts')) } addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp @@ -897,9 +894,9 @@ addTickHsCmd (XCmd nec) = noExtCon nec addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do +addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = cL l matches' } + return $ mg { mg_alts = L l matches' } addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) @@ -910,11 +907,11 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = addTickCmdMatch (XMatch nec) = noExtCon nec addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' (cL l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds addTickCmdGRHSs (XGRHSs nec) = noExtCon nec @@ -961,8 +958,8 @@ addTickCmdStmt (BodyStmt x c bind' guard') = do (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (dL->L l binds)) = do - liftM (LetStmt x . cL l) +addTickCmdStmt (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) @@ -986,9 +983,9 @@ addTickHsRecordBinds (HsRecFields fields dd) addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) -> TM (LHsRecField' id (LHsExpr GhcTc)) -addTickHsRecField (dL->L l (HsRecField id expr pun)) +addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr - ; return (cL l (HsRecField id expr' pun)) } + ; return (L l (HsRecField id expr' pun)) } addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) @@ -1168,10 +1165,10 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (cL pos (HsTick noExtField tickish (cL pos e))) + return (L pos (HsTick noExtField tickish (L pos e))) ) (do e <- m - return (cL pos e) + return (L pos e) ) -- the tick application inherits the source position of its @@ -1239,7 +1236,7 @@ allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of - HpcTicks -> do e <- liftM (cL pos) m + HpcTicks -> do e <- liftM (L pos) m ifGoodTickSrcSpan pos (mkBinTickBoxHpc boxLabel pos e) (return e) @@ -1255,8 +1252,8 @@ mkBinTickBoxHpc boxLabel pos e = c = tickBoxCount st mes = mixEntries st in - ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c) - $ cL pos $ HsBinTick noExtField (c+1) (c+2) e + ( L pos $ HsTick noExtField (HpcTick (this_mod env) c) + $ L pos $ HsBinTick noExtField (c+1) (c+2) e -- notice that F and T are reversed, -- because we are building the list in -- reverse... @@ -1283,12 +1280,11 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ })) + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss - matchCount (dL->L _ (Match { m_grhss = XGRHSs nec })) + matchCount (L _ (Match { m_grhss = XGRHSs nec })) = noExtCon nec - matchCount (dL->L _ (XMatch nec)) = noExtCon nec - matchCount _ = panic "matchCount: Impossible Match" -- due to #15884 + matchCount (L _ (XMatch nec)) = noExtCon nec type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index c2978d8774..f5aa6f0785 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -369,13 +369,13 @@ Reason -} dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (dL->L loc (HsRule { rd_name = name - , rd_act = rule_act - , rd_tmvs = vars - , rd_lhs = lhs - , rd_rhs = rhs })) +dsRule (L loc (HsRule { rd_name = name + , rd_act = rule_act + , rd_tmvs = vars + , rd_lhs = lhs + , rd_rhs = rhs })) = putSrcSpanDs loc $ - do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars] + do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ @@ -412,8 +412,7 @@ dsRule (dL->L loc (HsRule { rd_name = name ; return (Just rule) } } } -dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec -dsRule _ = panic "dsRule: Impossible Match" -- due to #15884 +dsRule (L _ (XRuleDecl nec)) = noExtCon nec warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () -- See Note [Rules and inlining/other rules] diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index ade017208d..0cbf3dae39 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -316,7 +316,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids) @@ -455,8 +455,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do dsCmd ids local_vars stack_ty res_ty (HsCmdLam _ (MG { mg_alts - = (dL->L _ [dL->L _ (Match { m_pats = pats - , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) })) + = (L _ [L _ (Match { m_pats = pats + , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) let @@ -567,7 +567,7 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches) + (HsCmdCase _ exp (MG { mg_alts = L l matches , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do @@ -616,7 +616,7 @@ dsCmd ids local_vars stack_ty res_ty in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase noExtField exp - (MG { mg_alts = cL l matches' + (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc arg_tys sum_ty , mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, @@ -632,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) @@ -660,7 +660,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) -- ---> premap (\ (env,stk) -> env) c dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty - (dL->L loc stmts)) + (L loc stmts)) env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty @@ -706,7 +706,7 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids - (dL->L _ (HsCmdTop + (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') @@ -778,7 +778,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do +dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do putSrcSpanDs loc $ dsNoLevPoly res_ty (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids @@ -1139,8 +1139,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" leavesMatch :: LMatch GhcTc (Located (body GhcTc)) -> [(Located (body GhcTc), IdSet)] -leavesMatch (dL->L _ (Match { m_pats = pats - , m_grhss = GRHSs _ grhss (dL->L _ binds) })) +leavesMatch (L _ (Match { m_pats = pats + , m_grhss = GRHSs _ grhss (L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1149,7 +1149,7 @@ leavesMatch (dL->L _ (Match { m_pats = pats [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | (dL->L _ (GRHS _ stmts body)) <- grhss] + | L _ (GRHS _ stmts body) <- grhss] leavesMatch _ = panic "leavesMatch" -- Replace the leaf commands in a match @@ -1161,12 +1161,12 @@ replaceLeavesMatch -> ([Located (body' GhcTc)], -- remaining leaf expressions LMatch GhcTc (Located (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves - (dL->L loc + (L loc match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) + (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesGRHS @@ -1174,8 +1174,8 @@ replaceLeavesGRHS -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command -> ([Located (body' GhcTc)], -- remaining leaf expressions LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _)) - = (leaves, cL loc (GRHS x stmts leaf)) +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" @@ -1221,14 +1221,14 @@ collectPatsBinders pats = foldr collectl [] pats --------------------- collectl :: LPat GhcTc -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut] -collectl (dL->L _ pat) bndrs +collectl (L _ pat) bndrs = go pat where - go (VarPat _ (dL->L _ var)) = var : bndrs + go (VarPat _ (L _ var)) = var : bndrs go (WildPat _) = bndrs go (LazyPat _ pat) = collectl pat bndrs go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs + go (AsPat _ (L _ a) pat) = a : collectl pat bndrs go (ParPat _ pat) = collectl pat bndrs go (ListPat _ pats) = foldr collectl bndrs pats @@ -1241,7 +1241,7 @@ collectl (dL->L _ pat) bndrs ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _ _) = bndrs go (NPat {}) = bndrs - go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs + go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs go (SigPat _ pat _) = collectl pat bndrs go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 20a3b23e96..dbfc6f52fd 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -101,7 +101,7 @@ dsTopLHsBinds binds unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds bang_binds = filterBag (isBangedHsBind . unLoc) binds - top_level_err desc (dL->L loc bind) + top_level_err desc (L loc bind) = putSrcSpanDs loc $ errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)) @@ -118,8 +118,8 @@ dsLHsBinds binds ------------------------ dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind +dsLHsBind (L loc bind) = do dflags <- getDynFlags + putSrcSpanDs loc $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags @@ -143,7 +143,7 @@ dsHsBind dflags (VarBind { var_id = var else [] ; return (force_var, [core_bind]) } -dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun) +dsHsBind dflags b@(FunBind { fun_id = L _ fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) @@ -657,7 +657,7 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding -- rhs is in the Id's unfolding -> Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl)) +dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index e0bb58bd49..e58bb341aa 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -72,11 +72,11 @@ import Control.Monad -} dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body -dsLocalBinds _ _ = panic "dsLocalBinds" +dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body +dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds _ _ = panic "dsLocalBinds" ------------------------- -- caller sets location @@ -94,7 +94,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where - ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body + ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) ds_ip_bind _ _ = panic "dsIPBinds" @@ -108,7 +108,7 @@ ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [dL->L loc bind] <- bagToList hsbinds + | [L loc bind] <- bagToList hsbinds -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes @@ -192,13 +192,13 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ; ds_binds <- dsTcEvBinds_s ev_binds ; return (mkCoreLets ds_binds body2) } -dsUnliftedBind (FunBind { fun_id = (dL->L l fun) +dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun)) + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches ; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( isIdHsWrapper co_fn ) @@ -231,7 +231,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (dL->L loc e) +dsLExpr (L loc e) = putSrcSpanDs loc $ do { core_expr <- dsExpr e -- uncomment this check to test the hsExprType function in TcHsSyn @@ -246,7 +246,7 @@ dsLExpr (dL->L loc e) -- See Note [Levity polymorphism checking] in DsMonad -- See Note [Levity polymorphism invariants] in CoreSyn dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsLExprNoLP (dL->L loc e) +dsLExprNoLP (L loc e) = putSrcSpanDs loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) @@ -260,7 +260,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap? -> HsExpr GhcTc -> DsM CoreExpr ds_expr _ (HsPar _ e) = dsLExpr e ds_expr _ (ExprWithTySig _ e _) = dsLExpr e -ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var +ds_expr w (HsVar _ (L _ var)) = dsHsVar w var ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them ds_expr w (HsConLikeOut _ con) = dsConLike w con ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" @@ -285,7 +285,7 @@ ds_expr _ (HsWrap _ co_fn e) ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } -ds_expr _ (NegApp _ (dL->L loc +ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do @@ -377,12 +377,12 @@ ds_expr _ e@(SectionR _ op expr) = do core_op [Var x_id, Var y_id])) ds_expr _ (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (dL->L _ (Missing ty)) + = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (dL->L _ (Present _ expr)) + go (lam_vars, args) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr @@ -419,11 +419,11 @@ ds_expr _ (HsLet _ binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty -ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts +ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -473,7 +473,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview. g = ... makeStatic loc f ... -} -ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do +ds_expr _ (HsStatic _ expr@(L loc _)) = do expr_ds <- dsLExprNoLP expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName @@ -612,7 +612,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- of the record selector, and we must not make that a local binder -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf #2735 - ds_field (dL->L _ rec_field) + ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) ; let fld_id = unLoc (hsRecUpdFieldId rec_field) ; lcl_id <- newSysLocalDs (idType fld_id) @@ -777,7 +777,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel - = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds + = [hsRecFieldArg fld | L _ fld <- rbinds , sel == idName (unLoc $ hsRecFieldId fld) ] {- @@ -896,7 +896,7 @@ dsDo stmts = goL stmts where goL [] = panic "dsDo" - goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body @@ -961,7 +961,7 @@ dsDo stmts , recS_ret_ty = body_ty} }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where - new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) + new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail @@ -1002,7 +1002,7 @@ handle_failure pat match fail_op | otherwise = extractMatchResult match (error "It can't fail") -mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String +mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ showPpr dflags (getLoc pat) @@ -1142,7 +1142,7 @@ we're not directly in an HsWrap, reject. checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of - HsVar _ (dL->L _ var) -> Just var + HsVar _ (L _ var) -> Just var HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 43ef2327c5..49dab953bf 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -97,7 +97,7 @@ dsForeigns' fos = do (vcat cs $$ vcat fe_init_code), foldr (appOL . toOL) nilOL bindss) where - do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl) + do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) @@ -106,10 +106,10 @@ dsForeigns' fos = do traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport { fd_name = (dL->L _ id) + do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co , fd_fe = CExport - (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do + (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) do_decl (XForeignDecl nec) = noExtCon nec diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index a6ef106c98..fe60cb8001 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -70,10 +70,9 @@ dsGRHSs _ (XGRHSs nec) _ = noExtCon nec dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs)) +dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec -dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884 +dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec {- ************************************************************************ diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index e826045eb5..084a9dabff 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -484,8 +484,8 @@ dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr @@ -639,7 +639,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts | otherwise = extractMatchResult match (error "It can't fail") - mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String + mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in monad comprehension at " ++ showPpr dflags (getLoc pat) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4c38212648..0b0c7abdb4 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -170,15 +170,15 @@ repTopDs group@(HsGroup { hs_valds = valds wrapGenSyms ss q_decs } where - no_splice (dL->L loc _) + no_splice (L loc _) = notHandledL loc "Splices within declaration brackets" empty - no_default_decl (dL->L loc decl) + no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) - no_warn (dL->L loc (Warning _ thing _)) + no_warn (L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing no_warn _ = panic "repTopDs" - no_doc (dL->L loc _) + no_doc (L loc _) = notHandledL loc "Haddock documentation" empty repTopDs (XHsGroup nec) = noExtCon nec @@ -192,7 +192,7 @@ hsScopedTvBinders binds XValBindsLR (NValBinds _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name] -get_scoped_tvs (dL->L _ signature) +get_scoped_tvs (L _ signature) | TypeSig _ _ sig <- signature = get_scoped_tvs_from_sig (hswc_body sig) | ClassOpSig _ _ _ sig <- signature @@ -302,24 +302,24 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. -- repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $ - repFamilyDecl (L loc fam) +repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ + repFamilyDecl (L loc fam) -repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) +repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repSynDecl tc1 bndrs rhs ; return (Just (loc, dec)) } -repTyClD (dL->L loc (DataDecl { tcdLName = tc - , tcdTyVars = tvs - , tcdDataDefn = defn })) +repTyClD (L loc (DataDecl { tcdLName = tc + , tcdTyVars = tvs + , tcdDataDefn = defn })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn ; return (Just (loc, dec)) } -repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds })) @@ -341,7 +341,7 @@ repTyClD _ = panic "repTyClD" ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles)) +repRoleD (L loc (RoleAnnotDecl _ tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1 @@ -351,7 +351,7 @@ repRoleD _ = panic "repRoleD" ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repKiSigD (dL->L loc kisig) = +repKiSigD (L loc kisig) = case kisig of StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v XStandaloneKindSig nec -> noExtCon nec @@ -393,11 +393,11 @@ repSynDecl tc bndrs ty ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info - , fdLName = tc - , fdTyVars = tvs - , fdResultSig = dL->L _ resultSig - , fdInjectivityAnn = injectivity })) +repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info + , fdLName = tc + , fdTyVars = tvs + , fdResultSig = L _ resultSig + , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = [] @@ -453,7 +453,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName } -repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) = +repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs ; rhs2 <- coreList nameTyConName rhs1 @@ -473,7 +473,7 @@ repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep]) repLFunDeps fds = repList funDepTyConName repLFunDep fds repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep) -repLFunDep (dL->L _ (xs, ys)) +repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs ys' <- repList nameTyConName (lookupBinder . unLoc) ys repFunDep xs' ys' @@ -481,13 +481,13 @@ repLFunDep (dL->L _ (xs, ys)) -- Represent instance declarations -- repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl })) +repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) } -repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl })) +repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) = do { dec <- repDataFamInstD fi_decl ; return (loc, dec) } -repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl })) +repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } repInstD _ = panic "repInstD" @@ -523,8 +523,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds repClsInstD (XClsInstDecl nec) = noExtCon nec repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat - , deriv_type = ty })) +repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat + , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ do { cxt' <- repLContext cxt ; strat' <- repDerivStrategy strat @@ -611,9 +611,8 @@ repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) -repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ - , fd_fi = CImport (dL->L _ cc) - (dL->L _ s) mch cis _ })) +repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc @@ -654,7 +653,7 @@ repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) +repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName @@ -668,12 +667,12 @@ repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) repFixD _ = panic "repFixD" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (dL->L loc (HsRule { rd_name = n - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs })) +repRuleD (L loc (HsRule { rd_name = n + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs })) = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs ; ss <- mkGenSyms tm_bndr_names @@ -695,29 +694,28 @@ repRuleD (dL->L loc (HsRule { rd_name = n repRuleD _ = panic "repRuleD" ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n] -ruleBndrNames (dL->L _ (RuleBndrSig _ n sig)) +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig = unLoc n : vars -ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) +ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) +ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec -ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 +ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) -repRuleBndr (dL->L _ (RuleBndr _ n)) +repRuleBndr (L _ (RuleBndr _ n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (dL->L _ (RuleBndrSig _ n sig)) +repRuleBndr (L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } repRuleBndr _ = panic "repRuleBndr" repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) +repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' @@ -725,10 +723,10 @@ repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) repAnnD _ = panic "repAnnD" repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (dL->L _ n)) +repAnnProv (ValueAnnProvenance (L _ n)) = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level ; rep2 valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (dL->L _ n)) +repAnnProv (TypeAnnProvenance (L _ n)) = do { MkC n' <- globalVar n ; rep2 typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance @@ -739,17 +737,17 @@ repAnnProv ModuleAnnProvenance ------------------------------------------------------- repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) -repC (dL->L _ (ConDeclH98 { con_name = con - , con_forall = (dL->L _ False) - , con_mb_cxt = Nothing - , con_args = args })) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = L _ False + , con_mb_cxt = Nothing + , con_args = args })) = repDataCon con args -repC (dL->L _ (ConDeclH98 { con_name = con - , con_forall = (dL->L _ is_existential) - , con_ex_tvs = con_tvs - , con_mb_cxt = mcxt - , con_args = args })) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = L _ is_existential + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> do { c' <- repDataCon con args ; ctxt' <- repMbContext mcxt @@ -759,11 +757,11 @@ repC (dL->L _ (ConDeclH98 { con_name = con } } -repC (dL->L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty })) +repC (L _ (ConDeclGADT { con_names = cons + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty })) | isEmptyLHsQTvs qtvs -- No implicit or explicit variables , Nothing <- mcxt -- No context -- ==> no need for a forall @@ -783,7 +781,7 @@ repC _ = panic "repC" repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) repMbContext Nothing = repContext [] -repMbContext (Just (dL->L _ cxt)) = repContext cxt +repMbContext (Just (L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] @@ -812,14 +810,14 @@ repBangTy ty = do ------------------------------------------------------- repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) -repDerivs (dL->L _ clauses) +repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ) -repDerivClause (dL->L _ (HsDerivingClause +repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L _ dct) })) + , deriv_clause_tys = L _ dct })) = do MkC dcs' <- repDerivStrategy dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] @@ -853,22 +851,22 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] rep_sigs = concatMapM rep_sig rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (dL->L loc (TypeSig _ nms ty)) +rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms -rep_sig (dL->L loc (PatSynSig _ nms ty)) +rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms -rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty)) +rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms | otherwise = mapM (rep_ty_sig sigDName loc ty) nms -rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level -rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc -rep_sig (dL->L loc (SpecSig _ nm tys ispec)) +rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) +rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc -rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty -rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty)) +rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc +rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty +rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc rep_sig _ = panic "rep_sig" @@ -990,7 +988,7 @@ rep_complete_sig :: Located [Located Name] -> Maybe (Located Name) -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_complete_sig (dL->L _ cls) mty loc +rep_complete_sig (L _ cls) mty loc = do { mty' <- repMaybe nameTyConName lookupLOcc mty ; cls' <- repList nameTyConName lookupLOcc cls ; sig <- repPragComplete cls' mty' @@ -1066,18 +1064,18 @@ addTyClTyVarBinds tvs m -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm +repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm = repPlainTV nm -repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm = repLTy ki >>= repKindedTV nm repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) -repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) ) +repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) = do { nm' <- lookupBinder nm ; repPlainTV nm' } -repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki)) +repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm ; ki' <- repLTy ki ; repKindedTV nm' ki' } @@ -1135,7 +1133,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty repTy ty@(HsQualTy {}) = repForall ForallInvis ty -repTy (HsTyVar _ _ (dL->L _ n)) +repTy (HsTyVar _ _ (L _ n)) | isLiftedTypeKindTyConName n = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` funTyConKey = repArrowTyCon @@ -1216,11 +1214,10 @@ repMaybeLTy :: Maybe (LHsKind GhcRn) repMaybeLTy = repMaybe kindQTyConName repLTy repRole :: Located (Maybe Role) -> DsM (Core TH.Role) -repRole (dL->L _ (Just Nominal)) = rep2 nominalRName [] -repRole (dL->L _ (Just Representational)) = rep2 representationalRName [] -repRole (dL->L _ (Just Phantom)) = rep2 phantomRName [] -repRole (dL->L _ Nothing) = rep2 inferRName [] -repRole _ = panic "repRole: Impossible Match" -- due to #15884 +repRole (L _ (Just Nominal)) = rep2 nominalRName [] +repRole (L _ (Just Representational)) = rep2 representationalRName [] +repRole (L _ (Just Phantom)) = rep2 phantomRName [] +repRole (L _ Nothing) = rep2 inferRName [] ----------------------------------------------------------------------------- -- Splices @@ -1256,10 +1253,10 @@ repLEs es = repList expQTyConName repLE es -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) -repLE (dL->L loc e) = putSrcSpanDs loc (repE e) +repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar _ (dL->L _ x)) = +repE (HsVar _ (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1279,8 +1276,8 @@ repE e@(HsRecFld _ f) = case f of -- HsOverlit can definitely occur repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) })) +repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = (L _ ms) })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } @@ -1301,7 +1298,7 @@ repE (NegApp _ x _) = do repE (HsPar _ x) = repLE x repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) })) +repE (HsCase _ e (MG { mg_alts = (L _ ms) })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 @@ -1315,13 +1312,13 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs +repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo _ ctxt (dL->L _ sts)) +repE e@(HsDo _ ctxt (L _ sts)) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1343,9 +1340,9 @@ repE e@(HsDo _ ctxt (dL->L _ sts)) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ)) - tupArgToCoreExp a - | L _ (Present _ e) <- dL a = do { e' <- repLE e - ; coreJust expQTyConName e' } + tupArgToCoreExp (L _ a) + | Present _ e <- a = do { e' <- repLE e + ; coreJust expQTyConName e' } | otherwise = coreNothing expQTyConName in do { args <- mapM tupArgToCoreExp es @@ -1407,8 +1404,8 @@ repE e = notHandled "Expression form" (ppr e) -- Building representations of auxiliary structures like Match, Clause, Stmt, repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) -repMatchTup (dL->L _ (Match { m_pats = [p] - , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = +repMatchTup (L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1420,8 +1417,8 @@ repMatchTup (dL->L _ (Match { m_pats = [p] repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) -repClauseTup (dL->L _ (Match { m_pats = ps - , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = +repClauseTup (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1430,11 +1427,11 @@ repClauseTup (dL->L _ (Match { m_pats = ps gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec +repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec repClauseTup _ = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) -repGuards [dL->L _ (GRHS _ [] e)] +repGuards [L _ (GRHS _ [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other @@ -1444,10 +1441,10 @@ repGuards other repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2)) +repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } -repLGRHS (dL->L _ (GRHS _ ss rhs)) +repLGRHS (L _ (GRHS _ ss rhs)) = do { (gs, ss') <- repLSts ss ; rhs' <- addBinds gs $ repLE rhs ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' @@ -1460,16 +1457,16 @@ repFields (HsRecFields { rec_flds = flds }) where rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } + rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name) + rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of + Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld) @@ -1513,7 +1510,7 @@ repSts (BindStmt _ p e _ _ : ss) = ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} -repSts (LetStmt _ (dL->L _ bs) : ss) = +repSts (LetStmt _ (L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) @@ -1590,18 +1587,16 @@ repBinds (HsValBinds _ decs) repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs))) +rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) = do { name <- case ename of - Left (dL->L _ n) -> rep_implicit_param_name n + Left (L _ n) -> rep_implicit_param_name n Right _ -> panic "rep_implicit_param_bind: post typechecking" ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (loc, ipb) } -rep_implicit_param_bind (dL->L _ b@(XIPBind _)) +rep_implicit_param_bind (L _ b@(XIPBind _)) = notHandled "Implicit parameter bind extension" (ppr b) -rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match" - -- due to #15884 rep_implicit_param_name :: HsIPName -> DsM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) @@ -1624,13 +1619,12 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (dL->L loc (FunBind +rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts - = (dL->L _ [dL->L _ (Match - { m_pats = [] - , m_grhss = GRHSs _ guards - (dL->L _ wheres) } + = (L _ [L _ (Match + { m_pats = [] + , m_grhss = GRHSs _ guards (L _ wheres) } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -1640,26 +1634,26 @@ rep_bind (dL->L loc (FunBind ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (dL->L loc (FunBind { fun_id = fn - , fun_matches = MG { mg_alts = (dL->L _ ms) } })) +rep_bind (L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = L _ ms } })) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec +rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec -rep_bind (dL->L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs _ guards (dL->L _ wheres) })) +rep_bind (L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs _ guards (L _ wheres) })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec +rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec -rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) +rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2 @@ -1668,11 +1662,11 @@ rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) = do { syn' <- lookupLBinder syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args @@ -1707,11 +1701,8 @@ rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec))) - = noExtCon nec -rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec -rep_bind _ = panic "rep_bind: Impossible match!" - -- due to #15884 +rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec +rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec repPatSynD :: Core TH.Name -> Core TH.PatSynArgsQ @@ -1747,7 +1738,7 @@ repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] -repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) +repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec @@ -1781,16 +1772,16 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) -repLambda (dL->L _ (Match { m_pats = ps - , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)] - (dL->L _ (EmptyLocalBinds _)) } )) +repLambda (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] + (L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m) +repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) ----------------------------------------------------------------------------- @@ -1837,12 +1828,12 @@ repP (ConPatIn dc details) } where rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) - rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) - ; MkC p <- repLP (hsRecFieldArg fld) - ; rep2 fieldPatName [v,p] } + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } -repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l - ; repPlit a } +repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l + ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP (SigPat _ p t) = do { p' <- repLP p diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index b76c4f0592..c358c175c6 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -674,7 +674,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -- and all the desugared binds mkSelectorBinds ticks pat val_expr - | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A) + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -721,9 +721,9 @@ mkSelectorBinds ticks pat val_expr strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens -strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p -strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp +strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp is_flat_prod_lpat :: LPat (GhcPass p) -> Bool is_flat_prod_lpat = is_flat_prod_pat . unLoc @@ -731,7 +731,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc is_flat_prod_pat :: Pat (GhcPass p) -> Bool is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon) +is_flat_prod_pat (ConPatOut { pat_con = L _ pcon , pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) @@ -759,7 +759,7 @@ is_triv_pat _ = False mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ +mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc @@ -952,25 +952,25 @@ decideBangHood dflags lpat | otherwise -- -XStrict = go lpat where - go lp@(dL->L l p) + go lp@(L l p) = case p of - ParPat x p -> cL l (ParPat x (go p)) + ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp - _ -> cL l (BangPat noExtField lp) + _ -> L l (BangPat noExtField lp) -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- ^ Banged pattern addBang = go where - go lp@(dL->L l p) + go lp@(L l p) = case p of - ParPat x p -> cL l (ParPat x (go p)) - LazyPat _ lp' -> cL l (BangPat noExtField lp') + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> L l (BangPat noExtField lp') -- Should we bring the extension value over? BangPat _ _ -> lp - _ -> cL l (BangPat noExtField lp) + _ -> L l (BangPat noExtField lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) @@ -980,24 +980,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v))) +isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (dL->L _ (HsConLikeOut _ con)) +isTrueLHsExpr (L _ (HsConLikeOut _ con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (dL->L _ (HsTick _ tickish e)) +isTrueLHsExpr (L _ (HsTick _ tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e)) +isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index 33bed3b3f5..ec5238ae4b 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -12,6 +12,7 @@ import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls import GHC.Hs.Extension +import GHC.Hs.Pat import GHC.Hs.Types import GHC.Hs.Utils import Name @@ -114,7 +115,8 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] +getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) => + HsDecl pass -> [IdP pass] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -141,13 +143,13 @@ getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some -- reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" @@ -164,7 +166,7 @@ subordinates :: Map SrcSpan Name subordinates instMap decl = case decl of InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = (dL->L l _) + FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn @@ -175,7 +177,7 @@ subordinates instMap decl = case decl of _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) - | (dL->L _ d, doc) <- classDecls dd + | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn @@ -189,8 +191,8 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons - , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) - , (dL->L _ n) <- ns ] + , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) + , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $ @@ -198,15 +200,15 @@ subordinates instMap decl = case decl of , Just instName <- [M.lookup l instMap] ] extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty ty = - case dL ty of + extract_deriv_ty (L l ty) = + case ty of -- deriving (forall a. C a {- ^ Doc comment -}) - L l (HsForAllTy{ hst_fvf = ForallInvis - , hst_body = dL->L _ (HsDocTy _ _ doc) }) - -> Just (l, doc) + HsForAllTy{ hst_fvf = ForallInvis + , hst_body = L _ (HsDocTy _ _ doc) } + -> Just (l, doc) -- deriving (C a {- ^ Doc comment -}) - L l (HsDocTy _ _ doc) -> Just (l, doc) - _ -> Nothing + HsDocTy _ _ doc -> Just (l, doc) + _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 2e0aeb9877..b11a2e2f06 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -271,7 +271,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1 + let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -407,16 +407,16 @@ tidy1 :: Id -- The Id being scrutinised tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p +tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v _ (VarPat _ (dL->L _ var)) +tidy1 v _ (VarPat _ (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (dL->L _ var) pat) +tidy1 v o (AsPat _ (L _ var) pat) = do { (wrap, pat') <- tidy1 v o (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -472,7 +472,7 @@ tidy1 _ o (LitPat _ lit) ; return (idDsWrapper, tidyLitPat lit) } -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq) +tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) = do { unless (isGenerated o) $ let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } | otherwise = lit @@ -480,7 +480,7 @@ tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq) ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } -- NPlusKPat: we may want to warn about the literals -tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _) +tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) = do { unless (isGenerated o) $ do warnAboutOverflowedOverLit lit1 warnAboutOverflowedOverLit lit2 @@ -495,15 +495,15 @@ tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p -tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time tidy_bang_pat v o l (AsPat x v' p) - = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p))) + = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) tidy_bang_pat v o l (CoPat x w p t) - = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t) + = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p @@ -512,7 +512,7 @@ tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p -- Data/newtype constructors -tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc)) +tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc) , pat_args = args , pat_arg_tys = arg_tys }) -- Newtypes: push bang inwards (#9844) @@ -538,7 +538,7 @@ tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc)) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p)) +tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -549,16 +549,16 @@ push_bang_into_newtype_arg :: SrcSpan -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args) - PrefixCon [cL l (BangPat noExtField arg)] + PrefixCon [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf) - | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf + | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg - = cL l (BangPat noExtField arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -724,7 +724,7 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) +matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches , mg_ext = MatchGroupTc arg_tys rhs_ty , mg_origin = origin }) = do { dflags <- getDynFlags @@ -747,7 +747,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) ; return (new_vars, result_expr) } where -- Called once per equation in the match, or alternative in the case - mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) + mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats dicts = collectEvVarsPats upats @@ -763,8 +763,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) ; return (EqnInfo { eqn_pats = upats , eqn_orig = FromSource , eqn_rhs = match_result }) } - mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec - mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884 + mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec handleWarnings = if isGenerated origin then discardWarningsDs @@ -1004,8 +1003,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar _ (dL->L _ e)) e' = exp e e' - exp e (HsPar _ (dL->L _ e')) = exp e e' + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' @@ -1058,8 +1057,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap res_wrap1 res_wrap2 --------- - tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2 - tup_arg (dL->L _ (Missing t1)) (dL->L _ (Missing t2)) = eqType t1 t2 + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- @@ -1094,13 +1093,13 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys patGroup :: DynFlags -> Pat GhcTc -> PatGroup -patGroup _ (ConPatOut { pat_con = (dL->L _ con) +patGroup _ (ConPatOut { pat_con = L _ con , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) = +patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) @@ -1108,7 +1107,7 @@ patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) = (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s -patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) = +patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index be65433c3b..43d71acfdf 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -170,7 +170,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = (dL->L _ con1) + ConPatOut { pat_con = L _ con1 , pat_arg_tys = arg_tys, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1 @@ -192,7 +192,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = arg_vars where fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars - lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env (idName (unLoc (hsRecFieldId rpat))) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" matchOneConLike _ _ [] = panic "matchOneCon []" @@ -209,7 +209,7 @@ compatible_pats _ _ = True -- Prefix or infix co same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields flds1 flds2 - = all2 (\(dL->L _ f1) (dL->L _ f2) + = all2 (\(L _ f1) (L _ f2) -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) (rec_flds flds1) (rec_flds flds2) diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 126346b935..4f65362b2b 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -288,11 +288,11 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- ^ See if the expression is an 'Integral' literal. -- Remember to look through automatically-added tick-boxes! (#8384) -getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit -getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit +getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit getLHsIntegralLit _ = Nothing -- | If 'Integral', extract the value and type name of the overloaded literal. @@ -469,7 +469,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1 + = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -500,7 +500,7 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus + = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 @@ -513,7 +513,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns) adjustMatchResult (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 40bb914d31..e77dcd3768 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -374,8 +374,8 @@ patScopes -> [LPat (GhcPass p)] -> [PScoped (LPat (GhcPass p))] patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ - listScopes patScope (map dL xs) + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs -- | 'listScopes' specialised to 'TVScoped' things tvScopes @@ -579,10 +579,10 @@ instance HasType (LHsBind GhcTc) where _ -> makeNode bind spn instance HasType (Located (Pat GhcRn)) where - getTypeNode (dL -> L spn pat) = makeNode pat spn + getTypeNode (L spn pat) = makeNode pat spn instance HasType (Located (Pat GhcTc)) where - getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) + getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat) instance HasType (LHsExpr GhcRn) where getTypeNode (L spn e) = makeNode e spn @@ -766,7 +766,7 @@ instance ( a ~ GhcPass p , HasType (LPat a) , Data (HsSplice a) ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = + toHie (PS rsp scope pscope lpat@(L ospan opat)) = concatM $ getTypeNode lpat : case opat of WildPat _ -> [] @@ -778,7 +778,7 @@ instance ( a ~ GhcPass p ] AsPat _ lname pat -> [ toHie $ C (PatternBind scope - (combineScopes (mkLScope (dL pat)) pscope) + (combineScopes (mkLScope pat) pscope) rsp) lname , toHie $ PS rsp scope pscope pat @@ -822,7 +822,7 @@ instance ( a ~ GhcPass p ] SigPat _ pat sig -> [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope (dL pat) in + , let cscope = mkLScope pat in toHie $ TS (ResolvedScopes [cscope, scope, pscope]) (protectSig @a cscope sig) -- See Note [Scoping Rules for SigPat] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 53c7680302..80131c6329 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -257,9 +257,6 @@ module GHC ( getLoc, unLoc, getRealSrcSpan, unRealSrcSpan, - -- ** HasSrcSpan - HasSrcSpan(..), SrcSpanLess, dL, cL, - -- *** Combining and comparing Located values eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost, @@ -1392,7 +1389,7 @@ getRichTokenStream mod = do addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] -> [(Located Token, String)] addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(dL->L span _) : ts) +addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts @@ -1418,7 +1415,7 @@ showRichTokenStream ts = go startLoc ts "" getFile (RealSrcSpan s : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id - go loc ((dL->L span _, str):ts) + go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts RealSrcSpan s diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index bd984618a4..96361591e9 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -85,7 +85,7 @@ getImports dflags buf filename source_filename = do imps = hsmodImports hsmod main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) - mod = mb_mod `orElse` cL main_loc mAIN_NAME + mod = mb_mod `orElse` L main_loc mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. @@ -96,8 +96,7 @@ getImports dflags buf filename source_filename = do implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps - convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i) - , ideclName i) + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) in return (map convImport src_idecls, map convImport (implicit_imports ++ ordinary_imps), @@ -120,23 +119,23 @@ mkPrelImports this_mod loc implicit_prelude import_decls | otherwise = [preludeImportDecl] where explicit_prelude_import - = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing })) + = notNull [ () | L _ (ImportDecl { ideclName = mod + , ideclPkgQual = Nothing }) <- import_decls , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = cL loc $ ImportDecl { ideclExt = noExtField, - ideclSourceSrc = NoSourceText, - ideclName = cL loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } + = L loc $ ImportDecl { ideclExt = noExtField, + ideclSourceSrc = NoSourceText, + ideclName = L loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = NotQualified, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } -------------------------------------------------------------- -- Get options @@ -192,7 +191,7 @@ lazyGetToks dflags filename handle = do _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) _ | not eof -> getMore handle state size - | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof] + | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end getMore :: Handle -> PState -> Int -> IO [Located Token] @@ -214,9 +213,9 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc) loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer False return) state of - POk _ t@(dL->L _ ITeof) -> [t] + POk _ t@(L _ ITeof) -> [t] POk state' t -> t : lexAll state' - _ -> [cL (RealSrcSpan (last_loc state)) ITeof] + _ -> [L (RealSrcSpan (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. @@ -245,16 +244,16 @@ getOptions' dflags toks = case toArgs str of Left _err -> optionsParseError str dflags $ -- #15053 combineSrcSpans (getLoc open) (getLoc close) - Right args -> map (cL (getLoc open)) args ++ parseToks xs + Right args -> map (L (getLoc open)) args ++ parseToks xs parseToks (open:close:xs) | ITinclude_prag str <- unLoc open , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-#include",removeSpaces str] ++ + = map (L (getLoc open)) ["-#include",removeSpaces str] ++ parseToks xs parseToks (open:close:xs) | ITdocOptions str <- unLoc open , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str] + = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++ parseToks xs parseToks (open:xs) | ITlanguage_prag <- unLoc open @@ -263,12 +262,12 @@ getOptions' dflags toks | isComment (unLoc comment) = parseToks xs parseToks _ = [] - parseLanguage ((dL->L loc (ITconid fs)):rest) - = checkExtension dflags (cL loc fs) : + parseLanguage ((L loc (ITconid fs)):rest) + = checkExtension dflags (L loc fs) : case rest of - (dL->L _loc ITcomma):more -> parseLanguage more - (dL->L _loc ITclose_prag):more -> parseToks more - (dL->L loc _):_ -> languagePragParseError dflags loc + (L _loc ITcomma):more -> parseLanguage more + (L _loc ITclose_prag):more -> parseToks more + (L loc _):_ -> languagePragParseError dflags loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) = languagePragParseError dflags (getLoc tok) @@ -296,7 +295,7 @@ checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () checkProcessArgsResult dflags flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags - where mkMsg (dL->L loc flag) + where mkMsg (L loc flag) = mkPlainErrMsg dflags loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -304,11 +303,11 @@ checkProcessArgsResult dflags flags ----------------------------------------------------------------------------- checkExtension :: DynFlags -> Located FastString -> Located String -checkExtension dflags (dL->L l ext) +checkExtension dflags (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = if ext' `elem` supported - then cL l ("-X"++ext') + then L l ("-X"++ext') else unsupportedExtnError dflags l ext' where ext' = unpackFS ext @@ -336,11 +335,11 @@ optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Mess optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) where unhandled_flags_lines :: [Located String] - unhandled_flags_lines = [ cL l f + unhandled_flags_lines = [ L l f | f <- unhandled_flags - , (dL->L l f') <- flags_lines + , L l f' <- flags_lines , f == f' ] - mkMsg (dL->L flagSpan flag) = + mkMsg (L flagSpan flag) = ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 27f192227f..a5072a7690 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -22,7 +22,7 @@ import Data.Char -- | Source Statistics ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc -ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list @@ -84,7 +84,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls val_decls = [d | ValD _ d <- decls] - real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es } + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } n_exports = length real_exports export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True ; _ -> False}) @@ -104,7 +104,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0) + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1) @@ -119,12 +119,10 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) sig_info (ClassOpSig {}) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) - import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) - import_info (dL->L _ (XImportDecl nec)) = noExtCon nec - import_info _ = panic " import_info: Impossible Match" - -- due to #15884 + import_info (L _ (XImportDecl nec)) = noExtCon nec safe_info False = 0 safe_info True = 1 @@ -138,7 +136,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs - , dd_derivs = (dL->L _ derivs)}}) + , dd_derivs = L _ derivs}}) = ( length cs , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) 0 derivs ) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 3a5a0bbee1..d1e0603088 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -386,7 +386,7 @@ handleFlagWarnings dflags warns = do -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) - | Warn _ (dL->L loc warn) <- warns' ] + | Warn _ (L loc warn) <- warns' ] printOrThrowWarnings dflags bag diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 01d2424a08..3a6ab1bc5b 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -760,7 +760,7 @@ unitdecl :: { LHsUnitDecl PackageName } signature :: { Located (HsModule GhcPs) } : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } @@ -768,13 +768,13 @@ signature :: { Located (HsModule GhcPs) } module :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (L 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 (cL loc (HsModule Nothing Nothing + ams (L loc (HsModule Nothing Nothing (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) (fst $1) } @@ -825,15 +825,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } header :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (L 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 (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | header_body2 {% fileSrcSpan >>= \ loc -> - return (cL loc (HsModule Nothing Nothing $1 [] Nothing + return (L loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl GhcPs] } @@ -905,7 +905,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(dL->L _ ImpExpQcWildcard) -> + l@(L _ ImpExpQcWildcard) -> return ([mj AnnComma $2, mj AnnDotdot l] ,(snd (unLoc $3) : snd $1)) l -> (ams (head (snd $1)) [mj AnnComma $2] >> @@ -967,7 +967,7 @@ importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec {% do { ; checkImportDecl $4 $7 - ; ams (cL (comb4 $1 $6 (snd $8) $9) $ + ; ams (L (comb4 $1 $6 (snd $8) $9) $ ImportDecl { ideclExt = noExtField , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 @@ -1014,7 +1014,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> - return (cL (gl $1) (Just (b, checkedIe))) } + return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, Located [LIE GhcPs]) } @@ -1163,7 +1163,7 @@ inst_decl :: { LInstDecl GhcPs } , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) + ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1250,24 +1250,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 (dL->L loc _) = $2 in - cL loc ([],Just (unLoc $2)) } + | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in + L loc ([],Just (unLoc $2)) } | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 ,mcc $3],Nothing) } - | vocurly '..' close { let (dL->L loc _) = $2 in - cL loc ([mj AnnDotdot $2],Nothing) } + | vocurly '..' close { let (L loc _) = $2 in + L loc ([mj AnnDotdot $2],Nothing) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% let (dL->L loc (anns, eqn)) = $3 in - asl (unLoc $1) $2 (cL loc eqn) + {% let (L loc (anns, eqn)) = $3 in + asl (unLoc $1) $2 (L loc eqn) >> ams $3 anns - >> return (sLL $1 $> (cL loc eqn : unLoc $1)) } + >> return (sLL $1 $> (L loc eqn : unLoc $1)) } | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in + | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in ams $1 anns - >> return (sLL $1 $> [cL loc eqn]) } + >> return (sLL $1 $> [L loc eqn]) } | {- empty -} { noLoc [] } ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } @@ -1504,7 +1504,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 { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) + | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) ,sL1 $3 (snd $ unLoc $3)) } pattern_synonym_sig :: { LSig GhcPs } @@ -1588,7 +1588,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 { cL (gl $2) (unLoc $2) } + | vocurly decls_inst close { L (gl $2) (unLoc $2) } -- Instance body -- @@ -1624,7 +1624,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 { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- @@ -1638,7 +1638,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } - | vocurly dbinds close { cL (getLoc $2) ([] + | vocurly dbinds close { L (getLoc $2) ([] ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } @@ -1666,7 +1666,7 @@ rule :: { LRuleDecl GhcPs } {%runECP_P $4 >>= \ $4 -> runECP_P $6 >>= \ $6 -> ams (sLL $1 $> $ HsRule { rd_ext = noExtField - , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) + , rd_name = L (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 }) @@ -1778,14 +1778,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) } (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } - : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) } + : STRING { sL1 $1 ([],[L (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` - (cL (gl $3) (getStringLiteral $3)))) } - | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) } + (L (gl $3) (getStringLiteral $3)))) } + | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } | {- empty -} { noLoc nilOL } ----------------------------------------------------------------------------- @@ -1839,7 +1839,7 @@ safety :: { Located Safety } fspec :: { Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] - ,(cL (getLoc $1) + ,(L (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } @@ -2005,13 +2005,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 noExtField (cL (comb2 $1 $2) + HsFunTy noExtField (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4) [mu AnnRarrow $3] } | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExtField (cL (comb2 $1 $2) + HsFunTy noExtField (L (comb2 $1 $2) (HsDocTy noExtField $2 $1)) $4) [mu AnnRarrow $3] } @@ -2157,7 +2157,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] } | fd { sL1 $1 [$1] } fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3) + : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) (reverse (unLoc $1), reverse (unLoc $3))) [mu AnnRarrow $2] } @@ -2200,13 +2200,13 @@ gadt_constrlist :: { Located ([AddAnn] ,[LConDecl GhcPs]) } -- Returned in order : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ - cL (comb2 $1 $3) + L (comb2 $1 $3) ([mj AnnWhere $1 ,moc $2 ,mcc $4] , unLoc $3) } | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ - cL (comb2 $1 $3) + L (comb2 $1 $3) ([mj AnnWhere $1] , unLoc $3) } | {- empty -} { noLoc ([],[]) } @@ -2214,8 +2214,8 @@ gadt_constrlist :: { Located ([AddAnn] gadt_constrs :: { Located [LConDecl GhcPs] } : gadt_constr_with_doc ';' gadt_constrs {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr_with_doc { cL (gl $1) [$1] } + >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } + | gadt_constr_with_doc { L (gl $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -2252,7 +2252,7 @@ allowed in usual data constructors, but not in GADTs). -} constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } - : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2] + : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] ,addConDocs (unLoc $3) $1)} constrs1 :: { Located [LConDecl GhcPs] } @@ -2316,7 +2316,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 (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con + addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) (Just $3) details)) @@ -2324,7 +2324,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 (cL (comb2 $2 $3) (mkConDeclH98 con + addConDoc (L (comb2 $2 $3) (mkConDeclH98 con (snd $ unLoc $2) Nothing -- No context details)) @@ -2352,8 +2352,8 @@ fielddecls1 :: { [LConDeclField GhcPs] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (cL (comb2 $2 $4) - (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5))) + {% ams (L (comb2 $2 $4) + (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2371,17 +2371,17 @@ derivings :: { HsDeriving GhcPs } deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField Nothing $2) + in ams (L full_loc $ HsDerivingClause noExtField Nothing $2) [mj AnnDeriving $1] } | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField (Just $2) $3) + in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3) [mj AnnDeriving $1] } | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField (Just $3) $2) + in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2) [mj AnnDeriving $1] } deriv_clause_types :: { Located [LHsSigType GhcPs] } @@ -2439,7 +2439,7 @@ decl_no_th :: { LHsDecl GhcPs } case r of { (FunBind _ n _ _ _) -> amsL l (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (dL->L lh _lhs) _rhs _) -> + (PatBind _ (L lh _lhs) _rhs _) -> amsL lh (fst $2) >> return () } ; _ <- amsL l (ann ++ (fst $ unLoc $3)); return $! (sL l $ ValD noExtField r) } } @@ -2764,7 +2764,7 @@ aexp :: { ECP } (mj AnnDo $1:(fst $ unLoc $2)) } | 'mdo' stmtlist {% runPV $2 >>= \ $2 -> fmap ecpFromExp $ - ams (cL (comb2 $1 $2) + ams (L (comb2 $1 $2) (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp @@ -2812,7 +2812,7 @@ aexp2 :: { ECP } | '(#' texp '#)' { ECP $ runECP_PV $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)])) + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)])) [mo $1,mc $3] } | '(#' tup_exprs '#)' { ECP $ $2 >>= \ $2 -> @@ -2946,7 +2946,7 @@ tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } { $2 >>= \ $2 -> do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } } | bars texp bars0 { runECP_PV $2 >>= \ $2 -> return $ @@ -2959,16 +2959,16 @@ commas_tup_tail : commas tup_tail do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } : texp commas_tup_tail { runECP_PV $1 >>= \ $1 -> $2 >>= \ $2 -> addAnnotation (gl $1) AnnComma (fst $2) >> - return ((cL (gl $1) (Just $1)) : snd $2) } + return ((L (gl $1) (Just $1)) : snd $2) } | texp { runECP_PV $1 >>= \ $1 -> - return [cL (gl $1) (Just $1)] } + return [L (gl $1) (Just $1)] } | {- empty -} { return [noLoc Nothing] } ----------------------------------------------------------------------------- @@ -2983,32 +2983,32 @@ list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } | lexps { \loc -> $1 >>= \ $1 -> mkHsExplicitListPV loc (reverse $1) } | texp '..' { \loc -> runECP_PV $1 >>= \ $1 -> - ams (cL loc $ ArithSeq noExtField Nothing (From $1)) + ams (L loc $ ArithSeq noExtField Nothing (From $1)) [mj AnnDotdot $2] >>= ecpFromExp' } | texp ',' exp '..' { \loc -> runECP_PV $1 >>= \ $1 -> runECP_PV $3 >>= \ $3 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) + ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) [mj AnnComma $2,mj AnnDotdot $4] >>= ecpFromExp' } | texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> runECP_PV $3 >>= \ $3 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) + ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) [mj AnnDotdot $2] >>= ecpFromExp' } | texp ',' exp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> runECP_PV $3 >>= \ $3 -> runECP_PV $5 >>= \ $5 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) + ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) [mj AnnComma $2,mj AnnDotdot $4] >>= ecpFromExp' } | texp '|' flattenedpquals { \loc -> checkMonadComp >>= \ ctxt -> runECP_PV $1 >>= \ $1 -> - ams (cL loc $ mkHsComp ctxt (unLoc $3) $1) + ams (L loc $ mkHsComp ctxt (unLoc $3) $1) [mj AnnVbar $2] >>= ecpFromExp' } @@ -3043,7 +3043,7 @@ 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 { cL (getLoc $1) [reverse (unLoc $1)] } + | squals { L (getLoc $1) [reverse (unLoc $1)] } squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last -- one can "grab" the earlier ones @@ -3056,7 +3056,7 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) } + return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } | qual {% runPV $1 >>= \ $1 -> return $ sL1 $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } @@ -3095,7 +3095,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- Guards guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) } + : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% runPV $3 >>= \ $3 -> @@ -3113,7 +3113,7 @@ altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Loca sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } | vocurly alts close { $2 >>= \ $2 -> return $ - cL (getLoc $2) (fst $ unLoc $2 + L (getLoc $2) (fst $ unLoc $2 ,(reverse (snd $ unLoc $2))) } | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { return $ noLoc ([],[]) } @@ -3210,7 +3210,7 @@ stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Locat sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? | vocurly stmts close { $2 >>= \ $2 -> return $ - cL (gl $2) (fst $ unLoc $2 + L (gl $2) (fst $ unLoc $2 ,reverse $ snd $ unLoc $2) } -- do { ;; s ; s ; ; s ;; } @@ -3765,87 +3765,87 @@ maybe_docnext :: { Maybe LHsDocString } happyError :: P a happyError = srcParseFail -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 -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 +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 +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 -- See Note [Pragma source text] in BasicTypes for the following -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 +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 getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) isUnicode :: Located Token -> Bool -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 (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 _ = False hasE :: Located Token -> Bool -hasE (dL->L _ (ITopenExpQuote HasE _)) = True -hasE (dL->L _ (ITopenTExpQuote HasE)) = True +hasE (L _ (ITopenExpQuote HasE _)) = True +hasE (L _ (ITopenTExpQuote HasE)) = True hasE _ = False getSCC :: Located Token -> P FastString @@ -3857,39 +3857,36 @@ getSCC lt = do let s = getSTRING lt else return s -- Utilities for combining source spans -comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan +comb2 :: Located a -> Located b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b -comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> c -> SrcSpan +comb3 :: Located a -> Located b -> Located c -> SrcSpan comb3 a b c = a `seq` b `seq` c `seq` combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) -comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => - a -> b -> c -> d -> SrcSpan +comb4 :: Located a -> Located b -> Located c -> Located 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 :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -sL span a = span `seq` a `seq` cL span a +sL :: SrcSpan -> a -> Located a +sL span a = span `seq` a `seq` L 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 :: HasSrcSpan a => SrcSpanLess a -> a -sL0 = cL noSrcSpan -- #define L0 L noSrcSpan +sL0 :: a -> Located a +sL0 = L noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b +sL1 :: Located a -> b -> Located b sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} -sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> SrcSpanLess c -> c +sLL :: Located a -> Located b -> c -> Located c sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) {- Note [Adding location info] @@ -3990,7 +3987,7 @@ in ApiAnnotation.hs -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword itself -mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn +mj :: AnnKeywordId -> Located e -> AddAnn mj a l = AddAnn a (gl l) @@ -3998,25 +3995,25 @@ mj a l = AddAnn a (gl l) -- 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@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l +mu a lt@(L l t) = AddAnn (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 :: Located a -> SrcSpan gl = getLoc -- |Add an annotation to the located element, and return the located -- element as a pass through -aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a -aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a +aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a) +aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a -- |Add an annotation to a located element resulting from a monadic action -am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a +am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) am a (b,s) = do - av@(dL->L l _) <- a + av@(L l _) <- a addAnnotation l b (gl s) return av @@ -4033,27 +4030,27 @@ am a (b,s) = do -- as any annotations that may arise in the binds. This will include open -- and closing braces if they are used to delimit the let expressions. -- -ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a -ams a@(dL->L l _) bs = addAnnsAt l bs >> return a +ams :: MonadP m => Located a -> [AddAnn] -> m (Located a) +ams 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, and wrap it in a 'Just' -ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a) +ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a)) ajs a bs = Just <$> ams a bs -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action -amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a -amms a bs = do { av@(dL->L l _) <- a +amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a) +amms a bs = do { av@(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 :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) -amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) +amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) +amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) -- |Synonyms for AddAnn versions of AnnOpen and AnnClose mo,mc :: Located Token -> AddAnn @@ -4083,14 +4080,14 @@ mvbars :: [SrcSpan] -> [AddAnn] mvbars = map (AddAnn AnnVbar) -- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: HasSrcSpan a => OrdList a -> SrcSpan +oll :: OrdList (Located 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 :: (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 +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 } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 89634193e4..617f1c08b2 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -160,10 +160,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -- *** See Note [The Naming story] in GHC.Hs.Decls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) +mkTyClD (L loc d) = L loc (TyClD noExtField d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (dL->L loc d) = cL loc (InstD noExtField d) +mkInstD (L loc d) = L loc (InstD noExtField d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -171,21 +171,21 @@ mkClassDecl :: SrcSpan -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) -mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (cL loc (ClassDecl { tcdCExt = noExtField, 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 (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } mkTyData :: SrcSpan -> NewOrData @@ -195,17 +195,17 @@ mkTyData :: SrcSpan -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) +mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataDecl { tcdDExt = noExtField, - tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn })) } + ; return (L loc (DataDecl { tcdDExt = noExtField, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) @@ -234,10 +234,10 @@ mkTySynonym loc lhs rhs ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (SynDecl { tcdSExt = noExtField - , tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs })) } + ; return (L loc (SynDecl { tcdSExt = noExtField + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } mkStandaloneKindSig :: SrcSpan @@ -247,7 +247,7 @@ mkStandaloneKindSig mkStandaloneKindSig loc lhs rhs = do { vs <- mapM check_lhs_name (unLoc lhs) ; v <- check_singular_lhs (reverse vs) - ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } + ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } where check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) @@ -292,7 +292,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs + ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs (FamEqn { feqn_ext = noExtField , feqn_tycon = tc , feqn_bndrs = bndrs @@ -304,7 +304,7 @@ mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn - = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn))) + = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -317,7 +317,7 @@ mkFamDecl loc info lhs ksig injAnn ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (FamDecl noExtField (FamilyDecl + ; return (L loc (FamDecl noExtField (FamilyDecl { fdExt = noExtField , fdInfo = info, fdLName = tc , fdTyVars = tyvars @@ -340,15 +340,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@(dL->L loc expr) +mkSpliceDecl lexpr@(L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) + = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) + = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) | otherwise - = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice BareSplice lexpr)) + = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan @@ -357,16 +357,16 @@ mkRoleAnnotDecl :: SrcSpan -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles - ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' } + ; return $ L loc $ RoleAnnotDecl noExtField 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 (dL->L loc_role Nothing) = return $ cL loc_role Nothing - parse_role (dL->L loc_role (Just role)) + parse_role (L loc_role Nothing) = return $ L loc_role Nothing + parse_role (L loc_role (Just role)) = case lookup role possible_roles of - Just found_role -> return $ cL loc_role $ Just found_role + Just found_role -> return $ L loc_role $ Just found_role Nothing -> let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) @@ -374,8 +374,6 @@ mkRoleAnnotDecl loc tycon roles addFatalError 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) @@ -400,9 +398,9 @@ cvTopDecls decls = go (fromOL decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] - 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 ((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 -- Declaration list may only contain value bindings and signatures. @@ -422,24 +420,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs) cvBindsAndSigs fb = go (fromOL fb) where go [] = return (emptyBag, [], [], [], [], []) - go ((dL->L l (ValD _ b)) : ds) + go ((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 (cL l b) ds - go ((dL->L l decl) : ds) + (b', ds') = getMonoBind (L l b) ds + go ((L l decl) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds ; case decl of SigD _ s - -> return (bs, cL l s : ss, ts, tfis, dfis, docs) + -> return (bs, L l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) - -> return (bs, ss, cL l t : ts, tfis, dfis, docs) + -> return (bs, ss, L l t : ts, tfis, dfis, docs) InstD _ (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) + -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) InstD _ (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) + -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) DocD _ d - -> return (bs, ss, ts, tfis, dfis, cL l d : docs) + -> return (bs, ss, ts, tfis, dfis, L l d : docs) SpliceD _ d -> addFatalError l $ hang (text "Declaration splices are allowed only" <+> @@ -465,25 +463,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) - , fun_matches = - MG { mg_alts = (dL->L _ mtchs1) } })) +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) + , fun_matches = + MG { mg_alts = (L _ mtchs1) } })) binds | has_args mtchs1 = go mtchs1 loc1 binds [] where go mtchs loc - ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) - , fun_matches = - MG { mg_alts = (dL->L _ mtchs2) } }))) + ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) + , fun_matches = + MG { mg_alts = (L _ mtchs2) } }))) : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls + go mtchs loc (doc_decl@(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 - = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) + = ( L 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 @@ -491,14 +489,13 @@ getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) getMonoBind bind binds = (bind, binds) has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool -has_args [] = panic "RdrHsSyn:has_args" -has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) +has_args [] = panic "RdrHsSyn:has_args" +has_args (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 ((dL->L _ (XMatch nec)) : _) = noExtCon nec -has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 +has_args (L _ (XMatch nec) : _) = noExtCon nec {- ********************************************************************** @@ -589,7 +586,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) - = return (cL loc (setRdrNameSpace tc srcDataName)) + = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise = Left (loc, msg) @@ -600,14 +597,14 @@ tyConToDataCon loc tc mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = +mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where - fromDecl (dL->L loc decl@(ValD _ (PatBind _ - pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) - rhs _))) = + fromDecl (L loc decl@(ValD _ (PatBind _ + pat@(L _ (ConPatIn ln@(L _ name) details)) + rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of @@ -629,8 +626,8 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = , mc_strictness = NoSrcStrict } RecCon{} -> recordPatSynErr loc pat - ; return $ cL loc match } - fromDecl (dL->L loc decl) = extraDeclErr loc decl + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = addFatalError loc $ @@ -672,7 +669,7 @@ mkGadtDecl :: [Located RdrName] mkGadtDecl names ty = (ConDeclGADT { con_g_ext = noExtField , con_names = names - , con_forall = cL l $ isLHsForAllTy ty' + , con_forall = L l $ isLHsForAllTy ty' , con_qvars = mkHsQTvs tvs , con_mb_cxt = mcxt , con_args = args @@ -680,13 +677,13 @@ mkGadtDecl names ty , con_doc = Nothing } , anns1 ++ anns2) where - (ty'@(dL->L l _),anns1) = peel_parens ty [] + (ty'@(L l _),anns1) = peel_parens ty [] (tvs, rho) = splitLHsForAllTyInvis ty' (mcxt, tau, anns2) = split_rho rho [] - split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann + split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann = (Just cxt, tau, ann) - split_rho (dL->L l (HsParTy _ ty)) ann + split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l) split_rho tau ann = (Nothing, tau, ann) @@ -694,12 +691,12 @@ mkGadtDecl names ty (args, res_ty) = split_tau tau -- See Note [GADT abstract syntax] in GHC.Hs.Decls - split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) - = (RecCon (cL loc rf), res_ty) + split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) + = (RecCon (L loc rf), res_ty) split_tau tau = (PrefixCon [], tau) - peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty + peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty (ann++mkParensApiAnn l) peel_parens ty ann = (ty, ann) @@ -823,19 +820,18 @@ checkTyVars pp_what equals_or_where tc tparms -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr GhcPs, [AddAnn]) - chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l - ++ acc) ty + chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty chkParens acc ty = do tv <- chk ty return (tv, reverse acc) -- Check that the name space is correct! chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) - chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) - | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k)) - chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) - | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv))) - chk t@(dL->L loc _) + chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) + | isRdrTyVar tv = return (L l (KindedTyVar noExtField (L lv tv) k)) + chk (L l (HsTyVar _ _ (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar noExtField (L ltv tv))) + chk t@(L loc _) = addFatalError loc $ vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> pp_what @@ -893,14 +889,14 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one) -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (dL->L loc (Unqual occ)) = do + where check (L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) (addFatalError loc (text $ "parse error on input " ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) -checkRecordSyntax lr@(dL->L loc r) +checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit unless allowed $ addError loc $ text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r @@ -910,7 +906,7 @@ checkRecordSyntax lr@(dL->L loc r) -- `data T where` to avoid affecting existing error message, see #8258. checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) -checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. +checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax unless gadtSyntax $ addError span $ vcat [ text "Illegal keyword 'where' in data declaration" @@ -934,23 +930,23 @@ checkTyClHdr :: Bool -- True <=> class header checkTyClHdr is_cls ty = goL ty [] [] Prefix where - goL (dL->L l ty) acc ann fix = go l ty acc ann fix + goL (L l ty) acc ann fix = go l ty acc ann fix -- workaround to define '*' despite StarIsType - go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix + go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix = do { warnStarBndr l ; let name = mkOccName tcClsName (starSym isUni) - ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } + ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } - go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix + go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix | isRdrTc tc = return (ltc, acc, fix, ann) - go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix + go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, HsValArg t1:HsValArg 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 (HsValArg t2:acc) ann fix go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) + = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity @@ -987,7 +983,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () HsCmdDo {} -> check "do command" cmd _ -> return () - check :: (HasSrcSpan a, Outputable a) => String -> a -> PV () + check :: Outputable a => String -> Located a -> PV () check element a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ @@ -1007,22 +1003,22 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -- (((Eq a))) --> [Eq a] -- @ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (dL->L l orig_t) - = check [] (cL l orig_t) +checkContext (L l orig_t) + = check [] (L l orig_t) where - check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + check anns (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,cL l ts) -- Ditto () + = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - check anns (dL->L lp1 (HsParTy _ ty)) + check anns (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 ([],cL l [cL l orig_t]) + check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t]) msg = text "data constructor context" @@ -1031,9 +1027,9 @@ checkContext (dL->L l orig_t) checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs msg ty = go ty where - go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki - go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 - go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep + go (L _ (HsAppKindTy _ ty ki)) = go ty *> go ki + go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 + go (L l (HsDocTy _ t ds)) = addError l $ hsep [ text "Unexpected haddock", quotes (ppr ds) , text "on", msg, quotes (ppr t) ] go _ = pure () @@ -1076,21 +1072,21 @@ checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) -checkLPat e@(dL->L l _) = checkPat l e [] +checkLPat e@(L l _) = checkPat l e [] checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) -checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args - | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) +checkPat loc (L l e@(PatBuilderVar (L _ c))) args + | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) | not (null args) && patIsRec c = localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ patFail l (ppr e) -checkPat loc (dL->L _ (PatBuilderApp f e)) args +checkPat loc (L _ (PatBuilderApp f e)) args = do p <- checkLPat e checkPat loc f (p : args) -checkPat loc (dL->L _ e) [] +checkPat loc (L _ e) [] = do p <- checkAPat loc e - return (cL loc p) + return (L loc p) checkPat loc e _ = patFail loc (ppr e) @@ -1104,21 +1100,21 @@ checkAPat loc e0 = do -- 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 - PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) + PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) -- n+k patterns PatBuilderOpApp - (dL->L nloc (PatBuilderVar (dL->L _ n))) - (dL->L _ plus) - (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + (L nloc (PatBuilderVar (L _ n))) + (L _ plus) + (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | nPlusKPatterns && (plus == plus_RDR) - -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) + -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - PatBuilderOpApp l (dL->L cl c) r + PatBuilderOpApp l (L cl c) r | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r - return (ConPatIn (cL cl c) (InfixCon l r)) + return (ConPatIn (L cl c) (InfixCon l r)) PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) _ -> patFail loc (ppr e0) @@ -1135,8 +1131,8 @@ pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) -checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) - return (cL l (fld { hsRecFieldArg = p })) +checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) + return (L l (fld { hsRecFieldArg = p })) patFail :: SrcSpan -> SDoc -> PV a patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e @@ -1157,12 +1153,12 @@ checkValDef lhs (Just sig) grhss = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat checkPatBind lhs' grhss -checkValDef lhs Nothing g@(dL->L l (_,grhss)) +checkValDef lhs Nothing g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> checkFunBind NoSrcStrict ann (getLoc lhs) - fun is_infix pats (cL l grhss) + fun is_infix pats (L l grhss) Nothing -> do lhs' <- checkPattern lhs checkPatBind lhs' g } @@ -1175,19 +1171,19 @@ checkFunBind :: SrcStrictness -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) +checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) = do ps <- mapM checkPattern 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 - [cL match_span (Match { m_ext = noExtField - , m_ctxt = FunRhs - { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) + [L match_span (Match { m_ext = noExtField + , 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. @@ -1205,28 +1201,28 @@ makeFunBind fn ms checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkPatBind lhs (dL->L match_span (_,grhss)) +checkPatBind lhs (L match_span (_,grhss)) | BangPat _ p <- unLoc lhs , VarPat _ v <- unLoc p - = return ([], makeFunBind v [cL match_span (m v)]) + = return ([], makeFunBind v [L match_span (m v)]) where m v = Match { m_ext = noExtField - , m_ctxt = FunRhs { mc_fun = cL (getLoc lhs) (unLoc v) + , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v) , mc_fixity = Prefix , mc_strictness = SrcStrict } , m_pats = [] , m_grhss = grhss } -checkPatBind lhs (dL->L _ (_,grhss)) +checkPatBind lhs (L _ (_,grhss)) = return ([],PatBind noExtField lhs grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) +checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr -checkValSigLhs lhs@(dL->L l _) +checkValSigLhs lhs@(L l _) = addFatalError l ((text "Invalid type signature:" <+> ppr lhs <+> text ":: ...") $$ text hint) @@ -1244,8 +1240,8 @@ checkValSigLhs lhs@(dL->L l _) -- so check for that, and suggest. cf #3805 -- 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 s (L _ (HsVar _ (L _ v))) = v == s + looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") @@ -1253,8 +1249,8 @@ checkValSigLhs lhs@(dL->L l _) pattern_RDR = mkUnqual varName (fsLit "pattern") checkDoAndIfThenElse - :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) - => a -> Bool -> b -> Bool -> c -> PV () + :: (Outputable a, Outputable b, Outputable c) + => Located a -> Bool -> b -> Bool -> Located c -> PV () checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit @@ -1287,21 +1283,21 @@ isFunLhs :: Located (PatBuilder GhcPs) isFunLhs e = go e [] [] where - go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann - | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) - go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann - go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) - go (dL->L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann + go (L loc (PatBuilderVar (L _ f))) es ann + | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) + go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann + go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann | not (isRdrDataCon op) -- We have found the function! - = return (Just (cL loc' op, Infix, (l:r:es), ann)) + = return (Just (L 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 = cL loc (PatBuilderOpApp k - (cL loc' op) r) + op_app = L loc (PatBuilderOpApp k + (L loc' op) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1343,7 +1339,7 @@ pUnpackedness , SourceText , SrcUnpackedness , [Located TyEl] {- remaining TyEl -}) -pUnpackedness ((dL->L l x1) : xs) +pUnpackedness (L l x1 : xs) | TyElUnpackedness (anns, prag, unpk) <- x1 = Just (l, anns, prag, unpk, xs) pUnpackedness _ = Nothing @@ -1355,13 +1351,13 @@ pBangTy , LHsType GhcPs {- the resulting BangTy -} , P () {- add annotations -} , [Located TyEl] {- remaining TyEl -}) -pBangTy lt@(dL->L l1 _) xs = +pBangTy lt@(L l1 _) xs = case pUnpackedness xs of Nothing -> (False, lt, pure (), xs) Just (l2, anns, prag, unpk, xs') -> let bl = combineSrcSpans l1 l2 bt = addUnpackedness (prag, unpk) lt - in (True, cL bl bt, addAnnsAt bl anns, xs') + in (True, L bl bt, addAnnsAt bl anns, xs') mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs mkBangTy strictness = @@ -1387,8 +1383,8 @@ addUnpackedness (prag, unpk) t -- -- See Note [Parsing data constructors is hard] mergeOps :: [Located TyEl] -> P (LHsType GhcPs) -mergeOps ((dL->L l1 (TyElOpd t)) : xs) - | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs +mergeOps ((L l1 (TyElOpd t)) : xs) + | (_, t', addAnns, xs') <- pBangTy (L 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 @@ -1398,7 +1394,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [unpk]: -- handle (NO)UNPACK pragmas - go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = + go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = if not (null acc) && null xs then do { acc' <- eitherToP $ mergeOpsAcc acc ; let a = ops_acc acc' @@ -1406,7 +1402,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs bl = combineSrcSpans l (getLoc a) bt = HsBangTy noExtField strictMark a ; addAnnsAt bl anns - ; return (cL bl bt) } + ; return (L bl bt) } else addFatalError l unpkError where unpkSDoc = case unpkSrc of @@ -1421,38 +1417,35 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [doc]: -- we do not expect to encounter any docs - go _ _ _ ((dL->L l (TyElDocPrev _)):_) = + go _ _ _ ((L l (TyElDocPrev _)):_) = failOpDocPrev l -- 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 ((dL->L l (TyElOpr op)):xs) = + go k acc ops_acc ((L l (TyElOpr op)):xs) = if null acc || null (filter isTyElOpd xs) - then failOpFewArgs (cL l op) + then failOpFewArgs (L l op) else do { acc' <- eitherToP (mergeOpsAcc acc) - ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } + ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs } where - isTyElOpd (dL->L _ (TyElOpd _)) = True + isTyElOpd (L _ (TyElOpd _)) = True isTyElOpd _ = False -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs + go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs -- clause [tyapp]: -- whenever a type application is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs + go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs -- clause [end] -- See Note [Non-empty 'acc' in mergeOps clause [end]] go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) ; return (ops_acc acc') } - go _ _ _ _ = panic "mergeOps.go: Impossible Match" - -- due to #15884 - mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [] = panic "mergeOpsAcc: empty input" @@ -1524,8 +1517,8 @@ 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 ((dL->L l (TyElOpd t)):xs) - | (True, t', addAnns, xs') <- pBangTy (cL l t) xs +pInfixSide ((L l (TyElOpd t)):xs) + | (True, t', addAnns, xs') <- pBangTy (L l t) xs = Just (t', addAnns, xs') pInfixSide (el:xs1) | Just t1 <- pLHsTypeArg el @@ -1542,15 +1535,15 @@ pInfixSide (el:xs1) pInfixSide _ = Nothing pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) -pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) -pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a) +pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a)) +pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a) pLHsTypeArg _ = Nothing pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) pDocPrev = go Nothing where - go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = - go (mTrailingDoc `mplus` Just (cL l doc)) xs + go mTrailingDoc ((L l (TyElDocPrev doc)):xs) = + go (mTrailingDoc `mplus` Just (L l doc)) xs go mTrailingDoc xs = (mTrailingDoc, xs) orErr :: Maybe a -> b -> Either b a @@ -1648,7 +1641,7 @@ mergeDataCon all_xs = -- A -- ^ Comment on A -- B -- ^ Comment on B (singleDoc == False) singleDoc = isJust mTrailingDoc && - null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] + null [ () | (L _ (TyElDocPrev _)) <- all_xs' ] -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. @@ -1670,38 +1663,38 @@ mergeDataCon all_xs = trailingFieldDoc | singleDoc = Nothing | otherwise = mTrailingDoc - goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] + goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } - goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) + goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs) | (mConDoc, xs') <- pDocPrev xs - , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' + , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs' = do { data_con <- tyConToDataCon l' tc ; let mDoc = mTrailingDoc `mplus` mConDoc - ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } - goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] + ; return (pure (), (data_con, RecCon (L l fields), mDoc)) } + goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () - , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) + , ( L l (getRdrName (tupleDataCon Boxed (length ts))) , PrefixCon ts , mTrailingDoc ) ) - goFirst ((dL->L l (TyElOpd t)):xs) - | (_, t', addAnns, xs') <- pBangTy (cL l t) xs + goFirst ((L l (TyElOpd t)):xs) + | (_, t', addAnns, xs') <- pBangTy (L l t) xs = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' goFirst (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) goFirst xs = go (pure ()) mTrailingDoc [] xs - go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] + go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } - 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 + 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 , t'' <- mkLHsDocTyMaybe t' mLastDoc = go (addAnns >> addAnns') Nothing (t'':ts) xs' - go _ _ _ ((dL->L _ (TyElOpr _)):_) = + go _ _ _ ((L _ (TyElOpr _)):_) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix @@ -1719,7 +1712,7 @@ mergeDataCon all_xs = ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr ; let (mOpDoc, xs2) = pDocPrev xs1 ; (op, xs3) <- case xs2 of - (dL->L l (TyElOpr op)) : xs3 -> + (L l (TyElOpr op)) : xs3 -> do { data_con <- tyConToDataCon l op ; return (data_con, xs3) } _ -> Left malformedErr @@ -1782,13 +1775,13 @@ class DisambInfixOp b where mkHsInfixHolePV :: SrcSpan -> PV (Located b) instance p ~ GhcPs => DisambInfixOp (HsExpr p) where - mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v) - mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l = return $ cL l hsHoleExpr + mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsInfixHolePV l = return $ L l hsHoleExpr instance DisambInfixOp RdrName where - mkHsConOpPV (dL->L l v) = return $ cL l v - mkHsVarOpPV (dL->L l v) = return $ cL l v + mkHsConOpPV (L l v) = return $ L l v + mkHsVarOpPV (L l v) = return $ L l v mkHsInfixHolePV l = addFatalError l $ text "Invalid infix hole, expected an infix operator" @@ -1915,34 +1908,34 @@ typechecker. instance p ~ GhcPs => DisambECP (HsCmd p) where type Body (HsCmd p) = HsCmd ecpFromCmd' = return - ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) - mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg) - mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e) + ecpFromExp' (L l e) = cmdFail l (ppr e) + mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) + mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) type InfixOp (HsCmd p) = HsExpr p superInfixOp m = m mkHsOpAppPV l c1 op c2 = do - let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c - return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg) + let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c + return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg) type FunArg (HsCmd p) = HsExpr p superFunArg m = m mkHsAppPV l c e = do checkCmdBlockArguments c checkExpBlockArguments e - return $ cL l (HsCmdApp noExtField c e) + return $ L l (HsCmdApp noExtField c e) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b - return $ cL l (mkHsCmdIf c a b) - mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts) - mkHsParPV l c = return $ cL l (HsCmdPar noExtField c) - mkHsVarPV (dL->L l v) = cmdFail l (ppr v) - mkHsLitPV (dL->L l a) = cmdFail l (ppr a) - mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) + return $ L l (mkHsCmdIf c a b) + mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts) + mkHsParPV l c = return $ L l (HsCmdPar noExtField c) + mkHsVarPV (L l v) = cmdFail l (ppr v) + mkHsLitPV (L l a) = cmdFail l (ppr a) + mkHsOverLitPV (L l a) = cmdFail l (ppr a) mkHsWildCardPV l = cmdFail l (text "_") mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) mkHsExplicitListPV l xs = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) - mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) + mkHsSplicePV (L l sp) = cmdFail l (ppr sp) mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ ppr a <+> ppr (mk_rec_fields fbinds ddLoc) mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) @@ -1966,42 +1959,42 @@ cmdFail loc e = addFatalError loc $ instance p ~ GhcPs => DisambECP (HsExpr p) where type Body (HsExpr p) = HsExpr - ecpFromCmd' (dL -> L l c) = do + ecpFromCmd' (L l c) = do addError l $ vcat [ text "Arrow command found where an expression was expected:", nest 2 (ppr c) ] - return (cL l hsHoleExpr) + return (L l hsHoleExpr) ecpFromExp' = return - mkHsLamPV l mg = return $ cL l (HsLam noExtField mg) - mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c) + mkHsLamPV l mg = return $ L l (HsLam noExtField mg) + mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) type InfixOp (HsExpr p) = HsExpr p superInfixOp m = m mkHsOpAppPV l e1 op e2 = do - return $ cL l $ OpApp noExtField e1 op e2 - mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg) + return $ L l $ OpApp noExtField e1 op e2 + mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) type FunArg (HsExpr p) = HsExpr p superFunArg m = m mkHsAppPV l e1 e2 = do checkExpBlockArguments e1 checkExpBlockArguments e2 - return $ cL l (HsApp noExtField e1 e2) + return $ L l (HsApp noExtField e1 e2) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b - return $ cL l (mkHsIf c a b) - mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts) - mkHsParPV l e = return $ cL l (HsPar noExtField e) - mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v) - mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a) - mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a) - mkHsWildCardPV l = return $ cL l hsHoleExpr - mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs) + return $ L l (mkHsIf c a b) + mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts) + mkHsParPV l e = return $ L l (HsPar noExtField e) + mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v) + mkHsLitPV (L l a) = return $ L l (HsLit noExtField a) + mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a) + mkHsWildCardPV l = return $ L l hsHoleExpr + mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) + mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs) mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp mkHsRecordPV l lrec a (fbinds, ddLoc) = do r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) - checkRecordSyntax (cL l r) - mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr) - mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e) + checkRecordSyntax (L l r) + mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) + mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty mkHsAsPatPV l v e = patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $ @@ -2018,7 +2011,7 @@ patSynErr item l e explanation = sep [text item <+> text "in expression context:", nest 4 (ppr e)] $$ explanation - ; return (cL l hsHoleExpr) } + ; return (L l hsHoleExpr) } hsHoleExpr :: HsExpr (GhcPass id) hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") @@ -2042,10 +2035,10 @@ instance Outputable (PatBuilder GhcPs) where instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (dL-> L l c) = + ecpFromCmd' (L l c) = addFatalError l $ text "Command syntax in pattern:" <+> ppr c - ecpFromExp' (dL-> L l e) = + ecpFromExp' (L l e) = addFatalError l $ text "Expression syntax in pattern:" <+> ppr e mkHsLamPV l _ = addFatalError l $ @@ -2054,54 +2047,54 @@ instance DisambECP (PatBuilder GhcPs) where mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m - mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2 + mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m - mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" - mkHsParPV l p = return $ cL l (PatBuilderPar p) - mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) - mkHsLitPV lit@(dL->L l a) = do + mkHsParPV l p = return $ L l (PatBuilderPar p) + mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) + mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit - return $ cL l (PatBuilderPat (LitPat noExtField a)) - mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) - mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField)) + return $ L l (PatBuilderPat (LitPat noExtField a)) + mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig = do p <- checkLPat b - return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) + return $ L l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) mkHsExplicitListPV l xs = do ps <- traverse checkLPat xs - return (cL l (PatBuilderPat (ListPat noExtField ps))) - mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp)) + return (L l (PatBuilderPat (ListPat noExtField ps))) + mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) mkHsRecordPV l _ a (fbinds, ddLoc) = do r <- mkPatRec a (mk_rec_fields fbinds ddLoc) - checkRecordSyntax (cL l r) - mkHsNegAppPV l (dL->L lp p) = do + checkRecordSyntax (L l r) + mkHsNegAppPV l (L lp p) = do lit <- case p of - PatBuilderOverLit pos_lit -> return (cL lp pos_lit) + PatBuilderOverLit pos_lit -> return (L lp pos_lit) _ -> patFail l (text "-" <> ppr p) - return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) mkHsViewPatPV l a b = do p <- checkLPat b - return $ cL l (PatBuilderPat (ViewPat noExtField a p)) + return $ L l (PatBuilderPat (ViewPat noExtField a p)) mkHsAsPatPV l v e = do p <- checkLPat e - return $ cL l (PatBuilderPat (AsPat noExtField v p)) + return $ L l (PatBuilderPat (AsPat noExtField v p)) mkHsLazyPatPV l e = do p <- checkLPat e - return $ cL l (PatBuilderPat (LazyPat noExtField p)) + return $ L l (PatBuilderPat (LazyPat noExtField p)) mkHsBangPatPV l e = do p <- checkLPat e let pb = BangPat noExtField p hintBangPat l pb - return $ cL l (PatBuilderPat pb) + return $ L l (PatBuilderPat pb) mkSumOrTuplePV = mkSumOrTuplePat checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () -checkUnboxedStringLitPat (dL->L loc lit) = +checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260 -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) @@ -2573,7 +2566,7 @@ checkPrecP :: Located (SourceText,Int) -- ^ precedence -> Located (OrdList (Located RdrName)) -- ^ operators -> P () -checkPrecP (dL->L l (_,i)) (dL->L _ ol) +checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) @@ -2587,9 +2580,9 @@ mkRecConstrOrUpdate -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> PV (HsExpr GhcPs) -mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) | isRdrDataCon c - = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) + = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp _ (fs,dd) | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) @@ -2607,15 +2600,13 @@ mkRdrRecordCon con flds mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs - , rec_dotdot = Just (cL s (length fs)) } + , rec_dotdot = Just (L s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) +mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun -mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) +mk_rec_upd_field (HsRecField (L _ (XFieldOcc nec)) _ _) = noExtCon nec -mk_rec_upd_field (HsRecField _ _ _) - = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -2658,7 +2649,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 (cL loc esrc) of + case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of Nothing -> addFatalError loc (text "Malformed entity string") Just importSpec -> returnSpec importSpec @@ -2670,7 +2661,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 (cL loc esrc) + importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) returnSpec spec = return $ ForD noExtField $ ForeignImport { fd_i_ext = noExtField @@ -2745,11 +2736,11 @@ parseCImport cconv safety nm str sourceText = mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) -mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) +mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = return $ ForD noExtField $ ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) - (cL le esrc) } + , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) + (L le esrc) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -2776,15 +2767,15 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcWildcard mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (dL->L l specname) subs = +mkModuleImpExp (L l specname) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExtField (cL l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExtField . cL l <$> nameT - ImpExpAll -> IEThingAll noExtField . cL l <$> nameT + -> return $ IEVar noExtField (L l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExtField . L l <$> nameT + ImpExpAll -> IEThingAll noExtField . L l <$> nameT ImpExpList xs -> - (\newName -> IEThingWith noExtField (cL l newName) + (\newName -> IEThingWith noExtField (L l newName) NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit @@ -2795,7 +2786,7 @@ mkModuleImpExp (dL->L l specname) subs = (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExtField (cL l newName) pos ies []) + -> IEThingWith noExtField (L l newName) pos ies []) <$> nameT else addFatalError l (text "Illegal export form (use PatternSynonyms to enable)") @@ -2821,7 +2812,7 @@ mkModuleImpExp (dL->L l specname) subs = ieNameFromSpec (ImpExpQcType ln) = IEType ln ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - wrapped = map (onHasSrcSpan ieNameFromSpec) + wrapped = map (mapLoc ieNameFromSpec) mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) @@ -2832,8 +2823,8 @@ mkTypeImpExp name = return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) -checkImportSpec ie@(dL->L _ specs) = - case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of +checkImportSpec ie@(L _ specs) = + case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where @@ -2845,7 +2836,7 @@ checkImportSpec ie@(dL->L _ specs) = -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = +mkImpExpSubSpec [L _ ImpExpQcWildcard] = return ([], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) @@ -2901,7 +2892,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg $$ text " including the definition module, you must qualify it." failOpFewArgs :: Located RdrName -> P a -failOpFewArgs (dL->L loc op) = +failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit ; let msg = too_few $$ starInfo star_is_type op ; addFatalError loc msg } @@ -3108,14 +3099,14 @@ mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExp -- Tuple mkSumOrTupleExpr l boxity (Tuple es) = - return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity) + return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity) where toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) -- Sum mkSumOrTupleExpr l Unboxed (Sum alt arity e) = - return $ cL l (ExplicitSum noExtField alt arity e) + return $ L l (ExplicitSum noExtField alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) @@ -3125,17 +3116,17 @@ mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Loc -- Tuple mkSumOrTuplePat l boxity (Tuple ps) = do ps' <- traverse toTupPat ps - return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity)) + return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity)) where toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) - toTupPat (dL -> L l p) = case p of + toTupPat (L l p) = case p of Nothing -> addFatalError l (text "Tuple section in pattern context") Just p' -> checkLPat p' -- Sum mkSumOrTuplePat l Unboxed (Sum alt arity p) = do p' <- checkLPat p - return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity)) + return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) @@ -3143,12 +3134,12 @@ mkSumOrTuplePat l Boxed a@Sum{} = mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y - in cL loc (mkHsOpTy x op y) + in L loc (mkHsOpTy x op y) mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs mkLHsDocTy t doc = let loc = getLoc t `combineSrcSpans` getLoc doc - in cL loc (HsDocTy noExtField t doc) + in L loc (HsDocTy noExtField t doc) mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 59ca753ae4..693d818f67 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -1368,7 +1368,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss - | otherwise = cL (getLoc (head ss)) rec_stmt + | otherwise = L (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index deaedb8bca..6af59a0210 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -17,9 +17,9 @@ rnMbLHsDoc mb_doc = case mb_doc of Nothing -> return Nothing rnLHsDoc :: LHsDocString -> RnM LHsDocString -rnLHsDoc (dL->L pos doc) = do +rnLHsDoc (L pos doc) = do doc' <- rnHsDoc doc - return (cL pos doc') + return (L pos doc') rnHsDoc :: HsDocString -> RnM HsDocString rnHsDoc = pure diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 61cdc140bf..59ab5446cd 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -129,13 +129,12 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing ; (r,fvs2) <- k v ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b +wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) -- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (dL->L loc a) +wrapSrcSpanCps fn (L loc a) = CpsRn (\k -> setSrcSpan loc $ unCpsRn (fn a) $ \v -> - k (cL loc v)) + k (L loc v)) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr @@ -220,9 +219,9 @@ rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) -newPatLName name_maker rdr_name@(dL->L loc _) +newPatLName name_maker rdr_name@(L loc _) = do { name <- newPatName name_maker rdr_name - ; return (cL loc name) } + ; return (L loc name) } newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name @@ -391,10 +390,10 @@ rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (LazyPat x pat') } rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (BangPat x pat') } -rnPatAndThen mk (VarPat x (dL->L l rdr)) +rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (cL loc rdr) - ; return (VarPat x (cL l name)) } + ; name <- newPatName mk (L loc rdr) + ; return (VarPat x (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -424,7 +423,7 @@ rnPatAndThen mk (LitPat x lit) where normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName @@ -436,9 +435,9 @@ rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (cL l lit') mb_neg' eq') } + ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) +rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -446,8 +445,8 @@ rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name) - (cL l lit') lit' ge minus) } + ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat x rdr pat) @@ -540,7 +539,7 @@ rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) -rnHsRecPatsAndThen mk (dL->L _ con) +rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields @@ -548,10 +547,10 @@ rnHsRecPatsAndThen mk (dL->L _ con) ; check_unused_wildcard (implicit_binders flds' <$> dd) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExtField (cL l n) - rn_field (dL->L l fld, n') = + mkVarPat l n = VarPat noExtField (L l n) + rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldArg = arg' })) } + ; return (L l (fld { hsRecFieldArg = arg' })) } loc = maybe noSrcSpan getLoc dd @@ -585,12 +584,12 @@ data HsRecFieldContext | HsRecFieldUpd rnHsRecFields - :: forall arg. HasSrcSpan arg => + :: forall arg. HsRecFieldContext - -> (SrcSpan -> RdrName -> SrcSpanLess arg) + -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field - -> HsRecFields GhcPs arg - -> RnM ([LHsRecField GhcRn arg], FreeVars) + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -616,38 +615,36 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldPat con -> Just con _ {- update -} -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg - -> RnM (LHsRecField GhcRn arg) - rn_fld pun_ok parent (dL->L l + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) + rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = - (dL->L loc (FieldOcc _ (dL->L ll lbl))) + (L loc (FieldOcc _ (L ll lbl))) , hsRecFieldArg = arg , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) + then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (mk_arg loc arg_rdr)) } + ; return (L loc (mk_arg loc arg_rdr)) } else return arg - ; return (cL l (HsRecField - { hsRecFieldLbl = (cL loc (FieldOcc - sel (cL ll lbl))) + ; return (L l (HsRecField + { hsRecFieldLbl = (L loc (FieldOcc + sel (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) } - rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) + rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) = panic "rnHsRecFields" - rn_fld _ _ _ = panic "rn_fld: Impossible Match" - -- due to #15884 rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField GhcRn arg] -- Explicit fields - -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in - rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in + rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We @@ -679,9 +676,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedGREs dot_dot_gres - ; return [ cL loc (HsRecField - { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr)) - , hsRecFieldArg = cL loc (mk_arg loc arg_rdr) + ; return [ L loc (HsRecField + { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl @@ -726,9 +723,9 @@ rnHsRecUpdFields flds rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) + rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker @@ -744,10 +741,10 @@ rnHsRecUpdFields flds Just r -> return r } else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) + then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) } + ; return (L loc (HsVar noExtField (L loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -757,14 +754,14 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - cL loc (Unambiguous sel_name (cL loc lbl)) + L loc (Unambiguous sel_name (L loc lbl)) Right [sel_name] -> - cL loc (Unambiguous sel_name (cL loc lbl)) - Right _ -> cL loc (Ambiguous noExtField (cL loc lbl)) + L loc (Unambiguous sel_name (L loc lbl)) + Right _ -> L loc (Ambiguous noExtField (L loc lbl)) - ; return (cL l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } + ; return (L l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 966e027fe2..88fe10b493 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -284,7 +284,7 @@ rnSrcWarnDecls _ [] rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates - ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls @@ -304,7 +304,7 @@ rnSrcWarnDecls bndr_set decls' what = text "deprecation" warn_rdr_dups = findDupRdrNames - $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls + $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -477,9 +477,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonadInstances | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName -> addWarnNonCanonicalMethod1 @@ -492,9 +492,9 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName -> addWarnNonCanonicalMethod2 @@ -523,9 +523,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonoidInstances | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName -> addWarnNonCanonicalMethod1 @@ -534,9 +534,9 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName -> addWarnNonCanonicalMethod2NoDefault @@ -549,10 +549,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" -- binding, and return @Just rhsName@ if this is the case isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name - isAliasMG MG {mg_alts = (dL->L _ - [dL->L _ (Match { m_pats = [] + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] , m_grhss = grhss })])} - | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss , EmptyLocalBinds _ <- unLoc lbinds , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing @@ -612,7 +611,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; cls <- case hsTyGetAppHead_maybe head_ty' of - Just (dL->L _ cls) -> pure cls + Just (L _ cls) -> pure cls Nothing -> do -- The instance is malformed. We'd still like -- to make *some* progress (rather than failing outright), so @@ -794,7 +793,7 @@ rnTyFamInstEqn atfi ctf_info , feqn_rhs = rhs }}) = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs ; (eqn'@(HsIB { hsib_body = - FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs) + FamEqn { feqn_tycon = L _ tycon' }}), fvs) <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn ; case ctf_info of NotClosedTyFam -> pure () @@ -1041,15 +1040,15 @@ bindRuleTmVars doc tyvs vars names thing_inside = go vars names $ \ vars' -> bindLocalNamesFV names (thing_inside vars') where - go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars') + thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') - go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars') + thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1474,12 +1473,12 @@ dupRoleAnnotErr list 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_annot list - ((dL->L loc first_decl) :| _) = sorted_list + ((L loc first_decl) :| _) = sorted_list - pp_role_annot (dL->L loc decl) = hang (ppr decl) + pp_role_annot (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 + cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list @@ -1489,12 +1488,12 @@ dupKindSig_Err list 2 (vcat $ map pp_kisig $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_loc list - ((dL->L loc first_decl) :| _) = sorted_list + ((L loc first_decl) :| _) = sorted_list - pp_kisig (dL->L loc decl) = + pp_kisig (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 + cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2 {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1640,7 +1639,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = - [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs + [op | L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only @@ -1750,15 +1749,15 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType } where h98_style = case condecls of -- Note [Stupid theta] - (dL->L _ (ConDeclGADT {})) : _ -> False - _ -> True + (L _ (ConDeclGADT {})) : _ -> False + _ -> True - rn_derivs (dL->L loc ds) + rn_derivs (L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (cL loc ds', fvs) } + ; return (L loc ds', fvs) } rnDataDefn _ (XHsDataDefn nec) = noExtCon nec warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) @@ -1787,21 +1786,19 @@ warnNoDerivStrat mds loc rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc - (dL->L loc (HsDerivingClause + (L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L loc' dct) })) + , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct ; warnNoDerivStrat dcs' loc - ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs' - , deriv_clause_tys = cL loc' dct' }) + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) , fvs ) } -rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec)) +rnLHsDerivingClause _ (L _ (XHsDerivingClause nec)) = noExtCon nec -rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" - -- due to #15884 rnLDerivStrategy :: forall a. HsDocContext @@ -1811,10 +1808,10 @@ rnLDerivStrategy :: forall a. rnLDerivStrategy doc mds thing_inside = case mds of Nothing -> boring_case Nothing - Just (dL->L loc ds) -> + Just (L loc ds) -> setSrcSpan loc $ do (ds', thing, fvs) <- rn_deriv_strat ds - pure (Just (cL loc ds'), thing, fvs) + pure (Just (L loc ds'), thing, fvs) where rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars) @@ -1902,7 +1899,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars ---------------------- rn_info :: Located Name -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) - rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns)) + rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs) <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) -- no class context @@ -1985,17 +1982,17 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -> LFamilyResultSig GhcRn -- ^ Result signature -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) - (dL->L srcSpan (InjectivityAnn injFrom injTo)) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) = do - { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) <- askNoErrs $ bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo - ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') } + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv @@ -2031,12 +2028,12 @@ rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) = +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo - return $ cL srcSpan (InjectivityAnn injFrom' injTo') + return $ L srcSpan (InjectivityAnn injFrom' injTo') return $ injDecl' {- @@ -2102,7 +2099,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs all_fvs) }} rnConDecl decl@(ConDeclGADT { con_names = names - , con_forall = (dL->L _ explicit_forall) + , con_forall = L _ explicit_forall , con_qvars = qtvs , con_mb_cxt = mcxt , con_args = args @@ -2178,12 +2175,12 @@ rnConDeclDetails _ doc (InfixCon ty1 ty2) ; (new_ty2, fvs2) <- rnLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclDetails con doc (RecCon (dL->L l fields)) +rnConDeclDetails con doc (RecCon (L l fields)) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon (cL l new_fields), fvs) } + ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- @@ -2210,20 +2207,19 @@ extendPatSynEnv val_decls local_fix_env thing = do { -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names - | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n) - , psb_args = RecCon as }))) <- bind + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind = do - bnd_name <- newTopSrcBinder (cL bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name)) + mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) - | (dL->L bind_loc (PatSynBind _ - (PSB { psb_id = (dL->L _ n)}))) <- bind + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do - bnd_name <- newTopSrcBinder (cL bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc n) return ((bnd_name, []): names) | otherwise = return names @@ -2249,9 +2245,9 @@ rnHsTyVars :: [Located RdrName] -> RnM [Located Name] rnHsTyVars tvs = mapM rnHsTyVar tvs rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (dL->L l tyvar) = do +rnHsTyVar (L l tyvar) = do tyvar' <- lookupOccRn tyvar - return (cL l tyvar') + return (L l tyvar') {- ********************************************************* @@ -2274,7 +2270,7 @@ addl :: HsGroup GhcPs -> [LHsDecl GhcPs] -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- This stuff reverses the declarations (again) but it doesn't matter addl gp [] = return (gp, Nothing) -addl gp ((dL->L l d) : ds) = add gp l d ds +addl gp (L l d : ds) = add gp l d ds add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] @@ -2282,7 +2278,7 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds = do { (ds', _) <- rnTopSpliceDecls qq ; addl gp (ds' ++ ds) } @@ -2308,52 +2304,52 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds | isClassDecl d - = let fsigs = [ cL l f - | (dL->L l (FixSig _ f)) <- tcdSigs d ] in - addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds + = let fsigs = [ L l f + | L l (FixSig _ f) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise - = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = cL l f : ts}) ds + = addl (gp {hs_fixds = L l f : ts}) ds -- Standalone kind signatures: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds - = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (cL l d) ts}) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (cL l d) ts }) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- Role annotations: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds -- NB instance declarations go into TyClGroups. We throw them into the first -- group, just as we do for the TyClD case. The renamer will go on to group -- and order them later. add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds -- The rest are routine add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = cL l d : ts }) ds + = addl (gp { hs_derivds = L l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = cL l d : ts }) ds + = addl (gp { hs_defds = L l d : ts }) ds add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = cL l d : ts }) ds + = addl (gp { hs_fords = L l d : ts }) ds add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = cL l d : ts }) ds + = addl (gp { hs_warnds = L l d : ts }) ds add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = cL l d : ts }) ds + = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = cL l d : ts }) ds + = addl (gp { hs_ruleds = L l d : ts }) ds add gp l (DocD _ d) ds - = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec add (XHsGroup nec) _ _ _ = noExtCon nec diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index d9cc28ee7b..6319a8ce10 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -361,13 +361,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote - = cL q_span $ HsApp noExtField (cL q_span - $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector))) - quoterExpr) - quoteExpr + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) + quoterExpr) + quoteExpr where - quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter) - quoteExpr = cL q_span $! HsLit noExtField $! HsString NoSourceText quote + quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -379,19 +379,19 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (cL loc splice_name) + ; splice_name' <- newLocalBndrRn (L loc splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn quoter @@ -620,7 +620,7 @@ rnSplicePat splice -- See Note [Delaying modFinalizers in untyped splices]. ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedPat) `onHasSrcSpan` + . HsSplicedPat) `mapLoc` pat , emptyFVs ) } @@ -629,12 +629,12 @@ rnSplicePat splice ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where pend_decl_splice rn_splice = ( makePending UntypedDeclSplice rn_splice - , SpliceDecl noExtField (cL loc rn_splice) flg) + , SpliceDecl noExtField (L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) rnSpliceDecl (XSpliceDecl nec) = noExtCon nec @@ -739,8 +739,8 @@ traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (dL->L loc _) -> return loc + Nothing -> getSrcSpanM + Just (L loc _) -> return loc ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) ; when is_decl $ -- Raw material for -dth-dec-file diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 1e7d101089..724dea866d 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -164,10 +164,10 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_lty env hs_ty ; return (nwcs, hs_ty', fvs) } where - rn_lty env (dL->L loc hs_ty) + rn_lty env (L loc hs_ty) = setSrcSpan loc $ do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (cL loc hs_ty', fvs) } + ; return (L loc hs_ty', fvs) } rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear @@ -179,23 +179,23 @@ rnWcBody ctxt nwc_rdrs hs_ty , hst_bndrs = tvs', hst_body = hs_body' } , fvs) } - rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt , hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 - ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)] + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt' + , hst_ctxt = L cx hs_ctxt' , hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } @@ -336,7 +336,7 @@ rnImplicitBndrs bind_free_tvs vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] ; loc <- getSrcSpanM - ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs ; bindLocalNamesFV vars $ thing_inside vars } @@ -467,11 +467,11 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args -------------- rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) -rnTyKiContext env (dL->L loc cxt) +rnTyKiContext env (L loc cxt) = do { traceRn "rncontext" (ppr cxt) ; let env' = env { rtke_what = RnConstraint } ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt - ; return (cL loc cxt', fvs) } + ; return (L loc cxt', fvs) } rnContext :: HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) @@ -479,10 +479,10 @@ rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsTyKi env (dL->L loc ty) +rnLHsTyKi env (L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty - ; return (cL loc ty', fvs) } + ; return (L loc ty', fvs) } rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) @@ -504,7 +504,7 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ withHsDocContext (rtke_ctxt env) $ @@ -513,7 +513,7 @@ rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExtField ip (cL loc name), unitFV name) } + ; return (HsTyVar noExtField ip (L loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ @@ -660,20 +660,20 @@ rnTyVar env rdr_name rnLTyVar :: Located RdrName -> RnM (Located Name) -- Called externally; does not deal with wildards -rnLTyVar (dL->L loc rdr_name) +rnLTyVar (L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name - ; return (cL loc tyvar) } + ; return (L loc tyvar) } -------------- rnHsTyOp :: Outputable a => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (dL->L loc op) +rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op ; unless (ops_ok || op' `hasKey` eqTyConKey) $ addErr (opTyErr op overall_ty) - ; let l_op' = cL loc op' + ; let l_op' = L loc op' ; return (l_op', unitFV op') } -------------- @@ -989,35 +989,33 @@ bindLHsTyVarBndr :: HsDocContext -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (dL->L loc +bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x - lrdr@(dL->L lv _))) thing_inside + lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (cL loc (UserTyVar x (cL lv nm))) } + thing_inside (L loc (UserTyVar x (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind)) +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) + $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec -bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" - -- due to #15884 +bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (dL->L loc rdr) +newTyVarNameRn mb_assoc (L loc rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of (Just _, Just n) -> return n -- Use the same Name as the parent class decl - _ -> newLocalBndrRn (cL loc rdr) } + _ -> newLocalBndrRn (L loc rdr) } {- ********************************************************* * * @@ -1044,23 +1042,21 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc)) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc) + ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (dL->L lr rdr)) = - FieldOcc (flSelector fl) (cL lr rdr) + lookupField (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl lookupField (XFieldOcc nec) = noExtCon nec -rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec -rnField _ _ _ = panic "rnField: Impossible Match" - -- due to #15884 +rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec {- ************************************************************************ @@ -1094,13 +1090,13 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 @@ -1116,8 +1112,8 @@ mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) mk_hs_op_ty mk1 op1 fix1 ty1 mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) - ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 ; return (mk2 (noLoc new_ty) ty22) } @@ -1133,35 +1129,35 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 +mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (cL loc' new_e)) + return (OpApp fix1 e11 op1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExtField (cL loc' new_e) neg_name) + return (NegApp noExtField (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) return (OpApp fix1 e1 op1 e2) @@ -1194,10 +1190,10 @@ instance Outputable OpName where get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n) -get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -1229,9 +1225,9 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(dL->L loc +mkOpFormRn a1@(L loc (HsCmdTop _ - (dL->L _ (HsCmdArrForm x op1 f (Just fix1) + (L _ (HsCmdArrForm x op1 f (Just fix1) [a11,a12])))) op2 fix2 a2 | nofix_error @@ -1241,7 +1237,7 @@ mkOpFormRn a1@(dL->L loc | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, cL loc (HsCmdTop [] (cL loc new_c))]) + [a11, L loc (HsCmdTop [] (L loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1255,7 +1251,7 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1266,7 +1262,7 @@ mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 else if associate_right then do { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) } + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? else return (ConPatIn op2 (InfixCon p1 p2)) } @@ -1284,12 +1280,12 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = (dL->L _ ms) }) +checkPrecMatch op (MG { mg_alts = (L _ ms) }) = mapM_ check ms where - check (dL->L _ (Match { m_pats = (dL->L l1 p1) - : (dL->L l2 p2) - : _ })) + check (L _ (Match { m_pats = (L l1 p1) + : (L l2 p2) + : _ })) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True @@ -1398,7 +1394,7 @@ unexpectedTypeSigErr ty 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () -badKindSigErr doc (dL->L loc ty) +badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) @@ -1416,7 +1412,7 @@ inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () -warnUnusedForAll in_doc (dL->L loc tv) used_names +warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ addWarnAt (Reason Opt_WarnUnusedForalls) loc $ @@ -1668,9 +1664,9 @@ extractHsTyVarBndrsKVs tv_bndrs -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -extractRdrKindSigVars (dL->L _ resultSig) - | KindSig _ k <- resultSig = extractHsTyRdrTyVars k - | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k +extractRdrKindSigVars (L _ resultSig) + | KindSig _ k <- resultSig = extractHsTyRdrTyVars k + | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k | otherwise = [] -- Get type/kind variables mentioned in the kind signature, preserving @@ -1695,7 +1691,7 @@ extract_ltys tys acc = foldr extract_lty acc tys extract_lty :: LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lty (dL->L _ ty) acc +extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc HsBangTy _ _ ty -> extract_lty ty acc @@ -1767,7 +1763,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty [] - [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs] + [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] extract_tv :: Located RdrName -> [Located RdrName] -> [Located RdrName] diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 0da8e30f6a..88996e31b1 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -66,7 +66,7 @@ import qualified GHC.LanguageExtensions as LangExt newLocalBndrRn :: Located RdrName -> RnM Name -- Used for non-top-level binders. These should -- never be qualified. -newLocalBndrRn (dL->L loc rdr_name) +newLocalBndrRn (L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell -- See Note [Binders in Template Haskell] in Convert.hs @@ -127,7 +127,7 @@ checkShadowedRdrNames loc_rdr_names where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr) + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index d45ed2ea8c..a448f74e56 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -305,7 +305,7 @@ tcHsBootSigs binds sigs where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where - f (dL->L _ name) + f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds @@ -340,12 +340,12 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds] + ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] -- I wonder if we should do these one at a time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr) + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] @@ -516,7 +516,7 @@ recursivePatSynErr loc binds 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc tc_single :: forall thing. @@ -524,7 +524,7 @@ tc_single :: forall thing. -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn - (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) })) + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside @@ -563,7 +563,7 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds , bndr <- collectHsBindBinders bind ] ------------------------ @@ -685,8 +685,8 @@ tcPolyCheck prag_fn (CompleteSig { sig_bndr = poly_id , sig_ctxt = ctxt , sig_loc = sig_loc }) - (dL->L loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches })) + (L loc (FunBind { fun_id = (L nm_loc name) + , fun_matches = matches })) = setSrcSpan sig_loc $ do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id @@ -703,7 +703,7 @@ tcPolyCheck prag_fn tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ tcExtendNameTyVarEnv tv_prs $ setSrcSpan loc $ - tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau) + tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) ; let prag_sigs = lookupPragEnv prag_fn name ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -711,7 +711,7 @@ tcPolyCheck prag_fn ; mod <- getModule ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = cL nm_loc mono_id + ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -723,13 +723,13 @@ tcPolyCheck prag_fn , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } - abs_bind = cL loc $ + abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds] , abs_exports = [export] - , abs_binds = unitBag (cL loc bind') + , abs_binds = unitBag (L loc bind') , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) } @@ -740,7 +740,7 @@ tcPolyCheck _prag_fn sig bind funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -806,7 +806,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = cL loc $ + abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -1249,9 +1249,9 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen - [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches - , fun_ext = fvs })] + [ L b_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches + , fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1271,11 +1271,11 @@ tcMonoBinds is_rec sig_fn no_gen -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking - tcMatchesFun (cL nm_loc name) matches exp_ty + tcMatchesFun (L nm_loc name) matches exp_ty ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ cL b_loc $ - FunBind { fun_id = cL nm_loc mono_id, + ; return (unitBag $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name @@ -1332,7 +1332,7 @@ tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- CheckGen is used only for functions with a complete type signature, -- and tcPolyCheck doesn't use tcMonoBinds at all -tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name) +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name , fun_matches = matches }) | Just (TcIdSig sig) <- sig_fn name = -- There is a type signature. @@ -1420,9 +1420,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = cL loc mono_id + ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] + , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1650,7 +1650,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature one_funbind_with_sig - | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds , Just (TcIdSig sig) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise @@ -1679,7 +1679,7 @@ isClosedBndrGroup type_env binds fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = (dL->L _ f) + bindFvs (FunBind { fun_id = L _ f , fun_ext = fvs }) = let open_fvs = get_open_fvs fvs in [(f, open_fvs)] diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index ffc054ee0a..00d95c405b 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -2359,7 +2359,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig = Just (vcat [ text "In other words, a successful match on the pattern" , nest 2 $ ppr pat , text "does not provide the constraint" <+> pprParendType pred ]) @@ -2488,7 +2488,7 @@ ctxtFixes has_ambig_tvs pred implics discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig = filterOut (discard name) givens | otherwise = givens diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index d1f894e14c..13a3d179b4 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -99,7 +99,7 @@ import Control.Arrow ( second ) -} hsLPatType :: LPat GhcTc -> Type -hsLPatType (dL->L _ p) = hsPatType p +hsLPatType (L _ p) = hsPatType p hsPatType :: Pat GhcTc -> Type hsPatType (ParPat _ pat) = hsLPatType pat @@ -349,7 +349,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id -zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env) +zonkLIdOcc env = mapLoc (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -529,7 +529,7 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- mapM (wrapLocM zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env - [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds] + [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where @@ -577,13 +577,13 @@ zonk_bind env (VarBind { var_ext = x , var_rhs = new_expr , var_inline = inl }) } -zonk_bind env bind@(FunBind { fun_id = (dL->L loc var) +zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms , fun_co_fn = co_fn }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = cL loc new_var + ; return (bind { fun_id = L loc new_var , fun_matches = new_ms , fun_co_fn = new_co_fn }) } @@ -610,16 +610,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs where zonk_val_bind env lbind | has_sig - , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id) - , fun_matches = ms - , fun_co_fn = co_fn })) <- lbind + , (L loc bind@(FunBind { fun_id = L mloc mono_id + , fun_matches = ms + , fun_co_fn = co_fn })) <- lbind = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ cL loc $ - bind { fun_id = cL mloc new_mono_id + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id , fun_matches = new_ms , fun_co_fn = new_co_fn } } | otherwise @@ -640,7 +640,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_prags = new_prags }) zonk_export _ (XABExport nec) = noExtCon nec -zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) +zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_args = details , psb_def = lpat , psb_dir = dir })) @@ -649,7 +649,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) ; let details' = zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind x $ - bind { psb_id = cL loc id' + bind { psb_id = L loc id' , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } @@ -684,9 +684,9 @@ zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] zonkLTcSpecPrags env ps = mapM zonk_prag ps where - zonk_prag (dL->L loc (SpecPrag id co_fn inl)) + zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } {- ************************************************************************ @@ -700,13 +700,13 @@ zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> MatchGroup GhcTcId (Located (body GhcTcId)) -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) +zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = cL l ms' + ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec @@ -715,14 +715,12 @@ zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> LMatch GhcTcId (Located (body GhcTcId)) -> TcM (LMatch GhcTc (Located (body GhcTc))) -zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats - , m_grhss = grhss })) +zonkMatch env zBody (L loc match@(Match { m_pats = pats + , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) } -zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec -zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" - -- due to #15884 + ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } +zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv @@ -730,7 +728,7 @@ zonkGRHSs :: ZonkEnv -> GRHSs GhcTcId (Located (body GhcTcId)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs) @@ -739,7 +737,7 @@ zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do return (GRHS xx new_guarded new_rhs) zonk_grhs (XGRHS nec) = noExtCon nec new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (cL l new_binds)) + return (GRHSs x new_grhss (L l new_binds)) zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec {- @@ -757,9 +755,9 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar x (dL->L l id)) +zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (cL l (zonkIdOcc env id))) + return (HsVar x (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -842,13 +840,11 @@ zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where - zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (cL l (Present x e')) } - zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (cL l (Missing t')) } - zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec - zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" - -- due to #15884 + zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } + zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t + ; return (L l (Missing t')) } + zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec zonkExpr env (ExplicitSum args alt arity expr) @@ -884,15 +880,15 @@ zonkExpr env (HsMultiIf ty alts) ; return $ GRHS x guard' expr' } zonk_alt (XGRHS nec) = noExtCon nec -zonkExpr env (HsLet x (dL->L l binds) expr) +zonkExpr env (HsLet x (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (cL l new_binds) new_expr) + return (HsLet x (L l new_binds) new_expr) -zonkExpr env (HsDo ty do_or_lc (dL->L l stmts)) +zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (cL l new_stmts)) + return (HsDo new_ty do_or_lc (L l new_stmts)) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit @@ -1044,15 +1040,15 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet x (dL->L l binds) cmd) +zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (cL l new_binds) new_cmd) + return (HsCmdLet x (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo ty (dL->L l stmts)) +zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (cL l new_stmts)) + return (HsCmdDo new_ty (L l new_stmts)) zonkCmd _ (XCmd nec) = noExtCon nec @@ -1235,9 +1231,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (dL->L l binds)) +zonkStmt env _ (LetStmt x (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (cL l new_binds)) + return (env1, LetStmt x (L l new_binds)) zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op @@ -1303,21 +1299,21 @@ zonkRecFields env (HsRecFields flds dd) = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) } where - zonk_rbind (dL->L l fld) + zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = new_id + ; return (L l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] -> TcM [LHsRecUpdField GhcTcId] zonkRecUpdFields env = mapM zonk_rbind where - zonk_rbind (dL->L l fld) + zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } + ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id + , hsRecFieldArg = new_expr })) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a @@ -1351,9 +1347,9 @@ zonk_pat env (WildPat ty) (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat x (dL->L l v)) +zonk_pat env (VarPat x (L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) } + ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat @@ -1363,10 +1359,10 @@ zonk_pat env (BangPat x pat) = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (dL->L loc v) pat) +zonk_pat env (AsPat x (L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat x (cL loc v') pat') } + ; return (env', AsPat x (L loc v') pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr @@ -1402,7 +1398,7 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys , pat_binds = binds , pat_args = args , pat_wrap = wrapper - , pat_con = (dL->L _ con) }) + , pat_con = L _ con }) = ASSERT( all isImmutableTyVar tyvars ) do { new_tys <- mapM (zonkTcTypeToTypeX env) tys @@ -1438,7 +1434,7 @@ zonk_pat env (SigPat ty pat hs_ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPat ty' pat' hs_ty) } -zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) +zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing) @@ -1446,9 +1442,9 @@ zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') } + ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) +zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n @@ -1456,7 +1452,7 @@ zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToTypeX env2 ty ; return (extendIdZonkEnv1 env2 n', - NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } + NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } zonk_pat env (CoPat x co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn @@ -1482,8 +1478,8 @@ zonkConStuff env (InfixCon p1 p2) zonkConStuff env (RecCon (HsRecFields rpats dd)) = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(dL->L l rp) p' -> - cL l (rp { hsRecFieldArg = p' })) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hsRecFieldArg = p' })) rpats pats' ; return (env', RecCon (HsRecFields rpats' dd)) } -- Field selectors have declared types; hence no zonking @@ -1535,13 +1531,11 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} , rd_lhs = new_lhs , rd_rhs = new_rhs } } where - zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v))) + zonk_tm_bndr env (L l (RuleBndr x (L loc v))) = do { (env', v') <- zonk_it env v - ; return (env', cL l (RuleBndr x (cL loc v'))) } - zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec - zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" - -- due to #15884 + ; return (env', L l (RuleBndr x (L loc v'))) } + zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec zonk_it env v | isId v = do { v' <- zonkIdBndr env v diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 5f96134676..9a5d745dea 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -352,10 +352,10 @@ tcDerivStrategy :: tcDerivStrategy mb_lds = case mb_lds of Nothing -> boring_case Nothing - Just (dL->L loc ds) -> + Just (L loc ds) -> setSrcSpan loc $ do (ds', tvs) <- tc_deriv_strategy ds - pure (Just (cL loc ds'), tvs) + pure (Just (L loc ds'), tvs) where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar]) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index d18b2af252..61e8b21597 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -302,11 +302,11 @@ tc_lpat :: LPat GhcRn -> PatEnv -> TcM a -> TcM (LPat GhcTcId, a) -tc_lpat (dL->L span pat) pat_ty penv thing_inside +tc_lpat (L span pat) pat_ty penv thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) thing_inside - ; return (cL span pat', res) } + ; return (L span pat', res) } tc_lpats :: PatEnv -> [LPat GhcRn] -> [ExpSigmaType] @@ -326,11 +326,11 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside +tc_pat penv (VarPat x (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -361,7 +361,7 @@ tc_pat _ (WildPat _) pat_ty thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -374,7 +374,7 @@ tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty, + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside @@ -523,7 +523,7 @@ tc_pat penv (LitPat x simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside +tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -541,7 +541,7 @@ tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) } + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -572,8 +572,8 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (dL->L nm_loc name) - (dL->L loc lit) _ ge minus) pat_ty +tc_pat penv (NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus) pat_ty thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit @@ -603,7 +603,7 @@ tc_pat penv (NPlusKPat _ (dL->L nm_loc name) ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2' + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' ; return (pat', res) } @@ -712,7 +712,7 @@ tcConPat :: PatEnv -> Located Name -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of RealDataCon data_con -> tcDataConPat penv con_lname data_con @@ -725,13 +725,13 @@ tcDataConPat :: PatEnv -> Located Name -> DataCon -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcDataConPat penv (dL->L con_span con_name) data_con pat_ty +tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con - header = cL con_span (RealDataCon data_con) + header = L con_span (RealDataCon data_con) -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion, @@ -821,7 +821,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn ; (subst, univ_tvs') <- newMetaTyVars univ_tvs @@ -858,7 +858,7 @@ tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = cL con_span $ PatSynCon pat_syn, + ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, pat_tvs = ex_tvs', pat_dicts = prov_dicts', pat_binds = ev_binds, @@ -988,19 +988,16 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (dL->L l (HsRecField (dL->L loc - (FieldOcc sel (dL->L lr rdr))) pat pun)) + tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat' + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) } - tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _ + tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ = panic "tcConArgs" - tc_field _ _ _ = panic "tc_field: Impossible Match" - -- due to #15884 find_field_ty :: Name -> FieldLabelString -> TcM TcType diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index afc807c461..1c39801f2f 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -81,7 +81,7 @@ tcPatSynDecl psb mb_sig recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = (dL->L _ name) +recoverPSB (PSB { psb_id = L _ name , psb_args = details }) = do { matcher_name <- newImplicitBinder name mkMatcherOcc ; let placeholder = AConLike $ PatSynCon $ @@ -135,7 +135,7 @@ pattern.) But it'll do for now. tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details +tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name @@ -341,7 +341,7 @@ is not very helpful, but at least we don't get a Lint error. tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta @@ -569,12 +569,12 @@ collectPatSynArgInfo details = splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = (dL->L _ patVar) - , recordPatSynSelectorId = (dL->L _ selId) }) + { recordPatSynPatVar = L _ patVar + , recordPatSynSelectorId = L _ selId }) = (patVar, selId) addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (dL->L loc name) thing_inside +addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ @@ -685,7 +685,7 @@ tcPatSynMatcher :: Located Name -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (dL->L loc name) lpat +tcPatSynMatcher (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty @@ -726,9 +726,9 @@ tcPatSynMatcher (dL->L loc name) lpat else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ - cL (getLoc lpat) $ + L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = cL (getLoc lpat) cases + MG{ mg_alts = L (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } @@ -739,18 +739,18 @@ tcPatSynMatcher (dL->L loc name) lpat , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (cL loc name)) [] + match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc (EmptyLocalBinds noExtField)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = cL (getLoc match) [match] + mg = MG{ mg_alts = L (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = cL loc matcher_id + , fun_id = L loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -786,7 +786,7 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (dL->L _ name) +mkPatSynBuilderId dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir @@ -812,7 +812,7 @@ mkPatSynBuilderId dir (dL->L _ name) tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) +tcPatSynBuilderBind (PSB { psb_id = L loc name , psb_def = lpat , psb_dir = dir , psb_args = details }) @@ -840,7 +840,7 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = cL loc (idName builder_id) + , fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -864,9 +864,9 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where - builder_args = [cL loc (VarPat noExtField (cL loc n)) - | (dL->L loc n) <- args] - builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) + builder_args = [L loc (VarPat noExtField (L loc n)) + | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -878,9 +878,8 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) -> MatchGroup GhcRn (LHsExpr GhcRn) add_dummy_arg mg@(MG { mg_alts = - (dL->L l [dL->L loc - match@(Match { m_pats = pats })]) }) - = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } + (L l [L loc match@(Match { m_pats = pats })]) }) + = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec @@ -926,9 +925,9 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(dL->L loc _) pats + mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y) + ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) (HsVar noExtField lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) @@ -938,7 +937,7 @@ tcPatToExpr name args pat = go pat ; return (RecordCon noExtField con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (dL->L loc p) = cL loc <$> go1 p + go (L loc p) = L loc <$> go1 p go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info) @@ -950,9 +949,9 @@ tcPatToExpr name args pat = go pat go1 (SigPat _ pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (dL->L l var)) + go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExtField (cL l var) + = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat @@ -969,7 +968,7 @@ tcPatToExpr name args pat = go pat (noLoc expr) } go1 (LitPat _ lit) = return $ HsLit noExtField lit - go1 (NPat _ (dL->L _ n) mb_neg _) + go1 (NPat _ (L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit noExtField n)] | otherwise = return $ HsOverLit noExtField n @@ -1142,7 +1141,7 @@ tcCollectEx pat = go pat = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p + goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 4d1d32f8a5..d2235e5bd8 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -163,7 +163,7 @@ tcRnModule :: HscEnv -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)} + parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc <- loc = withTiming dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod)) @@ -186,7 +186,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax pair :: (Module, SrcSpan) pair@(this_mod,_) - | Just (dL->L mod_loc mod) <- hsmodName this_module + | Just (L mod_loc mod) <- hsmodName this_module = (mkModule this_pkg mod, mod_loc) | otherwise -- 'module M where' is omitted @@ -205,7 +205,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (dL->L loc (HsModule maybe_mod export_ies + (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -232,7 +232,7 @@ tcRnModuleTcRnM hsc_env mod_sum addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (dL->L _ idecl) = + let { simplifyImport (L _ idecl) = ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) } ; raw_sig_imports <- liftIO @@ -242,7 +242,7 @@ tcRnModuleTcRnM hsc_env mod_sum $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) - ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc + ; let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { ideclHiding = Just (False, noLoc [])} ; mkImport _ = panic "mkImport" } @@ -256,7 +256,7 @@ tcRnModuleTcRnM hsc_env mod_sum -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns let { tcg_env1 = case mod_deprec of - Just (dL->L _ txt) -> + Just (L _ txt) -> tcg_env {tcg_warns = WarnAll txt} Nothing -> tcg_env } @@ -552,7 +552,7 @@ tc_rn_src_decls ds else do { (th_group, th_group_tail) <- findSplice th_ds ; case th_group_tail of { Nothing -> return () - ; Just (SpliceDecl _ (dL->L loc _) _, _) -> + ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpan loc $ addErr (text ("Declaration splices are not " @@ -588,7 +588,7 @@ tc_rn_src_decls ds { Nothing -> return (tcg_env, tcl_env, lie1) -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (dL->L _ splice) _, rest_ds) -> + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> do { -- We need to simplify any constraints from the previous declaration -- group, or else we might reify metavariables, as in #16980. @@ -681,7 +681,7 @@ tcRnHsBootDecls hsc_src decls ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (dL->L loc _) +badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of @@ -874,7 +874,7 @@ checkHiBootIface' -- that modifying boot_dfun, to make local_boot_fun. | otherwise - = setSrcSpan (getLoc (getName boot_dfun)) $ + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ do { traceTc "check_cls_inst" $ vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) @@ -1747,7 +1747,7 @@ check_main dflags tcg_env explicit_mod_hdr ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $ - tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name))) + tcMonoExpr (L loc (HsVar noExtField (L loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id] @@ -2057,53 +2057,53 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (dL->L loc (BodyStmt _ expr _ _)) +tcUserStmt (L loc (BodyStmt _ expr _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr + matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr] - the_bind = cL loc $ (mkTopFunBind FromSource - (cL loc fresh_it) matches) + the_bind = L loc $ (mkTopFunBind FromSource + (L loc fresh_it) matches) { fun_ext = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField + let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] - bind_stmt = cL loc $ BindStmt noExtField - (cL loc (VarPat noExtField (cL loc fresh_it))) + bind_stmt = L loc $ BindStmt noExtField + (L loc (VarPat noExtField (L loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr -- [; print it] - print_it = cL loc $ BodyStmt noExtField + print_it = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr -- NewA - no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_b = cL loc $ BodyStmt noExtField (rn_expr) + no_it_b = L loc $ BodyStmt noExtField (rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_c = cL loc $ BodyStmt noExtField + no_it_c = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2203,7 +2203,7 @@ But for naked expressions, you will have In an equation for ‘x’: x = putStrLn True -} -tcUserStmt rdr_stmt@(dL->L loc _) +tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv @@ -2214,8 +2214,8 @@ tcUserStmt rdr_stmt@(dL->L loc _) ; ghciStep <- getGhciStepIO ; let gi_stmt - | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt - = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 + | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult @@ -2237,7 +2237,7 @@ tcUserStmt rdr_stmt@(dL->L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2594,7 +2594,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (dL->L loc rdr_name) +tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ setSrcSpan loc $ do { -- If the identifier is a constructor (begins with an diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index a4ef692c58..0f0067ab5d 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -254,7 +254,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod fix_faminst avail = avail -exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do ie_avails <- accumExports do_litem rdr_items let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families return (Just ie_avails, final_exports) @@ -280,7 +280,7 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod exports_from_item :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) exports_from_item (ExportAccum occs earlier_mods) - (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod))) + (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M = do { warnIfFlag Opt_WarnDuplicateExports True (dupModuleExport mod) ; @@ -317,13 +317,13 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod , ppr new_exports ]) ; return (Just ( ExportAccum occs' mods - , ( cL loc (IEModuleContents noExtField lmod) + , ( L loc (IEModuleContents noExtField lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie) + exports_from_item acc@(ExportAccum occs mods) (L loc ie) | isDoc ie = do new_ie <- lookup_doc_ie ie - return (Just (acc, (cL loc new_ie, []))) + return (Just (acc, (L loc new_ie, []))) | otherwise = do (new_ie, avail) <- lookup_ie ie @@ -334,17 +334,17 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs ie occs [avail] return (Just ( ExportAccum occs' mods - , (cL loc new_ie, [avail]))) + , (L loc new_ie, [avail]))) ------------- lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (dL->L l rdr)) + lookup_ie (IEVar _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail) + return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) - lookup_ie (IEThingAbs _ (dL->L l rdr)) + lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name)) + return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') @@ -376,18 +376,18 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] -> RnM (Located Name, [LIEWrappedName Name], [Name], [Located FieldLabel]) - lookup_ie_with (dL->L l rdr) sub_rdrs + lookup_ie_with (L l rdr) sub_rdrs = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name - then return (cL l name, [], [name], []) - else return (cL l name, non_flds + then return (L l name, [], [name], []) + else return (L l name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (dL->L l rdr) = + lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres @@ -401,7 +401,7 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (cL l name, non_flds, flds) + return (L l name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) @@ -530,8 +530,8 @@ lookupChildrenExport spec_parent rdr_items = case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (cL l (IEName (cL l ub))))} - FoundFL fls -> return $ Right (cL (getLoc n) fls) + ; return (Left (L l (IEName (L l ub))))} + FoundFL fls -> return $ Right (L (getLoc n) fls) FoundName par name -> do { checkPatSynParent spec_parent par name ; return $ Left (replaceLWrappedName n name) } diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 3442e8729a..ec4d38fc10 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -840,31 +840,28 @@ setSrcSpan (RealSrcSpan real_loc) thing_inside -- Don't overwrite useful info with useless: setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b -addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a -wrapLocM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (cL loc b) } -wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c) -wrapLocFstM fn (dL->L loc a) = +wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a + ; return (L loc b) } + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (cL loc b, c) + return (L loc b, c) -wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) => - (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c) -wrapLocSndM fn (dL->L loc a) = +wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (b, cL loc c) + return (b, L loc c) -wrapLocM_ :: HasSrcSpan a => - (SrcSpanLess a -> TcM ()) -> a -> TcM () -wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a) +wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () +wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) -- Reporting errors diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 18565405f1..52d9e57229 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -997,15 +997,15 @@ mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv` mkNameEnv [ (name, APromotionErr TyConPE) - | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ] + | (L _ (FamilyDecl { fdLName = L _ name })) <- ats ] -mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name) +mk_prom_err_env (DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE) - | (dL->L _ con') <- cons - , (dL->L _ con) <- getConNames con' ] + | L _ con' <- cons + , L _ con <- getConNames con' ] mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE) @@ -1054,7 +1054,7 @@ getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] -- -- No family instances are passed to checkInitialKinds/inferInitialKinds getInitialKind strategy - (ClassDecl { tcdLName = dL->L _ name + (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ @@ -1072,7 +1072,7 @@ getInitialKind strategy InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy - (DataDecl { tcdLName = dL->L _ name + (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } }) @@ -1105,7 +1105,7 @@ getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = ; return [tc] } getInitialKind strategy - (SynDecl { tcdLName = dL->L _ name + (SynDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) = do { let ctxt = TySynKindCtxt name @@ -1124,14 +1124,14 @@ get_fam_decl_initial_kind -> FamilyDecl GhcRn -> TcM TcTyCon get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = (dL->L _ name) + FamilyDecl { fdLName = L _ name , fdTyVars = ktvs - , fdResultSig = (dL->L _ resultSig) + , fdResultSig = L _ resultSig , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred @@ -1258,7 +1258,7 @@ Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] -kcLTyClDecl (dL->L loc decl) +kcLTyClDecl (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "kcTyClDecl {" (ppr tc_name) @@ -1273,10 +1273,10 @@ kcTyClDecl :: TyClDecl GhcRn -> TcM () -- result kind signature have already been dealt with -- by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) +kcTyClDecl (DataDecl { tcdLName = (L _ name) , tcdDataDefn = defn }) - | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _) - , dd_ctxt = (dL->L _ []) + | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) + , dd_ctxt = (L _ []) , dd_ND = new_or_data } <- defn = do { tyCon <- kcLookupTcTyCon name -- See Note [Implementation of UnliftedNewtypes] STEP 2 @@ -1298,13 +1298,13 @@ kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) ; kcConDecls new_or_data (tyConResKind tyCon) cons } -kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs }) +kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) = bindTyClTyVars name $ \ _ res_kind -> discardResult $ tcCheckLHsType rhs res_kind -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) +kcTyClDecl (ClassDecl { tcdLName = L _ name , tcdCtxt = ctxt, tcdSigs = sigs }) = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt @@ -1315,7 +1315,7 @@ kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) skol_info = TyConSkol ClassFlavour name -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) +kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't -- do anything here @@ -1698,7 +1698,7 @@ unlifted types, resolving #13595. -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (dL->L loc decl) +tcTyClDecl roles_info (L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things] ATyCon tc -> return (tc, wiredInDerivInfo tc decl) @@ -1735,7 +1735,7 @@ tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) -- "type" synonym declaration tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = (dL->L _ tc_name) + (SynDecl { tcdLName = L _ tc_name , tcdRhs = rhs }) = ASSERT( isNothing _parent ) fmap noDerivInfos $ @@ -1744,7 +1744,7 @@ tcTyClDecl1 _parent roles_info -- "data/newtype" declaration tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = (dL->L _ tc_name) + decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) bindTyClTyVars tc_name $ \ tycon_binders res_kind -> @@ -1752,7 +1752,7 @@ tcTyClDecl1 _parent roles_info tycon_binders res_kind defn tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = (dL->L _ class_name) + (ClassDecl { tcdLName = L _ class_name , tcdCtxt = hs_ctxt , tcdMeths = meths , tcdFDs = fundeps @@ -1853,10 +1853,10 @@ tcClassATs class_name cls ats at_defs ; mapM tc_at ats } where at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn + at_def_tycon (L _ eqn) = tyFamInstDeclName eqn at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name (dL->L _ decl) = unLoc (fdLName decl) + at_fam_name (L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) @@ -1885,7 +1885,7 @@ tcDefaultAssocDecl _ (d1:_:_) <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc - [dL->L loc (TyFamInstDecl { tfid_eqn = + [L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ tc_name , feqn_bndrs = mb_expl_bndrs @@ -1983,8 +1983,9 @@ tcDefaultAssocDecl fam_tc suggestion :: SDoc suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables" -tcDefaultAssocDecl _ [_] - = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 + +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x {- Note [Type-checking default assoc decls] @@ -2052,8 +2053,8 @@ delicate for my taste, but it works. tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(dL->L _ tc_name) - , fdResultSig = (dL->L _ sig) + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info = bindTyClTyVars tc_name $ \ binders res_kind -> do @@ -2176,7 +2177,7 @@ tcInjectivity _ Nothing -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags @@ -2300,11 +2301,11 @@ kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () -- Used for the equations of a closed type family only -- Not used for data/type instances kcTyFamInstEqn tc_fam_tc - (dL->L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) = setSrcSpan loc $ do { traceTc "kcTyFamInstEqn" (vcat [ text "tc_name =" <+> ppr eqn_tc_name @@ -2330,9 +2331,8 @@ kcTyFamInstEqn tc_fam_tc where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec -kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec -kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 +kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec +kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec -------------------------- @@ -2342,7 +2342,7 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (dL->L loc (HsIB { hsib_ext = imp_vars + (L loc (HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name , feqn_bndrs = mb_expl_bndrs , feqn_pats = hs_pats @@ -2642,8 +2642,8 @@ dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True -consUseGadtSyntax _ = False +consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -2734,7 +2734,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (dL->L _ name) = do + buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name @@ -2762,7 +2762,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let ((dL->L _ name) : _) = names + ; let (L _ name : _) = names ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise @@ -2821,7 +2821,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let - buildOneDataCon (dL->L _ name) = do + buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name @@ -2875,7 +2875,7 @@ tcConArgs (RecCon fields) = mapM tcConArg btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f)) + combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined @@ -4040,7 +4040,7 @@ checkValidRoleAnnots role_annots tc check_roles = whenIsJust role_annot_decl_maybe $ - \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) -> + \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations @@ -4064,11 +4064,10 @@ checkValidRoleAnnots role_annots tc = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (dL->L _ Nothing) _ = return () -checkRoleAnnot tv (dL->L _ (Just r1)) r2 +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 -checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls @@ -4355,25 +4354,21 @@ badRoleAnnot var annot inferred , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots)) +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) = hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) -wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec -wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match" - -- due to #15884 +wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _)) +illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec -illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match" - -- due to #15884 +illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 026186c1bd..c7bcfbe068 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -225,7 +225,7 @@ checkSynCycles this_uid tcs tyclds = do mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl + Just (L loc decl) -> ppr loc <> colon <+> ppr decl Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" where @@ -486,7 +486,7 @@ initialRoleEnv1 hsc_src annots_env tc -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of - Just (dL->L _ (RoleAnnotDecl _ _ annots)) + Just (L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots @@ -828,13 +828,13 @@ when typechecking the [d| .. |] quote, and typecheck them later. tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs - , let loc = getSrcSpan sel_id ] + sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] @@ -854,7 +854,7 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (sel_id, cL loc sel_bind) + = (sel_id, L loc sel_bind) where loc = getSrcSpan sel_name lbl = flLabel fl @@ -892,18 +892,18 @@ mkOneRecordSelector all_cons idDetails fl [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [cL loc (mk_sel_pat con)] - (cL loc (HsVar noExtField (cL loc field_var))) - mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields) + [L loc (mk_sel_pat con)] + (L loc (HsVar noExtField (L loc field_var))) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = cL loc (FieldOcc sel_name - (cL loc $ mkVarUnqual lbl)) + = L loc (FieldOcc sel_name + (L loc $ mkVarUnqual lbl)) , hsRecFieldArg - = cL loc (VarPat noExtField (cL loc field_var)) + = L loc (VarPat noExtField (L loc field_var)) , hsRecPun = False }) - sel_lname = cL loc sel_name + sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -911,10 +911,10 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [cL loc (WildPat noExtField)] - (mkHsApp (cL loc (HsVar noExtField - (cL loc (getName rEC_SEL_ERROR_ID)))) - (cL loc (HsLit noExtField msg_lit)))] + [L loc (WildPat noExtField)] + (mkHsApp (L loc (HsVar noExtField + (L loc (getName rEC_SEL_ERROR_ID)))) + (L loc (HsLit noExtField msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 2bf061f3b5..b07a376482 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -325,7 +325,7 @@ processAllTypeCheckedModule tcm = do -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) + getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid)) getTypeLHsBind _ = pure Nothing @@ -337,25 +337,25 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i - | otherwise = Nothing + mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing unwrapVar (HsWrap _ _ var) = var unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLPat (dL->L spn pat) = + getTypeLPat (L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where - getMaybeId (VarPat _ (dL->L _ vid)) = Just vid + getMaybeId (VarPat _ (L _ vid)) = Just vid getMaybeId _ = Nothing -- | Get ALL source spans in the source. - listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a] + listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x])) where - p (dL->L spn _) = isGoodSrcSpan spn + p (L spn _) = isGoodSrcSpan spn -- | Variant of @syb@'s @everything@ (which summarises all nodes -- in top-down, left-to-right order) with a stop-condition on 'NameSet's diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 184070c630..3a0d4ff0fb 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -35,12 +35,12 @@ main = do removeFile "Test.hs" print ok where - isDataCon (dL->L _ (AbsBinds { abs_binds = bs })) + isDataCon (L _ (AbsBinds { abs_binds = bs })) = not (isEmptyBag (filterBag isDataCon bs)) - isDataCon (dL->L l (f@FunBind {})) - | (MG _ (dL->L _ (m:_)) _) <- fun_matches f, - ((dL->L _ (c@ConPatOut{})):_)<-hsLMatchPats m, - (dL->L l _)<-pat_con c + isDataCon (L l (f@FunBind {})) + | (MG _ (L _ (m:_)) _) <- fun_matches f, + ((L _ (c@ConPatOut{})):_)<-hsLMatchPats m, + (L l _)<-pat_con c = isGoodSrcSpan l -- Check that the source location is a good one isDataCon _ = False diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.hs b/testsuite/tests/pmcheck/should_compile/pmc009.hs index 08f130de33..95999b2de5 100644 --- a/testsuite/tests/pmcheck/should_compile/pmc009.hs +++ b/testsuite/tests/pmcheck/should_compile/pmc009.hs @@ -2,10 +2,6 @@ module HsUtils where import GHC.Hs.Binds import SrcLoc - --- | We have to be careful to normalise @SrcSpanLess (LHsBind)@ to --- @LHsBindLR l r@ before passing the representative of @unLoc bind@ on to --- @mkOneConFull@, otherwise this triggers a panic in @zipTvSubst@. addPatSynSelector:: LHsBind p -> [a] addPatSynSelector bind | PatSynBind _ _ <- unLoc bind diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.stderr b/testsuite/tests/pmcheck/should_compile/pmc009.stderr index d046b38d0f..9614f2497b 100644 --- a/testsuite/tests/pmcheck/should_compile/pmc009.stderr +++ b/testsuite/tests/pmcheck/should_compile/pmc009.stderr @@ -1,4 +1,4 @@ -pmc009.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)] +pmc009.hs:6:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘addPatSynSelector’: Patterns not matched: L _ _ diff --git a/utils/haddock b/utils/haddock -Subproject b6359cba90e5edfe549f933beeb00a13f01567b +Subproject f4298e24044cf01890ff6a257d387ee9a7f13d8 |