2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
6 (Well, really, for specialisations involving @ProtoName@s, even if
7 they are used somewhat later on in the compiler...)
10 #include "HsVersions.h"
23 ProtoNameArithSeqInfo(..),
25 ProtoNameClassDecl(..),
26 ProtoNameClassOpPragmas(..),
27 ProtoNameClassOpSig(..),
28 ProtoNameClassPragmas(..),
31 ProtoNameCoreExpr(..),
32 ProtoNameDataPragmas(..),
33 ProtoNameSpecDataSig(..),
34 ProtoNameDefaultDecl(..),
35 ProtoNameFixityDecl(..),
37 ProtoNameGRHSsAndBinds(..),
38 ProtoNameGenPragmas(..),
41 ProtoNameHsModule(..),
43 ProtoNameImportedInterface(..),
44 ProtoNameInstDecl(..),
45 ProtoNameInstancePragmas(..),
46 ProtoNameInterface(..),
48 ProtoNameMonoBinds(..),
49 ProtoNameMonoType(..),
51 ProtoNamePolyType(..),
54 ProtoNameSpecInstSig(..),
57 ProtoNameUnfoldingCoreExpr(..)
62 import Bag ( emptyBag, snocBag, unionBags, listToBag, Bag )
63 import FiniteMap ( mkSet, listToFM, emptySet, emptyFM, FiniteSet(..), FiniteMap )
65 import Outputable ( ExportFlag(..) )
66 import ProtoName ( cmpProtoName, ProtoName(..) )
67 import Util ( panic{-ToDo:rm eventually-} )
71 type ProtoNameArithSeqInfo = ArithSeqInfo Fake Fake ProtoName ProtoNamePat
72 type ProtoNameBind = Bind Fake Fake ProtoName ProtoNamePat
73 type ProtoNameClassDecl = ClassDecl Fake Fake ProtoName ProtoNamePat
74 type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName
75 type ProtoNameClassOpSig = Sig ProtoName
76 type ProtoNameClassPragmas = ClassPragmas ProtoName
77 type ProtoNameConDecl = ConDecl ProtoName
78 type ProtoNameContext = Context ProtoName
79 type ProtoNameCoreExpr = UnfoldingCoreExpr ProtoName
80 type ProtoNameDataPragmas = DataPragmas ProtoName
81 type ProtoNameSpecDataSig = SpecDataSig ProtoName
82 type ProtoNameDefaultDecl = DefaultDecl ProtoName
83 type ProtoNameFixityDecl = FixityDecl ProtoName
84 type ProtoNameGRHS = GRHS Fake Fake ProtoName ProtoNamePat
85 type ProtoNameGRHSsAndBinds = GRHSsAndBinds Fake Fake ProtoName ProtoNamePat
86 type ProtoNameGenPragmas = GenPragmas ProtoName
87 type ProtoNameHsBinds = HsBinds Fake Fake ProtoName ProtoNamePat
88 type ProtoNameHsExpr = HsExpr Fake Fake ProtoName ProtoNamePat
89 type ProtoNameHsModule = HsModule Fake Fake ProtoName ProtoNamePat
90 type ProtoNameIE = IE ProtoName
91 type ProtoNameImportedInterface = ImportedInterface Fake Fake ProtoName ProtoNamePat
92 type ProtoNameInstDecl = InstDecl Fake Fake ProtoName ProtoNamePat
93 type ProtoNameInstancePragmas = InstancePragmas ProtoName
94 type ProtoNameInterface = Interface Fake Fake ProtoName ProtoNamePat
95 type ProtoNameMatch = Match Fake Fake ProtoName ProtoNamePat
96 type ProtoNameMonoBinds = MonoBinds Fake Fake ProtoName ProtoNamePat
97 type ProtoNameMonoType = MonoType ProtoName
98 type ProtoNamePat = InPat ProtoName
99 type ProtoNamePolyType = PolyType ProtoName
100 type ProtoNameQual = Qual Fake Fake ProtoName ProtoNamePat
101 type ProtoNameSig = Sig ProtoName
102 type ProtoNameSpecInstSig = SpecInstSig ProtoName
103 type ProtoNameStmt = Stmt Fake Fake ProtoName ProtoNamePat
104 type ProtoNameTyDecl = TyDecl ProtoName
105 type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName
109 eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
111 eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
115 @cmpInstanceTypes@ compares two @PolyType@s which are being used as
116 ``instance types.'' This is used when comparing as-yet-unrenamed
117 instance decls to eliminate duplicates. We allow things (e.g.,
118 overlapping instances) which standard Haskell doesn't, so we must
119 cater for that. Generally speaking, the instance-type
120 ``shape''-checker in @tcInstDecl@ will catch any mischief later on.
122 All we do is call @cmpMonoType@, passing it a tyvar-comparing function
123 that always claims that tyvars are ``equal;'' the result is that we
124 end up comparing the non-tyvar-ish structure of the two types.
127 cmpInstanceTypes :: ProtoNamePolyType -> ProtoNamePolyType -> TAG_
129 cmpInstanceTypes (HsPreForAllTy _ ty1) (HsPreForAllTy _ ty2)
130 = cmpMonoType funny_cmp ty1 ty2 -- Hey! ignore those contexts!
132 funny_cmp :: ProtoName -> ProtoName -> TAG_
134 {- The only case we are really trying to catch
135 is when both types are tyvars: which are both
136 "Unk"s and names that start w/ a lower-case letter! (Whew.)
138 funny_cmp (Unk u1) (Unk u2)
139 | isLower s1 && isLower s2 = EQ_
144 funny_cmp x y = cmpProtoName x y -- otherwise completely normal
147 @getNonPrelOuterTyCon@ is a yukky function required when deciding
148 whether to import an instance decl. If the class name or type
149 constructor are ``wanted'' then we should import it, otherwise not.
150 But the built-in core constructors for lists, tuples and arrows are
151 never ``wanted'' in this sense. @getNonPrelOuterTyCon@ catches just a
152 user-defined tycon and returns it.
155 getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName
157 getNonPrelOuterTyCon (MonoTyApp con _) = Just con
158 getNonPrelOuterTyCon _ = Nothing
161 %************************************************************************
163 \subsection{Grabbing importees and exportees}
165 %************************************************************************
167 We want to know what names are exported (the first list of the result)
168 and what modules are exported (the second list of the result).
171 = Maybe -- Nothing => no export list
172 ( FiniteMap FAST_STRING ExportFlag,
173 -- Assoc list of im/exported things &
174 -- their "export" flags (im/exported
175 -- abstractly, concretely, etc.)
176 -- Hmm... slight misnomer there (WDP 95/02)
177 FiniteSet FAST_STRING )
178 -- List of modules to be exported
179 -- entirely; NB: *not* everything with
180 -- original names in these modules;
181 -- but: everything that these modules'
182 -- interfaces told us about.
183 -- Note: This latter component can
184 -- only arise on export lists.
186 getImportees :: [ProtoNameIE] -> FiniteSet FAST_STRING
187 getExportees :: Maybe [ProtoNameIE] -> ExportListInfo
189 getRawImportees :: [ProtoNameIE] -> [FAST_STRING]
190 getRawExportees :: Maybe [ProtoNameIE] -> ([(ProtoName, ExportFlag)], [FAST_STRING])
191 -- "Raw" gives the raw lists of things; we need this for
192 -- checking for duplicates.
194 getImportees [] = emptySet
195 getImportees imps = mkSet (getRawImportees imps)
197 getExportees Nothing = Nothing
199 = case (getRawExportees exps) of { (pairs, mods) ->
200 Just (panic "RdrHsSyn.getExportees" {-listToFM pairs-}, mkSet mods) }
203 = foldr do_imp [] imps
205 do_imp (IEVar (Unk n)) acc = n:acc
206 do_imp (IEThingAbs (Unk n)) acc = n:acc
207 do_imp (IEThingAll (Unk n)) acc = n:acc
209 getRawExportees Nothing = ([], [])
210 getRawExportees (Just exps)
211 = foldr do_exp ([],[]) exps
213 do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods)
214 do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods)
215 do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods)
216 do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods)
219 %************************************************************************
221 \subsection{Collect mentioned variables}
223 %************************************************************************
225 This is just a {\em hack} whichs collects, from a module body, all the
226 variables that are ``mentioned,'' either as top-level binders or as
227 free variables. We can then use this list when walking over
228 interfaces, using it to avoid imported variables that are patently of
231 We have to be careful to look out for \tr{M..} constructs in the
232 export list; if so, the game is up (and we must so report).
235 type NameMapper a = FAST_STRING -> Maybe a
236 -- For our purposes here, we don't care *what*
237 -- they are mapped to; only if the names are
240 getMentionedVars :: NameMapper any -- a prelude-name lookup function, so
241 -- we can avoid recording prelude things
243 -> Maybe [IE ProtoName]{-exports-} -- All the bits of the module body to
244 -> [ProtoNameFixityDecl]-- look in for "mentioned" vars.
245 -> [ProtoNameClassDecl]
246 -> [ProtoNameInstDecl]
249 -> (Bool, -- True <=> M.. construct in exports
250 Bag FAST_STRING) -- list of vars "mentioned" in the module body
252 getMentionedVars val_nf exports fixes class_decls inst_decls binds
253 = panic "getMentionedVars (RdrHsSyn)"
255 = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) ->
257 initMentioned val_nf export_mentioned (
258 -- mapMent fixity fixes `thenMent_` -- see note below.
259 mapMent classDecl class_decls `thenMent_`
260 mapMent instDecl inst_decls `thenMent_`
261 bindsDecls True{-top-level-} binds )
264 ToDo: if we ever do something proper with fixity declarations,
265 we will need to create a @fixities@ function and make it do something.
267 Here's relevant bit of monad fluff: hides carrying around
268 the NameMapper function (down only) and passing along an
271 type MentionM nm a = NameMapper nm -> Bag FAST_STRING -> Bag FAST_STRING
273 initMentioned :: NameMapper nm -> Bag FAST_STRING -> MentionM nm a -> Bag FAST_STRING
274 thenMent_ :: MentionM nm a -> MentionM nm b -> MentionM nm b
275 returnNothing :: MentionM nm a
276 mapMent :: (a -> MentionM nm b) -> [a] -> MentionM nm b
277 mentionedName :: FAST_STRING -> MentionM nm a
278 mentionedNames :: [FAST_STRING] -> MentionM nm a
279 lookupAndAdd :: ProtoName -> MentionM nm a
281 initMentioned val_nf acc action = action val_nf acc
283 returnNothing val_nf acc = acc
285 thenMent_ act1 act2 val_nf acc
286 = act2 val_nf (act1 val_nf acc)
288 mapMent f [] = returnNothing
293 mentionedName name val_nf acc
296 mentionedNames names val_nf acc
297 = acc `unionBags` listToBag names
299 lookupAndAdd (Unk str) val_nf acc
300 | _LENGTH_ str >= 3 -- simply don't bother w/ very short names...
301 = case (val_nf str) of
302 Nothing -> acc `snocBag` str
305 lookupAndAdd _ _ acc = acc -- carry on with what we had
309 mention_IE :: [IE ProtoName] -> (Bool, Bag FAST_STRING)
312 = foldr men (False, emptyBag) exps
314 men (IEVar str) (dotdot_seen, so_far) = (dotdot_seen, so_far `snocBag` str)
315 men (IEModuleContents _) (_, so_far) = (True, so_far)
316 men other_ie acc = acc
320 classDecl (ClassDecl _ _ _ _ binds _ _) = monoBinds True{-toplev-} binds
321 instDecl (InstDecl _ _ binds _ _ _ _ _) = monoBinds True{-toplev-} binds
325 bindsDecls toplev EmptyBinds = returnNothing
326 bindsDecls toplev (ThenBinds a b)= bindsDecls toplev a `thenMent_` bindsDecls toplev b
327 bindsDecls toplev (SingleBind a) = bindDecls toplev a
328 bindsDecls toplev (BindWith a _) = bindDecls toplev a
330 bindDecls toplev EmptyBind = returnNothing
331 bindDecls toplev (NonRecBind a) = monoBinds toplev a
332 bindDecls toplev (RecBind a) = monoBinds toplev a
334 monoBinds toplev EmptyMonoBinds = returnNothing
335 monoBinds toplev (AndMonoBinds a b) = monoBinds toplev a `thenMent_` monoBinds toplev b
336 monoBinds toplev (PatMonoBind p gb _)
338 then mentionedNames (map stringify (collectPatBinders p))
339 else returnNothing) `thenMent_`
342 monoBinds toplev (FunMonoBind v ms _)
344 then mentionedName (stringify v)
345 else returnNothing) `thenMent_`
348 stringify :: ProtoName -> FAST_STRING
349 stringify (Unk s) = s
353 match (PatMatch _ m) = match m
354 match (GRHSMatch gb) = grhssAndBinds gb
356 grhssAndBinds (GRHSsAndBindsIn gs bs)
357 = mapMent grhs gs `thenMent_` bindsDecls False bs
359 grhs (OtherwiseGRHS e _) = expr e
360 grhs (GRHS g e _) = expr g `thenMent_` expr e
364 expr (HsVar v) = lookupAndAdd v
366 expr (HsLit _) = returnNothing
367 expr (HsLam m) = match m
368 expr (HsApp a b) = expr a `thenMent_` expr b
369 expr (OpApp a b c) = expr a `thenMent_` expr b `thenMent_` expr c
370 expr (SectionL a b) = expr a `thenMent_` expr b
371 expr (SectionR a b) = expr a `thenMent_` expr b
372 expr (CCall _ es _ _ _) = mapMent expr es
373 expr (HsSCC _ e) = expr e
374 expr (HsCase e ms _)= expr e `thenMent_` mapMent match ms
375 expr (HsLet b e) = expr e `thenMent_` bindsDecls False{-not toplev-} b
376 expr (HsDo bs _) = panic "mentioned_whatnot:RdrHsSyn:HsDo"
377 expr (ListComp e q) = expr e `thenMent_` mapMent qual q
378 expr (ExplicitList es) = mapMent expr es
379 expr (ExplicitTuple es) = mapMent expr es
380 expr (RecordCon con rbinds) = panic "mentioned:RdrHsSyn:RecordCon"
381 expr (RecordUpd aexp rbinds) = panic "mentioned:RdrHsSyn:RecordUpd"
382 expr (ExprWithTySig e _) = expr e
383 expr (HsIf b t e _) = expr b `thenMent_` expr t `thenMent_` expr e
384 expr (ArithSeqIn s) = arithSeq s
386 arithSeq (From a) = expr a
387 arithSeq (FromThen a b) = expr a `thenMent_` expr b
388 arithSeq (FromTo a b) = expr a `thenMent_` expr b
389 arithSeq (FromThenTo a b c) = expr a `thenMent_` expr b `thenMent_` expr c
391 qual (GeneratorQual _ e) = expr e
392 qual (FilterQual e) = expr e
393 qual (LetQual bs) = bindsDecls False{-not toplev-} bs