X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=fab7c61ff07cd2e388a1bf4a0d7141255c112e18;hp=a3ce1a9f2729265157cb6e2c9b7f788d9f552e38;hb=74e1e73af872e63fbbec2bc9442494c3657053c3;hpb=a5673c5bcc20a9504c523c122112b935962dafe3 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index a3ce1a9..fab7c61 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -327,21 +327,12 @@ tcDeriving tycl_decls inst_decls deriv_decls -- from each type declaration, so this is emptyBag ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls -{- - -- Generate the Generic instances - -- from each type declaration - ; repInstsMeta <- genGenericAlls is_boot tycl_decls - - ; let repInsts = concat (map (\(a,_,_) -> a) repInstsMeta) - repMetaTys = map (\(_,b,_) -> b) repInstsMeta - repTyCons = map (\(_,_,c) -> c) repInstsMeta --} ; (inst_info, rn_binds, rn_dus) - <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts {- ++ repInsts -}) + <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts) ; dflags <- getDOpts ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds)) + (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts)) {- ; when (not (null inst_info)) $ dumpDerivingInfo (ddump_deriving inst_info rn_binds) @@ -349,11 +340,26 @@ tcDeriving tycl_decls inst_decls deriv_decls ; return ( inst_info, rn_binds, rn_dus , concat (map metaTyCons2TyCons repMetaTys), repTyCons) } where - ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc - ddump_deriving inst_infos extra_binds - = hang (ptext (sLit "Derived instances")) - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) - $$ ppr extra_binds) + ddump_deriving :: [InstInfo Name] -> HsValBinds Name + -> [MetaTyCons] -- ^ Empty data constructors + -> [TyCon] -- ^ Rep type family instances + -> [[(InstInfo RdrName, DerivAuxBinds)]] + -- ^ Instances for the repMetaTys + -> SDoc + ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts + = hang (ptext (sLit "Derived instances")) + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) + $$ ppr extra_binds) + $$ hangP "Generic representation" ( + hangP "Generated datatypes for meta-information" + (vcat (map ppr repMetaTys)) + -- The Outputable instance for TyCon unfortunately only prints the name... + $$ hangP "Representation types" + (vcat (map ppr repTyCons)) + $$ hangP "Meta-information instances" + (vcat (map (pprInstInfoDetails . fst) (concat metaInsts)))) + + hangP s x = text "" $$ hang (ptext (sLit s)) 2 x renameDeriv :: Bool -> LHsBinds RdrName @@ -413,22 +419,6 @@ renameDeriv is_boot gen_binds insts where (tyvars,_, clas,_) = instanceHead inst clas_nm = className clas - ------------------------------------------ -{- Now unused -mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) -mkGenericBinds is_boot tycl_decls - | is_boot - = return emptyBag - | otherwise - = 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 --} \end{code} Note [Newtype deriving and unused constructors] @@ -460,19 +450,6 @@ stored in NewTypeDerived. @makeDerivSpecs@ fishes around to find the info about needed derived instances. \begin{code} -{- --- Make the EarlyDerivSpec for Generic -mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec) -mkGenDerivSpec tc = do - { cls <- tcLookupClass genClassName - ; let tc_tvs = tyConTyVars tc - ; let tc_app = mkTyConApp tc (mkTyVarTys tc_tvs) - ; let cls_tys = [] - ; let mtheta = Just [] - ; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta - -- JPM TODO: StandAloneDerivOrigin?... - ; return ds } --} -- Make the "extras" for the generic representation mkGenDerivExtras :: TyCon -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)]) @@ -488,17 +465,21 @@ makeDerivSpecs :: Bool -> TcM ( [EarlyDerivSpec] , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])]) makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - | is_boot -- No 'deriving' at all in hs-boot files - = do { mapM_ add_deriv_err deriv_locs - ; return ([],[]) } + | is_boot -- No 'deriving' at all in hs-boot files + = do { mapM_ add_deriv_err deriv_locs + ; return ([],[]) } | otherwise - = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata - ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - -- Generate EarlyDerivSpec's for Generic, if asked for - -- ; (xGenerics, xDerRep) <- genericsFlags - ; xDerRep <- genericsFlag - ; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] - -- ; allTyDecls <- mapM tcLookupTyCon allTyNames + = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata + ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls + + -- Generic representation stuff: we might need to add some "extras" + -- to the instances + ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric + ; generic_extras_deriv <- if not xDerRep + -- No extras if the flag is off + then (return []) + else do { + let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] -- Select only those types that derive Generic ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata , getClassName c == Just genClassName ] @@ -510,23 +491,14 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls (sel_tydata ++ sel_deriv_decls)) allTyNames -- We need to generate the extras to add to what has -- already been derived - ; generic_extras_deriv <- mapM mkGenDerivExtras derTyDecls - -- For the remaining types, if Generics is on, we need to - -- generate both the instances and the extras, but only for the - -- types we can represent. -{- - ; let repTyDecls = filter canDoGenerics allTyDecls - ; let remTyDecls = filter (\x -> not (x `elem` derTyDecls)) repTyDecls - ; generic_instances <- if xGenerics - then mapM mkGenDerivSpec remTyDecls - else return [] - ; generic_extras_flag <- if xGenerics - then mapM mkGenDerivExtras remTyDecls - else return [] --} - -- Merge and return everything - ; return ( eqns1 ++ eqns2 -- ++ generic_instances - , generic_extras_deriv {- ++ generic_extras_flag -}) } + ; {- pprTrace "sel_tydata" (ppr sel_tydata) $ + pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $ + pprTrace "derTyDecls" (ppr derTyDecls) $ + pprTrace "deriv_decls" (ppr deriv_decls) $ -} + mapM mkGenDerivExtras derTyDecls } + + -- Merge and return + ; return ( eqns1 ++ eqns2, generic_extras_deriv) } where -- We need extras if the flag DeriveGeneric is on and this type is -- deriving Generic @@ -534,34 +506,37 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls -- Extracts the name of the class in the deriving getClassName :: HsType Name -> Maybe Name - getClassName (HsPredTy (HsClassP n _)) = Just n - getClassName _ = Nothing + getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n + getClassName (HsPredTy (HsClassP n _)) = Just n + getClassName _ = Nothing -- Extracts the name of the type in the deriving + -- This function (and also getClassName above) is not really nice, and I + -- might not have covered all possible cases. I wonder if there is no easier + -- way to extract class and type name from a LDerivDecl... getTypeName :: HsType Name -> Maybe Name + getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n getTypeName (HsTyVar n) = Just n getTypeName (HsOpTy _ (L _ n) _) = Just n getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n + getTypeName (HsAppTy (L _ n) _) = getTypeName n + getTypeName (HsParTy (L _ n)) = getTypeName n + getTypeName (HsKindSig (L _ n) _) = getTypeName n getTypeName _ = Nothing extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] all_tydata :: [(LHsType Name, LTyClDecl Name)] - -- Derived predicate paired with its data type declaration + -- Derived predicate paired with its data type declaration all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls) deriv_locs = map (getLoc . snd) all_tydata - ++ map getLoc deriv_decls + ++ map getLoc deriv_decls add_deriv_err loc = setSrcSpan loc $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) - -genericsFlag :: TcM Bool -genericsFlag = do dOpts <- getDOpts - return ( xopt Opt_Generics dOpts - || xopt Opt_DeriveGeneric dOpts) + addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) + 2 (ptext (sLit "Use an instance declaration instead"))) ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec @@ -991,12 +966,7 @@ no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have at least one data constructor") --- JPM TODO: should give better error message cond_RepresentableOk :: Condition -{- -cond_RepresentableOk (_,t) | canDoGenerics t = Nothing - | otherwise = Just (ptext (sLit "Cannot derive Generic for type") <+> ppr t) --} cond_RepresentableOk (_,t) = canDoGenerics t cond_enumOrProduct :: Condition @@ -1413,7 +1383,7 @@ inferInstanceContexts oflag infer_specs ; let tv_set = mkVarSet tyvars weird_preds = [pred | pred <- deriv_rhs - , not (tyVarsOfPred pred `subVarSet` tv_set)] + , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs @@ -1544,14 +1514,12 @@ genInst standalone_deriv oflag where inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) + Just co_con -> mkAxInstCo co_con rep_tc_args Nothing -> id_co -- Not a family => rep_tycon = main tycon - co2 = case newTyConCo_maybe rep_tycon of - 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) + co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args + co = co1 `mkTransCo` co2 + id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) -- Example: newtype instance N [a] = N1 (Tree a) -- deriving instance Eq b => Eq (N [(b,b)]) @@ -1649,7 +1617,8 @@ genGenericRepExtras tc = let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons rep0_tycon <- tc_mkRepTyCon tc metaDts - + + -- pprTrace "rep0" (ppr rep0_tycon) $ return (metaDts, rep0_tycon) {- genGenericAll :: TyCon