Incorporate suggestions

6 files changed, 55 insertions, 33 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 7c7f37b3b7..c43a27cef2 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -664,7 +664,7 @@ tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
 tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
 tyClDeclLName decl = tcdLName decl
 
-tcdName :: TyClDecl pass -> (IdP pass)
+tcdName :: TyClDecl pass -> IdP pass
 tcdName = unLoc . tyClDeclLName
 
 tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index f1b9ec12e3..0686f669d3 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -260,8 +260,9 @@ mkStandaloneKindSig loc lhs rhs =
         [] -> panic "mkStandaloneKindSig: empty left-hand side"
         [v] -> return v
         _ -> addFatalError (getLoc lhs) $
-             hang (text "Standalone kind signatures do not support multiple names at the moment:") 2
-                  (pprWithCommas ppr vs)
+             vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
+                       2 (pprWithCommas ppr vs)
+                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
 
 mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
                -> LHsType GhcPs
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 3cc1994f5b..2d59dc191b 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -36,6 +36,7 @@ module TcEnv(
 
         tcLookup, tcLookupLocated, tcLookupLocalIds,
         tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
+        tcLookupTcTyCon,
         tcLookupLcl_maybe,
         getInLocalScope,
         wrongThingErr, pprBinders,
@@ -106,6 +107,7 @@ import ListSetOps
 import ErrUtils
 import Maybes( MaybeErr(..), orElse )
 import qualified GHC.LanguageExtensions as LangExt
+import Util ( HasDebugCallStack )
 
 import Data.IORef
 import Data.List
@@ -443,6 +445,13 @@ tcLookupLocalIds ns
                 Just (ATcId { tct_id = id }) ->  id
                 _ -> pprPanic "tcLookupLocalIds" (ppr name)
 
+tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
+tcLookupTcTyCon name = do
+    thing <- tcLookup name
+    case thing of
+        ATcTyCon tc -> return tc
+        _           -> pprPanic "tcLookupTcTyCon" (ppr name)
+
 getInLocalScope :: TcM (Name -> Bool)
 getInLocalScope = do { lcl_env <- getLclTypeEnv
                      ; return (`elemNameEnv` lcl_env) }
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 26bc90bba0..cd65fc0522 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -39,6 +39,7 @@ module TcHsType (
         -- Kind-checking types
         -- No kind generalisation, no checkValidType
         InitialKindStrategy(..),
+        SAKS_or_CUSK(..),
         kcDeclHeader,
         tcNamedWildCardBinders,
         tcHsLiftedType,   tcHsOpenType,
@@ -1790,10 +1791,22 @@ newWildTyVar
 *                                                                      *
 ********************************************************************* -}
 
+-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]
 data InitialKindStrategy
-  = InitialKindCheck (Maybe Kind)
+  = InitialKindCheck SAKS_or_CUSK
   | InitialKindInfer
 
+-- Does the declaration have a standalone kind signature (SAKS) or a complete
+-- user-specified kind (CUSK)?
+data SAKS_or_CUSK
+  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)
+  | CUSK       -- Complete user-specified kind (CUSK)
+
+instance Outputable SAKS_or_CUSK where
+  ppr (SAKS k) = text "SAKS" <+> ppr k
+  ppr CUSK = text "CUSK"
+
+-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]
 kcDeclHeader
   :: InitialKindStrategy
   -> Name              -- ^ of the thing being checked
@@ -1822,15 +1835,14 @@ of a type constructor.
 
 ------------------------------
 kcCheckDeclHeader
-  :: Maybe Kind        -- ^  Just sig  <=>  Standalone kind signature, fully zonked! (zonkTcTypeToType)
-                       --    Nothing   <=>  Complete user-specified kind (CUSK)
+  :: SAKS_or_CUSK
   -> Name              -- ^ of the thing being checked
   -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
   -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> TcM ContextKind   -- ^ The result kind
+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature
   -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon
-kcCheckDeclHeader (Just sig) = kcCheckDeclHeader_sig sig
-kcCheckDeclHeader Nothing    = kcCheckDeclHeader_cusk
+kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig
+kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk
 
 kcCheckDeclHeader_cusk
   :: Name              -- ^ of the thing being checked
@@ -1974,7 +1986,7 @@ kcCheckDeclHeader_sig
   -> Name              -- ^ of the thing being checked
   -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
   -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> TcM ContextKind   -- ^ The result kind
+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature
   -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
 kcCheckDeclHeader_sig kisig name flav ktvs kc_res_ki =
   addTyConFlavCtxt name flav $
@@ -2299,7 +2311,8 @@ invisible binders of the standalone kind signature to split off:
 This decision is made in 'split_invis':
 
 * If a user-written result kind signature is not provided, as in F,
-  then split off all invisible binders.
+  then split off all invisible binders. This is why we need special treatment
+  for AnyKind.
 * If a user-written result kind signature is provided, as in G,
   then do as checkExpectedKind does and split off (n_sig - n_res) binders.
   That is, split off such an amount of binders that the remainder of the
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 232cc5d5f1..904f80827f 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -533,10 +533,10 @@ kcTyClGroup kisig_env decls
 
               get_kind d
                 | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))
-                = Right (d, Just ki)
+                = Right (d, SAKS ki)
 
                 | cusks_enabled && hsDeclHasCusk (unLoc d)
-                = Right (d, Nothing)
+                = Right (d, CUSK)
 
                 | otherwise = Left d
 
@@ -786,7 +786,7 @@ These design choices are implemented by two completely different code
 paths for
 
   * Declarations with a standalone kind signature or a complete user-specified
-    kind signature (CUSK). Handed by the kcCheckDeclHeader.
+    kind signature (CUSK). Handled by the kcCheckDeclHeader.
 
   * Declarations without a kind signature (standalone or CUSK) are handled by
     kcInferDeclHeader; see Note [Inferring kinds for type declarations].
@@ -1015,7 +1015,7 @@ inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
 -- each with its initial kind
 
 inferInitialKinds decls
-  = do { traceTc "inferInitialKinds {" empty
+  = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)
        ; tcs <- concatMapM infer_initial_kind decls
        ; traceTc "inferInitialKinds done }" empty
        ; return tcs }
@@ -1024,14 +1024,18 @@ inferInitialKinds decls
 
 -- Check type/class declarations against their standalone kind signatures or
 -- CUSKs, producing a generalized TcTyCon for each.
-checkInitialKinds :: [(LTyClDecl GhcRn, Maybe Kind)] -> TcM [TcTyCon]
-checkInitialKinds = concatMapM check_initial_kind
+checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]
+checkInitialKinds decls
+  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)
+       ; tcs <- concatMapM check_initial_kind decls
+       ; traceTc "checkInitialKinds done }" empty
+       ; return tcs }
   where
-    check_initial_kind (dL -> L l d, msig) =
-      setSrcSpan l (getInitialKind (InitialKindCheck msig) d)
+    check_initial_kind (ldecl, msig) =
+      addLocM (getInitialKind (InitialKindCheck msig)) ldecl
 
 -- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
--- depending on the InitialKindStrategy.
+-- depending on the 'InitialKindStrategy'.
 getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
 
 -- Allocate a fresh kind variable for each TyCon and Class
@@ -1094,8 +1098,8 @@ getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =
                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
                  Nothing ->
                    case msig of
-                     Nothing -> return (TheKind liftedTypeKind)
-                     Just _  -> return AnyKind
+                     CUSK -> return (TheKind liftedTypeKind)
+                     SAKS _ -> return AnyKind
        ; return [tc] }
 
 getInitialKind strategy
@@ -1104,15 +1108,9 @@ getInitialKind strategy
              , tcdRhs = rhs })
   = do { let ctxt = TySynKindCtxt name
        ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $
-               case strategy of
-                 InitialKindInfer -> return AnyKind
-                 InitialKindCheck msig ->
-                   case hsTyKindSig rhs of
-                     Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
-                     Nothing ->
-                       case msig of
-                         Nothing -> return (TheKind liftedTypeKind)
-                         Just _  -> return AnyKind
+               case hsTyKindSig rhs of
+                 Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig
+                 Nothing -> return AnyKind
        ; return [tc] }
 
 getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
@@ -1153,7 +1151,7 @@ check_initial_kind_assoc_fam cls
     , fdTyVars    = ktvs
     , fdResultSig = unLoc -> resultSig
     , fdInfo      = info }
-  = kcDeclHeader (InitialKindCheck Nothing) name flav ktvs $
+  = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $
     case famResultKindSignature resultSig of
       Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
       Nothing -> return (TheKind liftedTypeKind)
@@ -2258,7 +2256,7 @@ tcDataDefn err_ctxt
                                   stupid_theta tc_rhs
                                   (VanillaAlgTyCon tc_rep_nm)
                                   gadt_syntax) }
-       ; ATcTyCon tctc <- tcLookup tc_name
+       ; tctc <- tcLookupTcTyCon tc_name
             -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need
             -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'
        ; let deriv_info = DerivInfo { di_rep_tc = tycon
diff --git a/testsuite/tests/saks/should_fail/saks_fail025.stderr b/testsuite/tests/saks/should_fail/saks_fail025.stderr
index da99d30e37..52e1527d3b 100644
--- a/testsuite/tests/saks/should_fail/saks_fail025.stderr
+++ b/testsuite/tests/saks/should_fail/saks_fail025.stderr
@@ -2,3 +2,4 @@
 saks_fail025.hs:7:6: error:
     Standalone kind signatures do not support multiple names at the moment:
       A, B, C
+    See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details.