%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
they are used somewhat later on in the compiler...)
\begin{code}
-#include "HsVersions.h"
-
module RdrHsSyn (
- SYN_IE(RdrNameArithSeqInfo),
- SYN_IE(RdrNameBangType),
- SYN_IE(RdrNameBind),
- SYN_IE(RdrNameClassDecl),
- SYN_IE(RdrNameClassOpSig),
- SYN_IE(RdrNameConDecl),
- SYN_IE(RdrNameContext),
- SYN_IE(RdrNameSpecDataSig),
- SYN_IE(RdrNameDefaultDecl),
- SYN_IE(RdrNameFixityDecl),
- SYN_IE(RdrNameGRHS),
- SYN_IE(RdrNameGRHSsAndBinds),
- SYN_IE(RdrNameHsBinds),
- SYN_IE(RdrNameHsDecl),
- SYN_IE(RdrNameHsExpr),
- SYN_IE(RdrNameHsModule),
- SYN_IE(RdrNameIE),
- SYN_IE(RdrNameImportDecl),
- SYN_IE(RdrNameInstDecl),
- SYN_IE(RdrNameMatch),
- SYN_IE(RdrNameMonoBinds),
- SYN_IE(RdrNamePat),
- SYN_IE(RdrNameHsType),
- SYN_IE(RdrNameQual),
- SYN_IE(RdrNameSig),
- SYN_IE(RdrNameSpecInstSig),
- SYN_IE(RdrNameStmt),
- SYN_IE(RdrNameTyDecl),
-
- SYN_IE(RdrNameClassOpPragmas),
- SYN_IE(RdrNameClassPragmas),
- SYN_IE(RdrNameDataPragmas),
- SYN_IE(RdrNameGenPragmas),
- SYN_IE(RdrNameInstancePragmas),
- SYN_IE(RdrNameCoreExpr),
- extractHsTyVars,
+ RdrNameArithSeqInfo,
+ RdrNameBangType,
+ RdrNameClassOpSig,
+ RdrNameConDecl,
+ RdrNameContext,
+ RdrNameSpecDataSig,
+ RdrNameDefaultDecl,
+ RdrNameForeignDecl,
+ RdrNameGRHS,
+ RdrNameGRHSs,
+ RdrNameHsBinds,
+ RdrNameHsDecl,
+ RdrNameHsExpr,
+ RdrNameHsModule,
+ RdrNameIE,
+ RdrNameImportDecl,
+ RdrNameInstDecl,
+ RdrNameMatch,
+ RdrNameMonoBinds,
+ RdrNamePat,
+ RdrNameHsType,
+ RdrNameSig,
+ RdrNameStmt,
+ RdrNameTyClDecl,
+
+ RdrNameClassOpPragmas,
+ RdrNameClassPragmas,
+ RdrNameDataPragmas,
+ RdrNameGenPragmas,
+ RdrNameInstancePragmas,
+ extractHsTyVars, extractHsCtxtTyVars, extractPatsTyVars,
RdrName(..),
qual, varQual, tcQual, varUnqual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
- showRdr, rdrNameOcc,
- cmpRdr
+ rdrNameOcc, rdrNameModule, ieOcc,
+ cmpRdr,
+ mkOpApp, mkClassDecl
) where
-IMP_Ubiq()
+#include "HsVersions.h"
import HsSyn
-import Lex
-import PrelMods ( pRELUDE )
-import Name ( ExportFlag(..), Module(..), pprModule,
- OccName(..), pprOccName )
-import Pretty
-import PprStyle ( PprStyle(..) )
-import Util ( cmpPString, panic, thenCmp )
+import BasicTypes ( IfaceFlavour(..), Unused )
+import Name ( NamedThing(..),
+ Module, pprModule, mkModuleFS,
+ OccName, srcTCOcc, srcVarOcc, isTvOcc,
+ pprOccName, mkClassTyConOcc, mkClassDataConOcc
+ )
+import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
+import Util ( thenCmp )
+import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
+import List ( nub )
+import Outputable
\end{code}
\begin{code}
-type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat
+type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
type RdrNameBangType = BangType RdrName
-type RdrNameBind = Bind Fake Fake RdrName RdrNamePat
-type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameContext = Context RdrName
-type RdrNameHsDecl = HsDecl Fake Fake RdrName RdrNamePat
+type RdrNameHsDecl = HsDecl RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
-type RdrNameFixityDecl = FixityDecl RdrName
-type RdrNameGRHS = GRHS Fake Fake RdrName RdrNamePat
-type RdrNameGRHSsAndBinds = GRHSsAndBinds Fake Fake RdrName RdrNamePat
-type RdrNameHsBinds = HsBinds Fake Fake RdrName RdrNamePat
-type RdrNameHsExpr = HsExpr Fake Fake RdrName RdrNamePat
-type RdrNameHsModule = HsModule Fake Fake RdrName RdrNamePat
+type RdrNameForeignDecl = ForeignDecl RdrName
+type RdrNameGRHS = GRHS RdrName RdrNamePat
+type RdrNameGRHSs = GRHSs RdrName RdrNamePat
+type RdrNameHsBinds = HsBinds RdrName RdrNamePat
+type RdrNameHsExpr = HsExpr RdrName RdrNamePat
+type RdrNameHsModule = HsModule RdrName RdrNamePat
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
-type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat
-type RdrNameMatch = Match Fake Fake RdrName RdrNamePat
-type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat
+type RdrNameInstDecl = InstDecl RdrName RdrNamePat
+type RdrNameMatch = Match RdrName RdrNamePat
+type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
-type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat
type RdrNameSig = Sig RdrName
-type RdrNameSpecInstSig = SpecInstSig RdrName
-type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat
-type RdrNameTyDecl = TyDecl RdrName
+type RdrNameStmt = Stmt RdrName RdrNamePat
+type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
type RdrNameClassOpPragmas = ClassOpPragmas RdrName
type RdrNameClassPragmas = ClassPragmas RdrName
type RdrNameDataPragmas = DataPragmas RdrName
type RdrNameGenPragmas = GenPragmas RdrName
type RdrNameInstancePragmas = InstancePragmas RdrName
-type RdrNameCoreExpr = GenCoreExpr RdrName RdrName RdrName RdrName
\end{code}
@extractHsTyVars@ looks just for things that could be type variables.
\begin{code}
extractHsTyVars :: HsType RdrName -> [RdrName]
-extractHsTyVars ty
- = get ty []
+extractHsTyVars ty = nub (extract_ty ty [])
+
+extractHsCtxtTyVars :: Context RdrName -> [RdrName]
+extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
+
+extract_ctxt ctxt acc = foldr extract_ass acc ctxt
+ where
+ extract_ass (cls, tys) acc = foldr extract_ty acc tys
+
+extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoListTy ty) acc = extract_ty ty acc
+extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
+extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys
+extract_ty (MonoTyVar tv) acc = insertTV tv acc
+extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
+ (filter (`notElem` locals) $
+ extract_ctxt ctxt (extract_ty ty []))
+ where
+ locals = map getTyVarName tvs
+
+insertTV name@(Unqual occ) acc | isTvOcc occ = name : acc
+insertTV other acc = acc
+
+extractPatsTyVars :: [RdrNamePat] -> [RdrName]
+extractPatsTyVars pats = nub (foldr extract_pat [] pats)
+
+extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
+extract_pat WildPatIn acc = acc
+extract_pat (VarPatIn var) acc = acc
+extract_pat (LitPatIn _) acc = acc
+extract_pat (LazyPatIn pat) acc = extract_pat pat acc
+extract_pat (AsPatIn a pat) acc = extract_pat pat acc
+extract_pat (NPlusKPatIn n _) acc = acc
+extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats
+extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
+extract_pat (NegPatIn pat) acc = extract_pat pat acc
+extract_pat (ParPatIn pat) acc = extract_pat pat acc
+extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats
+extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats
+extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
+\end{code}
+
+
+A useful function for building @OpApps@. The operator is always a variable,
+and we don't know the fixity yet.
+
+\begin{code}
+mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
+\end{code}
+
+mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
+by deriving them from the name of the class.
+
+\begin{code}
+mkClassDecl cxt cname tyvars sigs mbinds prags loc
+ = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
where
- get (MonoTyApp con tys) acc = foldr get (insert con acc) tys
- get (MonoListTy tc ty) acc = get ty acc
- get (MonoTupleTy tc tys) acc = foldr get acc tys
- get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
- get (MonoDictTy cls ty) acc = get ty acc
- get (MonoTyVar tv) acc = insert tv acc
- get (HsPreForAllTy ctxt ty) acc = foldr (get . snd) (get ty acc) ctxt
- get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $
- foldr (get . snd) (get ty acc) ctxt
- where
- locals = map getTyVarName tvs
-
- insert (Qual _ _) acc = acc
- insert (Unqual (TCOcc _)) acc = acc
- insert other acc | other `elem` acc = acc
- | otherwise = other : acc
+ -- The datacon and tycon are called "_DC" and "_TC", where the class is C
+ -- This prevents name clashes with user-defined tycons or datacons C
+ (dname, tname) = case cname of
+ Qual m occ hif -> (Qual m (mkClassDataConOcc occ) hif,
+ Qual m (mkClassTyConOcc occ) hif)
+ Unqual occ -> (Unqual (mkClassDataConOcc occ),
+ Unqual (mkClassTyConOcc occ))
\end{code}
-
%************************************************************************
%* *
\subsection[RdrName]{The @RdrName@ datatype; names read from files}
\begin{code}
data RdrName
= Unqual OccName
- | Qual Module OccName
+ | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only),
+ -- HiFile for the common M.t
-qual (m,n) = Qual m n
-tcQual (m,n) = Qual m (TCOcc n)
-varQual (m,n) = Qual m (VarOcc n)
+-- These ones are used for making RdrNames for known-key things,
+-- Or in code constructed from derivings
+qual (m,n) = Qual m n HiFile
+tcQual (m,n) = Qual m (srcTCOcc n) HiFile
+varQual (m,n) = Qual m (srcVarOcc n) HiFile
+varUnqual n = Unqual (srcVarOcc n)
-- This guy is used by the reader when HsSyn has a slot for
-- an implicit name that's going to be filled in by
-- the renamer. We can't just put "error..." because
-- we sometimes want to print out stuff after reading but
-- before renaming
-dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
-dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
+dummyRdrVarName = Unqual (srcVarOcc SLIT("V-DUMMY"))
+dummyRdrTcName = Unqual (srcVarOcc SLIT("TC-DUMMY"))
+
-varUnqual n = Unqual (VarOcc n)
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _ _) = False
-isUnqual (Unqual _) = True
-isUnqual (Qual _ _) = False
+isQual (Unqual _) = False
+isQual (Qual _ _ _) = True
-isQual (Unqual _) = False
-isQual (Qual _ _) = True
-cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
-cmpRdr (Unqual n1) (Qual m2 n2) = LT_
-cmpRdr (Qual m1 n1) (Unqual n2) = GT_
-cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
+cmpRdr (Unqual n1) (Unqual n2) = n1 `compare` n2
+cmpRdr (Unqual n1) (Qual m2 n2 _) = LT
+cmpRdr (Qual m1 n1 _) (Unqual n2) = GT
+cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2)
-- always compare module-names *second*
rdrNameOcc :: RdrName -> OccName
-rdrNameOcc (Unqual occ) = occ
-rdrNameOcc (Qual _ occ) = occ
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Qual _ occ _) = occ
-instance Text RdrName where -- debugging
- showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
+rdrNameModule :: RdrName -> Module
+rdrNameModule (Qual m _ _) = m
+
+ieOcc :: RdrNameIE -> OccName
+ieOcc ie = rdrNameOcc (ieName ie)
+
+instance Show RdrName where -- debugging
+ showsPrec p rn = showsPrecSDoc p (ppr rn)
instance Eq RdrName where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
instance Ord RdrName where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
-
-instance Ord3 RdrName where
- cmp = cmpRdr
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = cmpRdr a b
instance Outputable RdrName where
- ppr sty (Unqual n) = pprOccName sty n
- ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n]
+ ppr (Unqual n) = pprOccName n
+ ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n]
instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
getOccName = rdrNameOcc
getName = panic "no getName for RdrNames"
-
-showRdr sty rdr = ppShow 100 (ppr sty rdr)
\end{code}
projects / ghc-hetmet.git / blobdiff