diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl/Class.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Class.hs | 33 |
1 files changed, 19 insertions, 14 deletions
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 |