-- 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
; let mtheta = Just []
; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta
-- JPM TODO: StandAloneDerivOrigin?...
- ; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds }
-
+ ; return ds }
+-}
-- Make the "extras" for the generic representation
mkGenDerivExtras :: TyCon
-> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
= do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
-- Generate EarlyDerivSpec's for Representable, if asked for
- ; (xGenerics, xDeriveRepresentable) <- genericsFlags
+ -- ; (xGenerics, xDerRep) <- genericsFlags
+ ; xDerRep <- genericsFlag
; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
- ; allTyDecls <- mapM tcLookupTyCon allTyNames
+ -- ; 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 ]
| L _ (DerivDecl (L _ t)) <- deriv_decls
, getClassName t == Just rep0ClassName ]
; 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
-- 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
; 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) }
+ -- Merge and return everything
+ ; 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
+ -- We need extras if the flag DeriveRepresentable is on and this type is
-- deriving Representable
- xDeriveRepresentable && tc_name `elem` tydata
+ needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
-- Extracts the name of the class in the deriving
getClassName :: HsType Name -> Maybe Name
-- Extracts the name of the type in the deriving
getTypeName :: HsType Name -> Maybe Name
- getTypeName (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n
- getTypeName _ = Nothing
+ 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")))
-genericsFlags :: TcM (Bool, Bool)
-genericsFlags = do dOpts <- getDOpts
- return ( xopt Opt_Generics dOpts
- , xopt Opt_DeriveRepresentable dOpts)
+genericsFlag :: TcM Bool
+genericsFlag = do dOpts <- getDOpts
+ return ( xopt Opt_Generics dOpts
+ || xopt Opt_DeriveRepresentable dOpts)
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
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
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, _)
projects / ghc-hetmet.git / blobdiff