X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=d7c80c4016b6e21f43c8a930ed747362d5215457;hb=f04dead93a15af1cb818172f207b8a81d2c81298;hp=e121cc6e2ec7febb9dd566086813f6b8d9e6854a;hpb=5eb2190d2aebc6e1a11780a43d31cbc7e831dd78;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index e121cc6..d7c80c4 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -288,15 +288,15 @@ tcDeriving tycl_decls inst_decls deriv_decls ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs - ; insts1 <- mapM (genInst overlap_flag) given_specs + ; insts1 <- mapM (genInst True overlap_flag) given_specs ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ inferInstanceContexts overlap_flag infer_specs - ; insts2 <- mapM (genInst overlap_flag) final_specs + ; insts2 <- mapM (genInst False overlap_flag) final_specs -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds is_boot + ; gen_binds <- mkGenericBinds is_boot tycl_decls ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2) ; dflags <- getDOpts @@ -353,27 +353,28 @@ renameDeriv is_boot gen_binds insts rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }) = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived co }, emptyFVs) - rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs }) + rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv }) = -- Bring the right type variables into -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars) $ do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds - ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }, fvs) } + ; let binds' = VanillaInst rn_binds [] standalone_deriv + ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) } where (tyvars,_,clas,_) = instanceHead inst clas_nm = className clas ----------------------------------------- -mkGenericBinds :: Bool -> TcM (LHsBinds RdrName) -mkGenericBinds is_boot +mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) +mkGenericBinds is_boot tycl_decls | is_boot = return emptyBag | otherwise - = do { gbl_env <- getGblEnv - ; let tcs = typeEnvTyCons (tcg_type_env gbl_env) - ; return (unionManyBags [ mkTyConGenericBinds tc | - tc <- tcs, tyConHasGenerics tc ]) } + = do { tcs <- mapM tcLookupTyCon [ tcdName d + | L _ d <- tycl_decls, isDataDecl d ] + ; return (unionManyBags [ mkTyConGenericBinds tc + | tc <- tcs, tyConHasGenerics tc ]) } -- We are only interested in the data type declarations, -- and then only in the ones whose 'has-generics' flag is on -- The predicate tyConHasGenerics finds both of these @@ -651,12 +652,14 @@ mkDataTypeEqn :: InstOrigin mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta - = case checkSideConditions dflags cls cls_tys rep_tc of - -- NB: pass the *representation* tycon to checkSideConditions - CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta - NonDerivableClass -> bale_out (nonStdErr cls) - DerivableClassError msg -> bale_out msg + | isJust mtheta = go_for_it -- Do not test side conditions for standalone deriving + | otherwise = case checkSideConditions dflags cls cls_tys rep_tc of + -- NB: pass the *representation* tycon to checkSideConditions + CanDerive -> go_for_it + NonDerivableClass -> bale_out (nonStdErr cls) + DerivableClassError msg -> bale_out msg where + go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg) mk_data_eqn, mk_typeable_eqn @@ -1022,18 +1025,18 @@ mkNewTypeEqn orig dflags tvs ; return (if isJust mtheta then Right spec else Left spec) } + | isJust mtheta = go_for_it -- Do not check side conditions for standalone deriving | otherwise - = case check_conditions of - CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta - -- Use the standard H98 method - DerivableClassError msg -> bale_out msg -- Error with standard class + = case checkSideConditions dflags cls cls_tys rep_tycon of + CanDerive -> go_for_it -- Use the standard H98 method + DerivableClassError msg -> bale_out msg -- Error with standard class NonDerivableClass -- Must use newtype deriving | newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving | otherwise -> bale_out non_std_err -- Try newtype deriving! where newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags - check_conditions = checkSideConditions dflags cls cls_tys rep_tycon - bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg) + go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta + bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg) non_std_err = nonStdErr cls $$ ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension") @@ -1347,26 +1350,25 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) -genInst oflag spec +genInst :: Bool -- True <=> standalone deriving + -> OverlapFlag + -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) +genInst standalone_deriv oflag spec | ds_newtype spec = return (InstInfo { iSpec = mkInstance oflag (ds_theta spec) spec , iBinds = NewTypeDerived co }, []) | otherwise - = do { let loc = getSrcSpan (ds_name spec) - inst = mkInstance oflag (ds_theta spec) spec - clas = ds_cls spec + = do { let loc = getSrcSpan (ds_name spec) + inst = mkInstance oflag (ds_theta spec) spec + clas = ds_cls spec -- In case of a family instance, we need to use the representation -- tycon (after all, it has the data constructors) ; fix_env <- getFixityEnv ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon - - -- Build the InstInfo - ; return (InstInfo { iSpec = inst, - iBinds = VanillaInst meth_binds [] }, - aux_binds) + binds = VanillaInst meth_binds [] standalone_deriv + ; return (InstInfo { iSpec = inst, iBinds = binds }, aux_binds) } where rep_tycon = ds_tc spec @@ -1385,6 +1387,7 @@ genInst oflag spec -- When dealing with the deriving clause -- co1 : N [(b,b)] ~ R1:N (b,b) -- co2 : R1:N (b,b) ~ Tree (b,b) +-- co : N [(b,b)] ~ Tree (b,b) genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) genDerivBinds loc fix_env clas tycon