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 (InfixL n i) = (n, i)
  70         pair_name (InfixR n i) = (n, i)
  71         pair_name (InfixN n i) = (n, i)
  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-}(panic "rnSource: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
  91                 {-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)")
  92                 new_ty_decls new_specdata_sigs new_class_decls
  93                 new_inst_decls new_specinst_sigs new_defaults
  94                 new_binds [] src_loc,
  95               exported_fn,
  96               occ_info
  97              )
  98   where
  99     trashed_exports = panic "rnSource:trashed_exports"
 100     trashed_imports = panic "rnSource:trashed_imports"
 101 \end{code}
 102
 103 %*********************************************************
 104 %*                                                      *
 105 \subsection{Type declarations}
 106 %*                                                      *
 107 %*********************************************************
 108
 109 @rnTyDecl@ uses the `global name function' to create a new type
 110 declaration in which local names have been replaced by their original
 111 names, reporting any unknown names.
 112
 113 Renaming type variables is a pain. Because they now contain uniques,
 114 it is necessary to pass in an association list which maps a parsed
 115 tyvar to its Name representation. In some cases (type signatures of
 116 values), it is even necessary to go over the type first in order to
 117 get the set of tyvars used by it, make an assoc list, and then go over
 118 it again to rename the tyvars! However, we can also do some scoping
 119 checks at the same time.
 120
 121 \begin{code}
 122 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
 123
 124 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
 125   = pushSrcLocRn src_loc $
 126     lookupTyCon tycon                  `thenRn` \ tycon' ->
 127     mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
 128     rnContext tv_env context           `thenRn` \ context' ->
 129     rnConDecls tv_env condecls         `thenRn` \ condecls' ->
 130     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 131     ASSERT(isNoDataPragmas pragmas)
 132     returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
 133
 134 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 135   = pushSrcLocRn src_loc $
 136     lookupTyCon tycon                 `thenRn` \ tycon' ->
 137     mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
 138     rnContext tv_env context          `thenRn` \ context' ->
 139     rnConDecls tv_env condecl         `thenRn` \ condecl' ->
 140     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 141     ASSERT(isNoDataPragmas pragmas)
 142     returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
 143
 144 rnTyDecl (TySynonym name tyvars ty src_loc)
 145   = pushSrcLocRn src_loc $
 146     lookupTyCon name                `thenRn` \ name' ->
 147     mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
 148     rnMonoType tv_env ty            `thenRn` \ ty' ->
 149     returnRn (TySynonym name' tyvars' ty' src_loc)
 150
 151 rn_derivs tycon2 locn Nothing -- derivs not specified
 152   = returnRn Nothing
 153
 154 rn_derivs tycon2 locn (Just ds)
 155   = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
 156     returnRn (Just derivs)
 157   where
 158     rn_deriv tycon2 locn clas
 159       = lookupClass clas            `thenRn` \ clas_name ->
 160         addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
 161                    (derivingNonStdClassErr clas locn)
 162                                     `thenRn_`
 163         returnRn clas_name
 164       where
 165         not_elem = isn'tIn "rn_deriv"
 166 \end{code}
 167
 168 @rnConDecls@ uses the `global name function' to create a new
 169 constructor in which local names have been replaced by their original
 170 names, reporting any unknown names.
 171
 172 \begin{code}
 173 rnConDecls :: TyVarNamesEnv
 174            -> [RdrNameConDecl]
 175            -> RnM_Fixes s [RenamedConDecl]
 176
 177 rnConDecls tv_env con_decls
 178   = mapRn rn_decl con_decls
 179   where
 180     rn_decl (ConDecl name tys src_loc)
 181       = pushSrcLocRn src_loc $
 182         lookupValue name        `thenRn` \ new_name ->
 183         mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
 184         returnRn (ConDecl new_name new_tys src_loc)
 185
 186     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 187       = pushSrcLocRn src_loc $
 188         lookupValue op          `thenRn` \ new_op  ->
 189         rn_bang_ty ty1          `thenRn` \ new_ty1 ->
 190         rn_bang_ty ty2          `thenRn` \ new_ty2 ->
 191         returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 192
 193     rn_decl (NewConDecl name ty src_loc)
 194       = pushSrcLocRn src_loc $
 195         lookupValue name        `thenRn` \ new_name ->
 196         rn_mono_ty ty           `thenRn` \ new_ty  ->
 197         returnRn (NewConDecl new_name new_ty src_loc)
 198
 199     rn_decl (RecConDecl con fields src_loc)
 200       = panic "rnConDecls:RecConDecl"
 201
 202     ----------
 203     rn_mono_ty = rnMonoType tv_env
 204
 205     rn_bang_ty (Banged ty)
 206       = rn_mono_ty ty `thenRn` \ new_ty ->
 207         returnRn (Banged new_ty)
 208     rn_bang_ty (Unbanged ty)
 209       = rn_mono_ty ty `thenRn` \ new_ty ->
 210         returnRn (Unbanged new_ty)
 211 \end{code}
 212
 213 %*********************************************************
 214 %*                                                      *
 215 \subsection{SPECIALIZE data pragmas}
 216 %*                                                      *
 217 %*********************************************************
 218
 219 \begin{code}
 220 rnSpecDataSig :: RdrNameSpecDataSig
 221               -> RnM_Fixes s RenamedSpecDataSig
 222
 223 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 224   = pushSrcLocRn src_loc $
 225     let
 226         tyvars = extractMonoTyNames ty
 227     in
 228     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 229     lookupTyCon tycon                   `thenRn` \ tycon' ->
 230     rnMonoType tv_env ty                `thenRn` \ ty' ->
 231     returnRn (SpecDataSig tycon' ty' src_loc)
 232 \end{code}
 233
 234 %*********************************************************
 235 %*                                                      *
 236 \subsection{Class declarations}
 237 %*                                                      *
 238 %*********************************************************
 239
 240 @rnClassDecl@ uses the `global name function' to create a new
 241 class declaration in which local names have been replaced by their
 242 original names, reporting any unknown names.
 243
 244 \begin{code}
 245 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 246
 247 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 248   = pushSrcLocRn src_loc $
 249     mkTyVarNamesEnv src_loc [tyvar]     `thenRn` \ (tv_env, [tyvar']) ->
 250     rnContext tv_env context            `thenRn` \ context' ->
 251     lookupClass cname                   `thenRn` \ cname' ->
 252     mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
 253     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 254     ASSERT(isNoClassPragmas pragmas)
 255     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 256   where
 257     rn_op clas tv_env (ClassOpSig op ty pragmas locn)
 258       = pushSrcLocRn locn $
 259         lookupClassOp clas op           `thenRn` \ op_name ->
 260         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 261
 262 {-
 263 *** Please check here that tyvar' appears in new_ty ***
 264 *** (used to be in tcClassSig, but it's better here)
 265 ***         not_elem = isn'tIn "tcClassSigs"
 266 ***         -- Check that the class type variable is mentioned
 267 ***     checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
 268 ***             (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
 269 -}
 270
 271         ASSERT(isNoClassOpPragmas pragmas)
 272         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 273 \end{code}
 274
 275
 276 %*********************************************************
 277 %*                                                      *
 278 \subsection{Instance declarations}
 279 %*                                                      *
 280 %*********************************************************
 281
 282
 283 @rnInstDecl@ uses the `global name function' to create a new of
 284 instance declaration in which local names have been replaced by their
 285 original names, reporting any unknown names.
 286
 287 \begin{code}
 288 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 289
 290 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 291   = pushSrcLocRn src_loc $
 292     lookupClass cname                   `thenRn` \ cname' ->
 293
 294     rnPolyType [] ty                    `thenRn` \ ty' ->
 295         -- [] tv_env ensures that tyvars will be foralled
 296
 297     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 298     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 299
 300     ASSERT(isNoInstancePragmas pragmas)
 301     returnRn (InstDecl cname' ty' mbinds'
 302                        from_here modname new_uprags noInstancePragmas src_loc)
 303   where
 304     rn_uprag class_name (SpecSig op ty using locn)
 305       = pushSrcLocRn src_loc $
 306         lookupClassOp class_name op     `thenRn` \ op_name ->
 307         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 308         rn_using using                  `thenRn` \ new_using ->
 309         returnRn (SpecSig op_name new_ty new_using locn)
 310
 311     rn_uprag class_name (InlineSig op locn)
 312       = pushSrcLocRn locn $
 313         lookupClassOp class_name op     `thenRn` \ op_name ->
 314         returnRn (InlineSig op_name locn)
 315
 316     rn_uprag class_name (DeforestSig op locn)
 317       = pushSrcLocRn locn $
 318         lookupClassOp class_name op     `thenRn` \ op_name ->
 319         returnRn (DeforestSig op_name locn)
 320
 321     rn_uprag class_name (MagicUnfoldingSig op str locn)
 322       = pushSrcLocRn locn $
 323         lookupClassOp class_name op     `thenRn` \ op_name ->
 324         returnRn (MagicUnfoldingSig op_name str locn)
 325
 326     rn_using Nothing
 327       = returnRn Nothing
 328     rn_using (Just v)
 329       = lookupValue v   `thenRn` \ new_v ->
 330         returnRn (Just new_v)
 331 \end{code}
 332
 333 %*********************************************************
 334 %*                                                      *
 335 \subsection{@SPECIALIZE instance@ user-pragmas}
 336 %*                                                      *
 337 %*********************************************************
 338
 339 \begin{code}
 340 rnSpecInstSig :: RdrNameSpecInstSig
 341               -> RnM_Fixes s RenamedSpecInstSig
 342
 343 rnSpecInstSig (SpecInstSig clas ty src_loc)
 344   = pushSrcLocRn src_loc $
 345     let
 346         tyvars = extractMonoTyNames ty
 347     in
 348     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 349     lookupClass clas                    `thenRn` \ new_clas ->
 350     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 351     returnRn (SpecInstSig new_clas new_ty src_loc)
 352 \end{code}
 353
 354 %*********************************************************
 355 %*                                                      *
 356 \subsection{Default declarations}
 357 %*                                                      *
 358 %*********************************************************
 359
 360 @rnDefaultDecl@ uses the `global name function' to create a new set
 361 of default declarations in which local names have been replaced by
 362 their original names, reporting any unknown names.
 363
 364 \begin{code}
 365 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 366
 367 rnDefaultDecl [] = returnRn []
 368 rnDefaultDecl [DefaultDecl tys src_loc]
 369   = pushSrcLocRn src_loc $
 370     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 371     returnRn [DefaultDecl tys' src_loc]
 372 rnDefaultDecl defs@(d:ds)
 373   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 374     rnDefaultDecl [d]
 375 \end{code}
 376
 377 %*************************************************************************
 378 %*                                                                      *
 379 \subsection{Fixity declarations}
 380 %*                                                                      *
 381 %*************************************************************************
 382
 383 \begin{code}
 384 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 385
 386 rnFixes fixities
 387   = mapRn rn_fixity fixities    `thenRn` \ fixes_maybe ->
 388     returnRn (catMaybes fixes_maybe)
 389   where
 390     rn_fixity fix@(InfixL name i)
 391       = rn_fixity_pieces InfixL name i fix
 392     rn_fixity fix@(InfixR name i)
 393       = rn_fixity_pieces InfixR name i fix
 394     rn_fixity fix@(InfixN name i)
 395       = rn_fixity_pieces InfixN name i fix
 396
 397     rn_fixity_pieces mk_fixity name i fix
 398       = lookupValueMaybe name   `thenRn` \ maybe_res ->
 399         case maybe_res of
 400           Just res | isLocallyDefined res
 401             -> returnRn (Just (mk_fixity res i))
 402           _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
 403
 404 \end{code}
 405
 406 %*********************************************************
 407 %*                                                      *
 408 \subsection{Support code to rename types}
 409 %*                                                      *
 410 %*********************************************************
 411
 412 \begin{code}
 413 rnPolyType :: TyVarNamesEnv
 414            -> RdrNamePolyType
 415            -> RnM_Fixes s RenamedPolyType
 416
 417 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 418   = rn_poly_help tv_env tvs ctxt ty
 419
 420 rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
 421   = rn_poly_help tv_env forall_tyvars ctxt ty
 422   where
 423     mentioned_tyvars = extract_poly_ty_names poly_ty
 424     forall_tyvars    = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 425
 426 ------------
 427 extract_poly_ty_names (HsPreForAllTy ctxt ty)
 428   = extractCtxtTyNames ctxt
 429     `unionLists`
 430     extractMonoTyNames ty
 431
 432 ------------
 433 rn_poly_help :: TyVarNamesEnv
 434              -> [RdrName]
 435              -> RdrNameContext
 436              -> RdrNameMonoType
 437              -> RnM_Fixes s RenamedPolyType
 438
 439 rn_poly_help tv_env tyvars ctxt ty
 440   = getSrcLocRn                                 `thenRn` \ src_loc ->
 441     mkTyVarNamesEnv src_loc tyvars              `thenRn` \ (tv_env1, new_tyvars) ->
 442     let
 443         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 444     in
 445     rnContext tv_env2 ctxt                      `thenRn` \ new_ctxt ->
 446     rnMonoType tv_env2 ty       `thenRn` \ new_ty ->
 447     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 448 \end{code}
 449
 450 \begin{code}
 451 rnMonoType :: TyVarNamesEnv
 452            -> RdrNameMonoType
 453            -> RnM_Fixes s RenamedMonoType
 454
 455 rnMonoType tv_env (MonoTyVar tyvar)
 456   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 457     returnRn (MonoTyVar tyvar')
 458
 459 rnMonoType tv_env (MonoListTy ty)
 460   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 461     returnRn (MonoListTy ty')
 462
 463 rnMonoType tv_env (MonoFunTy ty1 ty2)
 464   = andRn MonoFunTy (rnMonoType tv_env ty1)
 465                     (rnMonoType tv_env ty2)
 466
 467 rnMonoType  tv_env (MonoTupleTy tys)
 468   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 469     returnRn (MonoTupleTy tys')
 470
 471 rnMonoType tv_env (MonoTyApp name tys)
 472   = let
 473         lookup_fn = if isAvarid (getLocalName name)
 474                     then lookupTyVarName tv_env
 475                     else lookupTyCon
 476     in
 477     lookup_fn name                                      `thenRn` \ name' ->
 478     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 479     returnRn (MonoTyApp name' tys')
 480 \end{code}
 481
 482 \begin{code}
 483 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
 484
 485 rnContext tv_env ctxt
 486   = mapRn rn_ctxt ctxt
 487   where
 488     rn_ctxt (clas, tyvar)
 489      = lookupClass clas             `thenRn` \ clas_name ->
 490        lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 491        returnRn (clas_name, tyvar_name)
 492 \end{code}
 493
 494
 495 \begin{code}
 496 derivingNonStdClassErr clas locn sty
 497   = ppHang (ppStr "Non-standard class in deriving")
 498          4 (ppCat [ppr sty clas, ppr sty locn])
 499
 500 dupDefaultDeclErr defs sty
 501   = ppHang (ppStr "Duplicate default declarations")
 502          4 (ppAboves (map pp_def_loc defs))
 503   where
 504     pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
 505
 506 undefinedFixityDeclErr decl sty
 507   = ppHang (ppStr "Fixity declaration for unknown operator")
 508          4 (ppr sty decl)
 509 \end{code}