Fix Trac #3155: better error message when -XRankNTypes is omitted

This patch sligtly re-adjusts the way in which the syntax of types
is handled:

 * In the lexer, '.' and '*' are always accepted in types
   (previously it was conditional).  This things can't mean
   anything else in H98, which is the only reason for doing things
   conditionally in the lexer.

 * As a result '.' in types is never treated as an operator.
   Instead, lacking a 'forall' keyword, it turns into a plain parse error.

 * Test for -XKindSignatures in the renamer when processing
     a) type variable bindings
     b) types with sigs (ty :: kind-sig)

 * Make -XKindSignatures be implied by -XTypeFamilies
   Previously this was buried in the conditonal lexing of '*'

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 47cc3fe..2c6163c 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1809,6 +1809,8 @@ impliedFlags
                                                      --      be completely rigid for GADTs
 
     , (Opt_TypeFamilies,        Opt_RelaxedPolyRec)  -- Trac #2944 gives a nice example
+    , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
+                                                    -- all over the place
 
     , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec)  -- Ditto for scoped type variables; see
                                                      --      Note [Scoped tyvars] in TcBinds

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 5c595f5..aa2703e 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -719,9 +719,9 @@ reservedSymsFM = listToUFM $
        ,("!",   ITbang,     always)
 
         -- For data T (a::*) = MkT
-       ,("*", ITstar, \i -> kindSigsEnabled i || tyFamEnabled i)
+       ,("*", ITstar, always) -- \i -> kindSigsEnabled i || tyFamEnabled i)
         -- For 'forall a . t'
-       ,(".", ITdot, \i -> explicitForallEnabled i || inRulePrag i)
+       ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
 
        ,("-<",  ITlarrowtail, arrowsEnabled)
        ,(">-",  ITrarrowtail, arrowsEnabled)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index b73deb5..f0fc523 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1829,6 +1829,11 @@ tyvar   : tyvarid                { $1 }
 tyvarop :: { Located RdrName }
 tyvarop : '`' tyvarid '`'      { LL (unLoc $2) }
        | tyvarsym              { $1 }
+       | '.'                   {% parseErrorSDoc (getLoc $1) 
+                                     (vcat [ptext (sLit "Illegal symbol '.' in type"), 
+                                            ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"),
+                                            ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")])
+                               }
 
 tyvarid        :: { Located RdrName }
        : VARID                 { L1 $! mkUnqual tvName (getVARID $1) }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 382b333..187d64d 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -49,7 +49,8 @@ module RdrHsSyn (
        checkMDo,             -- [Stmt] -> P [Stmt]
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-       parseError,           -- String -> Pa
+       parseError,         
+       parseErrorSDoc,     
     ) where
 
 import HsSyn           -- Lots of it

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 72ec8c4..56f18ab 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -30,7 +30,7 @@ module RnEnv (
        mapFvRn, mapFvRnCPS,
        warnUnusedMatches, warnUnusedModules, warnUnusedImports, 
        warnUnusedTopBinds, warnUnusedLocalBinds,
-       dataTcOccs, unknownNameErr, perhapsForallMsg,
+       dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
 
        checkM
     ) where
@@ -824,13 +824,15 @@ bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
              -> RnM a
 -- Haskell-98 binding of type variables; e.g. within a data type decl
 bindTyVarsRn doc_str tyvar_names enclosed_scope
-  = let
-       located_tyvars = hsLTyVarLocNames tyvar_names
-    in
-    bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
-    enclosed_scope (zipWith replace tyvar_names names)
-    where 
-       replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
+  = bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
+    do { kind_sigs_ok <- doptM Opt_KindSignatures
+       ; checkM (null kinded_tyvars || kind_sigs_ok) 
+                       (mapM_ (addErr . kindSigErr) kinded_tyvars)
+       ; enclosed_scope (zipWith replace tyvar_names names) }
+  where 
+    replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
+    located_tyvars = hsLTyVarLocNames tyvar_names
+    kinded_tyvars  = [n | L _ (KindedTyVar n _) <- tyvar_names]
 
 bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
   -- Find the type variables in the pattern type 
@@ -1087,6 +1089,12 @@ dupNamesErr get_loc descriptor names
              | otherwise = ptext (sLit "Bound at:") <+> 
                            vcat (map ppr (sortLe (<=) locs))
 
+kindSigErr :: Outputable a => a -> SDoc
+kindSigErr thing
+  = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
+       2 (ptext (sLit "Perhaps you intended to use -XKindSignatures"))
+
+
 badQualBndrErr :: RdrName -> SDoc
 badQualBndrErr rdr_name
   = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index d5fc150..4f9672b 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -148,9 +148,11 @@ rnHsType doc (HsListTy ty) = do
     ty' <- rnLHsType doc ty
     return (HsListTy ty')
 
-rnHsType doc (HsKindSig ty k) = do
-    ty' <- rnLHsType doc ty
-    return (HsKindSig ty' k)
+rnHsType doc (HsKindSig ty k)
+  = do { kind_sigs_ok <- doptM Opt_KindSignatures
+       ; checkM kind_sigs_ok (addErr (kindSigErr ty))
+       ; ty' <- rnLHsType doc ty
+       ; return (HsKindSig ty' k) }
 
 rnHsType doc (HsPArrTy ty) = do
     ty' <- rnLHsType doc ty