summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Utils.hs3
-rw-r--r--compiler/typecheck/TcDeriv.hs34
-rw-r--r--compiler/typecheck/TcEnv.hs3
-rw-r--r--compiler/typecheck/TcGenDeriv.hs86
4 files changed, 82 insertions, 44 deletions
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index ac157d4caf..36e0c6d2c4 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -725,9 +725,10 @@ signatures in order to kind-check. Here is an example from #14579:
The derived Eq instance for Glurp (without any kind signatures) would be:
instance Eq a => Eq (Glurp a) where
+ (==) :: Glurp a -> Glurp a -> Bool
(==) = coerce @(Wat2 P -> Wat2 P -> Bool)
@(Glurp a -> Glurp a -> Bool)
- (==) :: Glurp a -> Glurp a -> Bool
+ (==)
(Where the visible type applications use types produced by typeToLHsType.)
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index aa5f5258df..711a30117e 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -42,7 +42,6 @@ import TyCoPpr ( pprTyVars )
import GHC.Rename.Names ( extendGlobalRdrEnvRn )
import GHC.Rename.Binds
import GHC.Rename.Env
-import GHC.Rename.Utils ( bindLocalNamesFV )
import GHC.Rename.Source ( addTcgDUs )
import Avail
@@ -315,12 +314,11 @@ renameDeriv inst_infos bagBinds
, ib_pragmas = sigs
, ib_extensions = exts -- Only for type-checking
, ib_derived = sa } })
- = ASSERT( null sigs )
- bindLocalNamesFV tyvars $
- do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
+ = do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst)
+ tyvars binds sigs
; let binds' = InstBindings { ib_binds = rn_binds
, ib_tyvars = tyvars
- , ib_pragmas = []
+ , ib_pragmas = rn_sigs
, ib_extensions = exts
, ib_derived = sa }
; return (inst_info { iBinds = binds' }, fvs) }
@@ -1846,7 +1844,7 @@ genInst :: DerivSpec theta
genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
, ds_tys = tys, ds_cls = clas, ds_loc = loc
, ds_standalone_wildcard = wildcard })
- = do (meth_binds, deriv_stuff, unusedNames)
+ = do (meth_binds, meth_sigs, deriv_stuff, unusedNames)
<- set_span_and_ctxt $
genDerivStuff mechanism loc clas tys tvs
let mk_inst_info theta = set_span_and_ctxt $ do
@@ -1858,7 +1856,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
, iBinds = InstBindings
{ ib_binds = meth_binds
, ib_tyvars = map Var.varName tvs
- , ib_pragmas = []
+ , ib_pragmas = meth_sigs
, ib_extensions = extensions
, ib_derived = True } }
return (mk_inst_info, deriv_stuff, unusedNames)
@@ -1866,9 +1864,14 @@ genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism
extensions :: [LangExt.Extension]
extensions
| isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
- -- Both these flags are needed for higher-rank uses of coerce
- -- See Note [Newtype-deriving instances] in TcGenDeriv
- = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]
+ = [
+ -- Both these flags are needed for higher-rank uses of coerce...
+ LangExt.ImpredicativeTypes, LangExt.RankNTypes
+ -- ...and this flag is needed to support the instance signatures
+ -- that bring type variables into scope.
+ -- See Note [Newtype-deriving instances] in TcGenDeriv
+ , LangExt.InstanceSigs
+ ]
| otherwise
= []
@@ -2035,7 +2038,7 @@ derivingThingFailWith newtype_deriving msg = do
genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
-> [Type] -> [TyVar]
- -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
genDerivStuff mechanism loc clas inst_tys tyvars
= case mechanism of
-- See Note [Bindings for Generalised Newtype Deriving]
@@ -2045,7 +2048,8 @@ genDerivStuff mechanism loc clas inst_tys tyvars
-- Try a stock deriver
DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc}
, dsm_stock_gen_fn = gen_fn }
- -> gen_fn loc rep_tc inst_tys
+ -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+ pure (binds, [], faminsts, field_names)
-- Try DeriveAnyClass
DerivSpecAnyClass -> do
@@ -2059,7 +2063,7 @@ genDerivStuff mechanism loc clas inst_tys tyvars
, ppr "genDerivStuff: bad derived class" <+> ppr clas )
mapM (tcATDefault loc mini_subst emptyNameSet)
(classATItems clas)
- return ( emptyBag -- No method bindings are needed...
+ return ( emptyBag, [] -- No method bindings are needed...
, listToBag (map DerivFamInst (concat tyfam_insts))
-- ...but we may need to generate binding for associated type
-- family default instances.
@@ -2071,8 +2075,8 @@ genDerivStuff mechanism loc clas inst_tys tyvars
-> gen_newtype_or_via via_ty
where
gen_newtype_or_via ty = do
- (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
- return (binds, faminsts, [])
+ (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
+ return (binds, sigs, faminsts, [])
{-
Note [Bindings for Generalised Newtype Deriving]
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 37eb4c2f98..c525ce15e9 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -952,7 +952,8 @@ pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> text "where")
2 (details (iBinds info))
where
- details (InstBindings { ib_binds = b }) = pprLHsBinds b
+ details (InstBindings { ib_pragmas = p, ib_binds = b }) =
+ pprDeclList (pprLHsBindsForUser b p)
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 4e6bbc935b..c81d15cf86 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1610,9 +1610,10 @@ coercing from. So from, say,
newtype T x = MkT <rep-ty>
instance C a <rep-ty> => C a (T x) where
- op = coerce @ (a -> [<rep-ty>] -> c -> Int)
- @ (a -> [T x] -> c -> Int)
- op :: forall c. a -> [T x] -> c -> Int
+ op :: forall c. a -> [T x] -> c -> Int
+ op = coerce @(a -> [<rep-ty>] -> c -> Int)
+ @(a -> [T x] -> c -> Int)
+ op
In addition to the type applications, we also have an explicit
type signature on the entire RHS. This brings the method-bound variable
@@ -1632,16 +1633,17 @@ a polytype. E.g.
class C a where op :: a -> forall b. b -> b
newtype T x = MkT <rep-ty>
instance C <rep-ty> => C (T x) where
- op = coerce @ (<rep-ty> -> forall b. b -> b)
- @ (T x -> forall b. b -> b)
- op :: T x -> forall b. b -> b
+ op :: T x -> forall b. b -> b
+ op = coerce @(<rep-ty> -> forall b. b -> b)
+ @(T x -> forall b. b -> b)
+ op
The use of type applications is crucial here. If we had tried using only
explicit type signatures, like so:
instance C <rep-ty> => C (T x) where
+ op :: T x -> forall b. b -> b
op = coerce (op :: <rep-ty> -> forall b. b -> b)
- :: T x -> forall b. b -> b
Then GHC will attempt to deeply skolemize the two type signatures, which will
wreak havoc with the Coercible solver. Therefore, we instead use type
@@ -1721,23 +1723,26 @@ See Note [Instances in no-evidence implications] in TcInteract.
But this isn't the death knell for combining QuantifiedConstraints with GND.
On the contrary, if we generate GND bindings in a slightly different way, then
we can avoid this situation altogether. Instead of applying `coerce` to two
-polymorphic types, we instead let an explicit type signature do the polymorphic
+polymorphic types, we instead let an instance signature do the polymorphic
instantiation, and omit the `forall`s in the type applications.
More concretely, we generate the following code instead:
instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
C (T m) where
+ join :: forall a. T m (T m a) -> T m a
join = coerce @( m (m a) -> m a)
@(T m (T m a) -> T m a)
- join :: forall a. T m (T m a) -> T m a
+ join
-Now the visible type arguments are both monotypes, so we need do any of this
-funny quantified constraint instantiation business.
+Now the visible type arguments are both monotypes, so we don't need any of this
+funny quantified constraint instantiation business. While this particular
+example no longer uses impredicative instantiation, we still need to enable
+ImpredicativeTypes to typecheck GND-generated code for class methods with
+higher-rank types. See Note [Newtype-deriving instances].
You might think that that second @(T m (T m a) -> T m a) argument is redundant
-in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
-signature, but in fact leaving it off will break this example (from the
-T15290d test case):
+in the presence of the instance signature, but in fact leaving it off will
+break this example (from the T15290d test case):
class C a where
c :: Int -> forall b. b -> a
@@ -1745,14 +1750,15 @@ T15290d test case):
instance C Int
instance C Age where
+ c :: Int -> forall b. b -> Age
c = coerce @(Int -> forall b. b -> Int)
- c :: Int -> forall b. b -> Age
+ c
-That is because the explicit type signature deeply skolemizes the forall-bound
+That is because the instance signature deeply skolemizes the forall-bound
`b`, which wreaks havoc with the `Coercible` solver. An additional visible type
argument of @(Int -> forall b. b -> Age) is enough to prevent this.
-Be aware that the use of an explicit type signature doesn't /solve/ this
+Be aware that the use of an instance signature doesn't /solve/ this
problem; it just makes it less likely to occur. For example, if a class has
a truly higher-rank type like so:
@@ -1775,8 +1781,8 @@ ambiguous type variables. As one example, consider the following example
A naïve attempt and generating a C T instance would be:
instance C T where
+ f :: String
f = coerce @String @String f
- :: String
This isn't going to typecheck, however, since GHC doesn't know what to
instantiate the type variable `a` with in the call to `f` in the method body.
@@ -1784,8 +1790,8 @@ instantiate the type variable `a` with in the call to `f` in the method body.
ambiguity here, we explicitly instantiate `a` like so:
instance C T where
+ f :: String
f = coerce @String @String (f @())
- :: String
All better now.
-}
@@ -1797,32 +1803,58 @@ gen_Newtype_binds :: SrcSpan
-- newtype itself)
-> [Type] -- instance head parameters (incl. newtype)
-> Type -- the representation type
- -> TcM (LHsBinds GhcPs, BagDerivStuff)
+ -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
-- See Note [Newtype-deriving instances]
gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
= do let ats = classATs cls
+ (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
mapM mk_atf_inst ats
- return ( listToBag $ map mk_bind (classMethods cls)
+ return ( listToBag binds
+ , sigs
, listToBag $ map DerivFamInst atf_insts )
where
- mk_bind :: Id -> LHsBind GhcPs
- mk_bind meth_id
- = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
- (mkPrefixFunRhs (L loc meth_RDR))
- [] rhs_expr]
+ -- For each class method, generate its derived binding and instance
+ -- signature. Using the first example from
+ -- Note [Newtype-deriving instances]:
+ --
+ -- class C a b where
+ -- op :: forall c. a -> [b] -> c -> Int
+ --
+ -- newtype T x = MkT <rep-ty>
+ --
+ -- Then we would generate <derived-op-impl> below:
+ --
+ -- instance C a <rep-ty> => C a (T x) where
+ -- <derived-op-impl>
+ mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
+ mk_bind_and_sig meth_id
+ = ( -- The derived binding, e.g.,
+ --
+ -- op = coerce @(a -> [<rep-ty>] -> c -> Int)
+ -- @(a -> [T x] -> c -> Int)
+ -- op
+ mkRdrFunBind loc_meth_RDR [mkSimpleMatch
+ (mkPrefixFunRhs loc_meth_RDR)
+ [] rhs_expr]
+ , -- The derived instance signature, e.g.,
+ --
+ -- op :: forall c. a -> [T x] -> c -> Int
+ L loc $ ClassOpSig noExtField False [loc_meth_RDR]
+ $ mkLHsSigType $ typeToLHsType to_ty
+ )
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
(_, _, from_tau) = tcSplitSigmaTy from_ty
(_, _, to_tau) = tcSplitSigmaTy to_ty
meth_RDR = getRdrName meth_id
+ loc_meth_RDR = L loc meth_RDR
rhs_expr = nlHsVar (getRdrName coerceId)
`nlHsAppType` from_tau
`nlHsAppType` to_tau
`nlHsApp` meth_app
- `nlExprWithTySig` to_ty
-- The class method, applied to all of the class instance types
-- (including the representation type) to avoid potential ambiguity.
View Lorry Controller Status