diff options
Diffstat (limited to 'compiler/typecheck')
29 files changed, 377 insertions, 372 deletions
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 213064d599..36c613c186 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -881,7 +881,7 @@ To do the injectivity check: 1. We build VarUsages that represent the LHS (rather, the portion of the LHS that is flagged as injective); each usage on the LHS is NotPresent, because we -hvae not yet looked at the RHS. +have not yet looked at the RHS. 2. We also build a VarUsage for the RHS, done by injTyVarUsages. diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 6421be4f16..a448f74e56 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -305,7 +305,7 @@ tcHsBootSigs binds sigs where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where - f (dL->L _ name) + f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds @@ -340,12 +340,12 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds] + ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] - -- I wonder if we should do these one at at time + -- I wonder if we should do these one at a time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr) + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] @@ -516,7 +516,7 @@ recursivePatSynErr loc binds 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc tc_single :: forall thing. @@ -524,7 +524,7 @@ tc_single :: forall thing. -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn - (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) })) + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside @@ -563,7 +563,7 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds , bndr <- collectHsBindBinders bind ] ------------------------ @@ -685,8 +685,8 @@ tcPolyCheck prag_fn (CompleteSig { sig_bndr = poly_id , sig_ctxt = ctxt , sig_loc = sig_loc }) - (dL->L loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches })) + (L loc (FunBind { fun_id = (L nm_loc name) + , fun_matches = matches })) = setSrcSpan sig_loc $ do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id @@ -703,7 +703,7 @@ tcPolyCheck prag_fn tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ tcExtendNameTyVarEnv tv_prs $ setSrcSpan loc $ - tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau) + tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) ; let prag_sigs = lookupPragEnv prag_fn name ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -711,7 +711,7 @@ tcPolyCheck prag_fn ; mod <- getModule ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = cL nm_loc mono_id + ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -723,13 +723,13 @@ tcPolyCheck prag_fn , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } - abs_bind = cL loc $ + abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds] , abs_exports = [export] - , abs_binds = unitBag (cL loc bind') + , abs_binds = unitBag (L loc bind') , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) } @@ -740,7 +740,7 @@ tcPolyCheck _prag_fn sig bind funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -806,7 +806,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = cL loc $ + abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -1098,7 +1098,7 @@ checkOverloadedSig monomorphism_restriction_applies sig {- Note [Partial type signatures and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If /any/ of the signatures in the gropu is a partial type signature +If /any/ of the signatures in the group is a partial type signature f :: _ -> Int then we *always* use the InferGen plan, and hence tcPolyInfer. We do this even for a local binding with -XMonoLocalBinds, when @@ -1249,9 +1249,9 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen - [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches - , fun_ext = fvs })] + [ L b_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches + , fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1271,11 +1271,11 @@ tcMonoBinds is_rec sig_fn no_gen -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking - tcMatchesFun (cL nm_loc name) matches exp_ty + tcMatchesFun (L nm_loc name) matches exp_ty ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ cL b_loc $ - FunBind { fun_id = cL nm_loc mono_id, + ; return (unitBag $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name @@ -1332,7 +1332,7 @@ tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- CheckGen is used only for functions with a complete type signature, -- and tcPolyCheck doesn't use tcMonoBinds at all -tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name) +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name , fun_matches = matches }) | Just (TcIdSig sig) <- sig_fn name = -- There is a type signature. @@ -1420,9 +1420,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = cL loc mono_id + ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] + , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1650,7 +1650,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature one_funbind_with_sig - | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds , Just (TcIdSig sig) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise @@ -1679,7 +1679,7 @@ isClosedBndrGroup type_env binds fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = (dL->L _ f) + bindFvs (FunBind { fun_id = L _ f , fun_ext = fvs }) = let open_fvs = get_open_fvs fvs in [(f, open_fvs)] diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 20790200d0..9d2acfc9f7 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -609,7 +609,7 @@ makeSuperClasses, giving us a a second quantified constrait (forall a. a ~# b) BUT this is an unboxed value! And nothing has prepared us for dictionary "functions" that are unboxed. Actually it does just -about work, but the simplier ends up with stuff like +about work, but the simplifier ends up with stuff like case (/\a. eq_sel d) of df -> ...(df @Int)... and fails to simplify that any further. And it doesn't satisfy isPredTy any more. diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 18e71c8803..09a9bb2f6e 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -78,7 +78,7 @@ would implicitly declare (forall b. Ord b => a -> b -> b) (We could use a record decl, but that means changing more of the existing apparatus. -One step at at time!) +One step at a time!) For classes with just one superclass+method, we use a newtype decl instead: diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index a6c44d0c45..3f89e2c033 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -369,7 +369,7 @@ the rest of the instance. The fact that it is suspended is important, because right now, we don't have ThetaTypes for the instances that use deriving clauses (only the standalone-derived ones). -Now we can can collect the type family instances and extend the local instance +Now we can collect the type family instances and extend the local instance environment. At this point, it is safe to run simplifyInstanceContexts on the deriving-clause instance specs, which gives us the ThetaTypes for the deriving-clause instances. Now we can feed all the ThetaTypes to the @@ -1016,7 +1016,7 @@ a poly-kinded typeclass for a poly-kinded datatype. For example: class Category (cat :: k -> k -> *) where newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category -This case is suprisingly tricky. To see why, let's write out what instance GHC +This case is surprisingly tricky. To see why, let's write out what instance GHC will attempt to derive (using -fprint-explicit-kinds syntax): instance Category k1 (T k2 c) where ... @@ -1289,7 +1289,7 @@ When there are no type families, it's quite easy: instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S -When type familes are involved it's trickier: +When type families are involved it's trickier: data family T a b newtype instance T Int a = MkT [a] deriving( Eq, Monad ) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 97dffcd1cf..10c58d502e 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -991,7 +991,7 @@ more complicated it will be reported in a civilised way. Note [Error reporting for deriving clauses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A suprisingly tricky aspect of deriving to get right is reporting sensible +A surprisingly tricky aspect of deriving to get right is reporting sensible error messages. In particular, if simplifyDeriv reaches a constraint that it cannot solve, which might include: diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index d9bd893dc5..725274bbaf 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -509,7 +509,7 @@ isTypeClosedLetBndr = noFreeVarsOfType . idType tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a -- Used for binding the recurive uses of Ids in a binding --- both top-level value bindings and and nested let/where-bindings +-- both top-level value bindings and nested let/where-bindings -- Does not extend the TcBinderStack tcExtendRecIds pairs thing_inside = tc_extend_local_env NotTopLevel @@ -533,7 +533,7 @@ tcExtendSigIds top_lvl sig_ids thing_inside tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed -> [TcId] -> TcM a -> TcM a --- Used for both top-level value bindings and and nested let/where-bindings +-- Used for both top-level value bindings and nested let/where-bindings -- Adds to the TcBinderStack too tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) ids thing_inside diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index ffc054ee0a..00d95c405b 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -2359,7 +2359,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig = Just (vcat [ text "In other words, a successful match on the pattern" , nest 2 $ ppr pat , text "does not provide the constraint" <+> pprParendType pred ]) @@ -2488,7 +2488,7 @@ ctxtFixes has_ambig_tvs pred implics discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig = filterOut (discard name) givens | otherwise = givens diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 712668f372..5560b219ba 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -181,17 +181,15 @@ tcExpr e@(HsLit x lit) res_ty tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar x expr') } -tcExpr (HsSCC x src lbl expr) res_ty +tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC x src lbl expr') } - -tcExpr (HsTickPragma x src info srcInfo expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma x src info srcInfo expr') } - -tcExpr (HsCoreAnn x src lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn x src lbl expr') } + ; return (HsPragE x (tc_prag prag) expr') } + where + tc_prag :: HsPragE GhcRn -> HsPragE GhcTc + tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl + tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + tc_prag (XHsPragE x) = noExtCon x tcExpr (HsOverLit x lit) res_ty = do { lit' <- newOverloadedLit lit res_ty diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index fed20bf810..5d5589df9a 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -714,7 +714,7 @@ other examples where lazy flattening caused problems. Bottom line: FM_Avoid is unused for now (Nov 14). Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathalogical anyway + T5837 did too, but it's pathological anyway Note [Phantoms in the flattener] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1708,7 +1708,7 @@ is an example; all the constraints here are Givens inert fsk ~ ((fsk3, TF Int), TF Int) Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathalogical +more duplication in the inert set. But this really only happens in pathological casee, so we don't care. diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 8eb86fcec2..f7fbb02aa6 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -358,11 +358,11 @@ gen_Ord_binds loc tycon = do = emptyBag negate_expr = nlHsApp (nlHsVar not_RDR) - lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $ + lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) - gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $ + gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $ + gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) get_tag con = dataConTag con - fIRST_TAG @@ -381,7 +381,7 @@ gen_Ord_binds loc tycon = do mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] + mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs dflags op) mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs @@ -597,7 +597,7 @@ gen_Enum_binds loc tycon = do occ_nm = getOccString tycon succ_enum dflags - = mk_easy_FunBind loc succ_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -607,7 +607,7 @@ gen_Enum_binds loc tycon = do nlHsIntLit 1])) pred_enum dflags - = mk_easy_FunBind loc pred_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -619,7 +619,7 @@ gen_Enum_binds loc tycon = do (mkIntegralLit (-1 :: Int)))])) to_enum dflags - = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [ nlHsVar a_RDR @@ -628,7 +628,7 @@ gen_Enum_binds loc tycon = do (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) enum_from dflags - = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR dflags tycon), @@ -637,7 +637,7 @@ gen_Enum_binds loc tycon = do (nlHsVar (maxtag_RDR dflags tycon)))] enum_from_then dflags - = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ + = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -650,7 +650,7 @@ gen_Enum_binds loc tycon = do )) from_enum dflags - = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) @@ -766,7 +766,7 @@ gen_Ix_binds loc tycon = do ] enum_range dflags - = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ @@ -775,7 +775,7 @@ gen_Ix_binds loc tycon = do (nlHsVarApps intDataCon_RDR [bh_RDR])) enum_index dflags - = mk_easy_FunBind loc unsafeIndex_RDR + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [noLoc (AsPat noExtField (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( @@ -792,7 +792,7 @@ gen_Ix_binds loc tycon = do -- This produces something like `(ch >= ah) && (ch <= bh)` enum_inRange dflags - = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( @@ -825,7 +825,7 @@ gen_Ix_binds loc tycon = do -------------------------------------------------------------- single_con_range - = mk_easy_FunBind loc range_RDR + = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ noLoc (mkHsComp ListComp stmts con_expr) where @@ -837,7 +837,7 @@ gen_Ix_binds loc tycon = do ---------------- single_con_index - = mk_easy_FunBind loc unsafeIndex_RDR + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] -- We need to reverse the order we consider the components in @@ -863,7 +863,7 @@ gen_Ix_binds loc tycon = do ------------------ single_con_inRange - = mk_easy_FunBind loc inRange_RDR + = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] $ if con_arity == 0 @@ -1380,7 +1380,7 @@ gen_data dflags data_type_name constr_names loc rep_tc mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold - gunfold_bind = mk_easy_FunBind loc + gunfold_bind = mkSimpleGeneratedFunBind loc gunfold_RDR [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] gunfold_rhs @@ -1409,7 +1409,7 @@ gen_data dflags data_type_name constr_names loc rep_tc to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) ------------ dataTypeOf - dataTypeOf_bind = mk_easy_FunBind + dataTypeOf_bind = mkSimpleGeneratedFunBind loc dataTypeOf_RDR [nlWildPat] @@ -1436,7 +1436,7 @@ gen_data dflags data_type_name constr_names loc rep_tc | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR | otherwise = emptyBag mk_gcast dataCast_RDR gcast_RDR - = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] + = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) @@ -2019,7 +2019,7 @@ mkFunBindSE arity loc fun pats_and_exprs mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind fun matches) + = L 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 @@ -2047,7 +2047,7 @@ mkRdrFunBindEC :: Arity -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches') + fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2071,7 +2071,7 @@ mkRdrFunBindEC arity catch_all mkRdrFunBindSE :: Arity -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') + fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2369,7 +2369,7 @@ mkAuxBinderName dflags parent occ_fun {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to make a top-level auxiliary binding. E.g. for comparison we haev +We often want to make a top-level auxiliary binding. E.g. for comparison we have instance Ord T where compare a b = $con2tag a `compare` $con2tag b diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index a2eee57947..0e8f0a6d06 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -980,7 +980,7 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ ; traceTc "w_givens are: " $ ppr w_givens ; rem <- runTcSDeriveds $ simpl_top w_givens -- We don't want any insoluble or simple constraints left, but - -- solved implications are ok (and neccessary for e.g. undefined) + -- solved implications are ok (and necessary for e.g. undefined) ; traceTc "rems was:" $ ppr rem ; traceTc "}" empty ; return (isSolvedWC rem, wrp) } } diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index e8b67bbc89..13a3d179b4 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -99,7 +99,7 @@ import Control.Arrow ( second ) -} hsLPatType :: LPat GhcTc -> Type -hsLPatType (dL->L _ p) = hsPatType p +hsLPatType (L _ p) = hsPatType p hsPatType :: Pat GhcTc -> Type hsPatType (ParPat _ pat) = hsLPatType pat @@ -265,7 +265,7 @@ There are three possibilities: So we default it to 'Any' of the right kind. All this works for both type and kind variables (indeed - the two are the same thign). + the two are the same thing). * SkolemiseFlexi: is a special case for the LHS of RULES. See Note [Zonking the LHS of a RULE] @@ -349,7 +349,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id -zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env) +zonkLIdOcc env = mapLoc (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -529,7 +529,7 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- mapM (wrapLocM zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env - [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds] + [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where @@ -577,13 +577,13 @@ zonk_bind env (VarBind { var_ext = x , var_rhs = new_expr , var_inline = inl }) } -zonk_bind env bind@(FunBind { fun_id = (dL->L loc var) +zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms , fun_co_fn = co_fn }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = cL loc new_var + ; return (bind { fun_id = L loc new_var , fun_matches = new_ms , fun_co_fn = new_co_fn }) } @@ -610,16 +610,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs where zonk_val_bind env lbind | has_sig - , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id) - , fun_matches = ms - , fun_co_fn = co_fn })) <- lbind + , (L loc bind@(FunBind { fun_id = L mloc mono_id + , fun_matches = ms + , fun_co_fn = co_fn })) <- lbind = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ cL loc $ - bind { fun_id = cL mloc new_mono_id + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id , fun_matches = new_ms , fun_co_fn = new_co_fn } } | otherwise @@ -640,7 +640,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_prags = new_prags }) zonk_export _ (XABExport nec) = noExtCon nec -zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) +zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_args = details , psb_def = lpat , psb_dir = dir })) @@ -649,7 +649,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) ; let details' = zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind x $ - bind { psb_id = cL loc id' + bind { psb_id = L loc id' , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } @@ -684,9 +684,9 @@ zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] zonkLTcSpecPrags env ps = mapM zonk_prag ps where - zonk_prag (dL->L loc (SpecPrag id co_fn inl)) + zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } {- ************************************************************************ @@ -700,13 +700,13 @@ zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> MatchGroup GhcTcId (Located (body GhcTcId)) -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) +zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = cL l ms' + ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec @@ -715,14 +715,12 @@ zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> LMatch GhcTcId (Located (body GhcTcId)) -> TcM (LMatch GhcTc (Located (body GhcTc))) -zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats - , m_grhss = grhss })) +zonkMatch env zBody (L loc match@(Match { m_pats = pats + , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) } -zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec -zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" - -- due to #15884 + ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } +zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv @@ -730,7 +728,7 @@ zonkGRHSs :: ZonkEnv -> GRHSs GhcTcId (Located (body GhcTcId)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs) @@ -739,7 +737,7 @@ zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do return (GRHS xx new_guarded new_rhs) zonk_grhs (XGRHS nec) = noExtCon nec new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (cL l new_binds)) + return (GRHSs x new_grhss (L l new_binds)) zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec {- @@ -757,9 +755,9 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar x (dL->L l id)) +zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (cL l (zonkIdOcc env id))) + return (HsVar x (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -842,13 +840,11 @@ zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where - zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (cL l (Present x e')) } - zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (cL l (Missing t')) } - zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec - zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" - -- due to #15884 + zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } + zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t + ; return (L l (Missing t')) } + zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec zonkExpr env (ExplicitSum args alt arity expr) @@ -884,15 +880,15 @@ zonkExpr env (HsMultiIf ty alts) ; return $ GRHS x guard' expr' } zonk_alt (XGRHS nec) = noExtCon nec -zonkExpr env (HsLet x (dL->L l binds) expr) +zonkExpr env (HsLet x (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (cL l new_binds) new_expr) + return (HsLet x (L l new_binds) new_expr) -zonkExpr env (HsDo ty do_or_lc (dL->L l stmts)) +zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (cL l new_stmts)) + return (HsDo new_ty do_or_lc (L l new_stmts)) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit @@ -936,18 +932,9 @@ zonkExpr env (ArithSeq expr wit info) where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln -zonkExpr env (HsSCC x src lbl expr) +zonkExpr env (HsPragE x prag expr) = do new_expr <- zonkLExpr env expr - return (HsSCC x src lbl new_expr) - -zonkExpr env (HsTickPragma x src info srcInfo expr) - = do new_expr <- zonkLExpr env expr - return (HsTickPragma x src info srcInfo new_expr) - --- hdaume: core annotations -zonkExpr env (HsCoreAnn x src lbl expr) - = do new_expr <- zonkLExpr env expr - return (HsCoreAnn x src lbl new_expr) + return (HsPragE x prag new_expr) -- arrow notation extensions zonkExpr env (HsProc x pat body) @@ -1053,15 +1040,15 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet x (dL->L l binds) cmd) +zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (cL l new_binds) new_cmd) + return (HsCmdLet x (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo ty (dL->L l stmts)) +zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (cL l new_stmts)) + return (HsCmdDo new_ty (L l new_stmts)) zonkCmd _ (XCmd nec) = noExtCon nec @@ -1244,9 +1231,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (dL->L l binds)) +zonkStmt env _ (LetStmt x (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (cL l new_binds)) + return (env1, LetStmt x (L l new_binds)) zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op @@ -1312,21 +1299,21 @@ zonkRecFields env (HsRecFields flds dd) = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) } where - zonk_rbind (dL->L l fld) + zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = new_id + ; return (L l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] -> TcM [LHsRecUpdField GhcTcId] zonkRecUpdFields env = mapM zonk_rbind where - zonk_rbind (dL->L l fld) + zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } + ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id + , hsRecFieldArg = new_expr })) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a @@ -1360,9 +1347,9 @@ zonk_pat env (WildPat ty) (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat x (dL->L l v)) +zonk_pat env (VarPat x (L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) } + ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat @@ -1372,10 +1359,10 @@ zonk_pat env (BangPat x pat) = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (dL->L loc v) pat) +zonk_pat env (AsPat x (L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat x (cL loc v') pat') } + ; return (env', AsPat x (L loc v') pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr @@ -1411,7 +1398,7 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys , pat_binds = binds , pat_args = args , pat_wrap = wrapper - , pat_con = (dL->L _ con) }) + , pat_con = L _ con }) = ASSERT( all isImmutableTyVar tyvars ) do { new_tys <- mapM (zonkTcTypeToTypeX env) tys @@ -1447,7 +1434,7 @@ zonk_pat env (SigPat ty pat hs_ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPat ty' pat' hs_ty) } -zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) +zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing) @@ -1455,9 +1442,9 @@ zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') } + ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) +zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n @@ -1465,7 +1452,7 @@ zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToTypeX env2 ty ; return (extendIdZonkEnv1 env2 n', - NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } + NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } zonk_pat env (CoPat x co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn @@ -1491,8 +1478,8 @@ zonkConStuff env (InfixCon p1 p2) zonkConStuff env (RecCon (HsRecFields rpats dd)) = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(dL->L l rp) p' -> - cL l (rp { hsRecFieldArg = p' })) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hsRecFieldArg = p' })) rpats pats' ; return (env', RecCon (HsRecFields rpats' dd)) } -- Field selectors have declared types; hence no zonking @@ -1544,13 +1531,11 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} , rd_lhs = new_lhs , rd_rhs = new_rhs } } where - zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v))) + zonk_tm_bndr env (L l (RuleBndr x (L loc v))) = do { (env', v') <- zonk_it env v - ; return (env', cL l (RuleBndr x (cL loc v'))) } - zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec - zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" - -- due to #15884 + ; return (env', L l (RuleBndr x (L loc v'))) } + zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec zonk_it env v | isId v = do { v' <- zonkIdBndr env v diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 4ed472386c..9a5d745dea 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -352,10 +352,10 @@ tcDerivStrategy :: tcDerivStrategy mb_lds = case mb_lds of Nothing -> boring_case Nothing - Just (dL->L loc ds) -> + Just (L loc ds) -> setSrcSpan loc $ do (ds', tvs) <- tc_deriv_strategy ds - pure (Just (cL loc ds'), tvs) + pure (Just (L loc ds'), tvs) where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar]) @@ -1323,7 +1323,7 @@ saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) -- Precondition for (saturateFamApp ty kind): -- tcTypeKind ty = kind -- --- If 'ty' is an unsaturated family application wtih trailing +-- If 'ty' is an unsaturated family application with trailing -- invisible arguments, instanttiate them. -- See Note [saturateFamApp] @@ -1559,7 +1559,7 @@ very convenient to typecheck instance types like any other HsSigType. Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's better to reject in checkValidType. If we say that the body kind should be '*' we risk getting TWO error messages, one saying that Eq -[a] doens't have kind '*', and one saying that we need a Constraint to +[a] doesn't have kind '*', and one saying that we need a Constraint to the left of the outer (=>). How do we figure out the right body kind? Well, it's a bit of a diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 6b69928419..a2aa82e51b 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -604,7 +604,7 @@ we keep? More subtle than you might think! and can be reported as redundant. See Note [Tracking redundant constraints] in TcSimplify. - It transpires that using the outermost one is reponsible for an + It transpires that using the outermost one is responsible for an 8% performance improvement in nofib cryptarithm2, compared to just rolling the dice. I didn't investigate why. @@ -1582,7 +1582,7 @@ inertsCanDischarge inerts tv rhs fr keep_deriv ev_i | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] , (Wanted WDeriv, _) <- fr -- work item is [WD] - = True -- Keep a derived verison of the work item + = True -- Keep a derived version of the work item | otherwise = False -- Work item is fully discharged diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs index 5a33300918..e1cf64f731 100644 --- a/compiler/typecheck/TcOrigin.hs +++ b/compiler/typecheck/TcOrigin.hs @@ -504,8 +504,7 @@ exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" @@ -514,7 +513,6 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" exprCtOrigin (XExpr nec) = noExtCon nec diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 6d68cd5904..61e8b21597 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -302,11 +302,11 @@ tc_lpat :: LPat GhcRn -> PatEnv -> TcM a -> TcM (LPat GhcTcId, a) -tc_lpat (dL->L span pat) pat_ty penv thing_inside +tc_lpat (L span pat) pat_ty penv thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) thing_inside - ; return (cL span pat', res) } + ; return (L span pat', res) } tc_lpats :: PatEnv -> [LPat GhcRn] -> [ExpSigmaType] @@ -326,11 +326,11 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside +tc_pat penv (VarPat x (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -361,7 +361,7 @@ tc_pat _ (WildPat _) pat_ty thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -374,7 +374,7 @@ tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty, + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside @@ -523,7 +523,7 @@ tc_pat penv (LitPat x simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside +tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -541,7 +541,7 @@ tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) } + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -572,8 +572,8 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (dL->L nm_loc name) - (dL->L loc lit) _ ge minus) pat_ty +tc_pat penv (NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus) pat_ty thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit @@ -603,7 +603,7 @@ tc_pat penv (NPlusKPat _ (dL->L nm_loc name) ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2' + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' ; return (pat', res) } @@ -712,7 +712,7 @@ tcConPat :: PatEnv -> Located Name -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of RealDataCon data_con -> tcDataConPat penv con_lname data_con @@ -725,13 +725,13 @@ tcDataConPat :: PatEnv -> Located Name -> DataCon -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcDataConPat penv (dL->L con_span con_name) data_con pat_ty +tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con - header = cL con_span (RealDataCon data_con) + header = L con_span (RealDataCon data_con) -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion, @@ -821,7 +821,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn ; (subst, univ_tvs') <- newMetaTyVars univ_tvs @@ -858,7 +858,7 @@ tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = cL con_span $ PatSynCon pat_syn, + ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, pat_tvs = ex_tvs', pat_dicts = prov_dicts', pat_binds = ev_binds, @@ -988,19 +988,16 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (dL->L l (HsRecField (dL->L loc - (FieldOcc sel (dL->L lr rdr))) pat pun)) + tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat' + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) } - tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _ + tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ = panic "tcConArgs" - tc_field _ _ _ = panic "tc_field: Impossible Match" - -- due to #15884 find_field_ty :: Name -> FieldLabelString -> TcM TcType @@ -1101,7 +1098,7 @@ So for now I'm just insisting on type *equality* in patterns. No subsumption. Old notes about desugaring, at a time when pattern coercions were handled: -A SigPat is a type coercion and must be handled one at at time. We can't +A SigPat is a type coercion and must be handled one at a time. We can't combine them unless the type of the pattern inside is identical, and we don't bother to check for that. For example: diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 746b48401b..1c39801f2f 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -81,7 +81,7 @@ tcPatSynDecl psb mb_sig recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = (dL->L _ name) +recoverPSB (PSB { psb_id = L _ name , psb_args = details }) = do { matcher_name <- newImplicitBinder name mkMatcherOcc ; let placeholder = AConLike $ PatSynCon $ @@ -135,7 +135,7 @@ pattern.) But it'll do for now. tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details +tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name @@ -153,7 +153,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details mk_named_tau arg = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) -- The mkSpecForAllTys is important (#14552), albeit - -- slightly artifical (there is no variable with this funny type). + -- slightly artificial (there is no variable with this funny type). -- We do not want to quantify over variable (alpha::k) -- that mention the existentially-bound type variables -- ex_tvs in its kind k. @@ -307,7 +307,7 @@ and is not implicitly instantiated. So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constaints when quantifying] in TcType +See also Note [Lift equality constraints when quantifying] in TcType Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -341,7 +341,7 @@ is not very helpful, but at least we don't get a Lint error. tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta @@ -569,12 +569,12 @@ collectPatSynArgInfo details = splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = (dL->L _ patVar) - , recordPatSynSelectorId = (dL->L _ selId) }) + { recordPatSynPatVar = L _ patVar + , recordPatSynSelectorId = L _ selId }) = (patVar, selId) addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (dL->L loc name) thing_inside +addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ @@ -685,7 +685,7 @@ tcPatSynMatcher :: Located Name -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (dL->L loc name) lpat +tcPatSynMatcher (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty @@ -726,9 +726,9 @@ tcPatSynMatcher (dL->L loc name) lpat else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ - cL (getLoc lpat) $ + L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = cL (getLoc lpat) cases + MG{ mg_alts = L (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } @@ -739,18 +739,18 @@ tcPatSynMatcher (dL->L loc name) lpat , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (cL loc name)) [] + match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc (EmptyLocalBinds noExtField)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = cL (getLoc match) [match] + mg = MG{ mg_alts = L (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = cL loc matcher_id + , fun_id = L loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -786,7 +786,7 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (dL->L _ name) +mkPatSynBuilderId dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir @@ -812,7 +812,7 @@ mkPatSynBuilderId dir (dL->L _ name) tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) +tcPatSynBuilderBind (PSB { psb_id = L loc name , psb_def = lpat , psb_dir = dir , psb_args = details }) @@ -840,7 +840,7 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = cL loc (idName builder_id) + , fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -864,9 +864,9 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where - builder_args = [cL loc (VarPat noExtField (cL loc n)) - | (dL->L loc n) <- args] - builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) + builder_args = [L loc (VarPat noExtField (L loc n)) + | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -878,9 +878,8 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) -> MatchGroup GhcRn (LHsExpr GhcRn) add_dummy_arg mg@(MG { mg_alts = - (dL->L l [dL->L loc - match@(Match { m_pats = pats })]) }) - = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } + (L l [L loc match@(Match { m_pats = pats })]) }) + = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec @@ -926,9 +925,9 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(dL->L loc _) pats + mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y) + ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) (HsVar noExtField lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) @@ -938,7 +937,7 @@ tcPatToExpr name args pat = go pat ; return (RecordCon noExtField con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (dL->L loc p) = cL loc <$> go1 p + go (L loc p) = L loc <$> go1 p go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info) @@ -950,9 +949,9 @@ tcPatToExpr name args pat = go pat go1 (SigPat _ pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (dL->L l var)) + go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExtField (cL l var) + = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat @@ -969,7 +968,7 @@ tcPatToExpr name args pat = go pat (noLoc expr) } go1 (LitPat _ lit) = return $ HsLit noExtField lit - go1 (NPat _ (dL->L _ n) mb_neg _) + go1 (NPat _ (L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit noExtField n)] | otherwise = return $ HsOverLit noExtField n @@ -1142,7 +1141,7 @@ tcCollectEx pat = go pat = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p + goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 4d1d32f8a5..d2235e5bd8 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -163,7 +163,7 @@ tcRnModule :: HscEnv -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)} + parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc <- loc = withTiming dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod)) @@ -186,7 +186,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax pair :: (Module, SrcSpan) pair@(this_mod,_) - | Just (dL->L mod_loc mod) <- hsmodName this_module + | Just (L mod_loc mod) <- hsmodName this_module = (mkModule this_pkg mod, mod_loc) | otherwise -- 'module M where' is omitted @@ -205,7 +205,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (dL->L loc (HsModule maybe_mod export_ies + (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -232,7 +232,7 @@ tcRnModuleTcRnM hsc_env mod_sum addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (dL->L _ idecl) = + let { simplifyImport (L _ idecl) = ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) } ; raw_sig_imports <- liftIO @@ -242,7 +242,7 @@ tcRnModuleTcRnM hsc_env mod_sum $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) - ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc + ; let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { ideclHiding = Just (False, noLoc [])} ; mkImport _ = panic "mkImport" } @@ -256,7 +256,7 @@ tcRnModuleTcRnM hsc_env mod_sum -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns let { tcg_env1 = case mod_deprec of - Just (dL->L _ txt) -> + Just (L _ txt) -> tcg_env {tcg_warns = WarnAll txt} Nothing -> tcg_env } @@ -552,7 +552,7 @@ tc_rn_src_decls ds else do { (th_group, th_group_tail) <- findSplice th_ds ; case th_group_tail of { Nothing -> return () - ; Just (SpliceDecl _ (dL->L loc _) _, _) -> + ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpan loc $ addErr (text ("Declaration splices are not " @@ -588,7 +588,7 @@ tc_rn_src_decls ds { Nothing -> return (tcg_env, tcl_env, lie1) -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (dL->L _ splice) _, rest_ds) -> + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> do { -- We need to simplify any constraints from the previous declaration -- group, or else we might reify metavariables, as in #16980. @@ -681,7 +681,7 @@ tcRnHsBootDecls hsc_src decls ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (dL->L loc _) +badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of @@ -874,7 +874,7 @@ checkHiBootIface' -- that modifying boot_dfun, to make local_boot_fun. | otherwise - = setSrcSpan (getLoc (getName boot_dfun)) $ + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ do { traceTc "check_cls_inst" $ vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) @@ -1747,7 +1747,7 @@ check_main dflags tcg_env explicit_mod_hdr ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $ - tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name))) + tcMonoExpr (L loc (HsVar noExtField (L loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id] @@ -2057,53 +2057,53 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (dL->L loc (BodyStmt _ expr _ _)) +tcUserStmt (L loc (BodyStmt _ expr _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr + matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr] - the_bind = cL loc $ (mkTopFunBind FromSource - (cL loc fresh_it) matches) + the_bind = L loc $ (mkTopFunBind FromSource + (L loc fresh_it) matches) { fun_ext = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField + let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] - bind_stmt = cL loc $ BindStmt noExtField - (cL loc (VarPat noExtField (cL loc fresh_it))) + bind_stmt = L loc $ BindStmt noExtField + (L loc (VarPat noExtField (L loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr -- [; print it] - print_it = cL loc $ BodyStmt noExtField + print_it = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr -- NewA - no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_b = cL loc $ BodyStmt noExtField (rn_expr) + no_it_b = L loc $ BodyStmt noExtField (rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_c = cL loc $ BodyStmt noExtField + no_it_c = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2203,7 +2203,7 @@ But for naked expressions, you will have In an equation for ‘x’: x = putStrLn True -} -tcUserStmt rdr_stmt@(dL->L loc _) +tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv @@ -2214,8 +2214,8 @@ tcUserStmt rdr_stmt@(dL->L loc _) ; ghciStep <- getGhciStepIO ; let gi_stmt - | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt - = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 + | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult @@ -2237,7 +2237,7 @@ tcUserStmt rdr_stmt@(dL->L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2594,7 +2594,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (dL->L loc rdr_name) +tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ setSrcSpan loc $ do { -- If the identifier is a constructor (begins with an diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index a4ef692c58..0f0067ab5d 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -254,7 +254,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod fix_faminst avail = avail -exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do ie_avails <- accumExports do_litem rdr_items let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families return (Just ie_avails, final_exports) @@ -280,7 +280,7 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod exports_from_item :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) exports_from_item (ExportAccum occs earlier_mods) - (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod))) + (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M = do { warnIfFlag Opt_WarnDuplicateExports True (dupModuleExport mod) ; @@ -317,13 +317,13 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod , ppr new_exports ]) ; return (Just ( ExportAccum occs' mods - , ( cL loc (IEModuleContents noExtField lmod) + , ( L loc (IEModuleContents noExtField lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie) + exports_from_item acc@(ExportAccum occs mods) (L loc ie) | isDoc ie = do new_ie <- lookup_doc_ie ie - return (Just (acc, (cL loc new_ie, []))) + return (Just (acc, (L loc new_ie, []))) | otherwise = do (new_ie, avail) <- lookup_ie ie @@ -334,17 +334,17 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs ie occs [avail] return (Just ( ExportAccum occs' mods - , (cL loc new_ie, [avail]))) + , (L loc new_ie, [avail]))) ------------- lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (dL->L l rdr)) + lookup_ie (IEVar _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail) + return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) - lookup_ie (IEThingAbs _ (dL->L l rdr)) + lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name)) + return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') @@ -376,18 +376,18 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] -> RnM (Located Name, [LIEWrappedName Name], [Name], [Located FieldLabel]) - lookup_ie_with (dL->L l rdr) sub_rdrs + lookup_ie_with (L l rdr) sub_rdrs = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name - then return (cL l name, [], [name], []) - else return (cL l name, non_flds + then return (L l name, [], [name], []) + else return (L l name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (dL->L l rdr) = + lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres @@ -401,7 +401,7 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (cL l name, non_flds, flds) + return (L l name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) @@ -530,8 +530,8 @@ lookupChildrenExport spec_parent rdr_items = case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (cL l (IEName (cL l ub))))} - FoundFL fls -> return $ Right (cL (getLoc n) fls) + ; return (Left (L l (IEName (L l ub))))} + FoundFL fls -> return $ Right (L (getLoc n) fls) FoundName par name -> do { checkPatSynParent spec_parent par name ; return $ Left (replaceLWrappedName n name) } diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 3442e8729a..ec4d38fc10 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -840,31 +840,28 @@ setSrcSpan (RealSrcSpan real_loc) thing_inside -- Don't overwrite useful info with useless: setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b -addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a -wrapLocM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (cL loc b) } -wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c) -wrapLocFstM fn (dL->L loc a) = +wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a + ; return (L loc b) } + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (cL loc b, c) + return (L loc b, c) -wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) => - (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c) -wrapLocSndM fn (dL->L loc a) = +wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (b, cL loc c) + return (b, L loc c) -wrapLocM_ :: HasSrcSpan a => - (SrcSpanLess a -> TcM ()) -> a -> TcM () -wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a) +wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () +wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) -- Reporting errors diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 59f9b45617..eb940aa1ee 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -474,7 +474,7 @@ creating a new EvVar when we have a new goal that we have solved in the past. But in particular, we can use it to create *recursive* dictionaries. -The simplest, degnerate case is +The simplest, degenerate case is instance C [a] => C [a] where ... If we have [W] d1 :: C [x] @@ -2859,7 +2859,7 @@ implications. Consider a ~ F b, forall c. b~Int => blah If we have F b ~ fsk in the flat-cache, and we push that into the nested implication, we might miss that F b can be rewritten to F Int, -and hence perhpas solve it. Moreover, the fsk from outside is +and hence perhaps solve it. Moreover, the fsk from outside is flattened out after solving the outer level, but and we don't do that flattening recursively. -} @@ -2881,7 +2881,7 @@ nestTcS (TcS thing_inside) ; new_inerts <- TcM.readTcRef new_inert_var - -- we want to propogate the safe haskell failures + -- we want to propagate the safe haskell failures ; let old_ic = inert_cans inerts new_ic = inert_cans new_inerts nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } @@ -2978,7 +2978,7 @@ Consider forall b. empty => Eq [a] We solve the simple (Eq [a]), under nestTcS, and then turn our attention to the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a signficant performance difference +the inner implications, and it can make a significant performance difference if you do so. -} diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index b4ef967fcb..1e284ec0a7 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -123,7 +123,7 @@ for two reasons: may actually give rise to f :: forall k. forall (f::k -> *) (a:k). f a -> f a So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *inital* ones! + NB: the scoped ones are not necessarily the *initial* ones! * Even aside from kind polymorphism, there may be more instantiated type variables than lexically-scoped ones. For example: diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 945e496db7..c2803571cf 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -431,6 +431,39 @@ When a variable is used, we compare -} +-- | We only want to produce warnings for TH-splices if the user requests so. +-- See Note [Warnings for TH splices]. +getThSpliceOrigin :: TcM Origin +getThSpliceOrigin = do + warn <- goptM Opt_EnableThSpliceWarnings + if warn then return FromSource else return Generated + +{- Note [Warnings for TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only produce warnings for TH splices when the user requests so +(-fenable-th-splice-warnings). There are multiple reasons: + + * It's not clear that the user that compiles a splice is the author of the code + that produces the warning. Think of the situation where she just splices in + code from a third-party library that produces incomplete pattern matches. + In this scenario, the user isn't even able to fix that warning. + * Gathering information for producing the warnings (pattern-match check + warnings in particular) is costly. There's no point in doing so if the user + is not interested in those warnings. + +That's why we store Origin flags in the Haskell AST. The functions from ThToHs +take such a flag and depending on whether TH splice warnings were enabled or +not, we pass FromSource (if the user requests warnings) or Generated +(otherwise). This is implemented in getThSpliceOrigin. + +For correct pattern-match warnings it's crucial that we annotate the Origin +consistently (#17270). In the future we could offer the Origin as part of the +TH AST. That would enable us to give quotes from the current module get +FromSource origin, and/or third library authors to tag certain parts of +generated code as FromSource to enable warnings. That effort is tracked in +#14838. +-} + {- ************************************************************************ * * @@ -686,15 +719,16 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do runQResult :: (a -> String) - -> (SrcSpan -> a -> b) + -> (Origin -> SrcSpan -> a -> b) -> (ForeignHValue -> TcM a) -> SrcSpan -> ForeignHValue {- TH.Q a -} -> TcM b runQResult show_th f runQ expr_span hval = do { th_result <- runQ hval + ; th_origin <- getThSpliceOrigin ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f expr_span th_result) } + ; return (f th_origin expr_span th_result) } ----------------- @@ -972,7 +1006,8 @@ instance TH.Quasi TcM where qAddTopDecls thds = do l <- getSrcSpanM - let either_hval = convertToHsDecls l thds + th_origin <- getThSpliceOrigin + let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of Left exn -> failWithTc $ hang (text "Error in a declaration passed to addTopDecls:") @@ -1255,7 +1290,8 @@ reifyInstances th_nm th_tys = addErrCtxt (text "In the argument of reifyInstances:" <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { loc <- getSrcSpanM - ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) + ; th_origin <- getThSpliceOrigin + ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) -- #9262 says to bring vars into scope, like in HsForAllTy case -- of rnHsTyKi ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty @@ -1297,10 +1333,10 @@ reifyInstances th_nm th_tys doc = ClassInstanceCtx bale_out msg = failWithTc msg - cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs) - cvt loc th_ty = case convertToHsType loc th_ty of - Left msg -> failWithTc msg - Right ty -> return ty + cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) + cvt origin loc th_ty = case convertToHsType origin loc th_ty of + Left msg -> failWithTc msg + Right ty -> return ty {- ************************************************************************ diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 9a81e35e06..545f001f00 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -454,9 +454,9 @@ We do the following steps: B :-> TcTyCon <initial kind> (thereby overriding the B :-> TyConPE binding) and do kcLTyClDecl on each decl to get equality constraints on - all those inital kinds + all those initial kinds - - Generalise the inital kind, making a poly-kinded TcTyCon + - Generalise the initial kind, making a poly-kinded TcTyCon 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded TcTyCons, again overriding the promotion-error bindings. @@ -997,15 +997,15 @@ mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv` mkNameEnv [ (name, APromotionErr TyConPE) - | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ] + | (L _ (FamilyDecl { fdLName = L _ name })) <- ats ] -mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name) +mk_prom_err_env (DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE) - | (dL->L _ con') <- cons - , (dL->L _ con) <- getConNames con' ] + | L _ con' <- cons + , L _ con <- getConNames con' ] mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE) @@ -1054,7 +1054,7 @@ getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] -- -- No family instances are passed to checkInitialKinds/inferInitialKinds getInitialKind strategy - (ClassDecl { tcdLName = dL->L _ name + (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ @@ -1072,7 +1072,7 @@ getInitialKind strategy InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy - (DataDecl { tcdLName = dL->L _ name + (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } }) @@ -1105,7 +1105,7 @@ getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = ; return [tc] } getInitialKind strategy - (SynDecl { tcdLName = dL->L _ name + (SynDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) = do { let ctxt = TySynKindCtxt name @@ -1124,14 +1124,14 @@ get_fam_decl_initial_kind -> FamilyDecl GhcRn -> TcM TcTyCon get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = (dL->L _ name) + FamilyDecl { fdLName = L _ name , fdTyVars = ktvs - , fdResultSig = (dL->L _ resultSig) + , fdResultSig = L _ resultSig , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred @@ -1258,7 +1258,7 @@ Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] -kcLTyClDecl (dL->L loc decl) +kcLTyClDecl (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "kcTyClDecl {" (ppr tc_name) @@ -1273,10 +1273,10 @@ kcTyClDecl :: TyClDecl GhcRn -> TcM () -- result kind signature have already been dealt with -- by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) +kcTyClDecl (DataDecl { tcdLName = (L _ name) , tcdDataDefn = defn }) - | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _) - , dd_ctxt = (dL->L _ []) + | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) + , dd_ctxt = (L _ []) , dd_ND = new_or_data } <- defn = do { tyCon <- kcLookupTcTyCon name -- See Note [Implementation of UnliftedNewtypes] STEP 2 @@ -1298,13 +1298,13 @@ kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) ; kcConDecls new_or_data (tyConResKind tyCon) cons } -kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs }) +kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) = bindTyClTyVars name $ \ _ res_kind -> discardResult $ tcCheckLHsType rhs res_kind -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) +kcTyClDecl (ClassDecl { tcdLName = L _ name , tcdCtxt = ctxt, tcdSigs = sigs }) = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt @@ -1315,7 +1315,7 @@ kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) skol_info = TyConSkol ClassFlavour name -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) +kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't -- do anything here @@ -1692,13 +1692,13 @@ There's also a change in the renamer: inside the data constructor to determine the result kind. See Note [Unlifted Newtypes and CUSKs] for more detail. -For completeness, it was also neccessary to make coerce work on +For completeness, it was also necessary to make coerce work on unlifted types, resolving #13595. -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (dL->L loc decl) +tcTyClDecl roles_info (L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things] ATyCon tc -> return (tc, wiredInDerivInfo tc decl) @@ -1735,7 +1735,7 @@ tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) -- "type" synonym declaration tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = (dL->L _ tc_name) + (SynDecl { tcdLName = L _ tc_name , tcdRhs = rhs }) = ASSERT( isNothing _parent ) fmap noDerivInfos $ @@ -1744,7 +1744,7 @@ tcTyClDecl1 _parent roles_info -- "data/newtype" declaration tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = (dL->L _ tc_name) + decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) bindTyClTyVars tc_name $ \ tycon_binders res_kind -> @@ -1752,7 +1752,7 @@ tcTyClDecl1 _parent roles_info tycon_binders res_kind defn tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = (dL->L _ class_name) + (ClassDecl { tcdLName = L _ class_name , tcdCtxt = hs_ctxt , tcdMeths = meths , tcdFDs = fundeps @@ -1853,10 +1853,10 @@ tcClassATs class_name cls ats at_defs ; mapM tc_at ats } where at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn + at_def_tycon (L _ eqn) = tyFamInstDeclName eqn at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name (dL->L _ decl) = unLoc (fdLName decl) + at_fam_name (L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) @@ -1885,7 +1885,7 @@ tcDefaultAssocDecl _ (d1:_:_) <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc - [dL->L loc (TyFamInstDecl { tfid_eqn = + [L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ tc_name , feqn_bndrs = mb_expl_bndrs @@ -1983,8 +1983,9 @@ tcDefaultAssocDecl fam_tc suggestion :: SDoc suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables" -tcDefaultAssocDecl _ [_] - = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 + +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x {- Note [Type-checking default assoc decls] @@ -2052,8 +2053,8 @@ delicate for my taste, but it works. tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(dL->L _ tc_name) - , fdResultSig = (dL->L _ sig) + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info = bindTyClTyVars tc_name $ \ binders res_kind -> do @@ -2176,7 +2177,7 @@ tcInjectivity _ Nothing -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags @@ -2300,11 +2301,11 @@ kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () -- Used for the equations of a closed type family only -- Not used for data/type instances kcTyFamInstEqn tc_fam_tc - (dL->L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) = setSrcSpan loc $ do { traceTc "kcTyFamInstEqn" (vcat [ text "tc_name =" <+> ppr eqn_tc_name @@ -2330,9 +2331,8 @@ kcTyFamInstEqn tc_fam_tc where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec -kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec -kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 +kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec +kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec -------------------------- @@ -2342,7 +2342,7 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (dL->L loc (HsIB { hsib_ext = imp_vars + (L loc (HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name , feqn_bndrs = mb_expl_bndrs , feqn_pats = hs_pats @@ -2642,8 +2642,8 @@ dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True -consUseGadtSyntax _ = False +consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -2734,7 +2734,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (dL->L _ name) = do + buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name @@ -2762,7 +2762,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let ((dL->L _ name) : _) = names + ; let (L _ name : _) = names ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise @@ -2821,7 +2821,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let - buildOneDataCon (dL->L _ name) = do + buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name @@ -2875,7 +2875,7 @@ tcConArgs (RecCon fields) = mapM tcConArg btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f)) + combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined @@ -3546,12 +3546,12 @@ checkValidDataCon dflags existential_ok tc con user_tvbs_invariant = Set.fromList (filterEqSpec eq_spec univs ++ exs) == Set.fromList user_tvs - ; WARN( not user_tvbs_invariant + ; MASSERT2( user_tvbs_invariant , vcat ([ ppr con , ppr univs , ppr exs , ppr eq_spec - , ppr user_tvs ])) return () } + , ppr user_tvs ])) } ; traceTc "Done validity of data con" $ vcat [ ppr con @@ -4040,7 +4040,7 @@ checkValidRoleAnnots role_annots tc check_roles = whenIsJust role_annot_decl_maybe $ - \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) -> + \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations @@ -4064,11 +4064,10 @@ checkValidRoleAnnots role_annots tc = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (dL->L _ Nothing) _ = return () -checkRoleAnnot tv (dL->L _ (Just r1)) r2 +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 -checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls @@ -4355,25 +4354,21 @@ badRoleAnnot var annot inferred , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots)) +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) = hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) -wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec -wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match" - -- due to #15884 +wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _)) +illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec -illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match" - -- due to #15884 +illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 026186c1bd..c7bcfbe068 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -225,7 +225,7 @@ checkSynCycles this_uid tcs tyclds = do mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl + Just (L loc decl) -> ppr loc <> colon <+> ppr decl Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" where @@ -486,7 +486,7 @@ initialRoleEnv1 hsc_src annots_env tc -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of - Just (dL->L _ (RoleAnnotDecl _ _ annots)) + Just (L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots @@ -828,13 +828,13 @@ when typechecking the [d| .. |] quote, and typecheck them later. tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs - , let loc = getSrcSpan sel_id ] + sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] @@ -854,7 +854,7 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (sel_id, cL loc sel_bind) + = (sel_id, L loc sel_bind) where loc = getSrcSpan sel_name lbl = flLabel fl @@ -892,18 +892,18 @@ mkOneRecordSelector all_cons idDetails fl [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [cL loc (mk_sel_pat con)] - (cL loc (HsVar noExtField (cL loc field_var))) - mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields) + [L loc (mk_sel_pat con)] + (L loc (HsVar noExtField (L loc field_var))) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = cL loc (FieldOcc sel_name - (cL loc $ mkVarUnqual lbl)) + = L loc (FieldOcc sel_name + (L loc $ mkVarUnqual lbl)) , hsRecFieldArg - = cL loc (VarPat noExtField (cL loc field_var)) + = L loc (VarPat noExtField (L loc field_var)) , hsRecPun = False }) - sel_lname = cL loc sel_name + sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -911,10 +911,10 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [cL loc (WildPat noExtField)] - (mkHsApp (cL loc (HsVar noExtField - (cL loc (getName rEC_SEL_ERROR_ID)))) - (cL loc (HsLit noExtField msg_lit)))] + [L loc (WildPat noExtField)] + (mkHsApp (L loc (HsVar noExtField + (L loc (getName rEC_SEL_ERROR_ID)))) + (L loc (HsLit noExtField msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 1537859d1b..90680f093f 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -277,7 +277,7 @@ Note, though, that a /bound/ type variable can (and probably should) be a TyVar. E.g forall a. a -> a Here 'a' is really just a deBruijn-number; it certainly does not have -a signficant TcLevel (as every TcTyVar does). So a forall-bound type +a significant TcLevel (as every TcTyVar does). So a forall-bound type variable should be TyVars; and hence a TyVar can appear free in a TcType. The type checker and constraint solver can also encounter /free/ type @@ -1657,7 +1657,7 @@ pickQuantifiablePreds qtvs theta EqPred eq_rel ty1 ty2 | quantify_equality eq_rel ty1 ty2 , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constaints when quantifying] + -- boxEqPred: See Note [Lift equality constraints when quantifying] , pick_cls_pred flex_ctxt cls tys -> Just (mkClassPred cls tys) @@ -1875,7 +1875,7 @@ Notice that See also TcTyDecls.checkClassCycles. -Note [Lift equality constaints when quantifying] +Note [Lift equality constraints when quantifying] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't quantify over a constraint (t1 ~# t2) because that isn't a predicate type; see Note [Types for coercions, predicates, and evidence] diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 44842e43ae..9f9e69850d 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -1715,7 +1715,7 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) -- Occurs check or an untouchable: just defer -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occured in type family parameter + -- eg tv1 occurred in type family parameter ; defer } ty1 = mkTyVarTy tv1 diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index f02cb887cf..3f780fe546 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -2574,7 +2574,7 @@ Notice that: positions where the class header has no influence over the parameter. Hence the fancy footwork in pp_expected_ty - - Although the binders in the axiom are aready tidy, we must + - Although the binders in the axiom are already tidy, we must re-tidy them to get a fresh variable name when we shadow - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the |