diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2021-02-21 21:23:40 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-20 07:48:38 -0400 |
| commit | 95275a5f25a2e70b71240d4756109180486af1b1 (patch) | |
| tree | eb4801bb0e00098b8b9d513479de4fbbd779ddac /compiler/GHC/Tc | |
| parent | f940fd466a86c2f8e93237b36835797be3f3c898 (diff) | |
| download | haskell-95275a5f25a2e70b71240d4756109180486af1b1.tar.gz | |
GHC Exactprint main commit
Metric Increase:
T10370
parsing001
Updates haddock submodule
Diffstat (limited to 'compiler/GHC/Tc')
35 files changed, 640 insertions, 530 deletions
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 7a536fcaf7..f3d6ede42d 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -294,7 +294,7 @@ renameDeriv inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) + ; let aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs) -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename -- auxiliary bindings as if they were defined locally. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. @@ -502,7 +502,7 @@ derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = -- We carefully set up uses of recoverM to minimize error message -- cascades. See Note [Recovering from failures in deriving clauses]. recoverM (pure Nothing) $ - setSrcSpan (getLoc deriv_pred) $ do + setSrcSpan (getLocA deriv_pred) $ do traceTc "derivePred" $ vcat [ text "tc" <+> ppr tc , text "tys" <+> ppr tys @@ -625,7 +625,7 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True @@ -730,7 +730,7 @@ tcStandaloneDerivInstType ctxt , sig_bndrs = outer_bndrs , sig_body = rho } let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, InferContext (Just wc_span), cls, inst_tys) + pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys) | otherwise = do dfun_ty <- tcHsClsInstType ctxt deriv_ty let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty @@ -1171,18 +1171,18 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do DerivEnv { denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask case mb_strat of - Just StockStrategy -> do + Just (StockStrategy _) -> do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args dit <- expectAlgTyConApp cls_tys inst_ty mk_eqn_stock dit - Just AnyclassStrategy -> mk_eqn_anyclass + Just (AnyclassStrategy _) -> mk_eqn_anyclass Just (ViaStrategy via_ty) -> do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args mk_eqn_via cls_tys inst_ty via_ty - Just NewtypeStrategy -> do + Just (NewtypeStrategy _) -> do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args dit <- expectAlgTyConApp cls_tys inst_ty unless (isNewTyCon (dit_rep_tc dit)) $ diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 324e51370c..d61b7180ef 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -158,7 +158,7 @@ gen_Functor_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag fmap_bind, emptyBag) where - fmap_name = L loc fmap_RDR + fmap_name = L (noAnnSrcSpan loc) fmap_RDR fmap_bind = mkRdrFunBind fmap_name fmap_eqns fmap_eqns = [mkSimpleMatch fmap_match_ctxt [nlWildPat] @@ -169,7 +169,7 @@ gen_Functor_binds loc tycon tycon_args = (listToBag [fmap_bind, replace_bind], emptyBag) where data_cons = getPossibleDataCons tycon tycon_args - fmap_name = L loc fmap_RDR + fmap_name = L (noAnnSrcSpan loc) fmap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns @@ -208,7 +208,7 @@ gen_Functor_binds loc tycon tycon_args , ft_co_var = panic "contravariant in ft_fmap" } -- See Note [Deriving <$] - replace_name = L loc replace_RDR + replace_name = L (noAnnSrcSpan loc) replace_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns @@ -617,8 +617,7 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do else nlParPat bare_pat rhs <- fold con_name (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" -- @@ -668,8 +667,7 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) rhs <- fold con_expr exps - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] @@ -794,7 +792,7 @@ gen_Foldable_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag foldMap_bind, emptyBag) where - foldMap_name = L loc foldMap_RDR + foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt [nlWildPat, nlWildPat] @@ -811,14 +809,14 @@ gen_Foldable_binds loc tycon tycon_args where data_cons = getPossibleDataCons tycon tycon_args - foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns + foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns eqns = map foldr_eqn data_cons foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_foldr con - foldMap_name = L loc foldMap_RDR + foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) @@ -841,7 +839,7 @@ gen_Foldable_binds loc tycon tycon_args go NotNull = Nothing go (NullM a) = Just (Just a) - null_name = L loc null_RDR + null_name = L (noAnnSrcSpan loc) null_RDR null_match_ctxt = mkPrefixFunRhs null_name null_bind = mkRdrFunBind null_name null_eqns null_eqns = map null_eqn data_cons @@ -851,7 +849,7 @@ gen_Foldable_binds loc tycon tycon_args case convert parts of Nothing -> return $ mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] - false_Expr (noLoc emptyLocalBinds) + false_Expr emptyLocalBinds Just cp -> match_null [] con cp -- Yields 'Just' an expression if we're folding over a type that mentions @@ -1023,7 +1021,7 @@ gen_Traversable_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag traverse_bind, emptyBag) where - traverse_name = L loc traverse_RDR + traverse_name = L (noAnnSrcSpan loc) traverse_RDR traverse_bind = mkRdrFunBind traverse_name traverse_eqns traverse_eqns = [mkSimpleMatch traverse_match_ctxt @@ -1036,7 +1034,7 @@ gen_Traversable_binds loc tycon tycon_args where data_cons = getPossibleDataCons tycon tycon_args - traverse_name = L loc traverse_RDR + traverse_name = L (noAnnSrcSpan loc) traverse_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 7b97d7bf22..5f2f69bee2 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -223,7 +223,7 @@ gen_Eq_binds loc tycon tycon_args = do no_tag_match_cons = null tag_match_cons -- (LHS patterns, result) - fall_through_eqn :: [([Located (Pat (GhcPass 'Parsed))] , LHsExpr GhcPs)] + fall_through_eqn :: [([LPat (GhcPass 'Parsed)] , LHsExpr GhcPs)] fall_through_eqn | no_tag_match_cons -- All constructors have arguments = case pat_match_cons of @@ -498,7 +498,8 @@ gen_Ord_binds loc tycon tycon_args = do , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con - tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) + tag_lit + = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K @@ -577,15 +578,15 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt -- mean more tests (dynamically) nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt where - ascribeBool e = noLoc $ ExprWithTySig noExtField e - $ mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType - $ nlHsTyVar boolTyCon_RDR + ascribeBool e = noLocA $ ExprWithTySig noAnn e + $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType + $ nlHsTyVar boolTyCon_RDR nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {}) -nlConWildPat con = noLoc $ ConPat - { pat_con_ext = noExtField - , pat_con = noLoc $ getRdrName con +nlConWildPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA $ getRdrName con , pat_args = RecCon $ HsRecFields { rec_flds = [] , rec_dotdot = Nothing } @@ -841,7 +842,7 @@ gen_Ix_binds loc tycon _ = do enum_index = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLoc (AsPat noExtField (noLoc c_RDR) + [noLocA (AsPat noAnn (noLocA c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr [(a_RDR, ah_RDR)] ( @@ -892,13 +893,13 @@ gen_Ix_binds loc tycon _ = do single_con_range = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - noLoc (mkHsComp ListComp stmts con_expr) + noLocA (mkHsComp ListComp stmts con_expr) where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed - mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c) + mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c) (nlHsApp (nlHsVar range_RDR) - (mkLHsVarTuple [a,b])) + (mkLHsVarTuple [a,b] noAnn)) ---------------- single_con_index @@ -920,11 +921,11 @@ gen_Ix_binds loc tycon _ = do ) plus_RDR ( genOpApp ( (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (mkLHsVarTuple [l,u])) + (mkLHsVarTuple [l,u] noAnn)) ) times_RDR (mk_index rest) ) mk_one l u i - = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, nlHsVar i] ------------------ single_con_inRange @@ -938,7 +939,8 @@ gen_Ix_binds loc tycon _ = do else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where - in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] + in_range a b c + = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c] {- ************************************************************************ @@ -1043,7 +1045,7 @@ gen_Read_binds get_fixity loc tycon _ read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] + [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLocA $ mkLastStmt (result_expr con [])])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the @@ -1058,7 +1060,7 @@ gen_Read_binds get_fixity loc tycon _ -- and Symbol s for operators mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] + result_expr con []] noAnn read_non_nullary_con data_con | is_infix = mk_parser infix_prec infix_stmts body @@ -1117,7 +1119,7 @@ gen_Read_binds get_fixity loc tycon _ ------------------------------------------------------------------------ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo (DoExpr Nothing) (ss ++ [noLoc $ mkLastStmt b])] + , nlHsDo (DoExpr Nothing) (ss ++ [noLocA $ mkLastStmt b])] con_app con as = nlHsVarApps (getRdrName con) as -- con as result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) @@ -1127,7 +1129,7 @@ gen_Read_binds get_fixity loc tycon _ ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] | otherwise = [ ident_pat s ] - bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p + bindLex pat = noLocA (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p -- See Note [Use expectP] ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") @@ -1136,7 +1138,7 @@ gen_Read_binds get_fixity loc tycon _ data_con_str con = occNameString (getOccName con) read_arg a ty = ASSERT( not (isUnliftedType ty) ) - noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) -- When reading field labels we might encounter -- a = 3 @@ -1144,8 +1146,8 @@ gen_Read_binds get_fixity loc tycon _ -- or (#) = 4 -- Note the parens! read_field lbl a = - [noLoc - (mkPsBindStmt + [noLocA + (mkPsBindStmt noAnn (nlVarPat a) (nlHsApp read_field @@ -1639,7 +1641,7 @@ gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], em data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con as_needed = take con_arity as_RDRs - lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) + lift_Expr = noLocA (HsBracket noAnn (mk_bracket br_body)) br_body = nlHsApps (Exact (dataConName data_con)) (map nlHsVar as_needed) @@ -1940,7 +1942,7 @@ gen_Newtype_binds :: SrcSpan -> Type -- the representation type -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) -- See Note [Newtype-deriving instances] -gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty +gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty = do let ats = classATs cls (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) @@ -1949,6 +1951,8 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty , sigs , listToBag $ map DerivFamInst atf_insts ) where + locn = noAnnSrcSpan loc' + loca = noAnnSrcSpan loc' -- For each class method, generate its derived binding and instance -- signature. Using the first example from -- Note [Newtype-deriving instances]: @@ -1979,10 +1983,10 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty -- Make sure that `forall c` is in an HsOuterExplicit so that it -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in -- Note [GND and QuantifiedConstraints]. - L loc $ ClassOpSig noExtField False [loc_meth_RDR] - $ L loc $ mkHsExplicitSigType - (map mk_hs_tvb to_tvbs) - (nlHsCoreTy to_rho) + L loca $ ClassOpSig noAnn False [loc_meth_RDR] + $ L loca $ mkHsExplicitSigType noAnn + (map mk_hs_tvb to_tvbs) + (nlHsCoreTy to_rho) ) where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id @@ -1995,13 +1999,13 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty -- Note [GND and QuantifiedConstraints]. mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs - mk_hs_tvb (Bndr tv flag) = noLoc $ KindedTyVar noExtField - flag - (noLoc (getRdrName tv)) - (nlHsCoreTy (tyVarKind tv)) + mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn + flag + (noLocA (getRdrName tv)) + (nlHsCoreTy (tyVarKind tv)) meth_RDR = getRdrName meth_id - loc_meth_RDR = L loc meth_RDR + loc_meth_RDR = L locn meth_RDR rhs_expr = nlHsVar (getRdrName coerceId) `nlHsAppType` from_tau @@ -2018,7 +2022,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty mk_atf_inst :: TyCon -> TcM FamInst mk_atf_inst fam_tc = do - rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) + rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc)) rep_lhs_tys let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' fam_tc rep_lhs_tys rep_rhs_ty @@ -2047,12 +2051,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty underlying_inst_tys = changeLast inst_tys rhs_ty nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) +nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty) where hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s nlHsCoreTy :: HsCoreTy -> LHsType GhcPs -nlHsCoreTy = noLoc . XHsType +nlHsCoreTy = noLocA . XHsType mkCoerceClassMethEqn :: Class -- the class being derived -> [TyVar] -- the tvs in the instance head (this includes @@ -2101,9 +2105,11 @@ genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpecOriginal dflags loc spec = (gen_bind spec, - L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)] + L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)] (genAuxBindSpecSig loc spec))) where + loca = noAnnSrcSpan loc + locn = noAnnSrcSpan loc gen_bind :: AuxBindSpec -> LHsBind GhcPs gen_bind (DerivTag2Con _ tag2con_RDR) = mkFunBindSE 0 loc tag2con_RDR @@ -2152,9 +2158,11 @@ genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpecDup loc original_rdr_name dup_spec = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name), - L loc (TypeSig noExtField [L loc dup_rdr_name] + L loca (TypeSig noAnn [L locn dup_rdr_name] (genAuxBindSpecSig loc dup_spec))) where + loca = noAnnSrcSpan loc + locn = noAnnSrcSpan loc dup_rdr_name = auxBindSpecRdrName dup_spec -- | Generate the type signature of an auxiliary binding. @@ -2162,17 +2170,17 @@ genAuxBindSpecDup loc original_rdr_name dup_spec genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs genAuxBindSpecSig loc spec = case spec of DerivTag2Con tycon _ - -> mk_sig $ L loc $ + -> mk_sig $ L (noAnnSrcSpan loc) $ XHsType $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkVisFunTyMany` mkParentType tycon DerivMaxTag _ _ - -> mk_sig (L loc (XHsType intTy)) + -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy)) DerivDataDataType _ _ _ -> mk_sig (nlHsTyVar dataType_RDR) DerivDataConstr _ _ _ -> mk_sig (nlHsTyVar constr_RDR) where - mk_sig = mkHsWildCardBndrs . L loc . mkHsImplicitSigType + mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType type SeparateBagsDerivStuff = -- DerivAuxBinds @@ -2235,17 +2243,17 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName -> [([LPat GhcPs], LHsExpr GhcPs)] -> LHsBind GhcPs mkFunBindSE arity loc fun pats_and_exprs - = mkRdrFunBindSE arity (L loc fun) matches + = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) + matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) + emptyLocalBinds | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] +mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind Generated fun matches) + = L (na2la loc) (mkFunBind Generated fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last @@ -2256,11 +2264,11 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName -> [([LPat GhcPs], LHsExpr GhcPs)] -> LHsBind GhcPs mkFunBindEC arity loc fun catch_all pats_and_exprs - = mkRdrFunBindEC arity catch_all (L loc fun) matches + = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches where - matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) + matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) + emptyLocalBinds | (p,e) <- pats_and_exprs ] -- | Produces a function binding. When no equations are given, it generates @@ -2269,11 +2277,11 @@ mkFunBindEC arity loc fun catch_all pats_and_exprs -- the right-hand side. mkRdrFunBindEC :: Arity -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> Located RdrName + -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') +mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches + = L (na2la loc) (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2288,16 +2296,16 @@ mkRdrFunBindEC arity catch_all then [mkMatch (mkPrefixFunRhs fun) (replicate (arity - 1) nlWildPat ++ [z_Pat]) (catch_all $ nlHsCase z_Expr []) - (noLoc emptyLocalBinds)] + emptyLocalBinds] else matches -- | Produces a function binding. When there are no equations, it generates -- a binding with the given arity that produces an error based on the name of -- the type of the last argument. -mkRdrFunBindSE :: Arity -> Located RdrName -> +mkRdrFunBindSE :: Arity -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') +mkRdrFunBindSE arity fun@(L loc fun_rdr) matches + = L (na2la loc) (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2307,7 +2315,7 @@ mkRdrFunBindSE arity matches' = if null matches then [mkMatch (mkPrefixFunRhs fun) (replicate arity nlWildPat) - (error_Expr str) (noLoc emptyLocalBinds)] + (error_Expr str) emptyLocalBinds] else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 8b0899e38a..5eff74aaa1 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -340,9 +340,9 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs]) mkBindsRep dflags gk tycon = (binds, sigs) where - binds = unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) + binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn]) `unionBags` - unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) + unitBag (mkRdrFunBind (L loc' to01_RDR) [to_eqn]) -- See Note [Generics performance tricks] sigs = if gopt Opt_InlineGenericsAggressively dflags @@ -361,7 +361,7 @@ mkBindsRep dflags gk tycon = (binds, sigs) cons = length datacons max_fields = maximum $ map dataConSourceArity datacons - inline1 f = L loc . InlineSig noExtField (L loc f) + inline1 f = L loc'' . InlineSig noAnn (L loc' f) $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 } -- The topmost M1 (the datatype metadata) has the exact same type @@ -375,6 +375,8 @@ mkBindsRep dflags gk tycon = (binds, sigs) from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] loc = srcLocSpan (getSrcLoc tycon) + loc' = noAnnSrcSpan loc + loc'' = noAnnSrcSpan loc datacons = tyConDataCons tycon (from01_RDR, to01_RDR) = case gk of diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index aa60f706a3..d6f0a2b474 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -269,9 +269,9 @@ data DerivSpecMechanism -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc -derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy -derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy -derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy +derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy noExtField +derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy noExtField +derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy noExtField derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index 90a703b6b5..07f2362688 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -43,7 +43,7 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc NoReason $ + = do { setSrcSpanA loc $ addWarnTc NoReason $ (text "Ignoring ANN annotation" <> plural anns <> comma <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") ; return [] } @@ -55,7 +55,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do let target = annProvenanceToTarget mod provenance -- Run that annotation and construct the full Annotation data structure - setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do + setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do -- See #10826 -- Annotations allow one to bypass Safe Haskell. dflags <- getDynFlags when (safeLanguageOn dflags) $ failWithTc safeHsErr @@ -64,7 +64,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -annProvenanceToTarget :: Module -> AnnProvenance Name +annProvenanceToTarget :: Module -> AnnProvenance GhcRn -> AnnTarget Name annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index cc1411ba90..4f4f53f1cf 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -138,7 +138,7 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType tcInferSigma inst (L loc rn_expr) | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr = addExprCtxt rn_expr $ - setSrcSpan loc $ + setSrcSpanA loc $ do { do_ql <- wantQuickLook rn_fun ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args @@ -650,12 +650,12 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn -- use "In the expression: arg" ---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside - = setSrcSpan arg_loc $ + = setSrcSpanA arg_loc $ addErrCtxt (funAppCtxt fun arg arg_no) $ thing_inside addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside - = setSrcSpan arg_loc $ + = setSrcSpanA arg_loc $ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated thing_inside diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index ad5a3474c0..7ab31322c9 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -140,7 +140,7 @@ tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty) tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) -- The main recursive function tcCmd env (L loc cmd) res_ty - = setSrcSpan loc $ do + = setSrcSpan (locA loc) $ do { cmd' <- tc_cmd env cmd res_ty ; return (L loc cmd') } @@ -149,11 +149,11 @@ tc_cmd env (HsCmdPar x cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar x cmd') } -tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ + setSrcSpan (locA body_loc) $ tc_cmd env body res_ty - ; return (HsCmdLet x (L l binds') (L body_loc body')) } + ; return (HsCmdLet x binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do @@ -259,11 +259,11 @@ tc_cmd env do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ + ; (pats', grhss') <- setSrcSpanA mtch_loc $ tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - ; let match' = L mtch_loc (Match { m_ext = noExtField + ; let match' = L mtch_loc (Match { m_ext = noAnn , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) arg_tys = map (unrestricted . hsLPatType) pats' @@ -276,10 +276,10 @@ tc_cmd env match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt - tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty + tc_grhss (GRHSs x grhss binds) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs x grhss' (L l binds')) } + ; return (GRHSs x grhss' binds') } tc_grhs stk_ty res_ty (GRHS x guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ @@ -393,7 +393,7 @@ tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names +tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names , recS_rec_ids = rec_names }) res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind @@ -417,13 +417,18 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; let ret_table = zip tup_ids tup_rets ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - ; return (emptyRecStmtId { recS_stmts = stmts' + ; let + stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) + stmt = emptyRecStmtId + { recS_stmts = L l stmts' + -- { recS_stmts = _ stmts' , recS_later_ids = later_ids , recS_rec_ids = rec_ids , recS_ext = unitRecStmtTc { recS_later_rets = later_rets , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty} }, thing) + , recS_ret_ty = res_ty} } + ; return (stmt, thing) }} tcArrDoStmt _ _ stmt _ _ diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 0ab561a0a7..e19491e93a 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -209,8 +209,8 @@ tcCompleteSigs sigs = -- There it is also where we consider if the type of the pattern match is -- compatible with the result type constructor 'mb_tc'. doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm)) - = fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $ do - cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns + = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do + cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc } doOne _ = return Nothing @@ -225,7 +225,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- signatures in it. The renamer checked all this tcHsBootSigs binds sigs = do { checkTc (null binds) badBootDeclErr - ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where @@ -254,7 +254,7 @@ tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside = do { ipClass <- tcLookupClass ipClassName ; (given_ips, ip_binds') <- - mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds + mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie @@ -275,7 +275,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcCheckMonoExpr expr ty ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } + ; return (ip_id, (IPBind noAnn (Right ip_id) d)) } tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" -- Coerces a `t` into a dictionary for `IP "x" t`. @@ -404,7 +404,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". do { traceTc "tc_group rec" (pprLHsBinds binds) ; whenIsJust mbFirstPatSyn $ \lpat_syn -> - recursivePatSynErr (getLoc lpat_syn) binds + recursivePatSynErr (locA $ getLoc lpat_syn) binds ; (binds1, thing) <- go sccs ; return ([(Recursive, binds1)], thing) } -- Rec them all together @@ -444,7 +444,7 @@ recursivePatSynErr loc binds where pprLoc loc = parens (text "defined at" <+> ppr loc) pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) - <+> pprLoc loc + <+> pprLoc (locA loc) tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv @@ -537,7 +537,7 @@ tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list ; return result } where binder_names = collectHsBindListBinders CollNoDictBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) + loc = foldr1 combineSrcSpans (map (locA . getLoc) bind_list) -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest -- span that includes them all @@ -618,7 +618,7 @@ tcPolyCheck prag_fn , fun_matches = matches })) = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) - ; mono_name <- newNameAt (nameOccName name) nm_loc + ; mono_name <- newNameAt (nameOccName name) (locA nm_loc) ; (wrap_gen, (wrap_res, matches')) <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> @@ -632,7 +632,7 @@ tcPolyCheck prag_fn -- Why mono_id in the BinderStack? -- See Note [Relevant bindings and the binder stack] - setSrcSpan bind_loc $ + setSrcSpanA bind_loc $ tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType rho_ty) @@ -648,7 +648,7 @@ tcPolyCheck prag_fn ; poly_id <- addInlinePrags poly_id prag_sigs ; mod <- getModule - ; tick <- funBindTicks nm_loc poly_id mod prag_sigs + ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs ; let bind' = FunBind { fun_id = L nm_loc poly_id2 , fun_matches = matches' @@ -743,7 +743,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = L loc $ + abs_bind = L (noAnnSrcSpan loc) $ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -1212,7 +1212,7 @@ tcMonoBinds is_rec sig_fn no_gen -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature - = setSrcSpan b_loc $ + = setSrcSpanA b_loc $ do { ((co_fn, matches'), rhs_ty) <- tcInfer $ \ exp_ty -> tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ @@ -1254,7 +1254,7 @@ tcMonoBinds is_rec sig_fn no_gen -- GENERAL CASE tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds + = do { tc_binds <- mapM (wrapLocMA (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs ; let mono_infos = getMonoBindInfo tc_binds @@ -1271,7 +1271,7 @@ tcMonoBinds _ sig_fn no_gen binds ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env] ; binds' <- tcExtendRecIds rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds + mapM (wrapLocMA tcRhs) tc_binds ; return (listToBag binds', mono_infos) } @@ -1373,7 +1373,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name -- Just g = ...f... -- Hence always typechecked with InferGen do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info nm_loc matches) } + ; return (TcFunBind mono_info (locA nm_loc) matches) } | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy @@ -1384,7 +1384,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name ; let mono_info = MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info nm_loc matches) } + ; return (TcFunBind mono_info (locA nm_loc) matches) } tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) = -- See Note [Typechecking pattern bindings] @@ -1460,9 +1460,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 (L loc (idName mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id)) matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L loc mono_id + ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches' , fun_ext = co_fn , fun_tick = [] } ) } @@ -1502,7 +1502,7 @@ tcExtendIdBinderStackForRhs infos thing_inside -- NotTopLevel: it's a monomorphic binding --------------------- -getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo] getMonoBindInfo tc_binds = foldr (get_info . unLoc) [] tc_binds where @@ -1773,7 +1773,7 @@ isClosedBndrGroup type_env binds -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) - => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt :: (OutputableBndrId p) + => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index c8106858b9..d9d7232595 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -49,7 +49,7 @@ tcDefaults [L _ (DefaultDecl _ [])] = return (Just []) -- Default declaration specifying no types tcDefaults [L locn (DefaultDecl _ mono_tys)] - = setSrcSpan locn $ + = setSrcSpan (locA locn) $ addErrCtxt defaultDeclCtxt $ do { ovl_str <- xoptM LangExt.OverloadedStrings ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules @@ -67,7 +67,7 @@ tcDefaults [L locn (DefaultDecl _ mono_tys)] ; return (Just tau_tys) } tcDefaults decls@(L locn (DefaultDecl _ _) : _) - = setSrcSpan locn $ + = setSrcSpan (locA locn) $ failWithTc (dupDefaultDeclErr decls) @@ -102,14 +102,14 @@ check_instance ty cls defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc +dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) = hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where - pp :: Located (DefaultDecl GhcRn) -> SDoc + pp :: LDefaultDecl GhcRn -> SDoc pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr locn + = text "here was another default declaration" <+> ppr (locA locn) dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" badDefaultTy :: Type -> [Class] -> SDoc diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index ec0efc48d5..168127bd19 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -154,7 +154,7 @@ type ExportOccMap = OccEnv (GreName, IE GhcPs) -- that have the same occurrence name rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list + -> Maybe (LocatedL [LIE GhcPs]) -- Nothing => no explicit export list -> RnM TcGblEnv -- Complains if two distinct exports have same OccName @@ -188,10 +188,11 @@ rnExports explicit_mod exports -- See Note [Modules without a module header] ; let real_exports | explicit_mod = exports - | has_main = Just (noLoc [noLoc (IEVar noExtField - (noLoc (IEName $ noLoc default_main)))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope + | has_main + = Just (noLocA [noLocA (IEVar noExtField + (noLocA (IEName $ noLocA default_main)))]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope | otherwise = Nothing -- Rename the export list @@ -216,7 +217,7 @@ rnExports explicit_mod exports , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly final_ns }) } -exports_from_avail :: Maybe (Located [LIE GhcPs]) +exports_from_avail :: Maybe (LocatedL [LIE GhcPs]) -- ^ 'Nothing' means no explicit export list -> GlobalRdrEnv -> ImportAvails @@ -262,7 +263,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod where do_litem :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) + do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie) -- Maps a parent to its in-scope children kids_env :: NameEnv [GlobalRdrElt] @@ -344,14 +345,14 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) + return (IEThingAbs noAnn (L l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') = do (n, avail, flds) <- lookup_ie_all ie n' let name = unLoc n - return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) + return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n)) , availTC name (name:avail) flds) @@ -380,8 +381,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name - then return (L l name, [], [name], []) - else return (L l name, non_flds + then return (L (locA l) name, [], [name], []) + else return (L (locA l) name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) @@ -401,7 +402,7 @@ exports_from_avail (Just (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 (L l name, non_flds, flds) + return (L (locA l) name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn) @@ -517,10 +518,10 @@ lookupChildrenExport spec_parent rdr_items = case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (L l (IEName (L l ub))))} + ; return (Left (L l (IEName (L (la2na l) ub))))} FoundChild par child -> do { checkPatSynParent spec_parent par child ; return $ case child of - FieldGreName fl -> Right (L (getLoc n) fl) + FieldGreName fl -> Right (L (getLocA n) fl) NormalGreName name -> Left (replaceLWrappedName n name) } IncorrectParent p c gs -> failWithDcErr p c gs diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index a74af6e564..597b9ca9cf 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -112,13 +112,13 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } tcPolyLExprNC (L loc expr) res_ty - = setSrcSpan loc $ + = setSrcSpanA loc $ do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -138,13 +138,13 @@ tcMonoExpr, tcMonoExprNC -> TcM (LHsExpr GhcTc) tcMonoExpr (L loc expr) res_ty - = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } tcMonoExprNC (L loc expr) res_ty - = setSrcSpan loc $ + = setSrcSpanA loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -152,13 +152,13 @@ tcMonoExprNC (L loc expr) res_ty tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. tcInferRho (L loc expr) - = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } tcInferRhoNC (L loc expr) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } @@ -206,7 +206,7 @@ tcExpr e@(HsOverLit _ lit) res_ty = do { mb_res <- tcShortCutLit lit res_ty -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk ; case mb_res of - Just lit' -> return (HsOverLit noExtField lit') + Just lit' -> return (HsOverLit noAnn lit') Nothing -> tcApp e res_ty } -- Typecheck an occurrence of an unbound Id @@ -249,7 +249,7 @@ tcExpr e@(HsIPVar _ x) res_ty ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) + (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var))) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. @@ -257,9 +257,9 @@ tcExpr e@(HsIPVar _ x) res_ty unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr (HsLam x match) res_ty +tcExpr (HsLam _ match) res_ty = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam x match')) } + ; return (mkHsWrap wrap (HsLam noExtField match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = sep [ text "The lambda expression" <+> @@ -328,7 +328,7 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys ; let expr' = ExplicitTuple x tup_args1 boxity - missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys] + missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] -- See Note [Linear fields generalization] in GHC.Tc.Gen.App act_res_ty @@ -357,10 +357,10 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty ************************************************************************ -} -tcExpr (HsLet x (L l binds) expr) res_ty +tcExpr (HsLet x binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet x (L l binds') expr') } + ; return (HsLet x binds' expr') } tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. @@ -449,9 +449,9 @@ tcExpr (HsStatic fvs expr) res_ty [p_ty] ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp noExtField - (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic fvs expr')) + ; return $ mkHsWrapCo co $ HsApp noComments + (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) + (L (noAnnSrcSpan loc) (HsStatic fvs expr')) } {- @@ -941,16 +941,16 @@ arithSeqEltType (Just fl) res_ty ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } ---------------- -tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] +tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc] tcTupArgs args tys = do MASSERT( equalLength args tys ) checkTupSize (length args) mapM go (args `zip` tys) where - go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy - ; return (L l (Missing (Scaled mult arg_ty))) } - go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty - ; return (L l (Present x expr')) } + go (Missing {}, arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy + ; return (Missing (Scaled mult arg_ty)) } + go (Present x expr, arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty + ; return (Present x expr') } --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1188,7 +1188,7 @@ getFixedTyVars upd_fld_occs univ_tvs cons -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Are all the fields unambiguous? = case mapM isUnambiguous rbnds of @@ -1253,7 +1253,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- where T does not have field x. pickParent :: RecSelParent -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + -> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) pickParent p (upd, xs) = case lookup p xs of -- Phew! The parent is valid for this field. @@ -1274,13 +1274,21 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Given a (field update, selector name) pair, look up the -- selector to give a field update with an unambiguous Id lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + -> TcM (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) lookupSelector (L l upd, n) = do { i <- tcLookupId n ; let L loc af = hsRecFieldLbl upd lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous i (L loc lbl)) } } + -- ; return $ L l upd { hsRecFieldLbl + -- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) } + ; return $ L l HsRecField + { hsRecFieldAnn = hsRecFieldAnn upd + , hsRecFieldLbl + = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) + , hsRecFieldArg = hsRecFieldArg upd + , hsRecPun = hsRecPun upd + } + } -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head reportAmbiguousField :: TyCon -> TcM () @@ -1293,7 +1301,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ] where rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } - loc = getLoc (head rbnds) + loc = getLocA (head rbnds) {- Game plan for record bindings @@ -1334,13 +1342,18 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing - Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - , hsRecFieldArg = rhs' }))) } + -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' + -- , hsRecFieldArg = rhs' }))) } + Just (f', rhs') -> return (Just (L l (HsRecField + { hsRecFieldAnn = hsRecFieldAnn fld + , hsRecFieldLbl = f' + , hsRecFieldArg = rhs' + , hsRecPun = hsRecPun fld}))) } tcRecordUpd :: ConLike -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -> TcM [LHsRecUpdField GhcTc] tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds @@ -1348,13 +1361,13 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds fields = map flSelector $ conLikeFieldLabels con_like flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) + do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) -> TcM (Maybe (LHsRecUpdField GhcTc)) do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) + f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing @@ -1363,7 +1376,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds (L l (fld { hsRecFieldLbl = L loc (Unambiguous (extFieldOcc (unLoc f')) - (L loc lbl)) + (L (noAnnSrcSpan loc) lbl)) , hsRecFieldArg = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type @@ -1463,7 +1476,7 @@ badFieldTypes prs 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 47d6e62997..ce5b052a94 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -235,7 +235,7 @@ tcFImport :: LForeignDecl GhcRn -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) - = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ + = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let @@ -376,7 +376,7 @@ tcForeignExports' decls = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) where combine (binds, fs, gres1) (L loc fe) = do - (b, f, gres2) <- setSrcSpan loc (tcFExport fe) + (b, f, gres2) <- setSrcSpanA loc (tcFExport fe) return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) tcFExport :: ForeignDecl GhcRn @@ -400,7 +400,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe -- We need to give a name to the new top-level binding that -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc return ( mkVarBind id rhs , ForeignExport { fd_name = L loc id , fd_sig_ty = undefined diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 4214b4cf92..2a442b3fd9 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -267,7 +267,7 @@ splitHsApps e = go e (top_ctxt 0 e) [] -- See Note [Desugar OpApp in the typechecker] go e@(OpApp _ arg1 (L l op) arg2) _ args - = ( (op, VACall op 0 l) + = ( (op, VACall op 0 (locA l)) , mkEValArg (VACall op 1 generatedSrcSpan) arg1 : mkEValArg (VACall op 2 generatedSrcSpan) arg2 : EWrap (EExpand e) @@ -275,12 +275,12 @@ splitHsApps e = go e (top_ctxt 0 e) [] go e ctxt args = ((e,ctxt), args) - set :: SrcSpan -> AppCtxt -> AppCtxt - set l (VACall f n _) = VACall f n l + set :: SrcSpanAnnA -> AppCtxt -> AppCtxt + set l (VACall f n _) = VACall f n (locA l) set _ ctxt@(VAExpansion {}) = ctxt - dec :: SrcSpan -> AppCtxt -> AppCtxt - dec l (VACall f n _) = VACall f (n-1) l + dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt + dec l (VACall f n _) = VACall f (n-1) (locA l) dec _ ctxt@(VAExpansion {}) = ctxt rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc @@ -288,19 +288,19 @@ rebuildHsApps fun _ [] = fun rebuildHsApps fun ctxt (arg : args) = case arg of EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } - -> rebuildHsApps (HsApp noExtField lfun arg) ctxt' args + -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args EPrag ctxt' p -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') - -> rebuildHsApps (HsPar noExtField lfun) ctxt' args + -> rebuildHsApps (HsPar noAnn lfun) ctxt' args EWrap (EExpand orig) -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args EWrap (EHsWrap wrap) -> rebuildHsApps (mkHsWrap wrap fun) ctxt args where - lfun = L (appCtxtLoc ctxt) fun + lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True @@ -555,7 +555,7 @@ tcInferRecSelId (Ambiguous _ lbl) args mb_res_ty ; return (expr, idType sel_id) } ------------------------ -tc_rec_sel_id :: Located RdrName -> Name -> TcM TcId +tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId -- Like tc_infer_id, but returns an Id not a HsExpr, -- so we can wrap it back up into a HsRecFld tc_rec_sel_id lbl sel_name @@ -579,7 +579,7 @@ tc_rec_sel_id lbl sel_name occ = rdrNameOcc (unLoc lbl) ------------------------ -tcInferAmbiguousRecSelId :: Located RdrName +tcInferAmbiguousRecSelId :: LocatedN RdrName -> [HsExprArg 'TcpRn] -> Maybe TcRhoType -> TcM Name -- Disgusting special case for ambiguous record selectors @@ -601,7 +601,7 @@ tcInferAmbiguousRecSelId lbl args mb_res_ty | otherwise = ambiguousSelector lbl -finish_ambiguous_selector :: Located RdrName -> Type -> TcM Name +finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name finish_ambiguous_selector lr@(L _ rdr) parent_type = do { fam_inst_envs <- tcGetFamInstEnvs ; case tyConOf fam_inst_envs parent_type of { @@ -631,7 +631,7 @@ finish_ambiguous_selector lr@(L _ rdr) parent_type -- This field name really is ambiguous, so add a suitable "ambiguous -- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a +ambiguousSelector :: LocatedN RdrName -> TcM a ambiguousSelector (L _ rdr) = do { addAmbiguousNameErr rdr ; failM } @@ -721,7 +721,7 @@ tcExprWithSig expr hs_ty ; (expr', poly_ty) <- tcExprSig expr sig_info ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } where - loc = getLoc (dropWildCards hs_ty) + loc = getLocA (dropWildCards hs_ty) tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) @@ -822,13 +822,13 @@ tcInferOverLit lit@(OverLit { ol_val = val ; hs_lit <- mkOverLit val ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) - ; let lit_expr = L loc $ mkHsWrapCo co $ - HsLit noExtField hs_lit + ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ + HsLit noAnn hs_lit from_expr = mkHsWrap (wrap2 <.> wrap1) $ HsVar noExtField (L loc from_id) - lit' = lit { ol_witness = HsApp noExtField (L loc from_expr) lit_expr + lit' = lit { ol_witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr , ol_ext = OverLitTc rebindable res_ty } - ; return (HsOverLit noExtField lit', res_ty) } + ; return (HsOverLit noAnn lit', res_ty) } where orig = LiteralOrigin lit mb_doc = Just (ppr from_name) @@ -852,7 +852,7 @@ tcCheckId name res_ty ; addFunResCtxt rn_fun [] actual_res_ty res_ty $ tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty } where - rn_fun = HsVar noExtField (noLoc name) + rn_fun = HsVar noExtField (noLocA name) ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType) @@ -877,7 +877,7 @@ tc_infer_assert assert_name = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) + ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho) } tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) @@ -928,7 +928,7 @@ tc_infer_id id_name = text "Illegal term-level use of the type constructor" <+> quotes (ppr (tyConName ty_con)) - return_id id = return (HsVar noExtField (noLoc id), idType id) + return_id id = return (HsVar noExtField (noLocA id), idType id) return_data_con con = do { let tvs = dataConUserTyVarBinders con @@ -1105,7 +1105,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName -- See Note [Lifting strings] - ; return (HsVar noExtField (noLoc sid)) } + ; return (HsVar noExtField (noLocA sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE @@ -1122,7 +1122,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) -- Update the pending splices ; ps <- readMutVar ps_var ; let pending_splice = PendingTcSplice id_name - (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) + (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) (nlHsVar id)) ; writeMutVar ps_var (pending_splice : ps) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 61b66f3919..f7ad3a2af6 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -51,7 +53,7 @@ module GHC.Tc.Gen.HsType ( kcDeclHeader, tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated, + tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, tcCheckLHsType, tcHsContext, tcLHsPredType, @@ -121,7 +123,6 @@ import GHC.Data.FastString import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt -import GHC.Parser.Annotation import GHC.Data.Maybe import GHC.Data.Bag( unitBag ) @@ -335,19 +336,19 @@ we promote the metavariable to level 1. This is all done in kindGeneralizeNone. -} -funsSigCtxt :: [Located Name] -> UserTypeCtxt +funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt -- Returns FunSigCtxt, with no redundant-context-reporting, -- form a list of located names funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False funsSigCtxt [] = panic "funSigCtxt" -addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> Located hs_ty -> TcM a -> TcM a +addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLoc hs_ty) $ + = setSrcSpan (getLocA hs_ty) $ addErrCtxt (pprSigCtxt ctxt hs_ty) $ thing_inside -pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> Located hs_ty -> SDoc +pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc -- (pprSigCtxt ctxt <extra> <type>) -- prints In the type signature for 'f': -- f :: <type> @@ -367,7 +368,7 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type -- already checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM () +kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () -- This is a special form of tcClassSigType that is used during the -- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type. -- Importantly, this does *not* kind-generalize. Consider @@ -387,7 +388,7 @@ kcClassSigType names tcLHsType hs_ty liftedTypeKind ; return () } -tcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM Type +tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType names sig_ty = addSigCtxt sig_ctxt sig_ty $ @@ -446,7 +447,7 @@ tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn -- Returns also an implication for the unsolved constraints tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs , sig_body = hs_ty })) ctxt_kind - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (tc_lvl, wanted, (outer_bndrs, ty)) <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $ -- See Note [Failure in local type signatures] @@ -523,7 +524,7 @@ tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Used for both types and kinds tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs , sig_body = body })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceTc "tc_top_lhs_type {" (ppr sig_ty) ; (tclvl, wanted, (outer_bndrs, ty)) <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ @@ -580,9 +581,12 @@ tcDerivStrategy mb_lds where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy StockStrategy = boring_case StockStrategy - tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy - tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy + tc_deriv_strategy (StockStrategy _) + = boring_case (StockStrategy noExtField) + tc_deriv_strategy (AnyclassStrategy _) + = boring_case (AnyclassStrategy noExtField) + tc_deriv_strategy (NewtypeStrategy _) + = boring_case (NewtypeStrategy noExtField) tc_deriv_strategy (ViaStrategy ty) = do ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty let (via_tvs, via_pred) = splitForAllTyCoVars ty' @@ -596,7 +600,7 @@ tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> TcM Type -- Like tcHsSigType, but for a class instance declaration tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLoc hs_inst_ty) $ + = setSrcSpan (getLocA hs_inst_ty) $ do { -- Fail eagerly if tcTopLHsType fails. We are at top level so -- these constraints will never be solved later. And failing -- eagerly avoids follow-on errors when checkValidInstance @@ -690,7 +694,7 @@ tcFamTyPats fam_tc hs_pats where fam_name = tyConName fam_tc fam_arity = tyConArity fam_tc - lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) + lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name)) {- Note [tcFamTyPats: zonking the result kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -756,7 +760,7 @@ tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) -- Eagerly instantiate any trailing invisible binders tcInferLHsTypeKind lhs_ty@(L loc hs_ty) = addTypeCtxt lhs_ty $ - setSrcSpan loc $ -- Cover the tcInstInvisibleTyBinders + setSrcSpanA loc $ -- Cover the tcInstInvisibleTyBinders do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty ; tcInstInvisibleTyBinders res_ty res_kind } -- See Note [Do not always instantiate eagerly in types] @@ -934,7 +938,7 @@ missing any patterns. -- level. tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) tc_infer_lhs_type mode (L span ty) - = setSrcSpan span $ + = setSrcSpanA span $ tc_infer_hs_type mode ty --------------------------- @@ -1051,7 +1055,7 @@ tcLHsType hs_ty exp_kind tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType tc_lhs_type mode (L span ty) exp_kind - = setSrcSpan span $ + = setSrcSpanA span $ tc_hs_type mode ty exp_kind tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType @@ -1159,7 +1163,7 @@ tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind [] -> (liftedTypeKind, BoxedTuple) -- In the [] case, it's not clear what the kind is, so guess * - ; tys' <- sequence [ setSrcSpan loc $ + ; tys' <- sequence [ setSrcSpanA loc $ checkExpectedKind hs_ty ty kind arg_kind | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] @@ -1279,13 +1283,13 @@ tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } {- Note [Skolem escape and forall-types] @@ -1431,7 +1435,7 @@ since the two constraints should be semantically equivalent. splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLoc hs_ty) []) + | is_app hs_ty = Just (go (noLocA hs_ty) []) | otherwise = Nothing where is_app :: HsType GhcRn -> Bool @@ -1446,11 +1450,15 @@ splitHsAppTys hs_ty is_app (HsParTy _ (L _ ty)) = is_app ty is_app _ = False + go :: LHsType GhcRn + -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)] + -> (LHsType GhcRn, + [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) - go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) + go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) go (L _ (HsOpTy _ l op@(L sp _) r)) as - = ( L sp (HsTyVar noExtField NotPromoted op) + = ( L (na2la sp) (HsTyVar noAnn NotPromoted op) , HsValArg l : HsValArg r : as ) go f as = (f, as) @@ -2962,7 +2970,7 @@ tcTKTelescope mode tele thing_inside = case tele of -- HsOuterTyVarBndrs -------------------------------------- -bindOuterTKBndrsX :: OutputableBndrFlag flag +bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> HsOuterTyVarBndrs flag GhcRn -> TcM a @@ -3034,7 +3042,7 @@ bindOuterFamEqnTKBndrs hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] --------------- -tcOuterTKBndrs :: OutputableBndrFlag flag +tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed => SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) @@ -3042,7 +3050,7 @@ tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False }) -- Do not clone the outer binders -- See Note [Cloning for type variable binder] under "must not" -tcOuterTKBndrsX :: OutputableBndrFlag flag +tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) @@ -3063,13 +3071,13 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside -- Explicit tyvar binders -------------------------------------- -tcExplicitTKBndrs :: OutputableBndrFlag flag +tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True }) -tcExplicitTKBndrsX :: OutputableBndrFlag flag +tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3095,7 +3103,7 @@ tcExplicitTKBndrsX skol_mode bndrs thing_inside -- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied -- 'TcTyMode'. bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: (OutputableBndrFlag flag) + :: (OutputableBndrFlag flag 'Renamed) => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) @@ -3124,7 +3132,7 @@ bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] -bindExplicitTKBndrsX :: (OutputableBndrFlag flag) +bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed) => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3873,7 +3881,7 @@ tcPartialContext _ Nothing = return ([], Nothing) tcPartialContext mode (Just (L _ hs_theta)) | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpan wc_loc $ + = do { wc_tv_ty <- setSrcSpanA wc_loc $ tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind ; theta <- mapM (tc_lhs_pred mode) hs_theta1 ; return (theta, Just wc_tv_ty) } diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 0a85147309..2f62d3d712 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -90,7 +91,7 @@ is used in error messages. It checks that all the equations have the same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: Located Name +tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) @@ -136,12 +137,12 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty parser guarantees that each equation has exactly one argument. -} -tcMatchesCase :: (Outputable (body GhcRn)) => - TcMatchCtxt body -- Case context - -> Scaled TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives +tcMatchesCase :: (AnnoBody body) => + TcMatchCtxt body -- Case context + -> Scaled TcSigmaType -- Type of scrutinee + -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty @@ -174,6 +175,7 @@ tcGRHSsPat grhss res_ty -- desugar to incorrect code. tcGRHSs match_ctxt grhss res_ty where + match_ctxt :: TcMatchCtxt HsExpr -- AZ match_ctxt = MC { mc_what = PatBindRhs, mc_body = tcBody } @@ -185,17 +187,29 @@ tcGRHSsPat grhss res_ty data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is - mc_body :: Located (body GhcRn) -- Type checker for a body of + mc_body :: LocatedA (body GhcRn) -- Type checker for a body of -- an alternative -> ExpRhoType - -> TcM (Located (body GhcTc)) } + -> TcM (LocatedA (body GhcTc)) } + +type AnnoBody body + = ( Outputable (body GhcRn) + , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL + , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan + , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + ) -- | Type-check a MatchGroup. -tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body +tcMatches :: (AnnoBody body ) => TcMatchCtxt body -> [Scaled ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup GhcRn (Located (body GhcRn)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) + -> ExpRhoType -- Expected result-type of the Match. + -> MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) @@ -221,21 +235,21 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) } ------------- -tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body +tcMatch :: (AnnoBody body) => TcMatchCtxt body -> [Scaled ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. - -> LMatch GhcRn (Located (body GhcRn)) - -> TcM (LMatch GhcTc (Located (body GhcTc))) + -> LMatch GhcRn (LocatedA (body GhcRn)) + -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) tcMatch ctxt pat_tys rhs_ty match - = wrapLocM (tc_match ctxt pat_tys rhs_ty) match + = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match where tc_match ctxt pat_tys rhs_ty match@(Match { m_pats = pats, m_grhss = grhss }) = add_match_ctxt match $ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ext = noExtField + ; return (Match { m_ext = noAnn , m_ctxt = mc_what ctxt, m_pats = pats' , m_grhss = grhss' }) } @@ -247,8 +261,9 @@ tcMatch ctxt pat_tys rhs_ty match _ -> addErrCtxt (pprMatchInCtxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType - -> TcM (GRHSs GhcTc (Located (body GhcTc))) +tcGRHSs :: AnnoBody body + => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType + -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like @@ -256,23 +271,23 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more -tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty +tcGRHSs ctxt (GRHSs _ grhss binds) res_ty = do { (binds', ugrhss) <- tcLocalBinds binds $ mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss ; let (usages, grhss') = unzip ugrhss ; tcEmitBindingUsage $ supUEs usages - ; return (GRHSs noExtField grhss' (L l binds')) } + ; return (GRHSs noExtField grhss' binds') } ------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) - -> TcM (GRHS GhcTc (Located (body GhcTc))) +tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn)) + -> TcM (GRHS GhcTc (LocatedA (body GhcTc))) tcGRHS ctxt res_ty (GRHS _ guards rhs) = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs - ; return (GRHS noExtField guards' rhs') } + ; return (GRHS noAnn guards' rhs') } where stmt_ctxt = PatGuard (mc_what ctxt) @@ -285,7 +300,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs) -} tcDoStmts :: HsStmtContext GhcRn - -> Located [LStmt GhcRn (LHsExpr GhcRn)] + -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty @@ -332,27 +347,27 @@ type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType type TcStmtChecker body rho_type = forall thing. HsStmtContext GhcRn - -> Stmt GhcRn (Located (body GhcRn)) + -> Stmt GhcRn (LocatedA (body GhcRn)) -> rho_type -- Result type for comprehension -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt GhcTc (Located (body GhcTc)), thing) + -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn +tcStmts :: (AnnoBody body) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] + -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type - -> TcM [LStmt GhcTc (Located (body GhcTc))] + -> TcM [LStmt GhcTc (LocatedA (body GhcTc))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ()) ; return stmts' } -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn +tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] + -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type -> (rho_type -> TcM thing) - -> TcM ([LStmt GhcTc (Located (body GhcTc))], thing) + -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts @@ -362,11 +377,11 @@ tcStmtsAndThen _ _ [] res_ty thing_inside ; return ([], thing) } -- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts) res_ty thing_inside = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } + ; return (L loc (LetStmt x binds') : stmts', thing) } -- Don't set the error context for an ApplicativeStmt. It ought to be -- possible to do this with a popErrCtxt in the tcStmt case for @@ -382,7 +397,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside -- For the vanilla case, handle the location-setting part | otherwise = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ + setSrcSpanA loc $ addErrCtxt (pprStmtInCtxt ctxt stmt) $ stmt_chk ctxt stmt res_ty $ \ res_ty' -> popErrCtxt $ @@ -686,7 +701,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- case form of ThenForm -> return noExpr - _ -> fmap unLoc . tcCheckPolyExpr (noLoc fmap_op) $ + _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $ mkInfForAllTy alphaTyVar $ mkInfForAllTy betaTyVar $ (alphaTy `mkVisFunTyMany` betaTy) @@ -758,7 +773,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside (m_ty `mkAppTy` betaTy) `mkVisFunTyMany` (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLoc mzip_op) mzip_ty + ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty -- type dummies since we don't know all binder types yet ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) @@ -872,7 +887,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside ; return (rhs', rhs_ty, thing) } ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names +tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) res_ty thing_inside @@ -914,7 +929,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; later_ids <- tcLookupLocalIds later_names ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), ppr later_ids <+> ppr (map idType later_ids)] - ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids + ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' , recS_ext = RecStmtTc @@ -1036,7 +1051,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside , arg_expr = rhs , .. }, pat_ty, exp_ty) - = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ + = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ do { rhs' <- tcCheckMonoExprNC rhs exp_ty ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ @@ -1103,7 +1118,8 @@ the variables they bind into scope, and typecheck the thing_inside. number of args are used in each equation. -} -checkArgs :: Name -> MatchGroup GhcRn body -> TcM () +checkArgs :: AnnoBody body + => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () checkArgs _ (MG { mg_alts = L _ [] }) = return () checkArgs fun (MG { mg_alts = L _ (match1:matches) }) @@ -1112,11 +1128,11 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) | otherwise = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> text "have different numbers of arguments" - , nest 2 (ppr (getLoc match1)) - , nest 2 (ppr (getLoc (head bad_matches)))]) + , nest 2 (ppr (getLocA match1)) + , nest 2 (ppr (getLocA (head bad_matches)))]) where n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] - args_in_match :: LMatch GhcRn body -> Int + args_in_match :: (LocatedA (Match GhcRn body1) -> Int) args_in_match (L _ (Match { m_pats = pats })) = length pats diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot index bb194a3cf1..9f6b6bf239 100644 --- a/compiler/GHC/Tc/Gen/Match.hs-boot +++ b/compiler/GHC/Tc/Gen/Match.hs-boot @@ -4,14 +4,14 @@ import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Types.Name ( Name ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types ( TcM ) -import GHC.Types.SrcLoc ( Located ) import GHC.Hs.Extension ( GhcRn, GhcTc ) +import GHC.Parser.Annotation ( LocatedN ) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: Located Name +tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 837fb7fbdc..671955feb7 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -331,7 +331,7 @@ tcMultiple tc_pat penv args thing_inside tc_lpat :: Scaled ExpSigmaType -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside - = setSrcSpan span $ + = setSrcSpanA span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) thing_inside ; return (L span pat', res) } @@ -400,7 +400,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of AsPat x (L nm_loc name) pat -> do { mult_wrap <- checkManyPattern pat_ty -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. - ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) penv pat thing_inside @@ -532,8 +532,8 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) - | otherwise = unmangled_result + isBoxed boxity = LazyPat noExtField (noLocA unmangled_result) + | otherwise = unmangled_result ; pat_ty <- readExpType (scaledThing pat_ty) ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced @@ -653,7 +653,7 @@ AST is used for the subtraction operation. <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $ \ [lit2_ty, var_ty] _ -> do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpan nm_loc $ + ; (wrap, bndr_id) <- setSrcSpanA nm_loc $ tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) -- co :: var_ty ~ idType bndr_id @@ -854,7 +854,7 @@ same name, leading to shadowing. -- MkT :: forall a b c. (a~[b]) => b -> c -> T a -- with scrutinee of type (T ty) -tcConPat :: PatEnv -> Located Name +tcConPat :: PatEnv -> LocatedN Name -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) @@ -867,7 +867,7 @@ tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside pat_ty arg_pats thing_inside } -tcDataConPat :: PatEnv -> Located Name -> DataCon +tcDataConPat :: PatEnv -> LocatedN Name -> DataCon -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) @@ -886,7 +886,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled ; pat_ty <- readExpType (scaledThing pat_ty_scaled) -- Add the stupid theta - ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys + ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) ; checkExistentials ex_tvs all_arg_tys penv @@ -971,7 +971,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled ; return (mkHsWrapPat wrap res_pat pat_ty, res) } } -tcPatSynPat :: PatEnv -> Located Name -> PatSyn +tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) @@ -1246,14 +1246,14 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTc (LPat GhcTc)) tc_field penv - (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) + (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun)) thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' - pun), res) } + ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat' + pun), res) } find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index bbbd528830..73dedfbaf5 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -99,12 +99,12 @@ equation. -} tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] -tcRules decls = mapM (wrapLocM tcRuleDecls) decls +tcRules decls = mapM (wrapLocMA tcRuleDecls) decls tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) tcRuleDecls (HsRules { rds_src = src , rds_rules = decls }) - = do { tc_decls <- mapM (wrapLocM tcRule) decls + = do { tc_decls <- mapM (wrapLocMA tcRule) decls ; return $ HsRules { rds_ext = noExtField , rds_src = src , rds_rules = tc_decls } } @@ -175,7 +175,7 @@ tcRule (HsRule { rd_ext = ext , rd_name = rname , rd_act = act , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) + , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA) (qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 45dbc96d8f..1d81b3636b 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -187,13 +187,13 @@ tcTySig (L _ (IdSig _ id)) ; return [TcIdSig sig] } tcTySig (L loc (TypeSig _ names sig_ty)) - = setSrcSpan loc $ - do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) + = setSrcSpanA loc $ + do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) | L _ name <- names ] ; return (map TcIdSig sigs) } tcTySig (L loc (PatSynSig _ names sig_ty)) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { tpsigs <- sequence [ tcPatSynSig name sig_ty | L _ name <- names ] ; return (map TcPatSynSig tpsigs) } @@ -288,7 +288,7 @@ no_anon_wc_ty lty = go lty && go ty HsQualTy { hst_ctxt = ctxt , hst_body = ty } -> gos (fromMaybeContext ctxt) && go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty HsSpliceTy{} -> True HsTyLit{} -> True HsTyVar{} -> True @@ -595,7 +595,7 @@ addInlinePrags poly_id prags_for_me -- and inl2 is a user NOINLINE pragma; we don't want to complain warn_multiple_inlines inl2 inls | otherwise - = setSrcSpan loc $ + = setSrcSpanA loc $ addWarnTc NoReason (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) 2 (vcat (text "Ignoring all but the first" @@ -721,8 +721,8 @@ tcSpecPrags :: Id -> [LSig GhcRn] tcSpecPrags poly_id prag_sigs = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) ; unless (null bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } + ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } where spec_sigs = filter isSpecLSig prag_sigs bad_sigs = filter is_bad_sig prag_sigs @@ -789,11 +789,11 @@ tcImpPrags prags ; if (not_specialising dflags) then return [] else do - { pss <- mapAndRecoverM (wrapLocM tcImpSpec) + { pss <- mapAndRecoverM (wrapLocMA tcImpSpec) [L loc (name,prag) | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } } where -- Ignore SPECIALISE pragmas for imported things -- when we aren't specialising, or when we aren't generating diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 89ba997d8a..456578f729 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -215,7 +215,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty rn_expr (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) (nlHsTyApp texpco [rep, expr_ty])) - (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps')))) + (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack) @@ -598,7 +598,7 @@ That effort is tracked in #14838. tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLoc expr) $ do + setSrcSpan (getLocA expr) $ do { stage <- getStage ; case stage of Splice {} -> tcTopSplice expr res_ty @@ -645,7 +645,7 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl -- But we still return a plausible expression -- (a) in case we print it in debug messages, and -- (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp - ; return (HsSpliceE noExtField $ + ; return (HsSpliceE noAnn $ HsSpliced noExtField (ThModFinalizers []) $ HsSplicedExpr (unLoc expr'')) } @@ -666,7 +666,7 @@ tcTopSplice expr res_ty ; lcl_env <- getLclEnv ; let delayed_splice = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) + ; return (HsSpliceE noAnn (XSplice (HsSplicedT delayed_splice))) } @@ -776,10 +776,11 @@ runAnnotation target expr = do -- LIE consulted by tcTopSpliceExpr -- and hence ensures the appropriate dictionary is bound by const_binds ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; let loc' = noAnnSrcSpan loc ; let specialised_to_annotation_wrapper_expr - = L loc (mkHsWrap wrapper - (HsVar noExtField (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp noExtField + = L loc' (mkHsWrap wrapper + (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id))) + ; return (L loc' (HsApp noComments specialised_to_annotation_wrapper_expr expr')) }) @@ -961,7 +962,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- encounter them inside the try -- -- See Note [Exceptions in TH] - let expr_span = getLoc expr + let expr_span = getLocA expr ; either_tval <- tryAllM $ setSrcSpan expr_span $ -- Set the span so that qLocation can -- see where this splice is diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 81cf5ea408..09edfcb8c3 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -236,7 +236,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (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 @@ -273,9 +273,9 @@ tcRnModuleTcRnM hsc_env mod_sum $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) - ; let { mkImport (Nothing, L _ mod_name) = noLoc + ; let { mkImport (Nothing, L _ mod_name) = noLocA $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLoc [])} + { ideclHiding = Just (False, noLocA [])} ; mkImport _ = panic "mkImport" } ; let { all_imports = prel_imports ++ import_decls ++ map mkImport (raw_sig_imports ++ raw_req_imports) } @@ -437,7 +437,7 @@ tcRnImports hsc_env import_decls -} tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) + -> Maybe (LocatedL [LIE GhcPs]) -> [LHsDecl GhcPs] -- Declarations -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr export_ies decls @@ -607,7 +607,7 @@ tc_rn_src_decls ds ; case th_group_tail of { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> - setSrcSpan loc + setSrcSpanA loc $ addErr (text ("Declaration splices are not " ++ "permitted inside top-level " @@ -728,9 +728,9 @@ tcRnHsBootDecls hsc_src decls }}} ; traceTc "boot" (ppr lie); return gbl_env } -badBootDecl :: HscSource -> String -> Located decl -> TcM () +badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _) - = addErrAt loc (char 'A' <+> text what + = addErrAt (locA loc) (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of HsBootFile -> text "hs-boot" @@ -1791,7 +1791,7 @@ checkMainType tcg_env ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module + -> Maybe (LocatedL [LIE GhcPs]) -- Export specs of Main module -> TcM TcGblEnv -- If we are in module Main, check that 'main' is exported, -- and generate the runMainIO binding that calls it @@ -1872,7 +1872,7 @@ generateMainBinding tcg_env main_name = do { traceTc "checkMain found" (ppr main_name) ; (io_ty, res_ty) <- getIOType ; let loc = getSrcSpan main_name - main_expr_rn = L loc (HsVar noExtField (L loc main_name)) + main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name)) ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ tcCheckMonoExpr main_expr_rn io_ty @@ -2228,20 +2228,21 @@ tcUserStmt (L loc (BodyStmt _ expr _ _)) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique + ; let loc' = noAnnSrcSpan $ locA loc ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr - (noLoc emptyLocalBinds)] + ; let fresh_it = itName uniq (locA loc) + matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr + emptyLocalBinds] -- [it = expr] the_bind = L loc $ (mkTopFunBind FromSource - (L loc fresh_it) matches) + (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 = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField + let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) @@ -2251,7 +2252,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _)) { xbsrn_bindOp = mkRnSyntaxExpr bindIOName , xbsrn_failOp = Nothing }) - (L loc (VarPat noExtField (L loc fresh_it))) + (L loc (VarPat noExtField (L loc' fresh_it))) (nlHsApp ghciStep rn_expr) -- [; print it] @@ -2373,7 +2374,7 @@ But for naked expressions, you will have tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do + rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv return (fix_env, emptyFVs) -- Don't try to typecheck if the renamer fails! @@ -2475,17 +2476,17 @@ tcGhciStmts stmts -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLoc $ ExplicitList unitTy $ + noLocA $ ExplicitList unitTy $ map mk_item ids mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) , getRuntimeRep unitTy , idType id, unitTy] `nlHsApp` nlHsVar id - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) + noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) @@ -2497,7 +2498,7 @@ getGhciStepIO = do ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) step_ty :: LHsSigType GhcRn - step_ty = noLoc $ HsSig + step_ty = noLocA $ HsSig { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} , sig_ext = noExtField , sig_body = nlHsFunTy ghciM ioM } @@ -2505,7 +2506,7 @@ getGhciStepIO = do stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs step_ty - return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name) isGHCiMonad hsc_env ty @@ -2550,7 +2551,7 @@ tcRnExpr hsc_env mode rdr_expr -- Generalise uniq <- newUnique ; - let { fresh_it = itName uniq (getLoc rdr_expr) } ; + let { fresh_it = itName uniq (getLocA rdr_expr) } ; ((qtvs, dicts, _, _), residual) <- captureConstraints $ simplifyInfer tclvl infer_mode @@ -2783,12 +2784,12 @@ getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod -tcRnLookupRdrName :: HscEnv -> Located RdrName +tcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (Messages DecoratedSDoc, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ - setSrcSpan loc $ + setSrcSpanA loc $ do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both -- constructor and type class identifiers. @@ -2928,7 +2929,7 @@ tcDump env full_dump = pprLHsBinds (tcg_binds env) -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords - ast_dump = showAstData NoBlankSrcSpan (tcg_binds env) + ast_dump = showAstData NoBlankSrcSpan NoBlankApiAnnotations (tcg_binds env) -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index ec8c2bb66e..bcb9fa084d 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -1286,7 +1286,7 @@ inferInitialKinds decls ; traceTc "inferInitialKinds done }" empty ; return tcs } where - infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + infer_initial_kind = addLocMA (getInitialKind InitialKindInfer) -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. @@ -1298,7 +1298,7 @@ checkInitialKinds decls ; return tcs } where check_initial_kind (ldecl, msig) = - addLocM (getInitialKind (InitialKindCheck msig)) ldecl + addLocMA (getInitialKind (InitialKindCheck msig)) ldecl -- | Get the initial kind of a TyClDecl, either generalized or non-generalized, -- depending on the 'InitialKindStrategy'. @@ -1327,7 +1327,7 @@ getInitialKind strategy -- See Note [Don't process associated types in getInitialKind] ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (getAssocFamInitialKind cls)) ats + mapM (addLocMA (getAssocFamInitialKind cls)) ats ; return (cls : inner_tcs) } where getAssocFamInitialKind cls = @@ -1531,7 +1531,7 @@ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { tycon <- tcLookupTcTyCon tc_name ; traceTc "kcTyClDecl {" (ppr tc_name) ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] @@ -1569,7 +1569,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon = bindTyClTyVars name $ \ _ _ _ -> do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kc_sig) sigs } + ; mapM_ (wrapLocMA_ kc_sig) sigs } where kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty kc_sig _ = return () @@ -1617,7 +1617,7 @@ kcConDecls :: NewOrData -> TcM () -- See Note [kcConDecls: kind-checking data type decls] kcConDecls new_or_data tc_res_kind cons - = mapM_ (wrapLocM_ (kcConDecl new_or_data tc_res_kind)) cons + = mapM_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons -- Kind check a data constructor. In additional to the data constructor, -- we also need to know about whether or not its corresponding type was @@ -2323,7 +2323,7 @@ tcTyClDecl roles_info (L loc decl) _ -> pprPanic "tcTyClDecl" (ppr thing) | otherwise - = setSrcSpan loc $ tcAddDeclCtxt decl $ + = setSrcSpanA loc $ tcAddDeclCtxt decl $ do { traceTc "---- tcTyClDecl ---- {" (ppr decl) ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) @@ -2341,7 +2341,7 @@ wiredInDerivInfo tycon decl if isFunTyCon tycon || isPrimTyCon tycon then [] -- no tyConTyVars else mkTyVarNamePairs (tyConTyVars tycon) - , di_clauses = unLoc derivs + , di_clauses = derivs , di_ctxt = tcMkDeclCtxt decl } ] wiredInDerivInfo _ _ = [] @@ -2404,7 +2404,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs -- The (binderVars binders) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocM tc_fundep) fundeps + ; fds <- mapM (addLocMA tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } @@ -2448,9 +2448,11 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs ; return clas } where skol_info = TyConSkol ClassFlavour class_name - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) + tc_fundep (FunDep _ tvs1 tvs2) + = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1', tvs2') } + ; return (tvs1',tvs2') } {- Note [Associated type defaults] @@ -2493,7 +2495,7 @@ tcClassATs class_name cls ats at_defs (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at + tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] ; atd <- tcDefaultAssocDecl fam_tc at_defs @@ -2518,7 +2520,7 @@ tcDefaultAssocDecl fam_tc , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty }})] = -- See Note [Type-checking default assoc decls] - setSrcSpan loc $ + setSrcSpanA loc $ tcAddFamInstCtxt (text "default type instance") tc_name $ do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) ; let fam_tc_name = tyConName fam_tc @@ -2559,7 +2561,7 @@ tcDefaultAssocDecl fam_tc -- simply create an empty substitution and let GHC fall -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. -- See Note [Type-checking default assoc decls]. - ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI loc pats) + ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats) -- We perform checks for well-formedness and validity later, in -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. } @@ -2789,7 +2791,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 (L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags @@ -2903,7 +2905,7 @@ tcDataDefn err_ctxt roles_info tc_name gadt_syntax) } ; let deriv_info = DerivInfo { di_rep_tc = tycon , di_scoped_tvs = tcTyConScopedTyVars tctc - , di_clauses = unLoc derivs + , di_clauses = derivs , di_ctxt = err_ctxt } ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) ; return (tycon, [deriv_info]) } @@ -2946,7 +2948,7 @@ kcTyFamInstEqn tc_fam_tc , feqn_bndrs = outer_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceTc "kcTyFamInstEqn" (vcat [ text "tc_name =" <+> ppr eqn_tc_name , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) @@ -2989,7 +2991,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo (L loc (FamEqn { feqn_bndrs = outer_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceTc "tcTyFamInstEqn" $ vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) @@ -3012,7 +3014,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo -- (tcFamInstEqnGuts zonks to Type) ; return (mkCoAxBranch qtvs [] [] pats rhs_ty (map (const Nominal) qtvs) - loc) } + (locA loc)) } {- Note [Instantiating a family tycon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3150,7 +3152,7 @@ checkFamTelescope tclvl hs_outer_bndrs outer_tvs , (b_first : _) <- bndrs , let b_last = last bndrs skol_info = ForAllSkol (fsep (map ppr bndrs)) - = setSrcSpan (combineSrcSpans (getLoc b_first) (getLoc b_last)) $ + = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC | otherwise = return () @@ -3324,7 +3326,7 @@ tcConDecls :: NewOrData -> TcKind -- Result kind -> [LConDecl GhcRn] -> TcM [DataCon] tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind - = concatMapM $ addLocM $ + = concatMapM $ addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) -- mkTyConTagMap: it's important that we pay for tag allocation here, @@ -3664,7 +3666,7 @@ tcConArg exp_kind (HsScaled w bty) ; return (Scaled w' arg_ty, getBangStrictness bty) } tcRecConDeclFields :: ContextKind - -> Located [LConDeclField GhcRn] + -> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled TcType, HsSrcBang)] tcRecConDeclFields exp_kind fields = mapM (tcConArg exp_kind) btys @@ -4292,7 +4294,7 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan con_loc $ - addErrCtxt (dataConCtxt [L con_loc con_name]) $ + addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $ do { let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) orig_res_ty = dataConOrigResTy con @@ -4891,7 +4893,7 @@ checkValidRoleAnnots role_annots tc = whenIsJust role_annot_decl_maybe $ \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ - setSrcSpan loc $ do + setSrcSpanA loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations ; checkTc role_annots_ok $ needXRoleAnnotations tc ; checkTc (vis_vars `equalLength` the_role_annots) @@ -5087,15 +5089,15 @@ fieldTypeMisMatch field_name con1 con2 = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] -dataConCtxt :: [Located Name] -> SDoc +dataConCtxt :: [LocatedN Name] -> SDoc dataConCtxt cons = text "In the definition of data constructor" <> plural cons <+> ppr_cons cons -dataConResCtxt :: [Located Name] -> SDoc +dataConResCtxt :: [LocatedN Name] -> SDoc dataConResCtxt cons = text "In the result type of data constructor" <> plural cons <+> ppr_cons cons -ppr_cons :: [Located Name] -> SDoc +ppr_cons :: [LocatedN Name] -> SDoc ppr_cons [con] = quotes (ppr con) ppr_cons cons = interpp'SP cons @@ -5217,7 +5219,7 @@ wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ - setSrcSpan loc $ + setSrcSpanA loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 8e637a1a32..80804ecaea 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -152,12 +152,14 @@ tcClassSigs clas sigs def_methods ; traceTc "tcClassSigs 2" (ppr clas) ; return op_info } where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] + vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp + vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp + gen_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) + tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn) -> TcM [TcMethInfo] tc_sig gen_dm_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) @@ -171,9 +173,12 @@ tcClassSigs clas sigs def_methods | nm `elem` dm_bind_names = Just VanillaDM | otherwise = Nothing + tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn) + -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp tc_gen_sig (op_names, gen_hs_ty) = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty - ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } + ; return [ (op_name, (locA loc, gen_op_ty)) + | L loc op_name <- op_names ] } {- ************************************************************************ @@ -188,9 +193,9 @@ tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) - = recoverM (return emptyLHsBinds) $ - setSrcSpan (getLoc class_name) $ - do { clas <- tcLookupLocatedClass class_name + = recoverM (return emptyLHsBinds) $ + setSrcSpan (getLocA class_name) $ + do { clas <- tcLookupLocatedClass (n2l class_name) -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus @@ -227,7 +232,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) = do { -- No default method - mapM_ (addLocM (badDmPrag sel_id)) + mapM_ (addLocMA (badDmPrag sel_id)) (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } @@ -272,7 +277,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } + lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind @@ -288,7 +293,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty local_dm_sig = CompleteSig { sig_bndr = local_dm_id , sig_ctxt = ctxt - , sig_loc = getLoc hs_ty } + , sig_loc = getLocA hs_ty } ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars [this_dict] $ @@ -337,7 +342,7 @@ tcClassMinimalDef _clas sigs op_info where -- By default require all methods without a default implementation defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLoc (mkVar name) + defMindef = mkAnd [ noLocA (mkVar name) | (name, _, Nothing) <- op_info ] instantiateMethod :: Class -> TcId -> [TcType] -> TcType @@ -368,7 +373,7 @@ mkHsSigFun sigs = lookupNameEnv env where env = mkHsSigEnv get_classop_sig sigs - get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) + get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn) get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) get_classop_sig _ = Nothing @@ -387,7 +392,7 @@ findMethodBind sel_name binds prag_fn f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) | op_name == sel_name - = Just (bind, bndr_loc, prags) + = Just (bind, locA bndr_loc, prags) f _other = Nothing --------------------------- @@ -517,7 +522,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) (tv', cv') = partition isTyVar tcv' tvs' = scopedSort tv' cvs' = scopedSort cv' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' + ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys' ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' fam_tc pat_tys' rhs' -- NB: no validity check. We check validity of default instances diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 8bfb5370bb..ec05dffaae 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -484,7 +484,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (instDeclCtxt1 hs_ty) $ do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty @@ -517,7 +517,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds -- from their defaults (if available) ; is_boot <- tcIsHsBootOrSig ; let atItems = classATItems clas - ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) + ; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats) (if is_boot then [] else atItems) -- Don't default type family instances, but rather omit, in hsig/hs-boot. -- Since hsig/hs-boot files are essentially large binders we want omission @@ -532,7 +532,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc hs_ty) + ; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty) -- Dfun location is that of instance *header* ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name @@ -581,7 +581,7 @@ tcTyFamInstDecl :: AssocInstInfo -- "type instance" -- See Note [Associated type instances] tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) - = setSrcSpan loc $ + = setSrcSpanA loc $ tcAddTyFamInstCtxt decl $ do { let fam_lname = feqn_tycon eqn ; fam_tc <- tcLookupLocatedTyCon fam_lname @@ -595,7 +595,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) -- For some reason we don't have a location for the equation -- itself, so we make do with the location of family name ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (getLoc fam_lname) eqn) + (L (na2la $ getLoc fam_lname) eqn) -- (2) check for validity ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch @@ -677,7 +677,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env , dd_cons = hs_cons , dd_kindSig = m_ksig , dd_derivs = derivs } }})) - = setSrcSpan loc $ + = setSrcSpanA loc $ tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupLocatedTyCon lfam_name @@ -781,8 +781,8 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc) m_deriv_info = case derivs of - L _ [] -> Nothing - L _ preds -> + [] -> Nothing + preds -> Just $ DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs , di_clauses = preds @@ -1237,8 +1237,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Create the result bindings ; self_dict <- newDict clas inst_tys ; let class_tc = classTyCon clas + loc' = noAnnSrcSpan loc [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict (L loc con_app_args) + dict_bind = mkVarBind self_dict (L loc' con_app_args) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application @@ -1257,8 +1258,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noExtField (L loc fun) - (L loc (wrapId arg_wrapper meth_id)) + app_to_meth fun meth_id = HsApp noComments (L loc' fun) + (L loc' (wrapId arg_wrapper meth_id)) inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys @@ -1285,7 +1286,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = unitBag dict_bind , abs_sig = True } - ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) + ; return (unitBag (L loc' main_bind) + `unionBags` sc_meth_binds) } where dfun_id = instanceDFunId ispec @@ -1324,7 +1326,7 @@ addDFunPrags dfun_id sc_meth_ids is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> Id -> HsExpr GhcTc -wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) +wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1436,7 +1438,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta , abs_ev_binds = [dfun_ev_binds, local_ev_binds] , abs_binds = emptyBag , abs_sig = False } - ; return (sc_top_id, L loc bind, sc_implic) } + ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) } ------------------- checkInstConstraints :: TcM result @@ -1655,7 +1657,7 @@ tcMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds - -> ([Located TcSpecPrag], TcPragEnv) + -> ([LTcSpecPrag], TcPragEnv) -> [ClassOpItem] -> InstBindings GhcRn -> TcM ([Id], LHsBinds GhcTc, Bag Implication) @@ -1722,12 +1724,15 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys mkLHsWrap lam_wrapper (error_rhs dflags) ; return (meth_id, meth_bind, Nothing) } where - error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) - error_fun = L inst_loc $ + inst_loc' = noAnnSrcSpan inst_loc + error_rhs dflags = L inst_loc' + $ HsApp noComments error_fun (error_msg dflags) + error_fun = L inst_loc' $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText + error_msg dflags = L inst_loc' + (HsLit noComments (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags @@ -1839,7 +1844,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } + ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc) + (idName local_meth_id) } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind @@ -1884,7 +1890,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind -- There is a signature in the instance -- See Note [Instance method signatures] = do { (sig_ty, hs_wrap) - <- setSrcSpan (getLoc hs_sig_ty) $ + <- setSrcSpan (getLocA hs_sig_ty) $ do { inst_sigs <- xoptM LangExt.InstanceSigs ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty @@ -1905,7 +1911,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind inner_meth_id = mkLocalId inner_meth_name Many sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt - , sig_loc = getLoc hs_sig_ty } + , sig_loc = getLocA hs_sig_ty } ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind @@ -2064,17 +2070,17 @@ mkDefMethBind dfun_id clas sel_id dm_name ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig noExtField fn inline_prag)] + = [noLocA (InlineSig noAnn fn inline_prag)] | otherwise = [] -- Copy the inline pragma (if any) from the default method -- to this version. Note [INLINE and default methods] - fn = noLoc (idName sel_id) + fn = noLocA (idName sel_id) visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys , tyConBinderArgFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys - bind = noLoc $ mkTopFunBind Generated fn $ + bind = noLocA $ mkTopFunBind Generated fn $ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body" @@ -2087,8 +2093,8 @@ mkDefMethBind dfun_id clas sel_id dm_name (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLoc $ XHsType ty)) + mk_vta fun ty = noLocA (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy + $ noLocA $ XHsType ty)) -- NB: use visible type application -- See Note [Default methods in instances] @@ -2281,9 +2287,9 @@ Note that -} tcSpecInstPrags :: DFunId -> InstBindings GhcRn - -> TcM ([Located TcSpecPrag], TcPragEnv) + -> TcM ([LTcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragEnv uprags binds) } diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 69a0d2898c..642429d61b 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -638,9 +638,9 @@ collectPatSynArgInfo details = InfixCon name1 name2 -> (map unLoc [name1, name2], True) RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) -addPatSynCtxt :: Located Name -> TcM a -> TcM a +addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ thing_inside @@ -654,7 +654,7 @@ wrongNumberOfParmsErr name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name +tc_patsyn_finish :: LocatedN Name -- ^ PatSyn Name -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat GhcTc -- ^ Pattern of the PatSyn @@ -737,7 +737,7 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ************************************************************************ -} -tcPatSynMatcher :: Located Name +tcPatSynMatcher :: LocatedN Name -> LPat GhcTc -> TcPragEnv -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) @@ -750,8 +750,9 @@ tcPatSynMatcher (L loc name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc + = do { let loc' = locA loc + ; rr_name <- newNameAt (mkTyVarOcc "rep") loc' + ; tv_name <- newNameAt (mkTyVarOcc "r") loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv res_tv = mkTyVar tv_name (tYPE rr) @@ -782,7 +783,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn fail' = nlHsApps fail [nlHsVar voidPrimId] args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty + lwpat = noLocA $ WildPat pat_ty cases = if isIrrefutableHsPat dflags lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', @@ -790,23 +791,23 @@ tcPatSynMatcher (L loc name) lpat prag_fn body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases + MG{ mg_alts = L (l2l $ getLoc lpat) cases , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty , mg_origin = Generated } - body' = noLoc $ + body' = noLocA $ HsLam noExtField $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] + MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr + args body] , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') - (noLoc (EmptyLocalBinds noExtField)) + (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] + mg = MG{ mg_alts = L (l2l $ getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } @@ -818,7 +819,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn , fun_matches = mg , fun_ext = idHsWrapper , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) + matcher_bind = unitBag (noLocA bind) ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) @@ -845,7 +846,7 @@ isUnidirectional ExplicitBidirectional{} = False ************************************************************************ -} -mkPatSynBuilder :: HsPatSynDir a -> Located Name +mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name -> [InvisTVBinder] -> ThetaType -> [InvisTVBinder] -> ThetaType -> [Type] -> Type @@ -879,7 +880,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ + = setSrcSpan (getLocA lpat) $ failWithTc $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" <+> quotes (ppr ps_name) <> colon) 2 why @@ -919,7 +920,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) vcat [ ppr patsyn , ppr builder_id <+> dcolon <+> ppr (idType builder_id) , ppr prags ] - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) + ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } @@ -934,13 +935,13 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated [builder_match] + mk_mg body = mkMatchGroup Generated (noLocA [builder_match]) where - builder_args = [L loc (VarPat noExtField (L loc n)) + builder_args = [L (na2la loc) (VarPat noExtField (L loc n)) | L loc n <- args] builder_match = mkMatch (mkPrefixFunRhs ps_lname) builder_args body - (noLoc (EmptyLocalBinds noExtField)) + (EmptyLocalBinds noExtField) args = case details of PrefixCon _ args -> args @@ -974,7 +975,7 @@ add_void need_dummy_arg ty | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn +tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), @@ -989,19 +990,22 @@ tcPatToExpr name args pat = go pat lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat GhcRn] + mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; let con = L loc (HsVar noExtField lcon) + ; let con = L (l2l loc) (HsVar noExtField lcon) ; return (unLoc $ mkHsApps con exprs) } - mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) + mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon noExtField con exprFields) } + mkRecordConExpr con (HsRecFields fields dd) + = do { exprFields <- mapM go' fields + ; return (RecordCon noExtField con (HsRecFields exprFields dd)) } + + go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn)) + go' (L l rf) = L l <$> traverse go rf go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p @@ -1021,25 +1025,24 @@ tcPatToExpr name args pat = go pat = 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 + go1 (ParPat _ pat) = fmap (HsPar noAnn) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats ; return $ ExplicitList noExtField exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField - (map (noLoc . (Present noExtField)) exprs) - box } + (map (Present noAnn) exprs) box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) ; return $ ExplicitSum noExtField alt arity - (noLoc expr) + (noLocA expr) } - go1 (LitPat _ lit) = return $ HsLit noExtField lit + go1 (LitPat _ lit) = return $ HsLit noComments lit go1 (NPat _ (L _ n) mb_neg _) | Just (SyntaxExprRn neg) <- mb_neg - = return $ unLoc $ foldl' nlHsApp (noLoc neg) - [noLoc (HsOverLit noExtField n)] - | otherwise = return $ HsOverLit noExtField n + = return $ unLoc $ foldl' nlHsApp (noLocA neg) + [noLocA (HsOverLit noAnn n)] + | otherwise = return $ HsOverLit noAnn n go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 8c7e764147..6c8daa0d56 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -242,7 +242,7 @@ checkSynCycles this_uid tcs tyclds = mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl + Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" where @@ -851,7 +851,8 @@ tcRecSelBinds sel_bind_prs tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id) + | (sel_id, _) <- sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] @@ -873,9 +874,11 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl has_sel - = (sel_id, L loc sel_bind) + = (sel_id, L (noAnnSrcSpan loc) sel_bind) where loc = getSrcSpan sel_name + loc' = noAnnSrcSpan loc + locn = noAnnSrcSpan loc lbl = flLabel fl sel_name = flSelector fl @@ -913,18 +916,19 @@ mkOneRecordSelector all_cons idDetails fl has_sel [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc (mk_sel_pat con)] - (L loc (HsVar noExtField (L loc field_var))) - mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields) + [L loc' (mk_sel_pat con)] + (L loc' (HsVar noExtField (L locn field_var))) + mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField - { hsRecFieldLbl + rec_field = noLocA (HsRecField + { hsRecFieldAnn = noAnn + , hsRecFieldLbl = L loc (FieldOcc sel_name - (L loc $ mkVarUnqual lbl)) + (L locn $ mkVarUnqual lbl)) , hsRecFieldArg - = L loc (VarPat noExtField (L loc field_var)) + = L loc' (VarPat noExtField (L locn field_var)) , hsRecPun = False }) - sel_lname = L loc sel_name + sel_lname = L locn sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -932,10 +936,10 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat noExtField)] - (mkHsApp (L loc (HsVar noExtField - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExtField msg_lit)))] + [L loc' (WildPat noExtField)] + (mkHsApp (L loc' (HsVar noExtField + (L locn (getName rEC_SEL_ERROR_ID)))) + (L loc' (HsLit noComments msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we @@ -966,7 +970,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- scenarios, eq_subst is an empty substitution. inst_tys = substTyVars eq_subst univ_tvs - unit_rhs = mkLHsTupleExpr [] + unit_rhs = mkLHsTupleExpr [] noExtField msg_lit = HsStringPrim NoSourceText (bytesFS lbl) {- diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 2c9be13dff..5da6364444 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -484,7 +484,7 @@ data TcGblEnv -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], + tcg_rn_exports :: Maybe [(LIE GhcRn, Avails)], -- Nothing <=> no explicit export list -- Is always Nothing if we don't want to retain renamed -- exports. diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index b1dd472d75..4ddb0ee000 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -479,7 +479,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin f +exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f) exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 066755e8f7..707d936504 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -185,7 +185,7 @@ checkHsigIface tcg_env gr sig_iface -- TODO: maybe we can be a little more -- precise here and use the Located -- info for the *specific* name we matched. - -> getLoc e + -> getLocA e _ -> nameSrcSpan name addErrAt loc (badReexportedBootThing False name name') @@ -611,7 +611,7 @@ mergeSignatures -- a signature package (i.e., does not expose any -- modules.) If so, we can thin it. | isFromSignaturePackage - -> setSrcSpan loc $ do + -> setSrcSpanA loc $ do -- Suppress missing errors; they might be used to refer -- to entities from other signatures we are merging in. -- If an identifier truly doesn't exist in any of the @@ -665,7 +665,7 @@ mergeSignatures is_mod = mod_name, is_as = mod_name, is_qual = False, - is_dloc = loc + is_dloc = locA loc } ImpAll rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) setGblEnv tcg_env { diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index c38ad9491c..7ffd2f2f2c 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -229,10 +229,10 @@ span of the Name. -} -tcLookupLocatedGlobal :: Located Name -> TcM TyThing +tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing -- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name - = addLocM tcLookupGlobal name + = addLocMA tcLookupGlobal name tcLookupGlobal :: Name -> TcM TyThing -- The Name is almost always an ExternalName, but not always @@ -310,14 +310,14 @@ tcLookupAxiom name = do ACoAxiom ax -> return ax _ -> wrongThingErr "axiom" (AGlobal thing) name -tcLookupLocatedGlobalId :: Located Name -> TcM Id -tcLookupLocatedGlobalId = addLocM tcLookupId +tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id +tcLookupLocatedGlobalId = addLocMA tcLookupId -tcLookupLocatedClass :: Located Name -> TcM Class -tcLookupLocatedClass = addLocM tcLookupClass +tcLookupLocatedClass :: LocatedA Name -> TcM Class +tcLookupLocatedClass = addLocMA tcLookupClass -tcLookupLocatedTyCon :: Located Name -> TcM TyCon -tcLookupLocatedTyCon = addLocM tcLookupTyCon +tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon +tcLookupLocatedTyCon = addLocMA tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely -- the same as in the instance declaration (modulo renaming & casts). @@ -424,8 +424,8 @@ tcExtendRecEnv gbl_stuff thing_inside ************************************************************************ -} -tcLookupLocated :: Located Name -> TcM TcTyThing -tcLookupLocated = addLocM tcLookup +tcLookupLocated :: LocatedA Name -> TcM TcTyThing +tcLookupLocated = addLocMA tcLookup tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name @@ -1056,12 +1056,12 @@ newDFunName clas tys loc ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] +newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name +newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys] -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name +newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name newFamInstAxiomName (L loc name) branches - = mk_fam_inst_name mkInstTyCoOcc loc name branches + = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name mk_fam_inst_name adaptOcc loc tc_name tyss diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 84e28a75e8..6238b6c36c 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -127,7 +127,7 @@ newMethodFromName origin name ty_args ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) instCall origin ty_args theta - ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } + ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) } {- ************************************************************************ @@ -761,7 +761,7 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do -- same type as the standard one. -- Tiresome jiggling because tcCheckSigma takes a located expression span <- getSrcSpanM - expr <- tcCheckPolyExpr (L span user_nm_expr) sigma1 + expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1 return (std_nm, unLoc expr) syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 873c9b9fd2..1a70f0ecbd 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -61,8 +61,9 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode, - wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode, + wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, failWith, failAt, @@ -917,28 +918,57 @@ setSrcSpan loc@(UnhelpfulSpan _) thing_inside | otherwise = thing_inside +setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a +setSrcSpanA l = setSrcSpan (locA l) + addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a +addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b +addLocMA fn (L loc a) = setSrcSpanA loc $ fn a + wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a ; return (L loc b) } +wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b) +wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a + ; return (L (locA loc) b) } + +wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b) +wrapLocMA fn (L loc a) = setSrcSpanA 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 (L loc b, c) +wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c) +wrapLocFstMA fn (L loc a) = + setSrcSpanA loc $ do + (b,c) <- fn a + return (L loc b, c) + 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, L loc c) +wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c) +wrapLocSndMA fn (L loc a) = + setSrcSpanA loc $ do + (b,c) <- fn a + return (b, L loc c) + wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) +wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM () +wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a) + -- Reporting errors getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc)) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 90717063f7..0e34d97c46 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -200,11 +200,11 @@ shortCutLit platform val res_ty where go_integral int@(IL src neg i) | isIntTy res_ty && platformInIntRange platform i - = Just (HsLit noExtField (HsInt noExtField int)) + = Just (HsLit noAnn (HsInt noExtField int)) | isWordTy res_ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy res_ty - = Just (HsLit noExtField (HsInteger src i res_ty)) + = Just (HsLit noAnn (HsInteger src i res_ty)) | otherwise = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important @@ -225,11 +225,11 @@ shortCutLit platform val res_ty -- is less than 100, which ensures desugaring isn't slow. go_string src s - | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) +mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name @@ -412,7 +412,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- It's OK to use nonDetEltsUFM here because we forget the ordering -- immediately by creating a TypeEnv -zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id +zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id zonkLIdOcc env = mapLoc (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id @@ -569,7 +569,7 @@ zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) ; return (env2, (r,b'):bs') } zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do - new_binds <- mapM (wrapLocM zonk_ip_bind) binds + new_binds <- mapM (wrapLocMA zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] @@ -594,7 +594,7 @@ zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc) zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocM (zonk_bind env) +zonk_lbind env = wrapLocMA (zonk_bind env) zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss @@ -733,10 +733,11 @@ zonkLTcSpecPrags env ps ************************************************************************ -} -zonkMatchGroup :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> MatchGroup GhcTc (Located (body GhcTc)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> MatchGroup GhcTc (LocatedA (body GhcTc)) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) @@ -747,10 +748,11 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } -zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> LMatch GhcTc (Located (body GhcTc)) - -> TcM (LMatch GhcTc (Located (body GhcTc))) +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> LMatch GhcTc (LocatedA (body GhcTc)) + -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) zonkMatch env zBody (L loc match@(Match { m_pats = pats , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats @@ -758,12 +760,13 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } ------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> GRHSs GhcTc (Located (body GhcTc)) - -> TcM (GRHSs GhcTc (Located (body GhcTc))) +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> GRHSs GhcTc (LocatedA (body GhcTc)) + -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss binds) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs) @@ -771,7 +774,7 @@ zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do new_rhs <- zBody env2 rhs return (GRHS xx new_guarded new_rhs) new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (L l new_binds)) + return (GRHSs x new_grhss new_binds) {- ************************************************************************ @@ -786,7 +789,7 @@ zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocM (zonkExpr env) expr +zonkLExpr env expr = wrapLocMA (zonkExpr env) expr zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) @@ -894,10 +897,10 @@ 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 (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' <- zonkScaledTcTypeToTypeX env t - ; return (L l (Missing t')) } + zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e + ; return (Present x e') } + zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t + ; return (Missing t') } zonkExpr env (ExplicitSum args alt arity expr) @@ -925,10 +928,10 @@ zonkExpr env (HsMultiIf ty alts) ; expr' <- zonkLExpr env' expr ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x (L l binds) expr) +zonkExpr env (HsLet x binds expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (L l new_binds) new_expr) + return (HsLet x new_binds new_expr) zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts @@ -1048,7 +1051,7 @@ zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc) zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc) -zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd +zonkLCmd env cmd = wrapLocMA (zonkCmd env) cmd zonkCmd env (XCmd (HsWrap w cmd)) = do { (env1, w') <- zonkCoFn env w @@ -1094,10 +1097,10 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) ; new_cElse <- zonkLCmd env1 cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x (L l binds) cmd) +zonkCmd env (HsCmdLet x binds cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (L l new_binds) new_cmd) + return (HsCmdLet x new_binds new_cmd) zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts @@ -1181,19 +1184,21 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> [LStmt GhcTc (Located (body GhcTc))] - -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) +zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> [LStmt GhcTc (LocatedA (body GhcTc))] + -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))]) zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndMA (zonkStmt env zBody) s ; (env2, ss') <- zonkStmts env1 zBody ss ; return (env2, s' : ss') } -zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> Stmt GhcTc (Located (body GhcTc)) - -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) +zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> Stmt GhcTc (LocatedA (body GhcTc)) + -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc))) zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty @@ -1213,7 +1218,8 @@ zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) new_return) } -zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs +zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs + , recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id , recS_bind_fn = bind_id , recS_ext = @@ -1235,7 +1241,8 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_ ; new_later_rets <- mapM (zonkExpr env5) later_rets ; new_rec_rets <- mapM (zonkExpr env5) rec_rets ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs + RecStmt { recS_stmts = noLocA new_segStmts + , recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id , recS_ext = RecStmtTc @@ -1283,9 +1290,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (L l binds)) +zonkStmt env _ (LetStmt x binds) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (L l new_binds)) + return (env1, LetStmt x new_binds) zonkStmt env zBody (BindStmt xbs pat body) = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs) @@ -1398,7 +1405,7 @@ zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) -- Extend the environment as we go, because it's possible for one -- pattern to bind something that is used in another (inside or -- to the right) -zonkPat env pat = wrapLocSndM (zonk_pat env) pat +zonkPat env pat = wrapLocSndMA (zonk_pat env) pat zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat x p) @@ -1530,7 +1537,7 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) zonk_pat env (XPat (CoPat co_fn pat ty)) = do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLoc pat) + ; (env'', pat') <- zonkPat env' (noLocA pat) ; ty' <- zonkTcTypeToTypeX env'' ty ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') } @@ -1574,7 +1581,7 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls +zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co @@ -1586,7 +1593,7 @@ zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs +zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index f446b69634..9a43e69c67 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1864,7 +1864,7 @@ checkValidInstance ctxt hs_type ty = failWithTc (text "Arity mis-match in instance head") | otherwise - = do { setSrcSpan head_loc $ + = do { setSrcSpanA head_loc $ checkValidInstHead ctxt clas inst_tys ; traceTc "checkValidInstance {" (ppr ty) |