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
; insts2 <- mapM (genInst False overlap_flag) final_specs
- -- Generate the (old) generic to/from functions from each type declaration
+ -- We no longer generate the old generic to/from functions
+ -- from each type declaration, so this is emptyBag
; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
- -- Generate the generic Representable0/1 instances from each type declaration
- ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls
+{-
+ -- Generate the generic Representable0 instances
+ -- 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
- -- Should we extendLocalInstEnv with repInsts?
-
- ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ repInsts)
+-}
+ ; (inst_info, rn_binds, rn_dus)
+ <- 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)
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
- do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+ do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
; let binds' = VanillaInst rn_binds [] standalone_deriv
; return (inst_info { iBinds = binds' }, fvs) }
where
@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?...
+ ; 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, xDerRep) <- genericsFlags
+ ; xDerRep <- genericsFlag
+ ; 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 xDerRep
+ (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 -}) }
where
+ -- We need extras if the flag DeriveRepresentable is on and this type is
+ -- deriving Representable
+ needsExtras xDerRep tydata tc_name = xDerRep && 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 (HsTyVar n) = Just n
+ getTypeName (HsOpTy _ (L _ n) _) = Just n
+ getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName 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")))
+genericsFlag :: TcM Bool
+genericsFlag = 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
Nothing -> Nothing -- c1 succeeds
Just x -> case c2 tc of -- c1 fails
Nothing -> Nothing
- Just y -> Just (x $$ ptext (sLit " and") $$ y)
+ Just y -> Just (x $$ ptext (sLit " or") $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition
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
gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
, ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
= setSrcSpan loc $
- addErrCtxt (derivInstCtxt clas inst_tys) $
+ addErrCtxt (derivInstCtxt the_pred) $
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
, not (tyVarsOfPred pred `subVarSet` tv_set)]
; mapM_ (addErrTc . badDerivedPred) weird_preds
- ; theta <- simplifyDeriv orig tyvars deriv_rhs
+ ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
-- Hence no need to call:
-- checkValidInstance tyvars theta clas inst_tys
; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
+ where
+ the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
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
standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
2 (quotes (ppr ty))
-derivInstCtxt :: Class -> [Type] -> Message
-derivInstCtxt clas inst_tys
- = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
+derivInstCtxt :: PredType -> Message
+derivInstCtxt pred
+ = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
badDerivedPred :: PredType -> Message
badDerivedPred pred
projects / ghc-hetmet.git / blobdiff