module RdrHsSyn (
SYN_IE(RdrNameArithSeqInfo),
SYN_IE(RdrNameBangType),
- SYN_IE(RdrNameBind),
SYN_IE(RdrNameClassDecl),
SYN_IE(RdrNameClassOpSig),
SYN_IE(RdrNameConDecl),
SYN_IE(RdrNameMonoBinds),
SYN_IE(RdrNamePat),
SYN_IE(RdrNameHsType),
- SYN_IE(RdrNameQual),
SYN_IE(RdrNameSig),
SYN_IE(RdrNameSpecInstSig),
SYN_IE(RdrNameStmt),
extractHsTyVars,
RdrName(..),
- qual, varQual, tcQual, varUnqual,
+ qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
- showRdr, rdrNameOcc,
- cmpRdr
+ showRdr, rdrNameOcc, ieOcc,
+ cmpRdr, prefixRdrName,
+ mkOpApp
) where
import HsSyn
import Lex
import PrelMods ( pRELUDE )
-import Name ( ExportFlag(..), Module(..), pprModule,
- OccName(..), pprOccName )
+import BasicTypes ( Module(..), NewOrData, IfaceFlavour(..) )
+import Name ( ExportFlag(..), pprModule,
+ OccName(..), pprOccName,
+ prefixOccName, SYN_IE(NamedThing) )
import Pretty
-import PprStyle ( PprStyle(..) )
-import Util ( cmpPString, panic, thenCmp )
+import Outputable ( PprStyle(..) )
+import Util --( cmpPString, panic, thenCmp )
+import Outputable
+#if __GLASGOW_HASKELL__ >= 202
+import CoreSyn ( GenCoreExpr )
+import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
+#endif
\end{code}
\begin{code}
type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake 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 RdrNameMonoBinds = MonoBinds Fake Fake 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
extractHsTyVars ty
= get ty []
where
- get (MonoTyApp con tys) acc = foldr get (insert con acc) tys
+ get (MonoTyApp ty1 ty2) acc = get ty1 (get ty2 acc)
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
+ -- In (All a => a -> a) -> Int, there are no free tyvars
+ -- We just assume that we quantify over all type variables mentioned in the context.
+ get (HsPreForAllTy ctxt ty) acc =
+ foldr insert acc (filter (`notElem` locals) (get ty []))
+ where
+ locals = foldr (get . snd) [] ctxt
+
+ get (HsForAllTy tvs ctxt ty) acc =
+ foldr insert acc (filter (`notElem` locals) $
+ foldr (get . snd) (get ty []) 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
\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}
+
+
%************************************************************************
%* *
\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 HiFile
+tcQual (m,n) = Qual m (TCOcc n) HiFile
+varQual (m,n) = Qual m (VarOcc n) HiFile
-qual (m,n) = Qual m n
-tcQual (m,n) = Qual m (TCOcc n)
-varQual (m,n) = Qual m (VarOcc n)
+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
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)
+ -- 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 `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)
-- always compare module-names *second*
rdrNameOcc :: RdrName -> OccName
-rdrNameOcc (Unqual occ) = occ
-rdrNameOcc (Qual _ occ) = occ
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Qual _ occ _) = occ
+
+ieOcc :: RdrNameIE -> OccName
+ieOcc ie = rdrNameOcc (ieName ie)
instance Text RdrName where -- debugging
- showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
+ showsPrec _ rn = showString (show (ppr PprDebug rn))
instance Eq RdrName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
cmp = cmpRdr
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 sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n
+ ppr sty (Qual m n _) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty 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)
+showRdr sty rdr = render (ppr sty rdr)
\end{code}
projects / ghc-hetmet.git / blobdiff