Commit 7567ad3c authored by Austin Seipp's avatar Austin Seipp
Browse files

[ci skip] typecheck: detabify/dewhitespace TcInstDecls


Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 3765e21b
......@@ -7,12 +7,6 @@ TcInstDecls: Typechecking instance declarations
\begin{code}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
......@@ -21,7 +15,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl( tcClassDecl2,
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod, tcInstanceMethodBody )
import TcPat ( addInlinePrags )
......@@ -48,7 +42,7 @@ import DataCon
import Class
import Var
import VarEnv
import VarSet
import VarSet
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName,
......@@ -373,7 +367,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
tcInstDecls1 tycl_decls inst_decls deriv_decls
tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do { -- Stop if addInstInfos etc discovers any errors
-- (they recover, so that we get more than one error each
......@@ -403,7 +397,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; traceTc "tcDeriving" Outputable.empty
; th_stage <- getStage -- See Note [Deriving inside TH brackets ]
; (gbl_env, deriv_inst_info, deriv_binds)
<- if isBrackStage th_stage
<- if isBrackStage th_stage
then do { gbl_env <- getGblEnv
; return (gbl_env, emptyBag, emptyValBindsOut) }
else tcDeriving tycl_decls inst_decls deriv_decls
......@@ -447,7 +441,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
typInstErr i = hang (ptext (sLit $ "Typeable instances can only be "
++ "derived in Safe Haskell.") $+$
++ "derived in Safe Haskell.") $+$
ptext (sLit "Replace the following instance:"))
2 (pprInstanceHdr (iSpec i))
......@@ -455,7 +449,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
[Overlappable, Overlapping, Overlaps]
genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
genInstErr i = hang (ptext (sLit $ "Generic instances can only be "
++ "derived in Safe Haskell.") $+$
++ "derived in Safe Haskell.") $+$
ptext (sLit "Replace the following instance:"))
2 (pprInstanceHdr (iSpec i))
......@@ -471,15 +465,15 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a
-- Extend (a) the family instance envt
-- (b) the type envt with stuff from data type decls
addFamInsts fam_insts thing_inside
= tcExtendLocalFamInstEnv fam_insts $
tcExtendGlobalEnv things $
= tcExtendLocalFamInstEnv fam_insts $
tcExtendGlobalEnv things $
do { traceTc "addFamInsts" (pprFamInsts fam_insts)
; tcg_env <- tcAddImplicits things
; setGblEnv tcg_env thing_inside }
where
axioms = map (toBranchedAxiom . famInstAxiom) fam_insts
tycons = famInstsRepTyCons fam_insts
things = map ATyCon tycons ++ map ACoAxiom axioms
things = map ATyCon tycons ++ map ACoAxiom axioms
\end{code}
Note [Deriving inside TH brackets]
......@@ -490,12 +484,12 @@ Given a declaration bracket
there is really no point in generating the derived code for deriving(
Show) and then type-checking it. This will happen at the call site
anyway, and the type check should never fail! Moreover (Trac #6005)
the scoping of the generated code inside the bracket does not seem to
work out.
the scoping of the generated code inside the bracket does not seem to
work out.
The easy solution is simply not to generate the derived instances at
all. (A less brutal solution would be to generate them with no
bindings.) This will become moot when we shift to the new TH plan, so
bindings.) This will become moot when we shift to the new TH plan, so
the brutal solution will do.
......@@ -533,7 +527,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
mb_info = Just (clas, mini_env)
-- Next, process any associated types.
; traceTc "tcLocalInstDecl" (ppr poly_ty)
; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
......@@ -544,11 +538,11 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
-- Check for missing associated types and build them
-- from their defaults (if available)
; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
`unionNameSets`
`unionNameSets`
mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats)
; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats)
(classATItems clas)
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
......@@ -558,9 +552,9 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
do defaultOverlapFlag <- getOverlapFlag
return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode
; (subst, tyvars') <- tcInstSkolTyVars tyvars
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-- Be sure to freshen those type variables,
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
inst_info = InstInfo { iSpec = ispec
, iBinds = InstBindings
......@@ -595,7 +589,7 @@ tcATDefault inst_subst defined_ats (ATI fam_tc defs)
; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs'
; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
, pprCoAxiom axiom ])
; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
newFamInst SynFamilyInst axiom
; return [fam_inst] }
......@@ -604,19 +598,19 @@ tcATDefault inst_subst defined_ats (ATI fam_tc defs)
= do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
; return [] }
where
subst_tv subst tc_tv
subst_tv subst tc_tv
| Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
= (subst, ty)
| otherwise
= (extendTvSubst subst tc_tv ty', ty')
where
ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv)
--------------
tcAssocTyDecl :: Class -- Class of associated type
-> VarEnv Type -- Instantiation of class TyVars
-> LTyFamInstDecl Name
-> LTyFamInstDecl Name
-> TcM (FamInst)
tcAssocTyDecl clas mini_env ldecl
= do { fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) ldecl
......@@ -684,7 +678,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
tcDataFamInstDecl :: Maybe (Class, VarEnv Type)
-> LDataFamInstDecl Name -> TcM FamInst
-- "newtype instance" and "data instance"
tcDataFamInstDecl mb_clsinfo
tcDataFamInstDecl mb_clsinfo
(L loc decl@(DataFamInstDecl
{ dfid_pats = pats
, dfid_tycon = fam_tc_name
......@@ -700,7 +694,7 @@ tcDataFamInstDecl mb_clsinfo
-- Kind check type patterns
; tcFamTyPats (famTyConShape fam_tc) pats
(kcDataDefn defn) $
(kcDataDefn defn) $
\tvs' pats' res_kind -> do
{ -- Check that left-hand side contains no type family applications
......@@ -709,7 +703,7 @@ tcDataFamInstDecl mb_clsinfo
checkValidFamPats fam_tc tvs' pats'
-- Check that type patterns match class instance head, if any
; checkConsistentFamInst mb_clsinfo fam_tc tvs' pats'
-- Result kind must be '*' (otherwise, we have too few patterns)
; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
......@@ -730,12 +724,12 @@ tcDataFamInstDecl mb_clsinfo
mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
-- freshen tyvars
; let (eta_tvs, eta_pats) = eta_reduce tvs' pats'
axiom = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats
axiom = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats
(mkTyConApp rep_tc (mkTyVarTys eta_tvs))
parent = FamInstTyCon axiom fam_tc pats'
roles = map (const Nominal) tvs'
rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs
Recursive
rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs
Recursive
False -- No promotable to the kind level
gadt_syntax parent
-- We always assume that indexed types are recursive. Why?
......@@ -911,9 +905,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
dfun_args :: [CoreExpr]
dfun_args = map Type inst_tys ++
map Var sc_ev_vars ++
map Var sc_ev_vars ++
map mk_meth_app meth_ids
mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars
mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars
export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
, abe_mono = self_dict, abe_prags = dfun_spec_prags }
......@@ -941,7 +935,7 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $
emitWanteds ScOrigin sc_theta
; if null inst_tyvars && null dfun_ev_vars
; if null inst_tyvars && null dfun_ev_vars
then return (sc_binds, sc_evs)
else return (emptyTcEvBinds, sc_lam_args) }
where
......@@ -949,14 +943,14 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
orig_ev_vars = drop n_silent dfun_ev_vars
sc_lam_args = map (find dfun_ev_vars) sc_theta
find [] pred
find [] pred
= pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred)
find (ev:evs) pred
find (ev:evs) pred
| pred `eqPred` evVarPred ev = ev
| otherwise = find evs pred
----------------------
mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcSigInfo)
mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
= do { let sel_occ = nameOccName sel_name
......@@ -988,11 +982,11 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
-- Check that any type signatures have exactly the right type
check_inst_sig hs_ty@(L loc _)
= setSrcSpan loc $
check_inst_sig hs_ty@(L loc _)
= setSrcSpan loc $
do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty
; inst_sigs <- xoptM Opt_InstanceSigs
; if inst_sigs then
; if inst_sigs then
unless (sig_ty `eqType` local_meth_ty)
(badInstSigErr sel_name local_meth_ty)
else
......@@ -1003,7 +997,7 @@ badInstSigErr :: Name -> Type -> TcM ()
badInstSigErr meth ty
= do { env0 <- tcInitTidyEnv
; let tidy_ty = tidyType env0 ty
-- Tidy the type using the ambient TidyEnv,
-- Tidy the type using the ambient TidyEnv,
-- to avoid apparent name capture (Trac #7475)
-- class C a where { op :: a -> b }
-- instance C (a->b) where
......@@ -1033,7 +1027,7 @@ Note [Silent superclass arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #3731, #4809, #5751, #5913, #6117, which all
describe somewhat more complicated situations, but ones
encountered in practice.
encountered in practice.
THE PROBLEM
......@@ -1100,7 +1094,7 @@ In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
[Wanted] (d1 :: C [a])
[Wanted] (d2 :: D [a])
And now, though we *can* solve:
And now, though we *can* solve:
d2 := dw
That's fine; and we solve d1:C[a] separately.
......@@ -1142,11 +1136,11 @@ The SPECIALISE pragmas are acted upon by the desugarer, which generate
$c$crangePair = ...specialised RHS of $crangePair...
{-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
Note that
* The specialised dictionary $s$dfIxPair is very much needed, in case we
call a function that takes a dictionary, but in a context where the
call a function that takes a dictionary, but in a context where the
specialised dictionary can be used. See Trac #7797.
* The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
......@@ -1220,12 +1214,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
where
set_exts :: [ExtensionFlag] -> TcM a -> TcM a
set_exts es thing = foldr setXOptM thing es
----------------------
tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
tc_item sig_fn (sel_id, dm_info)
= case findMethodBind (idName sel_id) binds of
Just (user_bind, bndr_loc)
Just (user_bind, bndr_loc)
-> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc
Nothing -> do { traceTc "tc_def" (ppr sel_id)
; tc_default sig_fn sel_id dm_info }
......@@ -1254,7 +1248,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tc_default sig_fn sel_id (GenDefMeth dm_name)
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
; tc_body sig_fn sel_id False {- Not generated code? -}
; tc_body sig_fn sel_id False {- Not generated code? -}
meth_bind inst_loc }
tc_default sig_fn sel_id NoDefMeth -- No default method at all
......@@ -1299,7 +1293,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-- Copy the inline pragma (if any) from the default
-- method to this version. Note [INLINE and default methods]
export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id1
, abe_mono = local_meth_id
, abe_prags = mk_meth_spec_prags meth_id1 [] }
......@@ -1331,7 +1325,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-- method is marked INLINE, because then it'll be inlined
-- and the specialisation would do nothing. (Indeed it'll provoke
-- a warning from the desugarer
| otherwise
| otherwise
= [ L inst_loc (SpecPrag meth_id wrap inl)
| L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
......@@ -1355,13 +1349,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- A generic default method
-- If the method is defined generically, we only have to call the
= -- A generic default method
-- If the method is defined generically, we only have to call the
-- dm_name.
do { dflags <- getDynFlags
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
do { dflags <- getDynFlags
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment