Use splitLHs{ForAll,Sigma}TyInvis throughout the codebase

Richard points out in #17688 that we use `splitLHsForAllTy` and
`splitLHsSigmaTy` in places that we ought to be using the
corresponding `-Invis` variants instead, identifying two bugs
that are caused by this oversight:

* Certain TH-quoted type signatures, such as those that appear in
  quoted `SPECIALISE` pragmas, silently turn visible `forall`s into
  invisible `forall`s.
* When quoted, the type `forall a -> (a ~ a) => a` will turn into
  `forall a -> a` due to a bug in `DsMeta.repForall` that drops
  contexts that follow visible `forall`s.

These are both ultimately caused by the fact that `splitLHsForAllTy`
and `splitLHsSigmaTy` split apart visible `forall`s in addition to
invisible ones. This patch cleans things up:

* We now use `splitLHsForAllTyInvis` and `splitLHsSigmaTyInvis`
  throughout the codebase. Relatedly, the `splitLHsForAllTy` and
  `splitLHsSigmaTy` have been removed, as they are easy to misuse.
* `DsMeta.repForall` now only handles invisible `forall`s to reduce
  the chance for confusion with visible `forall`s, which need to be
  handled differently. I also renamed it from `repForall` to
  `repForallT` to emphasize that its distinguishing characteristic
  is the fact that it desugars down to `L.H.TH.Syntax.ForallT`.

Fixes #17688.

11 files changed, 62 insertions, 47 deletions

diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index c250ec0..bc7ba47 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -56,8 +56,7 @@ module GHC.Hs.Types (
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
         splitLHsPatSynTy,
-        splitLHsForAllTy, splitLHsForAllTyInvis,
-        splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis,
+        splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis,
         splitHsFunType, hsTyGetAppHead_maybe,
         mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
         ignoreParens, hsSigType, hsSigWcType,
@@ -1237,21 +1236,9 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
     (provs, ty4) = splitLHsQualTy ty3
 
 -- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
--- into its constituent parts.
---
--- Note that this function looks through parentheses, so it will work on types
--- such as @(forall a. <...>)@. The downside to this is that it is not
--- generally possible to take the returned types and reconstruct the original
--- type (parentheses and all) from them.
-splitLHsSigmaTy :: LHsType pass
-                -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
-splitLHsSigmaTy ty
-  | (tvs, ty1)  <- splitLHsForAllTy ty
-  , (ctxt, ty2) <- splitLHsQualTy ty1
-  = (tvs, ctxt, ty2)
-
--- | Like 'splitLHsSigmaTy', but only splits type variable binders that were
--- quantified invisibly (e.g., @forall a.@, with a dot).
+-- into its constituent parts. Note that only /invisible/ @forall@s
+-- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s
+-- (i.e., @forall a ->@, with an arrow) are left untouched.
 --
 -- This function is used to split apart certain types, such as instance
 -- declaration types, which disallow visible @forall@s. For instance, if GHC
@@ -1269,20 +1256,10 @@ splitLHsSigmaTyInvis ty
   , (ctxt, ty2) <- splitLHsQualTy ty1
   = (tvs, ctxt, ty2)
 
--- | Decompose a type of the form @forall <tvs>. body@) into its constituent
--- parts.
---
--- Note that this function looks through parentheses, so it will work on types
--- such as @(forall a. <...>)@. The downside to this is that it is not
--- generally possible to take the returned types and reconstruct the original
--- type (parentheses and all) from them.
-splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
-splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
-splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
-splitLHsForAllTy body              = ([], body)
-
--- | Like 'splitLHsForAllTy', but only splits type variable binders that
--- were quantified invisibly (e.g., @forall a.@, with a dot).
+-- | Decompose a type of the form @forall <tvs>. body@ into its constituent
+-- parts. Note that only /invisible/ @forall@s
+-- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s
+-- (i.e., @forall a ->@, with an arrow) are left untouched.
 --
 -- This function is used to split apart certain types, such as instance
 -- declaration types, which disallow visible @forall@s. For instance, if GHC
diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs
index f36a556..6a84e309 100644
--- a/compiler/GHC/Rename/Source.hs
+++ b/compiler/GHC/Rename/Source.hs
@@ -1834,7 +1834,7 @@ rnLDerivStrategy doc mds thing_inside
           do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
              let HsIB { hsib_ext  = via_imp_tvs
                       , hsib_body = via_body } = via_ty'
-                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body
                  via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs
                  via_tvs = via_imp_tvs ++ via_exp_tvs
              (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 1af0b11..cdb049c 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -349,7 +349,7 @@ get_scoped_tvs (L _ signature)
       --    here 'k' scopes too
       | HsIB { hsib_ext = implicit_vars
              , hsib_body = hs_ty } <- sig
-      , (explicit_vars, _) <- splitLHsForAllTy hs_ty
+      , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
       = implicit_vars ++ hsLTyVarNames explicit_vars
     get_scoped_tvs_from_sig (XHsImplicitBndrs nec)
       = noExtCon nec
@@ -1240,7 +1240,7 @@ repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
 repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
 repHsSigType (HsIB { hsib_ext = implicit_tvs
                    , hsib_body = body })
-  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body
   = addSimpleTyVarBinds implicit_tvs $
       -- See Note [Don't quantify implicit type variables in quotes]
     addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
@@ -1264,21 +1264,29 @@ repLTys tys = mapM repLTy tys
 repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
 repLTy ty = repTy (unLoc ty)
 
-repForall :: ForallVisFlag -> HsType GhcRn -> MetaM (Core (M TH.Type))
--- Arg of repForall is always HsForAllTy or HsQualTy
-repForall fvf ty
- | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
+-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
+-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
+-- In other words, the argument to this function is always an
+-- @HsForAllTy ForallInvis@ or @HsQualTy@.
+-- Types headed by visible foralls (which are desugared to ForallVisT) are
+-- handled separately in repTy.
+repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
+repForallT ty
+ | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)
  = addHsTyVarBinds tvs $ \bndrs ->
    do { ctxt1  <- repLContext ctxt
-      ; ty1    <- repLTy tau
-      ; case fvf of
-          ForallVis   -> repTForallVis bndrs ty1    -- forall a      -> {...}
-          ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}
+      ; tau1   <- repLTy tau
+      ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
       }
 
 repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
-repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf         ty
-repTy ty@(HsQualTy {})                = repForall ForallInvis ty
+repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =
+  case fvf of
+    ForallInvis -> repForallT ty
+    ForallVis   -> addHsTyVarBinds tvs $ \bndrs ->
+                   do body1 <- repLTy body
+                      repTForallVis bndrs body1
+repTy ty@(HsQualTy {}) = repForallT ty
 
 repTy (HsTyVar _ _ (L _ n))
   | isLiftedTypeKindTyConName n       = repTStar
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 74d6802..06b0a82 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
       = [ null theta
         | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
             <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
-        , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
+        , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]
 
     has_partial_sigs   = not (null partial_sig_mrs)
 
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 75332ec..8b33dd4 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -717,7 +717,7 @@ tcStandaloneDerivInstType
 tcStandaloneDerivInstType ctxt
     (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
                                        , hsib_body   = deriv_ty_body })})
-  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
+  | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body
   , L _ [wc_pred] <- theta
   , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
   = do dfun_ty <- tcHsClsInstType ctxt $
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 5635b2d..038871a 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -3131,7 +3131,7 @@ tcHsPartialSigType ctxt sig_ty
   | HsWC { hswc_ext  = sig_wcs, hswc_body = ib_ty } <- sig_ty
   , HsIB { hsib_ext = implicit_hs_tvs
          , hsib_body = hs_ty } <- ib_ty
-  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty
   = addSigCtxt ctxt hs_ty $
     do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
             <- solveLocalEqualities "tcHsPartialSigType"    $
diff --git a/testsuite/tests/th/T17688a.hs b/testsuite/tests/th/T17688a.hs
new file mode 100644
index 0000000..aae0b6d
--- /dev/null
+++ b/testsuite/tests/th/T17688a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T17688a where
+
+import Language.Haskell.TH
+import System.IO
+
+$( do ty <- [d| {-# SPECIALISE id :: forall a -> a -> a #-} |]
+      runIO $ hPutStrLn stderr $ pprint ty
+      return [] )
diff --git a/testsuite/tests/th/T17688a.stderr b/testsuite/tests/th/T17688a.stderr
new file mode 100644
index 0000000..f746b55
--- /dev/null
+++ b/testsuite/tests/th/T17688a.stderr
@@ -0,0 +1 @@
+{-# SPECIALISE GHC.Base.id :: forall a_0 -> a_0 -> a_0 #-}
diff --git a/testsuite/tests/th/T17688b.hs b/testsuite/tests/th/T17688b.hs
new file mode 100644
index 0000000..f78cf02
--- /dev/null
+++ b/testsuite/tests/th/T17688b.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module T17688b where
+
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+import System.IO
+
+$(do decs <- [d| type T :: forall (a :: Type) -> (a ~ a) => Type
+                 data T x |]
+     runIO $ hPutStrLn stderr $ pprint decs
+     return [] )
diff --git a/testsuite/tests/th/T17688b.stderr b/testsuite/tests/th/T17688b.stderr
new file mode 100644
index 0000000..e5384ff
--- /dev/null
+++ b/testsuite/tests/th/T17688b.stderr
@@ -0,0 +1,2 @@
+type T_0 :: forall (a_1 :: *) -> a_1 ~ a_1 => *
+data T_0 x_2
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 1e0eb38..72cb2b9 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -496,5 +496,7 @@ test('T17379b', normal, compile_fail, [''])
 test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T17511', normal, compile, [''])
 test('T17608', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T17688a', normal, compile, [''])
+test('T17688b', normal, compile, [''])
 test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
 test('TH_StringLift', normal, compile, [''])