+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
OccName, -- Abstract, instance of Outputable
pprOccName,
- mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
+ mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
+ mkVarOcc, mkVarOccEncoded,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
import Util ( thenCmp )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
+import FastString
import Outputable
-import GlaExts
+import Binary
+
+import GLAEXTS
\end{code}
We hold both module names and identifier names in a 'Z-encoded' form
These type synonyms help documentation.
\begin{code}
-type UserFS = FAST_STRING -- As the user typed it
-type EncodedFS = FAST_STRING -- Encoded form
+type UserFS = FastString -- As the user typed it
+type EncodedFS = FastString -- Encoded form
type UserString = String -- As the user typed it
type EncodedString = String -- Encoded form
pprEncodedFS fs
= getPprStyle $ \ sty ->
if userStyle sty
- -- ptext (decodeFS fs) would needlessly pack the string again
- then text (decode (_UNPK_ fs))
- else ptext fs
+ -- ftext (decodeFS fs) would needlessly pack the string again
+ then text (decode (unpackFS fs))
+ else ftext fs
\end{code}
%************************************************************************
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
+ {-! derive: Binary !-}
-- Though type constructors and classes are in the same name space now,
-- the NameSpace type is abstract, so we can easily separate them later
data OccName = OccName
NameSpace
EncodedFS
+ {-! derive : Binary !-}
\end{code}
\begin{code}
mkSysOcc :: NameSpace -> EncodedString -> OccName
mkSysOcc occ_sp str = ASSERT2( alreadyEncoded str, text str )
- OccName occ_sp (_PK_ str)
+ OccName occ_sp (mkFastString str)
mkSysOccFS :: NameSpace -> EncodedFS -> OccName
mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs )
-- because it will be something like "{__ccall f dyn Int# -> Int#}"
-- This encodes a lot into something that then parses like an Id.
-- But then alreadyEncoded complains about the braces!
-mkFCallOcc str = OccName varName (_PK_ str)
+mkFCallOcc str = OccName varName (mkFastString str)
-- Kind constructors get a special function. Uniquely, they are not encoded,
-- so that they have names like '*'. This means that *even in interface files*
mkVarOcc :: UserFS -> OccName
mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
+
+mkVarOccEncoded :: EncodedFS -> OccName
+mkVarOccEncoded fs = mkSysOccFS varName fs
\end{code}
occNameFS (OccName _ s) = s
occNameString :: OccName -> EncodedString
-occNameString (OccName _ s) = _UNPK_ s
+occNameString (OccName _ s) = unpackFS s
occNameUserString :: OccName -> UserString
occNameUserString occ = decode (occNameString occ)
tack on the '1', if necessary.
\begin{code}
-type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames
+type TidyOccEnv = FiniteMap FastString Int -- The in-scope OccNames
emptyTidyOccEnv = emptyFM
initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid!
= (addToFM in_scope fs 1, occ) -- First occurrence
| otherwise -- Already occurs
- = go in_scope (_UNPK_ fs)
+ = go in_scope (unpackFS fs)
where
go in_scope str = case lookupFM in_scope pk_str of
Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str)
-- str is now unique
where
- pk_str = _PK_ str
+ pk_str = mkFastString str
\end{code}
-- reject them here
ok ch = isAlphaNum ch
-alreadyEncodedFS :: FAST_STRING -> Bool
-alreadyEncodedFS fs = alreadyEncoded (_UNPK_ fs)
+alreadyEncodedFS :: FastString -> Bool
+alreadyEncodedFS fs = alreadyEncoded (unpackFS fs)
encode :: UserString -> EncodedString
encode cs = case maybe_tuple cs of
encodeFS :: UserFS -> EncodedFS
encodeFS fast_str | all unencodedChar str = fast_str
- | otherwise = _PK_ (encode str)
+ | otherwise = mkFastString (encode str)
where
- str = _UNPK_ fast_str
+ str = unpackFS fast_str
unencodedChar :: Char -> Bool -- True for chars that don't need encoding
unencodedChar 'Z' = False
Decode is used for user printing.
\begin{code}
-decodeFS :: FAST_STRING -> FAST_STRING
-decodeFS fs = _PK_ (decode (_UNPK_ fs))
+decodeFS :: FastString -> FastString
+decodeFS fs = mkFastString (decode (unpackFS fs))
decode :: EncodedString -> UserString
decode [] = []
defined in the Haskell report.
\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool
-isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool
+isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool
isLexCon cs = isLexConId cs || isLexConSym cs
isLexVar cs = isLexVarId cs || isLexVarSym cs
-------------
isLexConId cs -- Prefix type or data constructors
- | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
- | cs == SLIT("[]") = True
- | otherwise = startsConId (_HEAD_ cs)
+ | nullFastString cs = False -- e.g. "Foo", "[]", "(,)"
+ | cs == FSLIT("[]") = True
+ | otherwise = startsConId (headFS cs)
isLexVarId cs -- Ordinary prefix identifiers
- | _NULL_ cs = False -- e.g. "x", "_x"
- | otherwise = startsVarId (_HEAD_ cs)
+ | nullFastString cs = False -- e.g. "x", "_x"
+ | otherwise = startsVarId (headFS cs)
isLexConSym cs -- Infix type or data constructors
- | _NULL_ cs = False -- e.g. ":-:", ":", "->"
- | cs == SLIT("->") = True
- | otherwise = startsConSym (_HEAD_ cs)
+ | nullFastString cs = False -- e.g. ":-:", ":", "->"
+ | cs == FSLIT("->") = True
+ | otherwise = startsConSym (headFS cs)
isLexVarSym cs -- Infix identifiers
- | _NULL_ cs = False -- e.g. "+"
- | otherwise = startsVarSym (_HEAD_ cs)
+ | nullFastString cs = False -- e.g. "+"
+ | otherwise = startsVarSym (headFS cs)
-------------
startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}
+\begin{code}
+{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
+instance Binary NameSpace where
+ put_ bh VarName = do
+ putByte bh 0
+ put_ bh DataName = do
+ putByte bh 1
+ put_ bh TvName = do
+ putByte bh 2
+ put_ bh TcClsName = do
+ putByte bh 3
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return VarName
+ 1 -> do return DataName
+ 2 -> do return TvName
+ _ -> do return TcClsName
+
+instance Binary OccName where
+ put_ bh (OccName aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (OccName aa ab)
+
+-- Imported from other files :-
+
+\end{code}
projects / ghc-hetmet.git / blobdiff