diff options
Diffstat (limited to 'compiler/GHC/Tc/Deriv/Generics.hs')
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generics.hs | 59 |
1 files changed, 26 insertions, 33 deletions
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 4ad9c8b849..3d71c25b7d 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -27,6 +27,7 @@ import GHC.Core.Type import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor +import GHC.Tc.Errors.Types import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) @@ -47,7 +48,7 @@ import GHC.Builtin.Names import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Session -import GHC.Utils.Error( Validity'(..), Validity, andValid ) +import GHC.Utils.Error( Validity'(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Types.Var.Env @@ -146,7 +147,7 @@ following constraints are satisfied. -} -canDoGenerics :: TyCon -> Validity +canDoGenerics :: TyCon -> Validity' [DeriveGenericsErrReason] -- canDoGenerics determines if Generic/Rep can be derived. -- -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken @@ -158,14 +159,14 @@ canDoGenerics tc = mergeErrors ( -- Check (b) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) + then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name) else IsValid) -- See comment below : (map bad_con (tyConDataCons tc))) where -- The tc can be a representation tycon. When we want to display it to the -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of + tc_name = case tyConFamInst_maybe tc of Just (ptc, _) -> ptc _ -> tc @@ -175,12 +176,12 @@ canDoGenerics tc -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) + bad_con :: DataCon -> Validity' DeriveGenericsErrReason + bad_con dc = if any bad_arg_type (map scaledThing $ dataConOrigArgTys dc) + then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc + else if not (isVanillaDataCon dc) + then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc + else IsValid -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) @@ -194,19 +195,20 @@ canDoGenerics tc allowedUnliftedTy :: Type -> Bool allowedUnliftedTy = isJust . unboxedRepRDRs -mergeErrors :: [Validity] -> Validity +mergeErrors :: [Validity' a] -> Validity' [a] mergeErrors [] = IsValid mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') + IsValid -> NotValid [s] + NotValid s' -> NotValid (s : s') mergeErrors (IsValid : t) = mergeErrors t + -- NotValid s' -> NotValid (s <> text ", and" $$ s') -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type + , _ccdg1_errors :: Validity' DeriveGenericsErrReason -- errors generated by this type } {- @@ -241,15 +243,14 @@ explicitly, even though foldDataConArgs is also doing this internally. -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not. -canDoGenerics1 :: TyCon -> Validity +canDoGenerics1 :: TyCon -> Validity' [DeriveGenericsErrReason] canDoGenerics1 rep_tc = canDoGenerics rep_tc `andValid` additionalChecks where additionalChecks -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" + | null (tyConTyVars rep_tc) = NotValid [ + DerivErrGenericsMustHaveSomeTypeParams rep_tc] | otherwise = mergeErrors $ concatMap check_con data_cons @@ -258,15 +259,12 @@ canDoGenerics1 rep_tc = j@(NotValid {}) -> [j] IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity + check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) + | otherwise = NotValid $ DerivErrGenericsMustNotHaveExistentials con - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s + bmzero = CCDG1 False IsValid + bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con) bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) -- check (e) from Note [Requirements for deriving Generic and Rep] @@ -279,30 +277,25 @@ canDoGenerics1 rep_tc = -- (component_0,component_1,...,component_n) , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg + then bmbad con else foldr bmplus bmzero components -- (dom -> rng), where the head of ty is not a tuple tycon , ft_fun = \dom rng -> -- cf #8516 if _ccdg1_hasParam dom - then bmbad con wrong_arg + then bmbad con else bmplus dom rng -- (ty arg), where head of ty is neither (->) nor a tuple constructor and -- the parameter of interest does not occur in ty , ft_ty_app = \_ _ arg -> arg - , ft_bad_app = bmbad con wrong_arg + , ft_bad_app = bmbad con , ft_forall = \_ body -> body -- polytypes are handled elsewhere } where caseVar = CCDG1 True IsValid - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - {- ************************************************************************ * * |