Sequester deriving-related validity check into cond_stdOK
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 1 Feb 2018 02:36:51 +0000 (21:36 -0500)
committerBen Gamari <ben@smart-cactus.org>
Thu, 1 Feb 2018 04:29:30 +0000 (23:29 -0500)
Currently, any standalone-derived instance must satisfy the
property that the tycon of the data type having an instance being
derived for it must be either a normal ADT tycon or a data family
tycon. But there are several other primitive tycons—such as `(->)`,
`Int#`, and others—which cannot have standalone-derived instances
(via the `anyclass` strategy) as a result of this check! See
https://ghc.haskell.org/trac/ghc/ticket/13154#comment:8 for an
example of where this overly conservative restriction bites.

Really, this validity check only makes sense in the context of
`stock` deriving, where we need the property that the tycon is that
of a normal ADT or a data family in order to inspect its data
constructors. Other deriving strategies don't require this validity
check, so the most sensible way to fix this error is to move the
logic of this check into `cond_stdOK`, which is specific to
`stock` deriving.

This makes progress towards fixing (but does not entirely fix)

Test Plan: make test TEST=T13154a

Reviewers: bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #13154

Differential Revision: https://phabricator.haskell.org/D4337

compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcDerivUtils.hs
testsuite/tests/deriving/should_compile/T13154a.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T

index f0ddce0..2290bce 100644 (file)
@@ -638,11 +638,10 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
               -> do warnUselessTypeable
                     return Nothing
 
-              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
-              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
-                                        tvs cls cls_tys tc tc_args
-                                        (Just theta) deriv_strat
-                    ; return $ Just spec }
+              | otherwise
+              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
+                                    tvs cls cls_tys tc tc_args
+                                    (Just theta) deriv_strat
 
            _  -> -- Complain about functions, primitive types, etc,
                  bale_out $
@@ -1097,12 +1096,13 @@ mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
              -> (SDoc -> DerivM EarlyDerivSpec)
              -> DerivM EarlyDerivSpec
 mk_eqn_stock go_for_it bale_out
-  = do DerivEnv { denv_rep_tc  = rep_tc
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
                 , denv_cls     = cls
                 , denv_cls_tys = cls_tys
                 , denv_mtheta  = mtheta } <- ask
        dflags <- getDynFlags
-       case checkSideConditions dflags mtheta cls cls_tys rep_tc of
+       case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
          CanDerive               -> mk_eqn_stock' go_for_it
          DerivableClassError msg -> bale_out msg
          _                       -> bale_out (nonStdErr cls)
@@ -1146,7 +1146,7 @@ mk_eqn_no_mechanism go_for_it bale_out
              | otherwise
              = nonStdErr cls $$ msg
 
-       case checkSideConditions dflags mtheta cls cls_tys rep_tc of
+       case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
            -- NB: pass the *representation* tycon to checkSideConditions
            NonDerivableClass   msg -> bale_out (dac_error msg)
            DerivableClassError msg -> bale_out msg
@@ -1361,7 +1361,8 @@ mkNewTypeEqn
                   || std_class_via_coercible cls)
           -> go_for_it_gnd
            | otherwise
-          -> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
+          -> case checkSideConditions dflags mtheta cls cls_tys
+                                      tycon rep_tycon of
                DerivableClassError msg
                  -- There's a particular corner case where
                  --
index d6b02dc..eae2fa5 100644 (file)
@@ -418,11 +418,11 @@ getDataConFixityFun tc
 -- family tycon (with indexes) in error messages.
 
 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-                    -> TyCon -- tycon
+                    -> TyCon -> TyCon
                     -> DerivStatus
-checkSideConditions dflags mtheta cls cls_tys rep_tc
+checkSideConditions dflags mtheta cls cls_tys tc rep_tc
   | Just cond <- sideConditions mtheta cls
-  = case (cond dflags rep_tc) of
+  = case (cond dflags tc rep_tc) of
         NotValid err -> DerivableClassError err  -- Class-specific error
         IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
                    -> CanDerive
@@ -497,38 +497,87 @@ canDeriveAnyClass dflags
   | otherwise
   = IsValid   -- OK!
 
-type Condition = DynFlags -> TyCon -> Validity
-        -- TyCon is the *representation* tycon if the data type is an indexed one
-        -- Nothing => OK
+type Condition
+   = DynFlags
+
+  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the
+              -- family 'TyCon'.
+
+  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.
+              -- Otherwise, this is the same as the other 'TyCon' argument.
+
+  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
+              -- possible. Otherwise, it's @'NotValid' err@, where @err@
+              -- explains what went wrong.
 
 orCond :: Condition -> Condition -> Condition
-orCond c1 c2 dflags tc
-  = case (c1 dflags tc, c2 dflags tc) of
+orCond c1 c2 dflags tc rep_tc
+  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of
      (IsValid,    _)          -> IsValid    -- c1 succeeds
      (_,          IsValid)    -> IsValid    -- c21 succeeds
      (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)
                                             -- Both fail
 
 andCond :: Condition -> Condition -> Condition
-andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc
-
-cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
-                           --     if standalone, we just say "yes, go for it"
-           -> Bool         -- True <=> permissive: allow higher rank
-                           --          args and no data constructors
-           -> Condition
-cond_stdOK (Just _) _ _ _
-  = IsValid     -- Don't check these conservative conditions for
+andCond c1 c2 dflags tc rep_tc
+  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc
+
+-- | Some common validity checks shared among stock derivable classes. One
+-- check that absolutely must hold is that if an instance @C (T a)@ is being
+-- derived, then @T@ must be a tycon for a data type or a newtype. The
+-- remaining checks are only performed if using a @deriving@ clause (i.e.,
+-- they're ignored if using @StandaloneDeriving@):
+--
+-- 1. The data type must have at least one constructor (this check is ignored
+--    if using @EmptyDataDeriving@).
+--
+-- 2. The data type cannot have any GADT constructors.
+--
+-- 3. The data type cannot have any constructors with existentially quantified
+--    type variables.
+--
+-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
+--
+-- 5. The data type cannot have fields with higher-rank types.
+cond_stdOK
+  :: DerivContext -- ^ 'Just' if this is standalone deriving, 'Nothing' if not.
+                  -- If it is standalone, we relax some of the validity checks
+                  -- we would otherwise perform (i.e., "just go for it").
+
+  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
+                  -- types (with no data constructors) even in the absence of
+                  -- the -XEmptyDataDeriving extension.
+
+  -> Condition
+cond_stdOK mtheta permissive dflags tc rep_tc
+  = valid_ADT `andValid` valid_misc
+  where
+    valid_ADT, valid_misc :: Validity
+    valid_ADT
+      | isAlgTyCon tc || isDataFamilyTyCon tc
+      = IsValid
+      | otherwise
+        -- Complain about functions, primitive types, and other tycons that
+        -- stock deriving can't handle.
+      = NotValid $ text "The last argument of the instance must be a"
+               <+> text "data or newtype application"
+
+    valid_misc
+      = case mtheta of
+         Just _ -> IsValid
+                -- Don't check these conservative conditions for
                 -- standalone deriving; just generate the code
                 -- and let the typechecker handle the result
-cond_stdOK Nothing permissive dflags rep_tc
-  | null data_cons
-  , not permissive = checkFlag LangExt.EmptyDataDeriving dflags rep_tc
-                     `orValid`
-                     NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
-  | not (null con_whys) = NotValid (vcat con_whys $$ standalone_suggestion)
-  | otherwise           = IsValid
-  where
+         Nothing
+           | null data_cons -- 1.
+           , not permissive
+           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
+              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
+           | not (null con_whys)
+           -> NotValid (vcat con_whys $$ standalone_suggestion)
+           | otherwise
+           -> IsValid
+
     empty_data_suggestion =
       text "Use EmptyDataDeriving to enable deriving for empty data types"
     standalone_suggestion =
@@ -538,13 +587,13 @@ cond_stdOK Nothing permissive dflags rep_tc
 
     check_con :: DataCon -> Validity
     check_con con
-      | not (null eq_spec)
+      | not (null eq_spec) -- 2.
       = bad "is a GADT"
-      | not (null ex_tvs)
+      | not (null ex_tvs) -- 3.
       = bad "has existential type variables in its type"
-      | not (null theta)
+      | not (null theta) -- 4.
       = bad "has constraints in its type"
-      | not (permissive || all isTauTy (dataConOrigArgTys con))
+      | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5.
       = bad "has a higher-rank type"
       | otherwise
       = IsValid
@@ -557,10 +606,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
                      text "must have at least one data constructor"
 
 cond_RepresentableOk :: Condition
-cond_RepresentableOk _ tc = canDoGenerics tc
+cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc
 
 cond_Representable1Ok :: Condition
-cond_Representable1Ok _ tc = canDoGenerics1 tc
+cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc
 
 cond_enumOrProduct :: Class -> Condition
 cond_enumOrProduct cls = cond_isEnumeration `orCond`
@@ -569,13 +618,13 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
 cond_args :: Class -> Condition
 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 -- by generating specialised code.  For others (eg Data) we don't.
-cond_args cls _ tc
+cond_args cls _ _ rep_tc
   = case bad_args of
       []     -> IsValid
       (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
                              2 (text "for type" <+> quotes (ppr ty)))
   where
-    bad_args = [ arg_ty | con <- tyConDataCons tc
+    bad_args = [ arg_ty | con <- tyConDataCons rep_tc
                         , arg_ty <- dataConOrigArgTys con
                         , isUnliftedType arg_ty
                         , not (ok_ty arg_ty) ]
@@ -593,7 +642,7 @@ cond_args cls _ tc
 
 
 cond_isEnumeration :: Condition
-cond_isEnumeration _ rep_tc
+cond_isEnumeration _ rep_tc
   | isEnumerationTyCon rep_tc = IsValid
   | otherwise                 = NotValid why
   where
@@ -603,7 +652,7 @@ cond_isEnumeration _ rep_tc
                   -- See Note [Enumeration types] in TyCon
 
 cond_isProduct :: Condition
-cond_isProduct _ rep_tc
+cond_isProduct _ rep_tc
   | isProductTyCon rep_tc = IsValid
   | otherwise             = NotValid why
   where
@@ -617,7 +666,7 @@ cond_functorOK :: Bool -> Bool -> Condition
 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 --            (d) optionally: don't use function types
 --            (e) no "stupid context" on data type
-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
   | null tc_tvs
   = NotValid (text "Data type" <+> quotes (ppr rep_tc)
               <+> text "must have some type parameters")
@@ -666,7 +715,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
     wrong_arg   = text "must use the type variable only as the last argument of a data type"
 
 checkFlag :: LangExt.Extension -> Condition
-checkFlag flag dflags _
+checkFlag flag dflags _ _
   | xopt flag dflags = IsValid
   | otherwise        = NotValid why
   where
diff --git a/testsuite/tests/deriving/should_compile/T13154a.hs b/testsuite/tests/deriving/should_compile/T13154a.hs
new file mode 100644 (file)
index 0000000..4d60785
--- /dev/null
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module T13154a where
+
+import GHC.Exts
+
+class C1 a
+deriving instance C1 (a -> b)
+
+class C2 (a :: TYPE 'IntRep)
+deriving instance C2 Int#
index 3360c81..a06cd27 100644 (file)
@@ -85,6 +85,7 @@ test('T12594', normal, compile, [''])
 test('T12616', normal, compile, [''])
 test('T12688', normal, compile, [''])
 test('T12814', normal, compile, ['-Wredundant-constraints'])
+test('T13154a', normal, compile, [''])
 test('T13272', normal, compile, [''])
 test('T13272a', normal, compile, [''])
 test('T13297', normal, compile, [''])