ghc/compiler/reader/RdrHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
   5
   6 (Well, really, for specialisations involving @ProtoName@s, even if
   7 they are used somewhat later on in the compiler...)
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module RdrHsSyn (
  13         cmpInstanceTypes,
  14         eqMonoType,
  15         getMentionedVars,
  16         getNonPrelOuterTyCon,
  17         ExportListInfo(..),
  18         getImportees,
  19         getExportees,
  20         getRawImportees,
  21         getRawExportees,
  22
  23         ProtoNameArithSeqInfo(..),
  24         ProtoNameBind(..),
  25         ProtoNameClassDecl(..),
  26         ProtoNameClassOpPragmas(..),
  27         ProtoNameClassOpSig(..),
  28         ProtoNameClassPragmas(..),
  29         ProtoNameConDecl(..),
  30         ProtoNameContext(..),
  31         ProtoNameCoreExpr(..),
  32         ProtoNameDataPragmas(..),
  33         ProtoNameSpecDataSig(..),
  34         ProtoNameDefaultDecl(..),
  35         ProtoNameFixityDecl(..),
  36         ProtoNameGRHS(..),
  37         ProtoNameGRHSsAndBinds(..),
  38         ProtoNameGenPragmas(..),
  39         ProtoNameHsBinds(..),
  40         ProtoNameHsExpr(..),
  41         ProtoNameHsModule(..),
  42         ProtoNameIE(..),
  43         ProtoNameImportedInterface(..),
  44         ProtoNameInstDecl(..),
  45         ProtoNameInstancePragmas(..),
  46         ProtoNameInterface(..),
  47         ProtoNameMatch(..),
  48         ProtoNameMonoBinds(..),
  49         ProtoNameMonoType(..),
  50         ProtoNamePat(..),
  51         ProtoNamePolyType(..),
  52         ProtoNameQual(..),
  53         ProtoNameSig(..),
  54         ProtoNameSpecInstSig(..),
  55         ProtoNameStmt(..),
  56         ProtoNameTyDecl(..),
  57         ProtoNameUnfoldingCoreExpr(..)
  58     ) where
  59
  60 import Ubiq{-uitous-}
  61
  62 import Bag              ( emptyBag, snocBag, unionBags, listToBag, Bag )
  63 import FiniteMap        ( mkSet, listToFM, emptySet, emptyFM, FiniteSet(..), FiniteMap )
  64 import HsSyn
  65 import Outputable       ( ExportFlag(..) )
  66 import ProtoName        ( cmpProtoName, ProtoName(..) )
  67 import Util             ( panic{-ToDo:rm eventually-} )
  68 \end{code}
  69
  70 \begin{code}
  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
 106 \end{code}
 107
 108 \begin{code}
 109 eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
 110
 111 eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
 112 \end{code}
 113
 114
 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.
 121
 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.
 125
 126 \begin{code}
 127 cmpInstanceTypes :: ProtoNamePolyType -> ProtoNamePolyType -> TAG_
 128
 129 cmpInstanceTypes (HsPreForAllTy _ ty1) (HsPreForAllTy _ ty2)
 130   = cmpMonoType funny_cmp ty1 ty2 -- Hey! ignore those contexts!
 131   where
 132     funny_cmp :: ProtoName -> ProtoName -> TAG_
 133
 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.)
 137     -}
 138     funny_cmp (Unk u1) (Unk u2)
 139       | isLower s1 && isLower s2 = EQ_
 140       where
 141         s1 = _HEAD_ u1
 142         s2 = _HEAD_ u2
 143
 144     funny_cmp x y = cmpProtoName x y -- otherwise completely normal
 145 \end{code}
 146
 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.
 153
 154 \begin{code}
 155 getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName
 156
 157 getNonPrelOuterTyCon (MonoTyApp con _)   = Just con
 158 getNonPrelOuterTyCon _                   = Nothing
 159 \end{code}
 160
 161 %************************************************************************
 162 %*                                                                      *
 163 \subsection{Grabbing importees and exportees}
 164 %*                                                                      *
 165 %************************************************************************
 166
 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).
 169 \begin{code}
 170 type ExportListInfo
 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.
 185
 186 getImportees    :: [ProtoNameIE] -> FiniteSet FAST_STRING
 187 getExportees    :: Maybe [ProtoNameIE] -> ExportListInfo
 188
 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.
 193
 194 getImportees []   = emptySet
 195 getImportees imps = mkSet (getRawImportees imps)
 196
 197 getExportees Nothing = Nothing
 198 getExportees exps
 199   = case (getRawExportees exps) of { (pairs, mods) ->
 200     Just (panic "RdrHsSyn.getExportees" {-listToFM pairs-}, mkSet mods) }
 201
 202 getRawImportees imps
 203   = foldr do_imp [] imps
 204   where
 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
 208
 209 getRawExportees Nothing     = ([], [])
 210 getRawExportees (Just exps)
 211   = foldr do_exp ([],[]) exps
 212   where
 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)
 217 \end{code}
 218
 219 %************************************************************************
 220 %*                                                                      *
 221 \subsection{Collect mentioned variables}
 222 %*                                                                      *
 223 %************************************************************************
 224
 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
 229 no interest.
 230
 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).
 233
 234 \begin{code}
 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
 238                     -- in the mapper
 239
 240 getMentionedVars :: NameMapper any      -- a prelude-name lookup function, so
 241                                         -- we can avoid recording prelude things
 242                                         -- as "mentioned"
 243                  -> Maybe [IE ProtoName]{-exports-}     -- All the bits of the module body to
 244                  -> [ProtoNameFixityDecl]-- look in for "mentioned" vars.
 245                  -> [ProtoNameClassDecl]
 246                  -> [ProtoNameInstDecl]
 247                  -> ProtoNameHsBinds
 248
 249                  -> (Bool,              -- True <=> M.. construct in exports
 250                      Bag FAST_STRING)   -- list of vars "mentioned" in the module body
 251
 252 getMentionedVars val_nf exports fixes class_decls inst_decls binds
 253   = panic "getMentionedVars (RdrHsSyn)"
 254 {- TO THE END
 255   = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) ->
 256     (module_dotdot_seen,
 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 )
 262     )}
 263 \end{code}
 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.
 266
 267 Here's relevant bit of monad fluff: hides carrying around
 268 the NameMapper function (down only) and passing along an
 269 accumulator:
 270 \begin{code}
 271 type MentionM nm a = NameMapper nm -> Bag FAST_STRING -> Bag FAST_STRING
 272
 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
 280
 281 initMentioned val_nf acc action = action val_nf acc
 282
 283 returnNothing val_nf acc = acc
 284
 285 thenMent_ act1 act2 val_nf acc
 286   = act2 val_nf (act1 val_nf acc)
 287
 288 mapMent f []     = returnNothing
 289 mapMent f (x:xs)
 290   = f x             `thenMent_`
 291     mapMent f xs
 292
 293 mentionedName name val_nf acc
 294   = acc `snocBag` name
 295
 296 mentionedNames names val_nf acc
 297   = acc `unionBags` listToBag names
 298
 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
 303       Just _  -> acc
 304
 305 lookupAndAdd _ _ acc = acc -- carry on with what we had
 306 \end{code}
 307
 308 \begin{code}
 309 mention_IE :: [IE ProtoName] -> (Bool, Bag FAST_STRING)
 310
 311 mention_IE exps
 312   = foldr men (False, emptyBag) exps
 313   where
 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
 317 \end{code}
 318
 319 \begin{code}
 320 classDecl (ClassDecl _ _ _ _ binds _ _)  = monoBinds True{-toplev-} binds
 321 instDecl  (InstDecl _ _ binds _ _ _ _ _) = monoBinds True{-toplev-} binds
 322 \end{code}
 323
 324 \begin{code}
 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
 329
 330 bindDecls toplev EmptyBind       = returnNothing
 331 bindDecls toplev (NonRecBind a)  = monoBinds toplev a
 332 bindDecls toplev (RecBind a)     = monoBinds toplev a
 333
 334 monoBinds toplev EmptyMonoBinds  = returnNothing
 335 monoBinds toplev (AndMonoBinds a b) = monoBinds toplev a `thenMent_` monoBinds toplev b
 336 monoBinds toplev (PatMonoBind p gb _)
 337   = (if toplev
 338     then mentionedNames (map stringify (collectPatBinders p))
 339     else returnNothing) `thenMent_`
 340     grhssAndBinds gb
 341
 342 monoBinds toplev (FunMonoBind v ms _)
 343   = (if toplev
 344     then mentionedName (stringify v)
 345     else returnNothing) `thenMent_`
 346     mapMent match ms
 347
 348 stringify :: ProtoName -> FAST_STRING
 349 stringify (Unk s) = s
 350 \end{code}
 351
 352 \begin{code}
 353 match (PatMatch _ m) = match m
 354 match (GRHSMatch gb) = grhssAndBinds gb
 355
 356 grhssAndBinds (GRHSsAndBindsIn gs bs)
 357   = mapMent grhs gs `thenMent_` bindsDecls False bs
 358
 359 grhs (OtherwiseGRHS e _) = expr e
 360 grhs (GRHS g e _)        = expr g  `thenMent_` expr e
 361 \end{code}
 362
 363 \begin{code}
 364 expr (HsVar v)  = lookupAndAdd v
 365
 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
 385
 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
 390
 391 qual (GeneratorQual _ e) = expr e
 392 qual (FilterQual e)      = expr e
 393 qual (LetQual bs)        = bindsDecls False{-not toplev-} bs
 394 -}
 395 \end{code}