%
-% (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 (
- RdrNameArithSeqInfo(..),
- RdrNameBangType(..),
- RdrNameBind(..),
- RdrNameClassDecl(..),
- RdrNameClassOpSig(..),
- RdrNameConDecl(..),
- RdrNameContext(..),
- RdrNameSpecDataSig(..),
- RdrNameDefaultDecl(..),
- RdrNameFixityDecl(..),
- RdrNameGRHS(..),
- RdrNameGRHSsAndBinds(..),
- RdrNameHsBinds(..),
- RdrNameHsExpr(..),
- RdrNameHsModule(..),
- RdrNameIE(..),
- RdrNameImportDecl(..),
- RdrNameInstDecl(..),
- RdrNameMatch(..),
- RdrNameMonoBinds(..),
- RdrNameMonoType(..),
- RdrNamePat(..),
- RdrNamePolyType(..),
- RdrNameQual(..),
- RdrNameSig(..),
- RdrNameSpecInstSig(..),
- RdrNameStmt(..),
- RdrNameTyDecl(..),
-
- RdrNameClassOpPragmas(..),
- RdrNameClassPragmas(..),
- RdrNameDataPragmas(..),
- RdrNameGenPragmas(..),
- RdrNameInstancePragmas(..),
- RdrNameCoreExpr(..),
-
- getRawImportees,
- getRawExportees
+ RdrNameArithSeqInfo,
+ RdrNameBangType,
+ RdrNameClassDecl,
+ RdrNameClassOpSig,
+ RdrNameConDecl,
+ RdrNameContext,
+ RdrNameSpecDataSig,
+ RdrNameDefaultDecl,
+ RdrNameForeignDecl,
+ RdrNameFixityDecl,
+ RdrNameGRHS,
+ RdrNameGRHSsAndBinds,
+ RdrNameHsBinds,
+ RdrNameHsDecl,
+ RdrNameHsExpr,
+ RdrNameHsModule,
+ RdrNameIE,
+ RdrNameImportDecl,
+ RdrNameInstDecl,
+ RdrNameMatch,
+ RdrNameMonoBinds,
+ RdrNamePat,
+ RdrNameHsType,
+ RdrNameSig,
+ RdrNameStmt,
+ RdrNameTyDecl,
+
+ RdrNameClassOpPragmas,
+ RdrNameClassPragmas,
+ RdrNameDataPragmas,
+ RdrNameGenPragmas,
+ RdrNameInstancePragmas,
+ extractHsTyVars, extractHsCtxtTyVars,
+
+ RdrName(..),
+ qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
+ mkTupConRdrName, mkUbxTupConRdrName,
+ dummyRdrVarName, dummyRdrTcName,
+ isUnqual, isQual,
+ rdrNameOcc, rdrNameModule, ieOcc,
+ cmpRdr, prefixRdrName,
+ mkOpApp, mkClassDecl, isClassDataConRdrName
+
) where
-import Ubiq
+#include "HsVersions.h"
import HsSyn
-import Name ( ExportFlag(..) )
+import BasicTypes ( Module, IfaceFlavour(..), Unused )
+import Name ( pprModule, OccName(..), pprOccName,
+ mkTupNameStr, mkUbxTupNameStr,
+ prefixOccName, NamedThing(..),
+ mkClassTyConStr, mkClassDataConStr )
+import Util ( thenCmp )
+import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
+import List ( nub )
+import Outputable
+
+import Char ( isUpper )
\end{code}
\begin{code}
-type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat
+type RdrNameArithSeqInfo = ArithSeqInfo Unused RdrName RdrNamePat
type RdrNameBangType = BangType RdrName
-type RdrNameBind = Bind Fake Fake RdrName RdrNamePat
-type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat
+type RdrNameClassDecl = ClassDecl Unused RdrName RdrNamePat
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameContext = Context RdrName
+type RdrNameHsDecl = HsDecl Unused RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
+type RdrNameForeignDecl = ForeignDecl 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 RdrNameGRHS = GRHS Unused RdrName RdrNamePat
+type RdrNameGRHSsAndBinds = GRHSsAndBinds Unused RdrName RdrNamePat
+type RdrNameHsBinds = HsBinds Unused RdrName RdrNamePat
+type RdrNameHsExpr = HsExpr Unused RdrName RdrNamePat
+type RdrNameHsModule = HsModule Unused 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 RdrNameMonoType = MonoType RdrName
+type RdrNameInstDecl = InstDecl Unused RdrName RdrNamePat
+type RdrNameMatch = Match Unused RdrName RdrNamePat
+type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat
type RdrNamePat = InPat RdrName
-type RdrNamePolyType = PolyType RdrName
-type RdrNameQual = Qual Fake Fake RdrName RdrNamePat
+type RdrNameHsType = HsType RdrName
type RdrNameSig = Sig RdrName
-type RdrNameSpecInstSig = SpecInstSig RdrName
-type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat
+type RdrNameStmt = Stmt Unused RdrName RdrNamePat
type RdrNameTyDecl = TyDecl RdrName
type RdrNameClassOpPragmas = ClassOpPragmas RdrName
type RdrNameDataPragmas = DataPragmas RdrName
type RdrNameGenPragmas = GenPragmas RdrName
type RdrNameInstancePragmas = InstancePragmas RdrName
-type RdrNameCoreExpr = UnfoldingCoreExpr RdrName
+\end{code}
+
+@extractHsTyVars@ looks just for things that could be type variables.
+It's used when making the for-alls explicit.
+
+\begin{code}
+extractHsTyVars :: HsType RdrName -> [RdrName]
+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 = insert tv acc
+extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
+ (filter (`notElem` locals) $
+ extract_ctxt ctxt (extract_ty ty []))
+ where
+ locals = map getTyVarName tvs
+
+insert (Qual _ _ _) acc = acc
+insert (Unqual (TCOcc _)) acc = acc
+insert other acc = other : acc
+\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
+ -- The datacon and tycon are called ":C" where the class is C
+ -- This prevents name clashes with user-defined tycons or datacons C
+ (dname, tname) = case cname of
+ Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif)
+ where
+ s1 = mkClassTyConStr s
+
+ Unqual (TCOcc s) -> (Unqual (VarOcc s1), Unqual (TCOcc s1))
+ where
+ s1 = mkClassDataConStr s
+
+-- This nasty little function tests for whether a RdrName was
+-- constructed by the above process. It's used only for filtering
+-- out duff error messages. Maybe there's a tidier way of doing this
+-- but I can't work up the energy to find it.
+
+isClassDataConRdrName rdr_name
+ = case rdrNameOcc rdr_name of
+ TCOcc s -> case _UNPK_ s of
+ ':' : c : _ -> isUpper c
+ other -> False
+ other -> False
\end{code}
%************************************************************************
%* *
-\subsection{Grabbing importees and exportees}
+\subsection[RdrName]{The @RdrName@ datatype; names read from files}
%* *
%************************************************************************
\begin{code}
-getRawImportees :: [RdrNameIE] -> [RdrName]
-getRawExportees :: Maybe [RdrNameIE] -> ([(RdrName, ExportFlag)], [Module])
+data RdrName
+ = Unqual OccName
+ | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only),
+ -- HiFile for the common M.t
-getRawImportees imps
- = foldr do_imp [] imps
- where
- do_imp (IEVar n) acc = n:acc
- do_imp (IEThingAbs n) acc = n:acc
- do_imp (IEThingWith n _) acc = n:acc
- do_imp (IEThingAll n) acc = n:acc
-
-getRawExportees Nothing = ([], [])
-getRawExportees (Just exps)
- = foldr do_exp ([],[]) exps
- where
- do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods)
- do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods)
- do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods)
- do_exp (IEThingWith n _) (prs, mods) = ((n, ExportAll):prs, mods)
- do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods)
+qual (m,n) = Qual m n HiFile
+tcQual (m,n) = Qual m (TCOcc n) HiFile
+varQual (m,n) = Qual m (VarOcc n) HiFile
+
+mkTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor
+ -- Hence VarOcc
+mkTupConRdrName arity = case mkTupNameStr arity of
+ (mod, occ) -> Qual mod (VarOcc occ) HiFile
+
+mkUbxTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor
+ -- Hence VarOcc
+mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of
+ (mod, occ) -> Qual mod (VarOcc occ) HiFile
+
+lexTcQual (m,n,hif) = Qual m (TCOcc n) hif
+lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
+
+ -- 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"))
+
+
+varUnqual n = Unqual (VarOcc n)
+
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _ _) = False
+
+isQual (Unqual _) = False
+isQual (Qual _ _ _) = True
+
+
+ -- Used for adding a prefix to a RdrName
+prefixRdrName :: FAST_STRING -> RdrName -> RdrName
+prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
+prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
+
+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
+
+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 `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord RdrName where
+ 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 (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"
\end{code}
+
projects / ghc-hetmet.git / blobdiff