ghc/compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnSource ( rnSource, rnPolyType ) where
  10
  11 import Ubiq
  12 import RnLoop           -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
  13
  14 import HsSyn
  15 import HsPragmas
  16 import RdrHsSyn
  17 import RnHsSyn
  18 import RnMonad
  19 import RnBinds          ( rnTopBinds, rnMethodBinds )
  20
  21 import Bag              ( bagToList )
  22 import Class            ( derivableClassKeys )
  23 import ListSetOps       ( unionLists, minusList )
  24 import Maybes           ( maybeToBool, catMaybes )
  25 import Name             ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
  26 import Pretty
  27 import SrcLoc           ( SrcLoc )
  28 import Unique           ( Unique )
  29 import UniqFM           ( addListToUFM, listToUFM )
  30 import UniqSet          ( UniqSet(..) )
  31 import Util             ( isn'tIn, panic, assertPanic )
  32
  33 rnExports mods Nothing     = returnRn (\n -> ExportAll)
  34 rnExports mods (Just exps) = returnRn (\n -> ExportAll)
  35 \end{code}
  36
  37 rnSource `renames' the source module and export list.
  38 It simultaneously performs dependency analysis and precedence parsing.
  39 It also does the following error checks:
  40 \begin{enumerate}
  41 \item
  42 Checks that tyvars are used properly. This includes checking
  43 for undefined tyvars, and tyvars in contexts that are ambiguous.
  44 \item
  45 Checks that all variable occurences are defined.
  46 \item
  47 Checks the (..) etc constraints in the export list.
  48 \end{enumerate}
  49
  50
  51 \begin{code}
  52 rnSource :: [Module]                            -- imported modules
  53          -> Bag RenamedFixityDecl               -- fixity info for imported names
  54          -> RdrNameHsModule
  55          -> RnM s (RenamedHsModule,
  56                    Name -> ExportFlag,          -- export info
  57                    Bag (RnName, RdrName))       -- occurrence info
  58
  59 rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
  60                                ty_decls specdata_sigs class_decls
  61                                inst_decls specinst_sigs defaults
  62                                binds _ src_loc)
  63
  64   = pushSrcLocRn src_loc $
  65
  66     rnExports (mod:imp_mods) exports    `thenRn` \ exported_fn ->
  67     rnFixes fixes                       `thenRn` \ src_fixes ->
  68     let
  69         pair_name inf@(InfixL n _) = (n, inf)
  70         pair_name inf@(InfixR n _) = (n, inf)
  71         pair_name inf@(InfixN n _) = (n, inf)
  72
  73         imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
  74         all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
  75     in
  76     setExtraRn all_fixes_fm $
  77
  78     mapRn rnTyDecl      ty_decls        `thenRn` \ new_ty_decls ->
  79     mapRn rnSpecDataSig specdata_sigs   `thenRn` \ new_specdata_sigs ->
  80     mapRn rnClassDecl   class_decls     `thenRn` \ new_class_decls ->
  81     mapRn rnInstDecl    inst_decls      `thenRn` \ new_inst_decls ->
  82     mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
  83     rnDefaultDecl       defaults        `thenRn` \ new_defaults ->
  84     rnTopBinds binds                    `thenRn` \ new_binds ->
  85
  86     getOccurrenceUpRn                   `thenRn` \ occ_info ->
  87
  88     returnRn (
  89               HsModule mod version
  90                 trashed_exports trashed_imports src_fixes
  91                 new_ty_decls new_specdata_sigs new_class_decls
  92                 new_inst_decls new_specinst_sigs new_defaults
  93                 new_binds [] src_loc,
  94               exported_fn,
  95               occ_info
  96              )
  97   where
  98     trashed_exports = trace "rnSource:trashed_exports" Nothing
  99     trashed_imports = trace "rnSource:trashed_imports" []
 100 \end{code}
 101
 102 %*********************************************************
 103 %*                                                      *
 104 \subsection{Type declarations}
 105 %*                                                      *
 106 %*********************************************************
 107
 108 @rnTyDecl@ uses the `global name function' to create a new type
 109 declaration in which local names have been replaced by their original
 110 names, reporting any unknown names.
 111
 112 Renaming type variables is a pain. Because they now contain uniques,
 113 it is necessary to pass in an association list which maps a parsed
 114 tyvar to its Name representation. In some cases (type signatures of
 115 values), it is even necessary to go over the type first in order to
 116 get the set of tyvars used by it, make an assoc list, and then go over
 117 it again to rename the tyvars! However, we can also do some scoping
 118 checks at the same time.
 119
 120 \begin{code}
 121 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
 122
 123 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
 124   = pushSrcLocRn src_loc $
 125     lookupTyCon tycon                  `thenRn` \ tycon' ->
 126     mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
 127     rnContext tv_env context           `thenRn` \ context' ->
 128     rnConDecls tv_env condecls         `thenRn` \ condecls' ->
 129     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 130     ASSERT(isNoDataPragmas pragmas)
 131     returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
 132
 133 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 134   = pushSrcLocRn src_loc $
 135     lookupTyCon tycon                 `thenRn` \ tycon' ->
 136     mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
 137     rnContext tv_env context          `thenRn` \ context' ->
 138     rnConDecls tv_env condecl         `thenRn` \ condecl' ->
 139     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 140     ASSERT(isNoDataPragmas pragmas)
 141     returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
 142
 143 rnTyDecl (TySynonym name tyvars ty src_loc)
 144   = pushSrcLocRn src_loc $
 145     lookupTyCon name                `thenRn` \ name' ->
 146     mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
 147     rnMonoType tv_env ty            `thenRn` \ ty' ->
 148     returnRn (TySynonym name' tyvars' ty' src_loc)
 149
 150 rn_derivs tycon2 locn Nothing -- derivs not specified
 151   = returnRn Nothing
 152
 153 rn_derivs tycon2 locn (Just ds)
 154   = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
 155     returnRn (Just derivs)
 156   where
 157     rn_deriv tycon2 locn clas
 158       = lookupClass clas            `thenRn` \ clas_name ->
 159         addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
 160                    (derivingNonStdClassErr clas locn)
 161                                     `thenRn_`
 162         returnRn clas_name
 163       where
 164         not_elem = isn'tIn "rn_deriv"
 165 \end{code}
 166
 167 @rnConDecls@ uses the `global name function' to create a new
 168 constructor in which local names have been replaced by their original
 169 names, reporting any unknown names.
 170
 171 \begin{code}
 172 rnConDecls :: TyVarNamesEnv
 173            -> [RdrNameConDecl]
 174            -> RnM_Fixes s [RenamedConDecl]
 175
 176 rnConDecls tv_env con_decls
 177   = mapRn rn_decl con_decls
 178   where
 179     rn_decl (ConDecl name tys src_loc)
 180       = pushSrcLocRn src_loc $
 181         lookupValue name        `thenRn` \ new_name ->
 182         mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
 183         returnRn (ConDecl new_name new_tys src_loc)
 184
 185     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 186       = pushSrcLocRn src_loc $
 187         lookupValue op          `thenRn` \ new_op  ->
 188         rn_bang_ty ty1          `thenRn` \ new_ty1 ->
 189         rn_bang_ty ty2          `thenRn` \ new_ty2 ->
 190         returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 191
 192     rn_decl (NewConDecl name ty src_loc)
 193       = pushSrcLocRn src_loc $
 194         lookupValue name        `thenRn` \ new_name ->
 195         rn_mono_ty ty           `thenRn` \ new_ty  ->
 196         returnRn (NewConDecl new_name new_ty src_loc)
 197
 198     rn_decl (RecConDecl con fields src_loc)
 199       = panic "rnConDecls:RecConDecl"
 200
 201     ----------
 202     rn_mono_ty = rnMonoType tv_env
 203
 204     rn_bang_ty (Banged ty)
 205       = rn_mono_ty ty `thenRn` \ new_ty ->
 206         returnRn (Banged new_ty)
 207     rn_bang_ty (Unbanged ty)
 208       = rn_mono_ty ty `thenRn` \ new_ty ->
 209         returnRn (Unbanged new_ty)
 210 \end{code}
 211
 212 %*********************************************************
 213 %*                                                      *
 214 \subsection{SPECIALIZE data pragmas}
 215 %*                                                      *
 216 %*********************************************************
 217
 218 \begin{code}
 219 rnSpecDataSig :: RdrNameSpecDataSig
 220               -> RnM_Fixes s RenamedSpecDataSig
 221
 222 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 223   = pushSrcLocRn src_loc $
 224     let
 225         tyvars = extractMonoTyNames ty
 226     in
 227     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 228     lookupTyCon tycon                   `thenRn` \ tycon' ->
 229     rnMonoType tv_env ty                `thenRn` \ ty' ->
 230     returnRn (SpecDataSig tycon' ty' src_loc)
 231 \end{code}
 232
 233 %*********************************************************
 234 %*                                                      *
 235 \subsection{Class declarations}
 236 %*                                                      *
 237 %*********************************************************
 238
 239 @rnClassDecl@ uses the `global name function' to create a new
 240 class declaration in which local names have been replaced by their
 241 original names, reporting any unknown names.
 242
 243 \begin{code}
 244 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 245
 246 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 247   = pushSrcLocRn src_loc $
 248     mkTyVarNamesEnv src_loc [tyvar]     `thenRn` \ (tv_env, [tyvar']) ->
 249     rnContext tv_env context            `thenRn` \ context' ->
 250     lookupClass cname                   `thenRn` \ cname' ->
 251     mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
 252     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 253     ASSERT(isNoClassPragmas pragmas)
 254     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 255   where
 256     rn_op clas tv_env (ClassOpSig op ty pragmas locn)
 257       = pushSrcLocRn locn $
 258         lookupClassOp clas op           `thenRn` \ op_name ->
 259         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 260
 261 {-
 262 *** Please check here that tyvar' appears in new_ty ***
 263 *** (used to be in tcClassSig, but it's better here)
 264 ***         not_elem = isn'tIn "tcClassSigs"
 265 ***         -- Check that the class type variable is mentioned
 266 ***     checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
 267 ***             (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
 268 -}
 269
 270         ASSERT(isNoClassOpPragmas pragmas)
 271         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 272 \end{code}
 273
 274
 275 %*********************************************************
 276 %*                                                      *
 277 \subsection{Instance declarations}
 278 %*                                                      *
 279 %*********************************************************
 280
 281
 282 @rnInstDecl@ uses the `global name function' to create a new of
 283 instance declaration in which local names have been replaced by their
 284 original names, reporting any unknown names.
 285
 286 \begin{code}
 287 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 288
 289 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 290   = pushSrcLocRn src_loc $
 291     lookupClass cname                   `thenRn` \ cname' ->
 292
 293     rnPolyType [] ty                    `thenRn` \ ty' ->
 294         -- [] tv_env ensures that tyvars will be foralled
 295
 296     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 297     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 298
 299     ASSERT(isNoInstancePragmas pragmas)
 300     returnRn (InstDecl cname' ty' mbinds'
 301                        from_here modname new_uprags noInstancePragmas src_loc)
 302   where
 303     rn_uprag class_name (SpecSig op ty using locn)
 304       = pushSrcLocRn src_loc $
 305         lookupClassOp class_name op     `thenRn` \ op_name ->
 306         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 307         rn_using using                  `thenRn` \ new_using ->
 308         returnRn (SpecSig op_name new_ty new_using locn)
 309
 310     rn_uprag class_name (InlineSig op locn)
 311       = pushSrcLocRn locn $
 312         lookupClassOp class_name op     `thenRn` \ op_name ->
 313         returnRn (InlineSig op_name locn)
 314
 315     rn_uprag class_name (DeforestSig op locn)
 316       = pushSrcLocRn locn $
 317         lookupClassOp class_name op     `thenRn` \ op_name ->
 318         returnRn (DeforestSig op_name locn)
 319
 320     rn_uprag class_name (MagicUnfoldingSig op str locn)
 321       = pushSrcLocRn locn $
 322         lookupClassOp class_name op     `thenRn` \ op_name ->
 323         returnRn (MagicUnfoldingSig op_name str locn)
 324
 325     rn_using Nothing
 326       = returnRn Nothing
 327     rn_using (Just v)
 328       = lookupValue v   `thenRn` \ new_v ->
 329         returnRn (Just new_v)
 330 \end{code}
 331
 332 %*********************************************************
 333 %*                                                      *
 334 \subsection{@SPECIALIZE instance@ user-pragmas}
 335 %*                                                      *
 336 %*********************************************************
 337
 338 \begin{code}
 339 rnSpecInstSig :: RdrNameSpecInstSig
 340               -> RnM_Fixes s RenamedSpecInstSig
 341
 342 rnSpecInstSig (SpecInstSig clas ty src_loc)
 343   = pushSrcLocRn src_loc $
 344     let
 345         tyvars = extractMonoTyNames ty
 346     in
 347     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 348     lookupClass clas                    `thenRn` \ new_clas ->
 349     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 350     returnRn (SpecInstSig new_clas new_ty src_loc)
 351 \end{code}
 352
 353 %*********************************************************
 354 %*                                                      *
 355 \subsection{Default declarations}
 356 %*                                                      *
 357 %*********************************************************
 358
 359 @rnDefaultDecl@ uses the `global name function' to create a new set
 360 of default declarations in which local names have been replaced by
 361 their original names, reporting any unknown names.
 362
 363 \begin{code}
 364 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 365
 366 rnDefaultDecl [] = returnRn []
 367 rnDefaultDecl [DefaultDecl tys src_loc]
 368   = pushSrcLocRn src_loc $
 369     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 370     returnRn [DefaultDecl tys' src_loc]
 371 rnDefaultDecl defs@(d:ds)
 372   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 373     rnDefaultDecl [d]
 374 \end{code}
 375
 376 %*************************************************************************
 377 %*                                                                      *
 378 \subsection{Fixity declarations}
 379 %*                                                                      *
 380 %*************************************************************************
 381
 382 \begin{code}
 383 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 384
 385 rnFixes fixities
 386   = mapRn rn_fixity fixities    `thenRn` \ fixes_maybe ->
 387     returnRn (catMaybes fixes_maybe)
 388   where
 389     rn_fixity fix@(InfixL name i)
 390       = rn_fixity_pieces InfixL name i fix
 391     rn_fixity fix@(InfixR name i)
 392       = rn_fixity_pieces InfixR name i fix
 393     rn_fixity fix@(InfixN name i)
 394       = rn_fixity_pieces InfixN name i fix
 395
 396     rn_fixity_pieces mk_fixity name i fix
 397       = lookupValueMaybe name   `thenRn` \ maybe_res ->
 398         case maybe_res of
 399           Just res | isLocallyDefined res
 400             -> returnRn (Just (mk_fixity res i))
 401           _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
 402
 403 \end{code}
 404
 405 %*********************************************************
 406 %*                                                      *
 407 \subsection{Support code to rename types}
 408 %*                                                      *
 409 %*********************************************************
 410
 411 \begin{code}
 412 rnPolyType :: TyVarNamesEnv
 413            -> RdrNamePolyType
 414            -> RnM_Fixes s RenamedPolyType
 415
 416 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 417   = rn_poly_help tv_env tvs ctxt ty
 418
 419 rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
 420   = rn_poly_help tv_env forall_tyvars ctxt ty
 421   where
 422     mentioned_tyvars = extract_poly_ty_names poly_ty
 423     forall_tyvars    = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 424
 425 ------------
 426 extract_poly_ty_names (HsPreForAllTy ctxt ty)
 427   = extractCtxtTyNames ctxt
 428     `unionLists`
 429     extractMonoTyNames ty
 430
 431 ------------
 432 rn_poly_help :: TyVarNamesEnv
 433              -> [RdrName]
 434              -> RdrNameContext
 435              -> RdrNameMonoType
 436              -> RnM_Fixes s RenamedPolyType
 437
 438 rn_poly_help tv_env tyvars ctxt ty
 439   = getSrcLocRn                                 `thenRn` \ src_loc ->
 440     mkTyVarNamesEnv src_loc tyvars              `thenRn` \ (tv_env1, new_tyvars) ->
 441     let
 442         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 443     in
 444     rnContext tv_env2 ctxt                      `thenRn` \ new_ctxt ->
 445     rnMonoType tv_env2 ty       `thenRn` \ new_ty ->
 446     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 447 \end{code}
 448
 449 \begin{code}
 450 rnMonoType :: TyVarNamesEnv
 451            -> RdrNameMonoType
 452            -> RnM_Fixes s RenamedMonoType
 453
 454 rnMonoType tv_env (MonoTyVar tyvar)
 455   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 456     returnRn (MonoTyVar tyvar')
 457
 458 rnMonoType tv_env (MonoListTy ty)
 459   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 460     returnRn (MonoListTy ty')
 461
 462 rnMonoType tv_env (MonoFunTy ty1 ty2)
 463   = andRn MonoFunTy (rnMonoType tv_env ty1)
 464                     (rnMonoType tv_env ty2)
 465
 466 rnMonoType  tv_env (MonoTupleTy tys)
 467   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 468     returnRn (MonoTupleTy tys')
 469
 470 rnMonoType tv_env (MonoTyApp name tys)
 471   = let
 472         lookup_fn = if isAvarid (getLocalName name)
 473                     then lookupTyVarName tv_env
 474                     else lookupTyCon
 475     in
 476     lookup_fn name                                      `thenRn` \ name' ->
 477     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 478     returnRn (MonoTyApp name' tys')
 479 \end{code}
 480
 481 \begin{code}
 482 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
 483
 484 rnContext tv_env ctxt
 485   = mapRn rn_ctxt ctxt
 486   where
 487     rn_ctxt (clas, tyvar)
 488      = lookupClass clas             `thenRn` \ clas_name ->
 489        lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 490        returnRn (clas_name, tyvar_name)
 491 \end{code}
 492
 493
 494 \begin{code}
 495 derivingNonStdClassErr clas locn sty
 496   = ppHang (ppStr "Non-standard class in deriving")
 497          4 (ppCat [ppr sty clas, ppr sty locn])
 498
 499 dupDefaultDeclErr defs sty
 500   = ppHang (ppStr "Duplicate default declarations")
 501          4 (ppAboves (map pp_def_loc defs))
 502   where
 503     pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
 504
 505 undefinedFixityDeclErr decl sty
 506   = ppHang (ppStr "Fixity declaration for unknown operator")
 507          4 (ppr sty decl)
 508 \end{code}