Fix #15415 and simplify tcWildCardBinders

Test Plan: Validate

Reviewers: goldfire, simonpj, bgamari

Reviewed By: simonpj

Subscribers: RyanGlScott, rwbarton, thomie, carter

GHC Trac Issues: #15415

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

(cherry picked from commit 120cc9f8)

compiler/typecheck/TcHsType.hs

@@ -359,7 +359,7 @@ tcHsTypeApp wc_ty kind
   = do { ty <- solveLocalEqualities $
                -- We are looking at a user-written type, very like a
                -- signature so we want to solve its equalities right now
-               tcWildCardBindersX newWildTyVar Nothing sig_wcs $ \ _ ->
+               tcWildCardBinders sig_wcs $ \ _ ->
                tcCheckLHsType hs_ty kind
        ; ty <- zonkPromoteType ty
        ; checkValidType TypeAppCtxt ty
@@ -1589,30 +1589,14 @@ in TcType.
 
 -}
 
-tcWildCardBinders :: SkolemInfo
-                  -> [Name]
+tcWildCardBinders :: [Name]
                   -> ([(Name, TcTyVar)] -> TcM a)
                   -> TcM a
-tcWildCardBinders info = tcWildCardBindersX new_tv (Just info)
-  where
-    new_tv name = do { kind <- newMetaKindVar
-                     ; newSkolemTyVar name kind }
-
-tcWildCardBindersX :: (Name -> TcM TcTyVar)
-                   -> Maybe SkolemInfo -- Just <=> we're bringing fresh vars
-                                       -- into scope; use scopeTyVars
-                   -> [Name]
-                   -> ([(Name, TcTyVar)] -> TcM a)
-                   -> TcM a
-tcWildCardBindersX new_wc maybe_skol_info wc_names thing_inside
-  = do { wcs <- mapM new_wc wc_names
+tcWildCardBinders wc_names thing_inside
+  = do { wcs <- mapM newWildTyVar wc_names
        ; let wc_prs = wc_names `zip` wcs
-       ; scope_tvs wc_prs $
+       ; tcExtendNameTyVarEnv wc_prs $
          thing_inside wc_prs }
-  where
-    scope_tvs
-      | Just info <- maybe_skol_info = scopeTyVars2 info
-      | otherwise                    = tcExtendNameTyVarEnv
 
 -- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,
 -- user-supplied kind signature (CUSK), generalise the result.
@@ -2361,7 +2345,7 @@ tcHsPartialSigType ctxt sig_ty
   , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
   = addSigCtxt ctxt hs_ty $
     do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
-            <- tcWildCardBindersX newWildTyVar Nothing sig_wcs $ \ wcs ->
+            <- tcWildCardBinders sig_wcs $ \ wcs ->
                tcImplicitTKBndrsSig skol_info implicit_hs_tvs      $
                tcExplicitTKBndrs    skol_info explicit_hs_tvs      $
                do {   -- Instantiate the type-class context; but if there
@@ -2429,7 +2413,7 @@ Consider
   the hswc_wcs field.
 
 * Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
-  tcWildCardBindersX.
+  tcWildCardBinders.
 
 * TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar
   with the inferred constraints, e.g. (Eq a, Show a)
@@ -2485,7 +2469,7 @@ tcHsPatSigType ctxt sig_ty
   = addSigCtxt ctxt hs_ty $
     do { sig_tkvs <- mapM new_implicit_tv sig_vars
        ; (wcs, sig_ty)
-            <- tcWildCardBindersX newWildTyVar    Nothing sig_wcs  $ \ wcs ->
+            <- tcWildCardBinders sig_wcs  $ \ wcs ->
                tcExtendTyVarEnv sig_tkvs                           $
                do { sig_ty <- tcHsOpenType hs_ty
                   ; return (wcs, sig_ty) }

compiler/typecheck/TcRnDriver.hs

@@ -2368,9 +2368,12 @@ tcRnType hsc_env normalise rdr_type
         -- It can have any rank or kind
         -- First bring into scope any wildcards
        ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
-       ; (ty, kind) <- solveEqualities $
-                       tcWildCardBinders (SigTypeSkol GhciCtxt) wcs $ \ _ ->
-                       tcLHsTypeUnsaturated rn_type
+       ; ((ty, kind), lie)  <-
+                       captureConstraints $
+                       tcWildCardBinders wcs $ \ wcs' ->
+                       do { emitWildCardHoleConstraints wcs'
+                          ; tcLHsTypeUnsaturated rn_type }
+       ; _ <- checkNoErrs (simplifyInteractive lie)
 
        -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
        ; kind <- zonkTcType kind

testsuite/tests/partial-sigs/should_run/GHCiWildcardKind.script

+:set -XPartialTypeSignatures -fno-warn-partial-type-signatures
 :kind _
 :kind Maybe _
 

testsuite/tests/partial-sigs/should_run/T15415.script

+import Data.Proxy
+:set -XPolyKinds
+data Dependent a (x :: a)
+
+:k Proxy _
+:k Proxy (Maybe :: _)
+:k Dependent _
+
+:set -XPartialTypeSignatures
+:k Proxy _
+:k Proxy (Maybe :: _)
+:k Dependent _
+
+:set -fno-warn-partial-type-signatures
+:k Proxy _
+:k Proxy (Maybe :: _)
+:k Dependent _

testsuite/tests/partial-sigs/should_run/T15415.stderr

+
+<interactive>:1:7: error:
+    Found type wildcard ‘_’ standing for ‘w0 :: k0’
+    Where: ‘w0’ is an ambiguous type variable
+           ‘k0’ is an ambiguous type variable
+    To use the inferred type, enable PartialTypeSignatures
+
+<interactive>:1:17: error:
+    Found type wildcard ‘_’ standing for ‘* -> *’
+    To use the inferred type, enable PartialTypeSignatures
+
+<interactive>:1:11: error:
+    Found type wildcard ‘_’ standing for ‘w0’
+    Where: ‘w0’ is an ambiguous type variable
+    To use the inferred type, enable PartialTypeSignatures
+
+<interactive>:1:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    Found type wildcard ‘_’ standing for ‘w0 :: k0’
+    Where: ‘w0’ is an ambiguous type variable
+           ‘k0’ is an ambiguous type variable
+
+<interactive>:1:17: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    Found type wildcard ‘_’ standing for ‘* -> *’
+
+<interactive>:1:11: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    Found type wildcard ‘_’ standing for ‘w0’
+    Where: ‘w0’ is an ambiguous type variable

testsuite/tests/partial-sigs/should_run/T15415.stdout

+Proxy _ :: *
+Proxy (Maybe :: _) :: *
+Dependent _ :: w -> *
+Proxy _ :: *
+Proxy (Maybe :: _) :: *
+Dependent _ :: w -> *

testsuite/tests/partial-sigs/should_run/all.T

 test('GHCiWildcardKind', normal, ghci_script, ['GHCiWildcardKind.script'])
+test('T15415', normal, ghci_script, ['T15415.script'])

testsuite/tests/unboxedsums/T12711.script

-:set -XUnboxedSums
+:set -XUnboxedSums -XPartialTypeSignatures -fno-warn-partial-type-signatures
 :kind (# _ | _ #)