diff options
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 66 | ||||
| -rw-r--r-- | testsuite/tests/th/T10598_TH.stderr | 6 | ||||
| -rw-r--r-- | testsuite/tests/th/T5700.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/T5883.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/T7532.stderr | 4 |
5 files changed, 55 insertions, 25 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index a1ea110cf6..ad4abf89e7 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -260,7 +260,7 @@ cvtDec (InstanceD o ctxt ty decs) ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty - ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' } + ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' ; returnJustL $ InstD $ ClsInstD $ ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' @@ -346,7 +346,7 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext cxt ; L loc ty' <- cvtType ty - ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' } + ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustL $ DerivD $ DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds , deriv_type = mkLHsSigType inst_ty' @@ -510,16 +510,9 @@ cvtConstr (ForallC tvs ctxt con) ; L _ con' <- cvtConstr con ; returnL $ case con' of ConDeclGADT { con_type = conT } -> - let hs_ty - | null tvs = rho_ty - | otherwise = noLoc $ HsForAllTy - { hst_bndrs = hsq_explicit tvs' - , hst_body = rho_ty } - rho_ty - | null ctxt = hsib_body conT - | otherwise = noLoc $ HsQualTy - { hst_ctxt = L loc ctxt' - , hst_body = hsib_body conT } + let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty + rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt') + (hsib_body conT) in con' { con_type = HsIB PlaceHolder hs_ty } ConDeclH98 {} -> let qvars = case (tvs, con_qvars con') of @@ -1221,12 +1214,8 @@ cvtTypeKind ty_str ty ; cxt' <- cvtContext cxt ; ty' <- cvtType ty ; loc <- getL - ; let hs_ty | null tvs = rho_ty - | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs' - , hst_body = rho_ty }) - rho_ty | null cxt = ty' - | otherwise = L loc (HsQualTy { hst_ctxt = cxt' - , hst_body = ty' }) + ; let hs_ty = mkHsForAllTy tvs loc tvs' rho_ty + rho_ty = mkHsQualTy cxt loc cxt' ty' ; return hs_ty } @@ -1433,6 +1422,47 @@ unboxedSumChecks alt arity | otherwise = return () +-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the +-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' +-- using the provided 'LHsQTyVars' and 'LHsType'. +mkHsForAllTy :: [TH.TyVarBndr] + -- ^ The original Template Haskell type variable binders + -> SrcSpan + -- ^ The location of the returned 'LHsType' if it needs an + -- explicit forall + -> LHsQTyVars name + -- ^ The converted type variable binders + -> LHsType name + -- ^ The converted rho type + -> LHsType name + -- ^ The complete type, quantified with a forall if necessary +mkHsForAllTy tvs loc tvs' rho_ty + | null tvs = rho_ty + | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' + , hst_body = rho_ty } + +-- | If passed an empty 'TH.Cxt', this simply returns the third argument +-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided +-- 'LHsContext' and 'LHsType'. + +-- It's important that we don't build an HsQualTy if the context is empty, +-- as the pretty-printer for HsType _always_ prints contexts, even if +-- they're empty. See Trac #13183. +mkHsQualTy :: TH.Cxt + -- ^ The original Template Haskell context + -> SrcSpan + -- ^ The location of the returned 'LHsType' if it needs an + -- explicit context + -> LHsContext name + -- ^ The converted context + -> LHsType name + -- ^ The converted tau type + -> LHsType name + -- ^ The complete type, qualified with a context if necessary +mkHsQualTy ctxt loc ctxt' ty + | null ctxt = ty + | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty } + -------------------------------------------------------------------- -- Turning Name back into RdrName -------------------------------------------------------------------- diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr index e149418bbd..64714211fd 100644 --- a/testsuite/tests/th/T10598_TH.stderr +++ b/testsuite/tests/th/T10598_TH.stderr @@ -36,6 +36,6 @@ T10598_TH.hs:(27,3)-(42,50): Splicing declarations deriving stock Eq deriving anyclass C deriving newtype Read - deriving stock instance () => Ord Foo - deriving anyclass instance () => D Foo - deriving newtype instance () => Show Foo + deriving stock instance Ord Foo + deriving anyclass instance D Foo + deriving newtype instance Show Foo diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr index f2f428892e..729a36604f 100644 --- a/testsuite/tests/th/T5700.stderr +++ b/testsuite/tests/th/T5700.stderr @@ -1,6 +1,6 @@ T5700.hs:8:3-9: Splicing declarations mkC ''D ======> - instance () => C D where + instance C D where {-# INLINE inlinable #-} inlinable _ = GHC.Tuple.() diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr index b63ea2f38c..aa87a41052 100644 --- a/testsuite/tests/th/T5883.stderr +++ b/testsuite/tests/th/T5883.stderr @@ -6,6 +6,6 @@ T5883.hs:(7,4)-(12,4): Splicing declarations {-# INLINE show #-} |] ======> data Unit = Unit - instance () => Show Unit where + instance Show Unit where {-# INLINE show #-} show _ = "" diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr index 21b753b5d3..baaf04f3f5 100644 --- a/testsuite/tests/th/T7532.stderr +++ b/testsuite/tests/th/T7532.stderr @@ -6,10 +6,10 @@ instance C Bool where T7532.hs:11:3-7: Splicing declarations bang' ======> - instance () => C Int where + instance C Int where data D Int = T ==================== Renamer ==================== -instance () => C Int where +instance C Int where data D Int = T7532.T |