ds_cls = c, ds_tys = tys, ds_theta = rhs })
= parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
<+> equals <+> ppr rhs)
+
+instance Outputable DerivSpec where
+ ppr = pprDerivSpec
\end{code}
-- And make the necessary "equations".
is_boot <- tcIsHsBoot
; traceTc "tcDeriving" (ppr is_boot)
- ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; (early_specs, genericsExtras)
+ <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
-- from each type declaration, so this is emptyBag
; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
+{-
-- Generate the generic Representable0 instances
- -- from each type declaration
+ -- from each type declaration
; repInstsMeta <- genGenericRepBinds 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 ++ repInsts)
+ <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts {- ++ repInsts -})
; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds))
-
+{-
; 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
2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
$$ ppr extra_binds)
+
renameDeriv :: Bool -> LHsBinds RdrName
-> [(InstInfo RdrName, DerivAuxBinds)]
-> TcM ([InstInfo Name], HsValBinds Name, DefUses)
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
\begin{code}
+-- Make the EarlyDerivSpec for Representable0
+mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec)
+mkGenDerivSpec tc = do
+ { cls <- tcLookupClass rep0ClassName
+ ; 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?...
+ ; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds }
+
+-- Make the "extras" for the generic representation
+mkGenDerivExtras :: TyCon
+ -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
+mkGenDerivExtras tc = do
+ { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
+ ; metaInsts <- genDtMeta (tc, metaTyCons)
+ ; return (metaTyCons, rep0TyInst, metaInsts) }
+
makeDerivSpecs :: Bool
-> [LTyClDecl Name]
- -> [LInstDecl Name]
+ -> [LInstDecl Name]
-> [LDerivDecl Name]
- -> TcM [EarlyDerivSpec]
-
+ -> 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 [] }
+ ; return ([],[]) }
| otherwise
= do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
- ; return (eqns1 ++ eqns2) }
+ -- Generate EarlyDerivSpec's for Representable, if asked for
+ ; (xGenerics, xDeriveRepresentable) <- genericsFlags
+ ; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
+ ; allTyDecls <- mapM tcLookupTyCon allTyNames
+ -- Select only those types that derive Representable
+ ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
+ , getClassName c == Just rep0ClassName ]
+ ; let sel_deriv_decls = catMaybes [ getTypeName t
+ | L _ (DerivDecl (L _ t)) <- deriv_decls
+ , getClassName t == Just rep0ClassName ]
+ ; derTyDecls <- mapM tcLookupTyCon $
+ filter (needsExtras xDeriveRepresentable
+ (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
+ ; {- pprTrace "allTyDecls" (ppr allTyDecls) $
+ pprTrace "derTyDecls" (ppr derTyDecls) $
+ pprTrace "repTyDecls" (ppr repTyDecls) $
+ pprTrace "remTyDecls" (ppr remTyDecls) $
+ pprTrace "xGenerics" (ppr xGenerics) $
+ pprTrace "xDeriveRep" (ppr xDeriveRepresentable) $
+ pprTrace "all_tydata" (ppr all_tydata) $
+ pprTrace "eqns1" (ppr eqns1) $
+ pprTrace "eqns2" (ppr eqns2) $
+-}
+ return ( eqns1 ++ eqns2 ++ generic_instances
+ , generic_extras_deriv ++ generic_extras_flag) }
where
+ needsExtras xDeriveRepresentable tydata tc_name =
+ -- We need extras if the flag DeriveGenerics is on and this type is
+ -- deriving Representable
+ xDeriveRepresentable && tc_name `elem` tydata
+
+ -- Extracts the name of the class in the deriving
+ getClassName :: HsType Name -> Maybe Name
+ getClassName (HsPredTy (HsClassP n _)) = Just n
+ getClassName _ = Nothing
+
+ -- Extracts the name of the type in the deriving
+ getTypeName :: HsType Name -> Maybe Name
+ getTypeName (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n
+ getTypeName _ = Nothing
+
extractTyDataPreds decls
= [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
2 (ptext (sLit "Use an instance declaration instead")))
+genericsFlags :: TcM (Bool, Bool)
+genericsFlags = do dOpts <- getDOpts
+ return ( xopt Opt_Generics dOpts
+ , xopt Opt_DeriveRepresentable dOpts)
+
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
-- Standalone deriving declarations
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
inferConstraints _ cls inst_tys rep_tc rep_tc_args
+ -- Representable0 constraints are easy
+ | cls `hasKey` rep0ClassKey
+ = []
+ -- The others are a bit more complicated
+ | otherwise
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
stupid_constraints ++ extra_constraints
++ sc_constraints ++ con_arg_constraints
cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
| cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
cond_functorOK False)
+ | cls_key == rep0ClassKey = Just (cond_RepresentableOk `andCond`
+ (checkFlag Opt_DeriveRepresentable `orCond`
+ checkFlag Opt_Generics))
| otherwise = Nothing
where
cls_key = getUnique cls
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "has no data constructors")
+-- JPM TODO: should give better error message
+cond_RepresentableOk :: Condition
+cond_RepresentableOk (_,t) | canDoGenerics t = Nothing
+ | otherwise = Just (ptext (sLit "Cannot derive Representable for type") <+> ppr t)
+
cond_enumOrProduct :: Condition
cond_enumOrProduct = cond_isEnumeration `orCond`
(cond_isProduct `andCond` cond_noUnliftedArgs)
non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- *Never* derive Read,Show,Typeable,Data,Representable0 by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
- = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
- typeableClassKeys)
+ = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+ , rep0ClassKey] ++ typeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
- gen_list = [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(ixClassKey, gen_Ix_binds)
- ,(showClassKey, gen_Show_binds fix_env)
- ,(readClassKey, gen_Read_binds fix_env)
- ,(dataClassKey, gen_Data_binds)
- ,(functorClassKey, gen_Functor_binds)
- ,(foldableClassKey, gen_Foldable_binds)
- ,(traversableClassKey, gen_Traversable_binds)
+ gen_list = [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ,(showClassKey, gen_Show_binds fix_env)
+ ,(readClassKey, gen_Read_binds fix_env)
+ ,(dataClassKey, gen_Data_binds)
+ ,(functorClassKey, gen_Functor_binds)
+ ,(foldableClassKey, gen_Foldable_binds)
+ ,(traversableClassKey, gen_Traversable_binds)
+ ,(rep0ClassKey, gen_Rep0_binds)
]
+\end{code}
--- Generate the binds for the generic representation
+%************************************************************************
+%* *
+\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
+%* *
+%************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Representable0 instance
+\item A Rep0 type instance
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+@gen_Rep0_binds@ does (1)
+@genGenericRepExtras@ does (2) and (3)
+@genGenericRepBind@ does all of them
+
+\begin{code}
+{-
genGenericRepBinds :: Bool -> [LTyClDecl Name]
-> TcM [([(InstInfo RdrName, DerivAuxBinds)]
, MetaTyCons, TyCon)]
return (ASSERT (length inst1 == length metaInsts)
[ (ri : mi, ms, rt)
| ((ri, ms, rt), mi) <- zip inst1 metaInsts ])
+-}
-genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds)
- , MetaTyCons, TyCon)
-genGenericRepBind tc =
- do clas <- tcLookupClass rep0ClassName
- uniqS <- newUniqueSupply
- dfun_name <- new_dfun_name clas tc
+gen_Rep0_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+gen_Rep0_binds _ tc = (mkBindsRep0 tc, [ {- No DerivAuxBinds -} ])
+
+genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras tc =
+ do uniqS <- newUniqueSupply
let
-- Uniques for everyone
(uniqD:uniqs) = uniqsFromSupply uniqS
| (u,m) <- zip uniqsC [0..] ]
s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
| (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
- tvs = tyConTyVars tc
- tc_ty = mkTyConApp tc (mkTyVarTys tvs)
mkTyCon name = ASSERT( isExternalName name )
buildAlgTyCon name [] [] mkAbstractTyConRhs
- NonRecursive False False NoParentTyCon Nothing
+ NonRecursive False NoParentTyCon Nothing
metaDTyCon <- mkTyCon d_name
metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
rep0_tycon <- tc_mkRep0TyCon tc metaDts
+ return (metaDts, rep0_tycon)
+{-
+genGenericRepBind :: TyCon
+ -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
+genGenericRepBind tc =
+ do (metaDts, rep0_tycon) <- genGenericRepExtras tc
+ clas <- tcLookupClass rep0ClassName
+ dfun_name <- new_dfun_name clas tc
let
mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds }
, [ {- No DerivAuxBinds -} ])
inst = mkLocalInstance dfun NoOverlap
binds = VanillaInst (mkBindsRep0 tc) [] False
+
+ tvs = tyConTyVars tc
+ tc_ty = mkTyConApp tc (mkTyVarTys tvs)
dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
return (mkInstRep0, metaDts, rep0_tycon)
-
+-}
genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
genDtMeta (tc,metaDts) =
do dClas <- tcLookupClass datatypeClassName