X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=8fa8c0b3fa45c3b60535b51a5e3dd5d4fc5c9ea1;hp=446bbdbf3dfa60945d6a979274cfecf4e7ec10c0;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=1971591f865ac0806802c476f23792ae2c89411a diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 446bbdb..8fa8c0b 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -68,10 +68,11 @@ Overall plan 3. Add the derived bindings, generating InstInfos + \begin{code} -- DerivSpec is purely local to this module data DerivSpec = DS { ds_loc :: SrcSpan - , ds_orig :: InstOrigin + , ds_orig :: CtOrigin , ds_name :: Name , ds_tvs :: [TyVar] , ds_theta :: ThetaType @@ -84,14 +85,27 @@ data DerivSpec = DS { ds_loc :: SrcSpan -- df :: forall tvs. theta => C tys -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the theta - -- For family indexes, the tycon in + -- For type families, the tycon in -- in ds_tys is the *family* tycon -- in ds_tc, ds_tc_args is the *representation* tycon -- For non-family tycons, both are the same -- ds_newtype = True <=> Newtype deriving -- False <=> Vanilla deriving +\end{code} + +Example: + newtype instance T [a] = MkT (Tree a) deriving( C s ) +==> + axiom T [a] = :RTList a + axiom :RTList a = Tree a + + DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] + , ds_tc = :RTList, ds_tc_args = [a] + , ds_newtype = True } + +\begin{code} type DerivContext = Maybe ThetaType -- Nothing <=> Vanilla deriving; infer the context of the instance decl -- Just theta <=> Standalone deriving: context supplied by programmer @@ -287,7 +301,7 @@ tcDeriving tycl_decls inst_decls deriv_decls do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". is_boot <- tcIsHsBoot - ; traceTc (text "tcDeriving" <+> ppr is_boot) + ; traceTc "tcDeriving" (ppr is_boot) ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ; overlap_flag <- getOverlapFlag @@ -334,9 +348,10 @@ renameDeriv is_boot gen_binds insts -- notably "con2tag" and/or "tag2con" functions. -- Bring those names into scope before renaming the instances themselves ; loc <- getSrcSpanM -- Generic loc for shared bindings - ; let aux_binds = listToBag $ map (genAuxBind loc) $ - rm_dups [] $ concat deriv_aux_binds - ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds []) + ; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $ + rm_dups [] $ concat deriv_aux_binds + aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs + ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds ; let aux_names = collectHsValBinders rn_aux_lhs ; bindLocalNames aux_names $ @@ -453,21 +468,21 @@ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec deriveStandalone (L loc (DerivDecl deriv_ty)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ - do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty) + do { traceTc "Standalone deriving decl for" (ppr deriv_ty) ; (tvs, theta, tau) <- tcHsInstHead deriv_ty - ; traceTc (text "standalone deriving;" - <+> text "tvs:" <+> ppr tvs - <+> text "theta:" <+> ppr theta - <+> text "tau:" <+> ppr tau) + ; traceTc "Standalone deriving;" $ vcat + [ text "tvs:" <+> ppr tvs + , text "theta:" <+> ppr theta + , text "tau:" <+> ppr tau ] ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau -- C.f. TcInstDcls.tcLocalInstDecl1 ; let cls_tys = take (length inst_tys - 1) inst_tys inst_ty = last inst_tys - ; traceTc (text "standalone deriving;" - <+> text "class:" <+> ppr cls - <+> text "class types:" <+> ppr cls_tys - <+> text "type:" <+> ppr inst_ty) + ; traceTc "Standalone deriving:" $ vcat + [ text "class:" <+> ppr cls + , text "class types:" <+> ppr cls_tys + , text "type:" <+> ppr inst_ty ] ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty (Just theta) } @@ -517,7 +532,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, -- Type families can't be partially applied -- e.g. newtype instance T Int a = MkT [a] deriving( Monad ) -- Note [Deriving, type families, and partial applications] - ; checkTc (not (isOpenTyCon tc) || n_args_to_drop == 0) + ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0) (typeFamilyPapErr tc cls cls_tys inst_ty) ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } } @@ -570,7 +585,7 @@ After all, we can write it out ... etc ... \begin{code} -mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type +mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type -> DerivContext -- Just => context supplied (standalone deriving) -- Nothing => context inferred (deriving on data decl) -> TcRn EarlyDerivSpec @@ -582,7 +597,7 @@ mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type mkEqnHelp orig tvs cls cls_tys tc_app mtheta | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app , isAlgTyCon tycon -- Check for functions, primitive types etc - = do { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args + = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args -- Be careful to test rep_tc here: in the case of families, -- we want to check the instance tycon, not the family tycon @@ -610,48 +625,6 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta (ptext (sLit "The last argument of the instance must be a data or newtype application"))) \end{code} -Note [Looking up family instances for deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcLookupFamInstExact is an auxiliary lookup wrapper which requires -that looked-up family instances exist. If called with a vanilla -tycon, the old type application is simply returned. - -If we have - data instance F () = ... deriving Eq - data instance F () = ... deriving Eq -then tcLookupFamInstExact will be confused by the two matches; -but that can't happen because tcInstDecls1 doesn't call tcDeriving -if there are any overlaps. - -There are two other things that might go wrong with the lookup. -First, we might see a standalone deriving clause - deriving Eq (F ()) -when there is no data instance F () in scope. - -Note that it's OK to have - data instance F [a] = ... - deriving Eq (F [(a,b)]) -where the match is not exact; the same holds for ordinary data types -with standalone deriving declrations. - -\begin{code} -tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type]) -tcLookupFamInstExact tycon tys - | not (isOpenTyCon tycon) - = return (tycon, tys) - | otherwise - = do { maybeFamInst <- tcLookupFamInst tycon tys - ; case maybeFamInst of - Nothing -> famInstNotFound tycon tys - Just famInst -> return famInst - } - -famInstNotFound :: TyCon -> [Type] -> TcM a -famInstNotFound tycon tys - = failWithTc (ptext (sLit "No family instance for") - <+> quotes (pprTypeApp tycon tys)) -\end{code} - %************************************************************************ %* * @@ -660,7 +633,7 @@ famInstNotFound tycon tys %************************************************************************ \begin{code} -mkDataTypeEqn :: InstOrigin +mkDataTypeEqn :: CtOrigin -> DynFlags -> [Var] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance @@ -685,7 +658,7 @@ mkDataTypeEqn orig dflags tvs cls cls_tys bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) mk_data_eqn, mk_typeable_eqn - :: InstOrigin -> [TyVar] -> Class + :: CtOrigin -> [TyVar] -> Class -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta @@ -944,17 +917,32 @@ functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] cond_functorOK :: Bool -> Condition --- OK for Functor class +-- OK for Functor/Foldable/Traversable class -- Currently: (a) at least one argument -- (b) don't use argument contravariantly -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) -- (d) optionally: don't use function types +-- (e) no "stupid context" on data type cond_functorOK allowFunctions (dflags, rep_tc) | not (dopt Opt_DeriveFunctor dflags) = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class")) + + | null tc_tvs + = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "has no parameters")) + + | not (null bad_stupid_theta) + = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta) + | otherwise = msum (map check_con data_cons) -- msum picks the first 'Just', if any where + tc_tvs = tyConTyVars rep_tc + Just (_, last_tv) = snocView tc_tvs + bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) + is_bad pred = last_tv `elemVarSet` tyVarsOfPred pred + data_cons = tyConDataCons rep_tc check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con) @@ -1051,7 +1039,7 @@ a context for the Data instances: %************************************************************************ \begin{code} -mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class +mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] -> DerivContext -> TcRn EarlyDerivSpec @@ -1059,7 +1047,7 @@ mkNewTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls) - = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) + = do { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds) ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; let spec = DS { ds_loc = loc, ds_orig = orig @@ -1240,7 +1228,7 @@ inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec] inferInstanceContexts _ [] = return [] inferInstanceContexts oflag infer_specs - = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs)) + = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs) ; iterate_deriv 1 initial_solutions } where ------------------------------------------------------------------ @@ -1283,21 +1271,26 @@ inferInstanceContexts oflag infer_specs , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ addErrCtxt (derivInstCtxt clas inst_tys) $ - do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs - -- checkValidInstance tyvars theta clas inst_tys - -- Not necessary; see Note [Exotic derived instance contexts] - -- in TcSimplify - - -- Check for a bizarre corner case, when the derived instance decl should + do { -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts -- of problems; in particular, it's hard to compare solutions for - -- equality when finding the fixpoint. So I just rule it out for now. + -- equality when finding the fixpoint. Moreover, simplifyDeriv + -- has an assert failure because it finds a TyVar when it expects + -- only TcTyVars. So I just rule it out for now. I'm not + -- even sure how it can arise. + ; let tv_set = mkVarSet tyvars - weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)] + weird_preds = [pred | pred <- deriv_rhs + , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds - ; traceTc (text "TcDeriv" <+> (ppr deriv_rhs $$ ppr theta)) + ; theta <- simplifyDeriv orig tyvars deriv_rhs + -- checkValidInstance tyvars theta clas inst_tys + -- Not necessary; see Note [Exotic derived instance contexts] + -- in TcSimplify + + ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys @@ -1418,12 +1411,14 @@ genInst standalone_deriv oflag spec rep_tycon = ds_tc spec rep_tc_args = ds_tc_args spec co1 = case tyConFamilyCoercion_maybe rep_tycon of - Nothing -> IdCo Just co_con -> ACo (mkTyConApp co_con rep_tc_args) + Nothing -> id_co + -- Not a family => rep_tycon = main tycon co2 = case newTyConCo_maybe rep_tycon of - Nothing -> IdCo -- The newtype is transparent; no need for a cast Just co_con -> ACo (mkTyConApp co_con rep_tc_args) + Nothing -> id_co -- The newtype is transparent; no need for a cast co = co1 `mkTransCoI` co2 + id_co = IdCo (mkTyConApp rep_tycon rep_tc_args) -- Example: newtype instance N [a] = N1 (Tree a) -- deriving instance Eq b => Eq (N [(b,b)])