X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=50640a37fd17a4c4a25da78886dbe2cce4bb5a0c;hb=ad4a18b179fbe4ad314b3accf32e806cf00f2a0b;hp=ecf4ac9790e02af4e872bf4be92f54d010a814d6;hpb=afef39736dcde6f4947a6f362f9e6b3586933db4;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ecf4ac9..50640a3 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -176,9 +176,8 @@ tcLocalInstDecl1 :: LInstDecl Name -- -- We check for respectable instance type, and context tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) + -- !!!TODO: Handle the `ats' parameter!!! -=chak = -- Prime error recovery, set source location - ASSERT( null ats ) - -- !!!TODO: Handle the `ats' parameter!!! -=chak recoverM (returnM Nothing) $ setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -304,8 +303,91 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) +-- Returns a binding for the dfun -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) +-- +-- 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 :: Tree [a] = T a +-- +-- So all need is to generate a binding looking like +-- dfunFooT :: forall a. (Show (T a), Foo Int (Tree [a]) => Foo Int (T a) +-- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])). +-- case df `cast` (Foo Int (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 + maybe_co_con = newTyConCo tycon + ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty + ; rep_dict <- newDict origin (head theta) + ; if isSingleton theta then + return (unitBag (VarBind dfun_id $ + case maybe_co_con of + Nothing -> rep_dict + Just co_con -> mkCoerce rep_dict $ + mkAppCoercion (mkAppsCoercion tycon rep_tys) + (mkTyConApp co_con tvs))) + else do + let rep_dict_id = instToId rep_dict + coerced_dict = case maybe_co_con of + Nothing -> rep_dict_id + Just co_con -> mkCoerce rep_dict_id $ + mkAppCoercion (mkAppsCoercion tycon rep_tys) + (mkTyConApp co_con tvs) + ; return (unitBag (VarBind dfun_id + co_fn = CoTyLams tvs <.> CoLams [rep_dict_id] <.> ExprCoFn cast + + ; return (unitBag (VarBind dfun_id (HsCoerce co_fn (HsVar rep_dict_id)))) + +tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' + avail_insts op_items (NewTypeDerived rep_tys) + = getInstLoc origin `thenM` \ inst_loc -> + mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) -> + + tcSimplifyCheck + (ptext SLIT("newtype derived instance")) + inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds -> + + -- I don't think we have to do the checkSigTyVars thing + + returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds) + + where + do_one inst_loc (sel_id, _) + = -- The binding is like "op @ NewTy = op @ RepTy" + -- Make the *binder*, like in mkMethodBind + tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst -> + + -- Make the *occurrence on the rhs* + tcInstClassOp inst_loc sel_id rep_tys' `thenM` \ rhs_inst -> + let + meth_id = instToId meth_inst + in + return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst) + + -- Instantiate rep_tys with the relevant type variables + -- This looks a bit odd, because inst_tyvars' are the skolemised version + -- of the type variables in the instance declaration; but rep_tys doesn't + -- have the skolemised version, so we substitute them in here + rep_tys' = substTys subst rep_tys + subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') + + + +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) = let dfun_id = instanceDFunId ispec rigid_info = InstSkol dfun_id @@ -342,7 +424,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) in tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' avail_insts - op_items binds `thenM` \ (meth_ids, meth_binds) -> + op_items monobinds uprags `thenM` \ (meth_ids, meth_binds) -> -- Figure out bindings for the superclass context -- Don't include this_dict in the 'givens', else @@ -357,12 +439,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) checkSigTyVars inst_tyvars' `thenM_` -- Deal with 'SPECIALISE instance' pragmas - let - specs = case binds of - VanillaInst _ prags -> filter isSpecInstLSig prags - other -> [] - in - tcPrags dfun_id specs `thenM` \ prags -> + tcPrags dfun_id (filter isSpecInstLSig prags) `thenM` \ prags -> -- Create the result bindings let @@ -406,7 +483,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' - avail_insts op_items (VanillaInst monobinds uprags) + avail_insts op_items monobinds uprags = -- Check that all the method bindings come from this class let sel_names = [idName sel_id | (sel_id, _) <- op_items] @@ -462,11 +539,13 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' mapM tc_method_bind meth_infos `thenM` \ meth_binds_s -> returnM (meth_ids, unionManyBags meth_binds_s) +v v v v v v v +************* -- Derived newtype instances tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' - avail_insts op_items (NewTypeDerived rep_tys) + avail_insts op_items (NewTypeDerived maybe_co rep_tys) = getInstLoc origin `thenM` \ inst_loc -> mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) -> @@ -497,6 +576,7 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' -- have the skolemised version, so we substitute them in here rep_tys' = substTys subst rep_tys subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') +^ ^ ^ ^ ^ ^ ^ \end{code}