-- 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
- ; 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 ++ 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)
; 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
-- 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
(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]
@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)])
-> 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 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
+ = 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 rep0ClassName ]
+ , getClassName c == Just genClassName ]
; let sel_deriv_decls = catMaybes [ getTypeName t
| L _ (DerivDecl (L _ t)) <- deriv_decls
- , getClassName t == Just rep0ClassName ]
+ , getClassName t == Just genClassName ]
; derTyDecls <- mapM tcLookupTyCon $
- filter (needsExtras xDeriveRepresentable
+ 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
- ; {- 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) }
+ ; {- 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
- 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
+ -- We need extras if the flag DeriveGeneric is on and this type is
+ -- deriving Generic
+ 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
+ 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 (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n
- getTypeName _ = Nothing
+ 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")))
-
-genericsFlags :: TcM (Bool, Bool)
-genericsFlags = do dOpts <- getDOpts
- return ( xopt Opt_Generics dOpts
- , xopt Opt_DeriveRepresentable 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
-- 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
+ -- Generic constraints are easy
+ | cls `hasKey` genClassKey
= []
-- The others are a bit more complicated
| otherwise
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))
+ | cls_key == genClassKey = Just (cond_RepresentableOk `andCond`
+ checkFlag Opt_DeriveGeneric)
| 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
check_con con
| isVanillaDataCon con
, all isTauTy (dataConOrigArgTys con) = Nothing
- | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
+ | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
no_cons_why :: TyCon -> SDoc
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "has no data constructors")
+ 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 Representable for type") <+> ppr t)
+cond_RepresentableOk (_,t) = canDoGenerics t
cond_enumOrProduct :: Condition
cond_enumOrProduct = cond_isEnumeration `orCond`
where
bad_cons = [ con | con <- tyConDataCons tc
, any isUnLiftedType (dataConOrigArgTys con) ]
- why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
+ why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
cond_isEnumeration :: Condition
cond_isEnumeration (_, rep_tc)
| otherwise = Just why
where
why = sep [ quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "is not an enumeration type")
+ ptext (sLit "must be an enumeration type")
, ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
-- See Note [Enumeration types] in TyCon
| otherwise = Just why
where
why = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "does not have precisely one constructor")
+ ptext (sLit "must have precisely one constructor")
cond_typeableOK :: Condition
-- OK for Typeable class
| otherwise = Nothing
where
too_many = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has too many arguments")
+ ptext (sLit "must have 7 or fewer arguments")
bad_kind = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has arguments of kind other than `*'")
+ ptext (sLit "must only have arguments of kind `*'")
functorLikeClassKeys :: [Unique]
functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
cond_functorOK allowFunctions (_, rep_tc)
| null tc_tvs
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has no parameters"))
+ <+> ptext (sLit "must have some type parameters"))
| not (null bad_stupid_theta)
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
+ <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
| otherwise
= msum (map check_con data_cons) -- msum picks the first 'Just', if any
, ft_bad_app = Just (badCon con wrong_arg)
, ft_forall = \_ x -> x }
- existential = ptext (sLit "has existential arguments")
- covariant = ptext (sLit "uses the type variable in a function argument")
- functions = ptext (sLit "contains function types")
- wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
+ existential = ptext (sLit "must not have existential arguments")
+ covariant = ptext (sLit "must not use the type variable in a function argument")
+ functions = ptext (sLit "must not contain function types")
+ wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last")
checkFlag :: ExtensionFlag -> Condition
checkFlag flag (dflags, _)
non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data,Representable0 by isomorphism,
+-- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
= classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
- , rep0ClassKey] ++ typeableClassKeys)
+ , genClassKey] ++ typeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
; 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)])
,(functorClassKey, gen_Functor_binds)
,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds)
- ,(rep0ClassKey, gen_Rep0_binds)
+ ,(genClassKey, genGenericBinds)
]
\end{code}
For the generic representation we need to generate:
\begin{itemize}
-\item A Representable0 instance
-\item A Rep0 type instance
+\item A Generic instance
+\item A Rep type instance
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}
-@gen_Rep0_binds@ does (1)
+@genGenericBinds@ does (1)
@genGenericRepExtras@ does (2) and (3)
-@genGenericRepBind@ does all of them
+@genGenericAll@ does all of them
\begin{code}
-{-
-genGenericRepBinds :: Bool -> [LTyClDecl Name]
- -> TcM [([(InstInfo RdrName, DerivAuxBinds)]
- , MetaTyCons, TyCon)]
-genGenericRepBinds isBoot tyclDecls
- | isBoot = return []
- | otherwise = do
- allTyDecls <- mapM tcLookupTyCon [ tcdName d | L _ d <- tyclDecls
- , isDataDecl d ]
- let tyDecls = filter tyConHasGenerics allTyDecls
- inst1 <- mapM genGenericRepBind tyDecls
- let (_repInsts, metaTyCons, _repTys) = unzip3 inst1
- metaInsts <- ASSERT (length tyDecls == length metaTyCons)
- mapM genDtMeta (zip tyDecls metaTyCons)
- return (ASSERT (length inst1 == length metaInsts)
- [ (ri : mi, ms, rt)
- | ((ri, ms, rt), mi) <- zip inst1 metaInsts ])
--}
-
-gen_Rep0_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
-gen_Rep0_binds _ tc = (mkBindsRep0 tc, [ {- No DerivAuxBinds -} ])
+genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
genGenericRepExtras tc =
let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
- rep0_tycon <- tc_mkRep0TyCon tc metaDts
-
+ rep0_tycon <- tc_mkRepTyCon tc metaDts
+
+ -- pprTrace "rep0" (ppr rep0_tycon) $
return (metaDts, rep0_tycon)
{-
-genGenericRepBind :: TyCon
+genGenericAll :: TyCon
-> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
-genGenericRepBind tc =
+genGenericAll tc =
do (metaDts, rep0_tycon) <- genGenericRepExtras tc
- clas <- tcLookupClass rep0ClassName
+ clas <- tcLookupClass genClassName
dfun_name <- new_dfun_name clas tc
let
- mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds }
+ mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
, [ {- No DerivAuxBinds -} ])
inst = mkLocalInstance dfun NoOverlap
- binds = VanillaInst (mkBindsRep0 tc) [] False
+ binds = VanillaInst (mkBindsRep 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)
+ return (mkInstRep, metaDts, rep0_tycon)
-}
genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
genDtMeta (tc,metaDts) =
projects / ghc-hetmet.git / blobdiff