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