Commit 9af77fa4 authored by simonpj's avatar simonpj

[project @ 2002-09-13 15:02:25 by simonpj]

--------------------------------------
	Make Template Haskell into the HEAD
	--------------------------------------

This massive commit transfers to the HEAD all the stuff that
Simon and Tim have been doing on Template Haskell.  The
meta-haskell-branch is no more!

WARNING: make sure that you

  * Update your links if you are using link trees.
    Some modules have been added, some have gone away.

  * Do 'make clean' in all library trees.
    The interface file format has changed, and you can
    get strange panics (sadly) if GHC tries to read old interface files:
    e.g.  ghc-5.05: panic! (the `impossible' happened, GHC version 5.05):
	  Binary.get(TyClDecl): ForeignType

  * You need to recompile the rts too; Linker.c has changed


However the libraries are almost unaltered; just a tiny change in
Base, and to the exports in Prelude.


NOTE: so far as TH itself is concerned, expression splices work
fine, but declaration splices are not complete.


		---------------
		The main change
		---------------

The main structural change: renaming and typechecking have to be
interleaved, because we can't rename stuff after a declaration splice
until after we've typechecked the stuff before (and the splice
itself).

* Combine the renamer and typecheker monads into one
	(TcRnMonad, TcRnTypes)
  These two replace TcMonad and RnMonad

* Give them a single 'driver' (TcRnDriver).  This driver
  replaces TcModule.lhs and Rename.lhs

* The haskell-src library package has a module
	Language/Haskell/THSyntax
  which defines the Haskell data type seen by the TH programmer.

* New modules:
	hsSyn/Convert.hs 	converts THSyntax -> HsSyn
	deSugar/DsMeta.hs 	converts HsSyn -> THSyntax

* New module typecheck/TcSplice type-checks Template Haskell splices.

		-------------
		Linking stuff
		-------------

* ByteCodeLink has been split into
	ByteCodeLink	(which links)
	ByteCodeAsm	(which assembles)

* New module ghci/ObjLink is the object-code linker.

* compMan/CmLink is removed entirely (was out of place)
  Ditto CmTypes (which was tiny)

* Linker.c initialises the linker when it is first used (no need to call
  initLinker any more).  Template Haskell makes it harder to know when
  and whether to initialise the linker.


	-------------------------------------
	Gathering the LIE in the type checker
	-------------------------------------

* Instead of explicitly gathering constraints in the LIE
	tcExpr :: RenamedExpr -> TcM (TypecheckedExpr, LIE)
  we now dump the constraints into a mutable varabiable carried
  by the monad, so we get
	tcExpr :: RenamedExpr -> TcM TypecheckedExpr

  Much less clutter in the code, and more efficient too.
  (Originally suggested by Mark Shields.)


		-----------------
		Remove "SysNames"
		-----------------

Because the renamer and the type checker were entirely separate,
we had to carry some rather tiresome implicit binders (or "SysNames")
along inside some of the HsDecl data structures.  They were both
tiresome and fragile.

Now that the typechecker and renamer are more intimately coupled,
we can eliminate SysNames (well, mostly... default methods still
carry something similar).

		-------------
		Clean up HsPat
		-------------

One big clean up is this: instead of having two HsPat types (InPat and
OutPat), they are now combined into one.  This is more consistent with
the way that HsExpr etc is handled; there are some 'Out' constructors
for the type checker output.

So:
	HsPat.InPat	--> HsPat.Pat
	HsPat.OutPat	--> HsPat.Pat
	No 'pat' type parameter in HsExpr, HsBinds, etc

	Constructor patterns are nicer now: they use
		HsPat.HsConDetails
	for the three cases of constructor patterns:
		prefix, infix, and record-bindings

	The *same* data type HsConDetails is used in the type
	declaration of the data type (HsDecls.TyData)

Lots of associated clean-up operations here and there.  Less code.
Everything is wonderful.
parent 69e55e74
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.221 2002/09/06 14:35:43 simonmar Exp $
# $Id: Makefile,v 1.222 2002/09/13 15:02:25 simonpj Exp $
TOP = ..
......@@ -101,11 +101,14 @@ CLEAN_FILES += $(CONFIG_HS)
ALL_DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
profiling parser usageSP cprAnalysis compMan ndpFlatten
profiling parser usageSP cprAnalysis compMan ndpFlatten
# Make sure we include Config.hs even if it doesn't exist yet...
ALL_SRCS += $(CONFIG_HS)
# HsGeneric.hs is not used just now
EXCLUDED_SRCS += hsSyn/HsGeneric.hs
ifeq ($(GhcWithNativeCodeGen),YES)
ALL_DIRS += nativeGen
else
......@@ -132,15 +135,17 @@ compiling_with_4xx = $(shell if (test $(GhcCanonVersion) -lt 500); then echo YES
endif
# Only include GHCi if we're bootstrapping with at least version 411
ifeq "$(GhcWithInterpreter)" "YES"
ifeq "$(bootstrapped)" "YES"
SRC_HC_OPTS += -DGHCI -package readline
ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
# Yes, include the interepreter, readline, and Template Haskell extensions
SRC_HC_OPTS += -DGHCI -package readline -package haskell-src
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
SRC_HC_OPTS += -package unix
endif
ALL_DIRS += ghci
endif
endif
else
# No interpreter, so exclude Template Haskell modules
EXCLUDED_SRCS += deSugar/DsMeta.hs typecheck/TcSplice.lhs hsSyn/Convert.lhs
endif
# There are some C files to include in HS_PROG, so add these to HS_OBJS
HS_OBJS += $(C_OBJS)
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.49 2002/08/02 13:08:33 simonmar Exp $
% $Id: AbsCSyn.lhs,v 1.50 2002/09/13 15:02:25 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CLabel.lhs,v 1.54 2002/07/18 09:16:12 simonmar Exp $
% $Id: CLabel.lhs,v 1.55 2002/09/13 15:02:26 simonpj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
......@@ -90,7 +90,6 @@ import TyCon ( TyCon )
import Unique ( pprUnique, Unique )
import PrimOp ( PrimOp )
import CostCentre ( CostCentre, CostCentreStack )
import BasicTypes ( Version )
import Outputable
import FastString
\end{code}
......
......@@ -20,7 +20,7 @@ module BasicTypes(
Unused, unused,
Fixity(..), FixityDirection(..),
FixitySig(..), Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence,
arrowFixity, negateFixity, negatePrecedence,
compareFixity,
......@@ -46,12 +46,15 @@ module BasicTypes(
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive
Activation(..), isActive, isNeverActive, isAlwaysActive,
SuccessFlag(..), succeeded, failed, successIf
) where
#include "HsVersions.h"
import Outputable
import SrcLoc
\end{code}
%************************************************************************
......@@ -137,21 +140,34 @@ mapIPName f (Linear n) = Linear (f n)
%************************************************************************
\begin{code}
------------------------
data FixitySig name = FixitySig name Fixity SrcLoc
instance Eq name => Eq (FixitySig name) where
(FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
instance Outputable name => Outputable (FixitySig name) where
ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
------------------------
data Fixity = Fixity Int FixityDirection
data FixityDirection = InfixL | InfixR | InfixN
deriving(Eq)
instance Outputable Fixity where
ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
instance Eq Fixity where -- Used to determine if two fixities conflict
(Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
------------------------
data FixityDirection = InfixL | InfixR | InfixN
deriving(Eq)
instance Outputable FixityDirection where
ppr InfixL = ptext SLIT("infixl")
ppr InfixR = ptext SLIT("infixr")
ppr InfixN = ptext SLIT("infix")
instance Eq Fixity where -- Used to determine if two fixities conflict
(Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
------------------------
maxPrecedence = (9::Int)
defaultFixity = Fixity maxPrecedence InfixL
......@@ -405,6 +421,28 @@ instance Outputable StrictnessMark where
\end{code}
%************************************************************************
%* *
\subsection{Success flag}
%* *
%************************************************************************
\begin{code}
data SuccessFlag = Succeeded | Failed
successIf :: Bool -> SuccessFlag
successIf True = Succeeded
successIf False = Failed
succeeded, failed :: SuccessFlag -> Bool
succeeded Succeeded = True
succeeded Failed = False
failed Succeeded = False
failed Failed = True
\end{code}
%************************************************************************
%* *
\subsection{Activation}
......@@ -443,3 +481,4 @@ isNeverActive act = False
isAlwaysActive AlwaysActive = True
isAlwaysActive other = False
\end{code}
......@@ -25,7 +25,7 @@ module IdInfo (
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo,
newDemandInfo, setNewDemandInfo,
newDemandInfo, setNewDemandInfo, pprNewStrictness,
-- Strictness; imported from Demand
StrictnessInfo(..),
......@@ -94,12 +94,12 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Type ( usOnce )
import Demand hiding( Demand, seqDemand )
import qualified Demand
import NewDemand
import Outputable
import Util ( seqList, listLengthCmp )
import Util ( listLengthCmp )
import Maybe ( isJust )
import List ( replicate )
......@@ -153,6 +153,9 @@ setAllStrictnessInfo info (Just sig)
seqNewStrictnessInfo Nothing = ()
seqNewStrictnessInfo (Just ty) = seqStrictSig ty
pprNewStrictness Nothing = empty
pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
#ifdef OLD_STRICTNESS
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
......
......@@ -42,8 +42,8 @@ import Util ( thenCmp )
import Ratio ( numerator )
import FastString ( uniqueOfFS, lengthFS )
import Int ( Int8, Int16, Int32 )
import Word ( Word8, Word16, Word32 )
import DATA_INT ( Int8, Int16, Int32 )
import DATA_WORD ( Word8, Word16, Word32 )
import Char ( ord, chr )
\end{code}
......
......@@ -49,7 +49,6 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, mkPredTy
)
import Module ( Module )
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import Literal ( Literal(..), nullAddrLit )
......@@ -58,8 +57,7 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet )
import Name ( mkWiredInName, mkFCallName, Name )
import OccName ( mkVarOcc )
import Name ( mkFCallName, Name )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon,
......@@ -98,7 +96,6 @@ import FastString
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
import Char ( ord )
\end{code}
%************************************************************************
......@@ -811,7 +808,7 @@ another gun with which to shoot yourself in the foot.
\begin{code}
-- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info
= pcMiscPrelId unsafeCoerceName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
......@@ -826,13 +823,13 @@ unsafeCoerceId
-- The reason is is here is because we don't provide
-- a way to write this literal in Haskell.
nullAddrId
= pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info
= pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit)
seqId
= pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info
= pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
......@@ -849,7 +846,7 @@ seqId
-- the info in PrelBase.hi. This is important, because the strictness
-- analyser will spot it as strict!
lazyId
= pcMiscPrelId lazyIdKey pREL_BASE FSLIT("lazy") ty info
= pcMiscPrelId lazyIdName ty info
where
info = noCafIdInfo
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
......@@ -865,7 +862,7 @@ evaluate its argument and call the dataToTag# primitive.
\begin{code}
getTagId
= pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info
= pcMiscPrelId getTagName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
......@@ -890,8 +887,7 @@ This comes up in strictness analysis
\begin{code}
realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#")
realWorldStatePrimTy
= pcMiscPrelId realWorldName realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
......@@ -937,22 +933,21 @@ mkRuntimeErrorApp err_id res_ty err_msg
where
err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError")
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError")
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError")
rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError")
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
pAT_ERROR_ID = mkRuntimeErrorId patErrorName
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
-- The runtime error Ids take a UTF8-encoded string as argument
mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
\begin{code}
eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
eRROR_ID = pc_bottoming_Id errorName errorTy
errorTy :: Type
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
......@@ -969,21 +964,17 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy
%************************************************************************
\begin{code}
pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id
pcMiscPrelId key mod str ty info
= let
name = mkWiredInName mod (mkVarOcc str) key
imp = mkVanillaGlobal name ty info -- the usual case...
in
imp
pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId name ty info
= mkVanillaGlobal name ty info
-- We lie and say the thing is imported; otherwise, we get into
-- a mess with dependency analysis; e.g., core2stg may heave in
-- random calls to GHCbase.unpackPS__. If GHCbase is the module
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
-- Do *not* mark them as NoCafRefs, because they can indeed have
......
......@@ -41,8 +41,8 @@ module Module
(
Module, -- Abstract, instance of Eq, Ord, Outputable
, PackageName -- = FastString; instance of Outputable, Uniquable
, preludePackage -- :: PackageName
, ModLocation(..),
, showModMsg
, ModuleName
, pprModuleName -- :: ModuleName -> SDoc
......@@ -59,7 +59,6 @@ module Module
, mkVanillaModule -- :: ModuleName -> Module
, isVanillaModule -- :: Module -> Bool
, mkPrelModule -- :: UserString -> Module
, mkModule -- :: ModuleName -> PackageName -> Module
, mkHomeModule -- :: ModuleName -> Module
, isHomeModule -- :: Module -> Bool
, mkPackageModule -- :: ModuleName -> Module
......@@ -70,15 +69,13 @@ module Module
, pprModule,
-- Where to find a .hi file
, WhereFrom(..)
, ModuleEnv,
, elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
, lookupModuleEnvByName, extendModuleEnv_C
, extendModuleEnv_C
, lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName
, ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
......@@ -87,9 +84,11 @@ module Module
#include "HsVersions.h"
import OccName
import Outputable
import Packages ( PackageName, preludePackage )
import CmdLineOpts ( opt_InPackage )
import FastString ( FastString )
import Unique ( Uniquable(..) )
import Maybes ( expectJust )
import UniqFM
import UniqSet
import Binary
......@@ -134,11 +133,6 @@ data PackageInfo
-- Later on (in RnEnv.newTopBinder) we'll update the cache
-- to have the right PackageName
type PackageName = FastString -- No encoding at all
preludePackage :: PackageName
preludePackage = FSLIT("base")
packageInfoPackage :: PackageInfo -> PackageName
packageInfoPackage ThisPackage = opt_InPackage
packageInfoPackage DunnoYet = FSLIT("<?>")
......@@ -152,28 +146,44 @@ instance Outputable PackageInfo where
%************************************************************************
%* *
\subsection{Where from}
\subsection{Module locations}
%* *
%************************************************************************
The @WhereFrom@ type controls where the renamer looks for an interface file
\begin{code}
data WhereFrom = ImportByUser -- Ordinary user import: look for M.hi
| ImportByUserSource -- User {- SOURCE -}: look for M.hi-boot
| ImportBySystem -- Non user import. Look for M.hi if M is in
-- the module this module depends on, or is a system-ish module;
-- M.hi-boot otherwise
| ImportByCmdLine -- The user typed a qualified name at
-- the GHCi prompt, try to demand-load
-- the interface.
instance Outputable WhereFrom where
ppr ImportByUser = empty
ppr ImportByUserSource = ptext SLIT("{- SOURCE -}")
ppr ImportBySystem = ptext SLIT("{- SYSTEM IMPORT -}")
data ModLocation
= ModLocation {
ml_hs_file :: Maybe FilePath,
ml_hspp_file :: Maybe FilePath, -- path of preprocessed source
ml_hi_file :: FilePath,
ml_obj_file :: Maybe FilePath
}
deriving Show
instance Outputable ModLocation where
ppr = text . show
-- Rather a gruesome function to have in Module
showModMsg :: Bool -> Module -> ModLocation -> String
showModMsg use_object mod location =
mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", "
++ (if use_object
then expectJust "showModMsg" (ml_obj_file location)
else "interpreted")
++ " )"
where mod_str = moduleUserString mod
\end{code}
For a module in another package, the hs_file and obj_file
components of ModLocation are undefined.
The locations specified by a ModLocation may or may not
correspond to actual files yet: for example, even if the object
file doesn't exist, the ModLocation still contains the path to
where the object file will reside if/when it is created.
%************************************************************************
%* *
......@@ -255,21 +265,22 @@ pprModule :: Module -> SDoc
pprModule (Module mod p) = getPprStyle $ \ sty ->
if debugStyle sty then
-- Print the package too
ppr p <> dot <> pprModuleName mod
-- Don't use '.' because it gets confused
-- with module names
brackets (ppr p) <> pprModuleName mod
else
pprModuleName mod
\end{code}
\begin{code}
mkModule :: ModuleName -- Name of the module
-> PackageName
-> Module
mkModule mod_nm pack_name
mkPrelModule :: ModuleName -> Module
mkPrelModule mod_nm
= Module mod_nm pack_info
where
pack_info | pack_name == opt_InPackage = ThisPackage
| otherwise = AnotherPackage
pack_info
| opt_InPackage == preludePackage = ThisPackage
| otherwise = AnotherPackage
mkHomeModule :: ModuleName -> Module
mkHomeModule mod_nm = Module mod_nm ThisPackage
......@@ -291,9 +302,6 @@ isVanillaModule :: Module -> Bool
isVanillaModule (Module nm DunnoYet) = True
isVanillaModule _ = False
mkPrelModule :: ModuleName -> Module
mkPrelModule name = mkModule name preludePackage
moduleString :: Module -> EncodedString
moduleString (Module (ModuleName fs) _) = unpackFS fs
......@@ -318,6 +326,9 @@ printModulePrefix _ = True
\begin{code}
type ModuleEnv elt = UniqFM elt
-- A ModuleName and Module have the same Unique,
-- so both will work as keys.
-- The 'ByName' variants work on ModuleNames
emptyModuleEnv :: ModuleEnv a
mkModuleEnv :: [(Module, a)] -> ModuleEnv a
......@@ -335,13 +346,18 @@ moduleEnvElts :: ModuleEnv a -> [a]
isEmptyModuleEnv :: ModuleEnv a -> Bool
lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
lookupModuleEnvByName:: ModuleEnv a -> ModuleName -> Maybe a
lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
elemModuleEnv :: Module -> ModuleEnv a -> Bool
foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
-- The ByName variants
lookupModuleEnvByName :: ModuleEnv a -> ModuleName -> Maybe a
unitModuleEnvByName :: ModuleName -> a -> ModuleEnv a
extendModuleEnvByName :: ModuleEnv a -> ModuleName -> a -> ModuleEnv a
elemModuleEnv = elemUFM
extendModuleEnv = addToUFM
extendModuleEnvByName = addToUFM
extendModuleEnv_C = addToUFM_C
extendModuleEnvList = addListToUFM
plusModuleEnv_C = plusUFM_C
......@@ -356,6 +372,7 @@ mkModuleEnv = listToUFM
emptyModuleEnv = emptyUFM
moduleEnvElts = eltsUFM
unitModuleEnv = unitUFM
unitModuleEnvByName = unitUFM
isEmptyModuleEnv = isNullUFM
foldModuleEnv = foldUFM
\end{code}
......
......@@ -17,31 +17,28 @@ module Name (
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe,
setNameOcc, nameRdrName, setNameModuleAndLoc,
toRdrName, hashName,
externaliseName, localiseName,
setNameOcc, setNameModuleAndLoc,
hashName, externaliseName, localiseName,
nameSrcLoc,
nameSrcLoc, eqNameByOcc,
isSystemName, isInternalName, isExternalName,
isTyVarName, isDllName,
isTyVarName, isDllName, isWiredInName,
nameIsLocalOrFrom, isHomePackageName,
-- Class NamedThing and overloaded friends
NamedThing(..),
getSrcLoc, getOccString, toRdrName
getSrcLoc, getOccString
) where
#include "HsVersions.h"
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule, isHomeModule )
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import Module ( Module, ModuleName, moduleName, mkVanillaModule, isHomeModule )
import CmdLineOpts ( opt_Static )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import SrcLoc ( noSrcLoc, isWiredInLoc, wiredInSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), getKey, pprUnique )
import FastTypes
import Binary
import Outputable
\end{code}
......@@ -108,12 +105,6 @@ nameSrcLoc :: Name -> SrcLoc
nameUnique name = n_uniq name
nameOccName name = n_occ name
nameSrcLoc name = n_loc name
nameModule (Name { n_sort = External mod }) = mod
nameModule name = pprPanic "nameModule" (ppr name)
nameModule_maybe (Name { n_sort = External mod }) = Just mod
nameModule_maybe name = Nothing
\end{code}
\begin{code}
......@@ -122,9 +113,18 @@ isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
isHomePackageName :: Name -> Bool
isWiredInName :: Name -> Bool
isWiredInName name = isWiredInLoc (n_loc name)
isExternalName (Name {n_sort = External _}) = True
isExternalName other = False
isExternalName other = False
nameModule (Name { n_sort = External mod }) = mod
nameModule name = pprPanic "nameModule" (ppr name)
nameModule_maybe (Name { n_sort = External mod }) = Just mod
nameModule_maybe name = Nothing
isInternalName name = not (isExternalName name)
......@@ -142,6 +142,18 @@ isTyVarName name = isTvOcc (nameOccName name)
isSystemName (Name {n_sort = System}) = True
isSystemName other = False
eqNameByOcc :: Name -> Name -> Bool
-- Compare using the strings, not the unique
-- See notes with HsCore.eq_ufVar
eqNameByOcc (Name {n_sort = sort1, n_occ = occ1})
(Name {n_sort = sort2, n_occ = occ2})
= sort1 `eq_sort` sort2 && occ1 == occ2
where
eq_sort (External m1) (External m2) = moduleName m1 == moduleName m2
eq_sort (External _) _ = False
eq_sort _ (External _) = False
eq_sort _ _ = True
\end{code}
......@@ -167,14 +179,12 @@ mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name
mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod,
n_occ = occ, n_loc = loc }
mkKnownKeyExternalName :: RdrName -> Unique -> Name
mkKnownKeyExternalName rdr_name uniq
= mkExternalName uniq (mkVanillaModule (rdrNameModule rdr_name))
(rdrNameOcc rdr_name)
builtinSrcLoc
mkKnownKeyExternalName :: ModuleName -> OccName -> Unique -> Name
mkKnownKeyExternalName mod occ uniq
= mkExternalName uniq (mkVanillaModule mod) occ noSrcLoc
mkWiredInName :: Module -> OccName -> Unique -> Name
mkWiredInName mod occ uniq = mkExternalName uniq mod occ builtinSrcLoc
mkWiredInName mod occ uniq = mkExternalName uniq mod occ wiredInSrcLoc
mkSystemName :: Unique -> UserFS -> Name
mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System,
......@@ -236,13 +246,6 @@ setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc
\begin{code}
hashName :: Name -> Int
hashName name = iBox (getKey (nameUnique name))
nameRdrName :: Name -> RdrName
-- Makes a qualified name for top-level (External) names,
-- whether locally defined or not and an unqualified name just for Internals
nameRdrName (Name { n_occ = occ, n_sort = External mod }) = mkRdrOrig (moduleName mod) occ
nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ
\end{code}
......@@ -275,26 +278,6 @@ instance NamedThing Name where
getName n = n
\end{code}
%************************************************************************
%* *
\subsection{Binary output}
%* *
%************************************************************************
\begin{code}
instance Binary Name where
-- we must print these as RdrNames, because that's how they will be read in
put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} =
case sort of
External mod
| this_mod == mod -> put_ bh (mkRdrUnqual occ)
| otherwise -> put_ bh (mkRdrOrig (moduleName mod) occ)
where (this_mod,_,_,_) = getUserData bh
_ -> do
put_ bh (mkRdrUnqual occ)
get bh = error "can't Binary.get a Name"
\end{code}