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 (
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}
......
......@@ -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
......
......@@ -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
......
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