+tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
+-- Returns a binding for the dfun
+
+------------------------
+-- 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
+
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
+ = do { let dfun_id = instanceDFunId ispec
+ rigid_info = InstSkol
+ origin = SigOrigin rigid_info
+ inst_ty = idType dfun_id
+ ; (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
+ (nt_tycon, tc_args) = tcSplitTyConApp last_ty -- Can't fail
+ rep_ty = newTyConInstRhs nt_tycon tc_args
+
+ rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
+ -- In our example, rep_pred is (Foo Int (Tree [a]))
+ the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
+ -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
+
+ ; inst_loc <- getInstLoc origin
+ ; sc_loc <- getInstLoc InstScOrigin
+ ; dfun_dicts <- newDictBndrs inst_loc theta
+ ; sc_dicts <- newDictBndrs sc_loc sc_theta'
+ ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
+ ; rep_dict <- newDictBndr inst_loc rep_pred
+
+ -- Figure out bindings for the superclass context from dfun_dicts
+ -- Don't include this_dict in the 'givens', else
+ -- wanted_sc_insts get bound by just selecting from this_dict!!
+ ; sc_binds <- addErrCtxt superClassCtxt $
+ tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
+
+ ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict))
+
+ ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
+ ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
+
+ ; return (unitBag $ noLoc $
+ AbsBinds tvs (map instToVar dfun_dicts)
+ [(tvs, dfun_id, instToId this_dict, [])]
+ (dict_bind `consBag` sc_binds)) }
+ where
+ -----------------------
+ -- make_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
+
+ make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
+ | Just co_con <- newTyConCo_maybe nt_tycon
+ , let co = mkSymCoercion (mkTyConApp co_con tc_args)
+ = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
+ | otherwise -- The newtype is transparent; no need for a cast
+ = idHsWrapper
+
+ -----------------------
+ -- (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
+
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
+ = let
+ dfun_id = instanceDFunId ispec
+ rigid_info = InstSkol
+ inst_ty = idType dfun_id
+ loc = getSrcSpan dfun_id
projects / ghc-hetmet.git / blobdiff