Type tags in import/export lists

Tue Sep 12 16:57:32 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Type tags in import/export lists
  - To write something like GMapKey(type GMap, empty, lookup, insert)
  - Requires -findexed-types

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index ccce706..25db761 100644 (file)
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -24,7 +24,7 @@ module Name (
        nameSrcLoc, nameParent, nameParent_maybe, isImplicitName, 
 
        isSystemName, isInternalName, isExternalName,
-       isTyVarName, isWiredInName, isBuiltInSyntax,
+       isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax,
        wiredInNameTyThing_maybe, 
        nameIsLocalOrFrom,
        
@@ -180,6 +180,9 @@ nameIsLocalOrFrom from name
 isTyVarName :: Name -> Bool
 isTyVarName name = isTvOcc (nameOccName name)
 
+isTyConName :: Name -> Bool
+isTyConName name = isTcOcc (nameOccName name)
+
 isSystemName (Name {n_sort = System}) = True
 isSystemName other                   = False
 \end{code}

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 0a8b0b6..8d55414 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -376,12 +376,20 @@ export    :: { LIE RdrName }
        |  'module' modid               { LL (IEModuleContents (unLoc $2)) }
 
 qcnames :: { [RdrName] }
-       :  qcnames ',' qcname                   { unLoc $3 : $1 }
-       |  qcname                               { [unLoc $1]  }
+       :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
+       |  qcname_ext                   { [unLoc $1]  }
 
+qcname_ext :: { Located RdrName }      -- Variable or data constructor
+                                       -- or tagged type constructor
+       :  qcname                       { $1 }
+       |  'type' qcon                  { sL (comb2 $1 $2) 
+                                            (setRdrNameSpace (unLoc $2) 
+                                                             tcClsName)  }
+
+-- Cannot pull into qcname_ext, as qcname is also used in expression.
 qcname         :: { Located RdrName }  -- Variable or data constructor
-       :  qvar                                 { $1 }
-       |  qcon                                 { $1 }
+       :  qvar                         { $1 }
+       |  qcon                         { $1 }
 
 -----------------------------------------------------------------------------
 -- Import Declarations

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 31ab4c7..8f6d158 100644 (file)
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -29,7 +29,7 @@ import PrelNames
 import Module
 import Name            ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName,
                          nameParent, nameParent_maybe, isExternalName,
-                         isBuiltInSyntax )
+                         isBuiltInSyntax, isTyConName )
 import NameSet
 import NameEnv
 import OccName         ( srcDataName, isTcOcc, pprNonVarNameSpace,
@@ -58,7 +58,7 @@ import DriverPhases   ( isHsBoot )
 import Util            ( notNull )
 import List            ( partition )
 import IO              ( openFile, IOMode(..) )
-import Monad           ( liftM )
+import Monad           ( liftM, when )
 \end{code}
 
 
@@ -535,7 +535,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_names
         = succeed_with True [name]
 
     get_item (IEThingWith name names)
-        = succeed_with True (name:names)
+        = do { optIdxTypes <- doptM Opt_IndexedTypes
+            ; when (not optIdxTypes && any isTyConName names) $
+                addErr (typeItemErr (head . filter isTyConName $ names )
+                                    (text "in import list"))
+            ; succeed_with True (name:names) }
     get_item (IEVar name)
         = succeed_with True [name]
 
@@ -578,33 +582,40 @@ rnExports :: Maybe [LIE RdrName]
           -> RnM (Maybe [LIE Name])
 rnExports Nothing = return Nothing
 rnExports (Just exports)
-    = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv
-         let sub_env :: NameEnv [Name] -- Classify each name by its parent
-             sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
-             rnExport (IEVar rdrName)
-                 = do name <- lookupGlobalOccRn rdrName
-                      return (IEVar name)
-             rnExport (IEThingAbs rdrName)
-                 = do name <- lookupGlobalOccRn rdrName
-                      return (IEThingAbs name)
-             rnExport (IEThingAll rdrName)
-                 = do name <- lookupGlobalOccRn rdrName
-                      return (IEThingAll name)
-             rnExport ie@(IEThingWith rdrName rdrNames)
-                 = do name <- lookupGlobalOccRn rdrName
-                      if isUnboundName name
-                         then return (IEThingWith name [])
-                         else do
-                      let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name]
-                          mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames
-                      if any isNothing mb_names
-                         then do addErr (exportItemErr ie)
-                                 return (IEThingWith name [])
-                         else return (IEThingWith name (catMaybes mb_names))
-             rnExport (IEModuleContents mod)
-                 = return (IEModuleContents mod)
-         rn_exports <- mapM (wrapLocM rnExport) exports
-         return (Just rn_exports)
+  = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv
+       let sub_env :: NameEnv [Name]   -- Classify each name by its parent
+          sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
+          rnExport (IEVar rdrName)
+              = do name <- lookupGlobalOccRn rdrName
+                   return (IEVar name)
+          rnExport (IEThingAbs rdrName)
+              = do name <- lookupGlobalOccRn rdrName
+                   return (IEThingAbs name)
+          rnExport (IEThingAll rdrName)
+              = do name <- lookupGlobalOccRn rdrName
+                   return (IEThingAll name)
+          rnExport ie@(IEThingWith rdrName rdrNames)
+              = do name <- lookupGlobalOccRn rdrName
+                   if isUnboundName name
+                      then return (IEThingWith name [])
+                      else do
+                   let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name]
+                       mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames
+                   if any isNothing mb_names
+                     then do addErr (exportItemErr ie)
+                             return (IEThingWith name [])
+                     else do let names = catMaybes mb_names
+                             optIdxTypes <- doptM Opt_IndexedTypes
+                             when (not optIdxTypes && any isTyConName names) $
+                               addErr (typeItemErr (  head 
+                                                    . filter isTyConName 
+                                                    $ names )
+                                                    (text "in export list"))
+                             return (IEThingWith name names)
+          rnExport (IEModuleContents mod)
+              = return (IEModuleContents mod)
+       rn_exports <- mapM (wrapLocM rnExport) exports
+       return (Just rn_exports)
 
 mkExportNameSet :: Bool  -- False => no 'module M(..) where' header at all
                 -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list
@@ -1117,6 +1128,10 @@ exportItemErr export_item
   = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
          ptext SLIT("attempts to export constructors or class methods that are not visible here") ]
 
+typeItemErr name wherestr
+  = sep [ ptext SLIT("Using 'type' tag on") <+> quotes (ppr name) <+> wherestr,
+         ptext SLIT("Use -findexed-types to enable this extension") ]
+
 exportClashErr global_env name1 name2 ie1 ie2
   = vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon
         , ppr_export ie1 name1