X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FRdrName.lhs;h=6903e6c4a2a42edf2b483a2c843dc140a8013b1d;hb=0171936c9092666692c69a7f93fa75af976330cb;hp=a40b051a5df2cb8f3ff71ce907ba9ffb5fa49186;hpb=4102e5cec12cd96f59260aee2c6da01616b97467;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index a40b051..6903e6c 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -1,3 +1,4 @@ +{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -9,20 +10,19 @@ module RdrName ( RdrName, -- Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkQual, - mkSysUnqual, mkSysQual, - mkPreludeQual, qualifyRdrName, mkRdrNameWkr, + mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrUnqual, + mkUnqual, mkQual, mkIfaceOrig, mkOrig, + qualifyRdrName, unqualifyRdrName, mkRdrNameWkr, dummyRdrVarName, dummyRdrTcName, -- Destruction rdrNameModule, rdrNameOcc, setRdrNameOcc, - isRdrDataCon, isRdrTyVar, isQual, isUnqual, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, isOrig, -- Environment RdrNameEnv, emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, - extendRdrEnv, rdrEnvToList, elemRdrEnv, + extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv, -- Printing; instance Outputable RdrName pprUnqualRdrName @@ -31,16 +31,17 @@ module RdrName ( #include "HsVersions.h" import OccName ( NameSpace, tcName, - OccName, UserFS, + OccName, UserFS, EncodedFS, mkSysOccFS, mkOccFS, mkVarOcc, - isDataOcc, isTvOcc, mkWorkerOcc + isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc ) import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) import FiniteMap import Outputable +import Binary import Util ( thenCmp ) \end{code} @@ -53,9 +54,20 @@ import Util ( thenCmp ) \begin{code} data RdrName = RdrName Qual OccName + {-! derive: Binary !-} + +data Qual + = Unqual + + | Qual ModuleName -- A qualified name written by the user in source code + -- The module isn't necessarily the module where + -- the thing is defined; just the one from which it + -- is imported + + | Orig ModuleName -- This is an *original* name; the module is the place + -- where the thing was defined + {-! derive: Binary !-} -data Qual = Unqual - | Qual ModuleName -- The (encoded) module name \end{code} @@ -68,6 +80,7 @@ data Qual = Unqual \begin{code} rdrNameModule :: RdrName -> ModuleName rdrNameModule (RdrName (Qual m) _) = m +rdrNameModule (RdrName (Orig m) _) = m rdrNameOcc :: RdrName -> OccName rdrNameOcc (RdrName _ occ) = occ @@ -84,29 +97,31 @@ mkRdrUnqual occ = RdrName Unqual occ mkRdrQual :: ModuleName -> OccName -> RdrName mkRdrQual mod occ = RdrName (Qual mod) occ +mkRdrOrig :: ModuleName -> OccName -> RdrName +mkRdrOrig mod occ = RdrName (Orig mod) occ + +mkIfaceOrig :: NameSpace -> (EncodedFS, EncodedFS) -> RdrName +mkIfaceOrig ns (m,n) = RdrName (Orig (mkSysModuleNameFS m)) (mkSysOccFS ns n) + + -- These two are used when parsing source files -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FAST_STRING -> RdrName +mkUnqual :: NameSpace -> UserFS -> RdrName mkUnqual sp n = RdrName Unqual (mkOccFS sp n) mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName mkQual sp (m, n) = RdrName (Qual (mkModuleNameFS m)) (mkOccFS sp n) - -- These two are used when parsing interface files - -- They do not encode the module and occurrence name -mkSysUnqual :: NameSpace -> FAST_STRING -> RdrName -mkSysUnqual sp n = RdrName Unqual (mkSysOccFS sp n) - -mkSysQual :: NameSpace -> (FAST_STRING, FAST_STRING) -> RdrName -mkSysQual sp (m,n) = RdrName (Qual (mkSysModuleNameFS m)) (mkSysOccFS sp n) - -mkPreludeQual :: NameSpace -> ModuleName -> FAST_STRING -> RdrName -mkPreludeQual sp mod n = RdrName (Qual mod) (mkOccFS sp n) +mkOrig :: NameSpace -> ModuleName -> UserFS -> RdrName +mkOrig sp mod n = RdrName (Orig mod) (mkOccFS sp n) qualifyRdrName :: ModuleName -> RdrName -> RdrName -- Sets the module name of a RdrName, even if it has one already qualifyRdrName mod (RdrName _ occ) = RdrName (Qual mod) occ +unqualifyRdrName :: RdrName -> RdrName +unqualifyRdrName (RdrName _ occ) = RdrName Unqual occ + mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) \end{code} @@ -117,19 +132,24 @@ mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) -- the renamer. We can't just put "error..." because -- we sometimes want to print out stuff after reading but -- before renaming -dummyRdrVarName = RdrName Unqual (mkVarOcc SLIT("V-DUMMY")) -dummyRdrTcName = RdrName Unqual (mkOccFS tcName SLIT("TC-DUMMY")) +dummyRdrVarName = RdrName Unqual (mkVarOcc FSLIT("V-DUMMY")) +dummyRdrTcName = RdrName Unqual (mkOccFS tcName FSLIT("TC-DUMMY")) \end{code} \begin{code} isRdrDataCon (RdrName _ occ) = isDataOcc occ isRdrTyVar (RdrName _ occ) = isTvOcc occ +isRdrTc (RdrName _ occ) = isTcOcc occ isUnqual (RdrName Unqual _) = True isUnqual other = False -isQual rdr_name = not (isUnqual rdr_name) +isQual (RdrName (Qual _) _) = True +isQual _ = False + +isOrig (RdrName (Orig _) _) = True +isOrig other = False \end{code} @@ -143,8 +163,9 @@ isQual rdr_name = not (isUnqual rdr_name) instance Outputable RdrName where ppr (RdrName qual occ) = pp_qual qual <> ppr occ where - pp_qual Unqual = empty - pp_qual (Qual mod) = ppr mod <> dot + pp_qual Unqual = empty + pp_qual (Qual mod) = ppr mod <> dot + pp_qual (Orig mod) = ppr mod <> dot pprUnqualRdrName (RdrName qual occ) = ppr occ @@ -162,10 +183,12 @@ instance Ord RdrName where = (o1 `compare` o2) `thenCmp` (q1 `cmpQual` q2) -cmpQual Unqual Unqual = EQ -cmpQual Unqual (Qual _) = LT -cmpQual (Qual _) Unqual = GT -cmpQual (Qual m1) (Qual m2) = m1 `compare` m2 +cmpQual Unqual Unqual = EQ +cmpQual (Qual m1) (Qual m2) = m1 `compare` m2 +cmpQual (Orig m1) (Orig m2) = m1 `compare` m2 +cmpQual Unqual _ = LT +cmpQual (Qual _) (Orig _) = LT +cmpQual _ _ = GT \end{code} @@ -186,12 +209,46 @@ extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] rdrEnvElts :: RdrNameEnv a -> [a] elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool +foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM +emptyRdrEnv = emptyFM +lookupRdrEnv = lookupFM addListToRdrEnv = addListToFM rdrEnvElts = eltsFM extendRdrEnv = addToFM rdrEnvToList = fmToList elemRdrEnv = elemFM +foldRdrEnv = foldFM +\end{code} +\begin{code} +{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} +instance Binary RdrName where + put_ bh (RdrName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (RdrName aa ab) + +instance Binary Qual where + put_ bh Unqual = do + putByte bh 0 + put_ bh (Qual aa) = do + putByte bh 1 + put_ bh aa + put_ bh (Orig ab) = do + putByte bh 2 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return Unqual + 1 -> do aa <- get bh + return (Qual aa) + _ -> do ab <- get bh + return (Orig ab) + +-- Imported from other files :- + \end{code}