+------------------------
+-- Derived newtype instances
+--
+-- We need to make a copy of the dictionary we are deriving from
+-- because we may need to change some of the superclass dictionaries
+-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
+--
+-- In the case of a newtype, things are rather easy
+-- class Show a => Foo a b where ...
+-- newtype T a = MkT (Tree [a]) deriving( Foo Int )
+-- The newtype gives an FC axiom looking like
+-- axiom CoT a :: T a :=: Tree [a]
+--
+-- So all need is to generate a binding looking like
+-- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
+-- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
+-- case df `cast` (Foo Int (sym (CoT a))) of
+-- Foo _ op1 .. opn -> Foo ds op1 .. opn
+
+tcInstDecl2 (InstInfo { iSpec = ispec,
+ iBinds = NewTypeDerived tycon rep_tys })
+ = do { let dfun_id = instanceDFunId ispec
+ rigid_info = InstSkol dfun_id
+ origin = SigOrigin rigid_info
+ inst_ty = idType dfun_id
+ ; inst_loc <- getInstLoc origin
+ ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
+ ; dicts <- newDictBndrs inst_loc theta
+ ; uniqs <- newUniqueSupply
+ ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
+ ; this_dict <- newDictBndr inst_loc (mkClassPred cls rep_tys)
+ ; let (rep_dict_id:sc_dict_ids)
+ | null dicts = [instToId this_dict]
+ | otherwise = map instToId dicts
+
+ -- (Here, we are relying on the order of dictionary
+ -- arguments built by NewTypeDerived in TcDeriv.)
+
+ wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids)
+
+ -- we need to find the kind that this class applies to
+ -- and drop trailing tvs appropriately
+ cls_kind = tyVarKind (head (reverse (tyConTyVars cls_tycon)))
+ the_tvs = drop_tail (length (fst (splitFunTys cls_kind))) tvs
+
+ coerced_rep_dict = mkHsCoerce (co_fn the_tvs cls_tycon cls_inst_tys) (HsVar rep_dict_id)
+
+ body | null sc_dict_ids = coerced_rep_dict
+ | otherwise = HsCase (noLoc coerced_rep_dict) $
+ MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
+ in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
+
+ the_match = mkSimpleMatch [noLoc the_pat] the_rhs
+ the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
+
+ (uniqs1, uniqs2) = splitUniqSupply uniqs
+
+ op_ids = zipWith (mkSysLocal FSLIT("op"))
+ (uniqsFromSupply uniqs1) op_tys
+
+ dict_ids = zipWith (mkSysLocal FSLIT("dict"))
+ (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
+
+ the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+ pat_dicts = dict_ids,
+ pat_binds = emptyLHsBinds,
+ pat_args = PrefixCon (map nlVarPat op_ids),
+ pat_ty = in_dict_ty}
+
+ cls_data_con = classDataCon cls
+ cls_tycon = dataConTyCon cls_data_con
+ cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
+
+ n_dict_args = if length dicts == 0 then 0 else length dicts - 1
+ op_tys = drop n_dict_args cls_arg_tys
+
+ dict = mkHsCoerce wrap_fn body
+ ; return (unitBag (noLoc $ VarBind dfun_id (noLoc dict))) }
+ where
+ -- For newtype T a = MkT <ty>
+ -- The returned coercion has kind :: C (T a):=:C <ty>
+ co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo tycon
+ = ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++
+ [mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))]))
+ | otherwise
+ = idCoercion
+ drop_tail n l = take (length l - n) l
+
+------------------------
+-- Ordinary instances
+
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
projects / ghc-hetmet.git / blobdiff