Commit 0cfba505 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

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
parent a357abfc
...@@ -24,7 +24,7 @@ module Name ( ...@@ -24,7 +24,7 @@ module Name (
nameSrcLoc, nameParent, nameParent_maybe, isImplicitName, nameSrcLoc, nameParent, nameParent_maybe, isImplicitName,
isSystemName, isInternalName, isExternalName, isSystemName, isInternalName, isExternalName,
isTyVarName, isWiredInName, isBuiltInSyntax, isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax,
wiredInNameTyThing_maybe, wiredInNameTyThing_maybe,
nameIsLocalOrFrom, nameIsLocalOrFrom,
...@@ -180,6 +180,9 @@ nameIsLocalOrFrom from name ...@@ -180,6 +180,9 @@ nameIsLocalOrFrom from name
isTyVarName :: Name -> Bool isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name) isTyVarName name = isTvOcc (nameOccName name)
isTyConName :: Name -> Bool
isTyConName name = isTcOcc (nameOccName name)
isSystemName (Name {n_sort = System}) = True isSystemName (Name {n_sort = System}) = True
isSystemName other = False isSystemName other = False
\end{code} \end{code}
......
...@@ -376,12 +376,20 @@ export :: { LIE RdrName } ...@@ -376,12 +376,20 @@ export :: { LIE RdrName }
| 'module' modid { LL (IEModuleContents (unLoc $2)) } | 'module' modid { LL (IEModuleContents (unLoc $2)) }
qcnames :: { [RdrName] } qcnames :: { [RdrName] }
: qcnames ',' qcname { unLoc $3 : $1 } : qcnames ',' qcname_ext { unLoc $3 : $1 }
| qcname { [unLoc $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 qcname :: { Located RdrName } -- Variable or data constructor
: qvar { $1 } : qvar { $1 }
| qcon { $1 } | qcon { $1 }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Import Declarations -- Import Declarations
......
...@@ -29,7 +29,7 @@ import PrelNames ...@@ -29,7 +29,7 @@ import PrelNames
import Module import Module
import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName,
nameParent, nameParent_maybe, isExternalName, nameParent, nameParent_maybe, isExternalName,
isBuiltInSyntax ) isBuiltInSyntax, isTyConName )
import NameSet import NameSet
import NameEnv import NameEnv
import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace, import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace,
...@@ -58,7 +58,7 @@ import DriverPhases ( isHsBoot ) ...@@ -58,7 +58,7 @@ import DriverPhases ( isHsBoot )
import Util ( notNull ) import Util ( notNull )
import List ( partition ) import List ( partition )
import IO ( openFile, IOMode(..) ) import IO ( openFile, IOMode(..) )
import Monad ( liftM ) import Monad ( liftM, when )
\end{code} \end{code}
...@@ -535,7 +535,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_names ...@@ -535,7 +535,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_names
= succeed_with True [name] = succeed_with True [name]
get_item (IEThingWith name names) 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) get_item (IEVar name)
= succeed_with True [name] = succeed_with True [name]
...@@ -578,33 +582,40 @@ rnExports :: Maybe [LIE RdrName] ...@@ -578,33 +582,40 @@ rnExports :: Maybe [LIE RdrName]
-> RnM (Maybe [LIE Name]) -> RnM (Maybe [LIE Name])
rnExports Nothing = return Nothing rnExports Nothing = return Nothing
rnExports (Just exports) rnExports (Just exports)
= do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv
let sub_env :: NameEnv [Name] -- Classify each name by its parent let sub_env :: NameEnv [Name] -- Classify each name by its parent
sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
rnExport (IEVar rdrName) rnExport (IEVar rdrName)
= do name <- lookupGlobalOccRn rdrName = do name <- lookupGlobalOccRn rdrName
return (IEVar name) return (IEVar name)
rnExport (IEThingAbs rdrName) rnExport (IEThingAbs rdrName)
= do name <- lookupGlobalOccRn rdrName = do name <- lookupGlobalOccRn rdrName
return (IEThingAbs name) return (IEThingAbs name)
rnExport (IEThingAll rdrName) rnExport (IEThingAll rdrName)
= do name <- lookupGlobalOccRn rdrName = do name <- lookupGlobalOccRn rdrName
return (IEThingAll name) return (IEThingAll name)
rnExport ie@(IEThingWith rdrName rdrNames) rnExport ie@(IEThingWith rdrName rdrNames)
= do name <- lookupGlobalOccRn rdrName = do name <- lookupGlobalOccRn rdrName
if isUnboundName name if isUnboundName name
then return (IEThingWith name []) then return (IEThingWith name [])
else do else do
let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name]
mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames
if any isNothing mb_names if any isNothing mb_names
then do addErr (exportItemErr ie) then do addErr (exportItemErr ie)
return (IEThingWith name []) return (IEThingWith name [])
else return (IEThingWith name (catMaybes mb_names)) else do let names = catMaybes mb_names
rnExport (IEModuleContents mod) optIdxTypes <- doptM Opt_IndexedTypes
= return (IEModuleContents mod) when (not optIdxTypes && any isTyConName names) $
rn_exports <- mapM (wrapLocM rnExport) exports addErr (typeItemErr ( head
return (Just rn_exports) . 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 mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all
-> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list
...@@ -1117,6 +1128,10 @@ exportItemErr export_item ...@@ -1117,6 +1128,10 @@ exportItemErr export_item
= sep [ ptext SLIT("The export item") <+> quotes (ppr 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") ] 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 exportClashErr global_env name1 name2 ie1 ie2
= vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon = vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon
, ppr_export ie1 name1 , ppr_export ie1 name1
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment