-
-------------------------
--- Derived newtype instances; surprisingly tricky!
---
--- class Show a => Foo a b where ...
--- newtype N a = MkN (Tree [a]) deriving( Foo Int )
---
--- The newtype gives an FC axiom looking like
--- axiom CoN a :: N a ~ Tree [a]
--- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
---
--- So all need is to generate a binding looking like:
--- dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
--- dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
--- case df `cast` (Foo Int (sym (CoN a))) of
--- Foo _ op1 .. opn -> Foo ds op1 .. opn
---
--- If there are no superclasses, matters are simpler, because we don't need the case
--- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-
-tc_inst_decl2 dfun_id (NewTypeDerived coi)
- = do { let rigid_info = InstSkol
- origin = SigOrigin rigid_info
- inst_ty = idType dfun_id
- inst_tvs = fst (tcSplitForAllTys inst_ty)
- ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
- -- inst_head_ty is a PredType
-
- ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
- (class_tyvars, sc_theta, _, _) = classBigSig cls
- cls_tycon = classTyCon cls
- sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
- Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
-
- (rep_ty, wrapper)
- = case coi of
- IdCo -> (last_ty, idHsWrapper)
- ACo co -> (snd (coercionKind co'), WpCast (mk_full_coercion co'))
- where
- co' = substTyWith inst_tvs (mkTyVarTys inst_tvs') co
- -- NB: the free variable of coi are bound by the
- -- universally quantified variables of the dfun_id
- -- This is weird, and maybe we should make NewTypeDerived
- -- carry a type-variable list too; but it works fine
-
- -----------------------
- -- mk_full_coercion
- -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
- -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
- -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm <rep_ty>)
- -- where rep_ty is the (eta-reduced) type rep of T
- -- So we just replace T with CoT, and insert a 'sym'
- -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
-
- mk_full_coercion co = mkTyConApp cls_tycon
- (initial_cls_inst_tys ++ [mkSymCoercion co])
- -- Full coercion : (Foo Int (Tree [a]) ~ Foo Int (N a)
-
- rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
- -- In our example, rep_pred is (Foo Int (Tree [a]))
-
- ; sc_loc <- getInstLoc InstScOrigin
- ; sc_dicts <- newDictBndrs sc_loc sc_theta'
- ; inst_loc <- getInstLoc origin
- ; dfun_dicts <- newDictBndrs inst_loc theta
- ; rep_dict <- newDictBndr inst_loc rep_pred
- ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
-
- -- Figure out bindings for the superclass context from dfun_dicts
- -- Don't include this_dict in the 'givens', else
- -- sc_dicts get bound by just selecting from this_dict!!
- ; sc_binds <- addErrCtxt superClassCtxt $
- tcSimplifySuperClasses inst_loc this_dict dfun_dicts
- (rep_dict:sc_dicts)
-
- -- It's possible that the superclass stuff might unified something
- -- in the envt with one of the clas_tyvars
- ; checkSigTyVars inst_tvs'
-
- ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict)
-
- ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
- ; let dict_bind = mkVarBind (instToId this_dict) (noLoc body)
-
- ; return (unitBag $ noLoc $
- AbsBinds inst_tvs' (map instToVar dfun_dicts)
- [(inst_tvs', dfun_id, instToId this_dict, [])]
- (dict_bind `consBag` sc_binds)) }
- where
- -----------------------
- -- (make_body C tys scs coreced_rep_dict)
- -- returns
- -- (case coerced_rep_dict of { C _ ops -> C scs ops })
- -- But if there are no superclasses, it returns just coerced_rep_dict
- -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
-
- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
- | null sc_dicts -- Case (a)
- = return coerced_rep_dict
- | otherwise -- Case (b)
- = do { op_ids <- newSysLocalIds (fsLit "op") op_tys
- ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
- ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
- pat_dicts = dummy_sc_dict_ids,
- pat_binds = emptyLHsBinds,
- pat_args = PrefixCon (map nlVarPat op_ids),
- pat_ty = pat_ty}
- the_match = mkSimpleMatch [noLoc the_pat] the_rhs
- the_rhs = mkHsConApp cls_data_con cls_inst_tys $
- map HsVar (sc_dict_ids ++ op_ids)
-
- -- Warning: this HsCase scrutinises a value with a PredTy, which is
- -- never otherwise seen in Haskell source code. It'd be
- -- nicer to generate Core directly!
- ; return (HsCase (noLoc coerced_rep_dict) $
- MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
- where
- sc_dict_ids = map instToId sc_dicts
- pat_ty = mkTyConApp cls_tycon cls_inst_tys
- cls_data_con = head (tyConDataCons cls_tycon)
- cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
- op_tys = dropList sc_dict_ids cls_arg_tys
-
-------------------------
--- Ordinary instances
-
-tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
- = do { let rigid_info = InstSkol
- inst_ty = idType dfun_id
- loc = getSrcSpan dfun_id