[commit: ghc] type-nats: Add -XExplicitNamespaces to enable using 'type' in import/exports. (81b2b11)

[Iavor Diatchki]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-nats

http://hackage.haskell.org/trac/ghc/changeset/81b2b11864bfb6a6dcf1834b228a0df4e5b1034e

>---------------------------------------------------------------

commit 81b2b11864bfb6a6dcf1834b228a0df4e5b1034e
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Sat Mar 24 16:01:00 2012 -0700

    Add -XExplicitNamespaces to enable using 'type' in import/exports.
    
    This extension is implied by:
    
      * TypeOperators: so that we can import/export things like (+)
      * TypeFamilies: because associated type synonyms use "type T"
                      to name the associated type in a subordinate list.

>---------------------------------------------------------------

 compiler/main/DynFlags.hs    |    9 ++++++++-
 compiler/parser/Lexer.x      |    8 ++++++++
 compiler/parser/Parser.y.pp  |    4 +---
 compiler/parser/RdrHsSyn.lhs |   11 ++++++++++-
 4 files changed, 27 insertions(+), 5 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index eeb1dfc..4e474ab 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -449,6 +449,7 @@ data ExtensionFlag
    | Opt_RankNTypes
    | Opt_ImpredicativeTypes
    | Opt_TypeOperators
+   | Opt_ExplicitNamespaces
    | Opt_PackageImports
    | Opt_ExplicitForAll
    | Opt_AlternativeLayoutRule
@@ -1973,6 +1974,7 @@ xFlags = [
   ( "RankNTypes",                       Opt_RankNTypes, nop ),
   ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop),
   ( "TypeOperators",                    Opt_TypeOperators, nop ),
+  ( "ExplicitNamespaces",               Opt_ExplicitNamespaces, nop ),
   ( "RecursiveDo",                      Opt_RecursiveDo,     -- Enables 'mdo'
     deprecatedForExtension "DoRec"),
   ( "DoRec",                            Opt_DoRec, nop ),    -- Enables 'rec' keyword
@@ -2084,7 +2086,11 @@ impliedFlags
     , (Opt_TypeFamilies,     turnOn, Opt_MonoLocalBinds)
 
     , (Opt_TypeFamilies,     turnOn, Opt_KindSignatures)  -- Type families use kind signatures
-                                                          -- all over the place
+
+    -- We turn this on so that we can export associated type
+    -- type synonyms in subordinates (e.g. MyClass(type AssocType))
+    , (Opt_TypeFamilies,     turnOn, Opt_ExplicitNamespaces)
+    , (Opt_TypeOperators, turnOn, Opt_ExplicitNamespaces)
 
     , (Opt_ImpredicativeTypes,  turnOn, Opt_RankNTypes)
 
@@ -2215,6 +2221,7 @@ glasgowExtsFlags = [
            , Opt_LiberalTypeSynonyms
            , Opt_RankNTypes
            , Opt_TypeOperators
+           , Opt_ExplicitNamespaces
            , Opt_DoRec
            , Opt_ParallelListComp
            , Opt_EmptyDataDecls
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 2b04294..94b2019 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -57,6 +57,7 @@ module Lexer (
    extension, bangPatEnabled, datatypeContextsEnabled,
    traditionalRecordSyntaxEnabled,
    typeLiteralsEnabled,
+   explicitNamespacesEnabled,
    addWarning,
    lexTokenStream
   ) where
@@ -1809,6 +1810,9 @@ traditionalRecordSyntaxBit :: Int
 traditionalRecordSyntaxBit = 27
 typeLiteralsBit :: Int
 typeLiteralsBit = 28
+explicitNamespacesBit :: Int
+explicitNamespacesBit = 29
+
 
 always :: Int -> Bool
 always           _     = True
@@ -1855,6 +1859,9 @@ traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit
 typeLiteralsEnabled :: Int -> Bool
 typeLiteralsEnabled flags = testBit flags typeLiteralsBit
 
+explicitNamespacesEnabled :: Int -> Bool
+explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
+
 -- PState for parsing options pragmas
 --
 pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
@@ -1914,6 +1921,7 @@ mkPState flags buf loc =
                .|. safeHaskellBit              `setBitIf` safeImportsOn                     flags
                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
                .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags
+               .|. explicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 38cada8..696fd3d 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -486,9 +486,7 @@ qcnames :: { [RdrName] }     -- A reversed list
 qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                         -- or tagged type constructor
         :  qcname                       { $1 }
-        |  'type' qcname                { sL (comb2 $1 $2) 
-                                             (setRdrNameSpace (unLoc $2) 
-                                                              tcClsName)  }
+        |  'type' qcname                {% mkTypeImpExp (LL (unLoc $2)) }
 
 -- Cannot pull into qcname_ext, as qcname is also used in expression.
 qcname  :: { Located RdrName }  -- Variable or data constructor
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index a847f55..b6893cf 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -49,7 +49,8 @@ module RdrHsSyn (
 
         -- Help with processing exports
         ImpExpSubSpec(..),
-        mkModuleImpExp
+        mkModuleImpExp,
+        mkTypeImpExp
 
     ) where
 
@@ -1041,6 +1042,14 @@ mkModuleImpExp name subs =
 
   where
     nameT = setRdrNameSpace name tcClsName
+
+mkTypeImpExp :: Located RdrName -> P (Located RdrName)
+mkTypeImpExp name =
+  do allowed <- extension explicitNamespacesEnabled
+     if allowed
+       then return (fmap (`setRdrNameSpace` tcClsName) name)
+       else parseErrorSDoc (getLoc name)
+              (text "Illegal keyword 'type' (use -XExplicitNamespaces to enable)")
 \end{code}
 
 -----------------------------------------------------------------------------