-------------------------
--- 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, noSpecPrags)]
- (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
-
- -- Instantiate the instance decl with skolem constants
- ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
- -- These inst_tyvars' scope over the 'where' part
- -- Those tyvars are inside the dfun_id's type, which is a bit
- -- bizarre, but OK so long as you realise it!
- ; let
- (clas, inst_tys') = tcSplitDFunHead inst_head'
- (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
-
- -- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
- origin = SigOrigin rigid_info
-
- -- Create dictionary Ids from the specified instance contexts.
- ; inst_loc <- getInstLoc origin
- ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities
- ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
- -- Default-method Ids may be mentioned in synthesised RHSs,
- -- but they'll already be in the environment.
-
-
- -- Cook up a binding for "this = df d1 .. dn",
- -- to use in each method binding
- -- Need to clone the dict in case it is floated out, and
- -- then clashes with its friends
- ; cloned_this <- cloneDict this_dict
- ; let cloned_this_bind = mkVarBind (instToId cloned_this) $
- L loc $ wrapId app_wrapper dfun_id
- app_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
- dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
- nested_this_pair
- | null inst_tyvars' && null dfun_theta' = (this_dict, emptyBag)
- | otherwise = (cloned_this, unitBag cloned_this_bind)