; 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)
; 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
(sel_tydata ++ sel_deriv_decls)) allTyNames
-- We need to generate the extras to add to what has
-- already been derived
- ; mapM mkGenDerivExtras derTyDecls }
+ ; {- 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) }
-- 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
; 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
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)])
let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
rep0_tycon <- tc_mkRepTyCon tc metaDts
-
+
+ -- pprTrace "rep0" (ppr rep0_tycon) $
return (metaDts, rep0_tycon)
{-
genGenericAll :: TyCon