ghc/compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 module RnSource ( rnDecl, rnHsSigType ) where
   8
   9 #include "HsVersions.h"
  10
  11 import RnExpr
  12 import HsSyn
  13 import HsDecls          ( HsIdInfo(..), HsStrictnessInfo(..) )
  14 import HsPragmas
  15 import HsTypes          ( getTyVarName, pprClassAssertion, cmpHsTypes )
  16 import RdrHsSyn
  17 import RnHsSyn
  18 import HsCore
  19
  20 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs )
  21 import RnEnv            ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
  22                           lookupImplicitOccRn, addImplicitOccRn,
  23                           bindLocalsRn,
  24                           newDfunName, checkDupOrQualNames, checkDupNames,
  25                           newLocallyDefinedGlobalName, newImportedGlobalName,
  26                           ifaceFlavour, listTyCon_name, tupleTyCon_name )
  27 import RnMonad
  28
  29 import Name             ( Name, OccName(..), occNameString, prefixOccName,
  30                           ExportFlag(..), Provenance(..),
  31                           nameOccName, NamedThing(..), isLexCon,
  32                           mkDefaultMethodName
  33                         )
  34 import NameSet
  35 import BasicTypes       ( TopLevelFlag(..) )
  36 import FiniteMap        ( elemFM )
  37 import PrelInfo         ( derivingOccurrences, numClass_RDR,
  38                           deRefStablePtr_NAME, makeStablePtr_NAME,
  39                           bindIO_NAME
  40                         )
  41 import Bag              ( bagToList )
  42 import Outputable
  43 import SrcLoc           ( SrcLoc )
  44 import UniqFM           ( lookupUFM )
  45 import Maybes           ( maybeToBool )
  46 import Util
  47 \end{code}
  48
  49 rnDecl `renames' declarations.
  50 It simultaneously performs dependency analysis and precedence parsing.
  51 It also does the following error checks:
  52 \begin{enumerate}
  53 \item
  54 Checks that tyvars are used properly. This includes checking
  55 for undefined tyvars, and tyvars in contexts that are ambiguous.
  56 \item
  57 Checks that all variable occurences are defined.
  58 \item
  59 Checks the (..) etc constraints in the export list.
  60 \end{enumerate}
  61
  62
  63 %*********************************************************
  64 %*                                                      *
  65 \subsection{Value declarations}
  66 %*                                                      *
  67 %*********************************************************
  68
  69 \begin{code}
  70 rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
  71
  72 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ new_binds ->
  73                       returnRn (ValD new_binds)
  74
  75
  76 rnDecl (SigD (IfaceSig name ty id_infos loc))
  77   = pushSrcLocRn loc $
  78     lookupBndrRn name           `thenRn` \ name' ->
  79     rnHsType doc_str ty         `thenRn` \ ty' ->
  80
  81         -- Get the pragma info (if any).
  82     getModeRn                   `thenRn` \ (InterfaceMode _ print_unqual) ->
  83     setModeRn (InterfaceMode Optional print_unqual) $
  84         -- In all the rest of the signature we read in optional mode,
  85         -- so that (a) we don't die
  86     mapRn rnIdInfo id_infos     `thenRn` \ id_infos' ->
  87     returnRn (SigD (IfaceSig name' ty' id_infos' loc))
  88   where
  89     doc_str = text "the interface signature for" <+> quotes (ppr name)
  90 \end{code}
  91
  92 %*********************************************************
  93 %*                                                      *
  94 \subsection{Type declarations}
  95 %*                                                      *
  96 %*********************************************************
  97
  98 @rnTyDecl@ uses the `global name function' to create a new type
  99 declaration in which local names have been replaced by their original
 100 names, reporting any unknown names.
 101
 102 Renaming type variables is a pain. Because they now contain uniques,
 103 it is necessary to pass in an association list which maps a parsed
 104 tyvar to its Name representation. In some cases (type signatures of
 105 values), it is even necessary to go over the type first in order to
 106 get the set of tyvars used by it, make an assoc list, and then go over
 107 it again to rename the tyvars! However, we can also do some scoping
 108 checks at the same time.
 109
 110 \begin{code}
 111 rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
 112   = pushSrcLocRn src_loc $
 113     lookupBndrRn tycon                                  `thenRn` \ tycon' ->
 114     bindTyVarsRn data_doc tyvars                        $ \ tyvars' ->
 115     rnContext data_doc context                          `thenRn` \ context' ->
 116     checkDupOrQualNames data_doc con_names              `thenRn_`
 117     mapRn rnConDecl condecls                            `thenRn` \ condecls' ->
 118     rnDerivs derivings                                  `thenRn` \ derivings' ->
 119     ASSERT(isNoDataPragmas pragmas)
 120     returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
 121   where
 122     data_doc = text "the data type declaration for" <+> ppr tycon
 123     con_names = map conDeclName condecls
 124
 125 rnDecl (TyD (TySynonym name tyvars ty src_loc))
 126   = pushSrcLocRn src_loc $
 127     lookupBndrRn name                           `thenRn` \ name' ->
 128     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 129     rnHsType syn_doc ty                         `thenRn` \ ty' ->
 130     returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
 131   where
 132     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 133 \end{code}
 134
 135 %*********************************************************
 136 %*                                                      *
 137 \subsection{Class declarations}
 138 %*                                                      *
 139 %*********************************************************
 140
 141 @rnClassDecl@ uses the `global name function' to create a new
 142 class declaration in which local names have been replaced by their
 143 original names, reporting any unknown names.
 144
 145 \begin{code}
 146 rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
 147   = pushSrcLocRn src_loc $
 148
 149     lookupBndrRn cname                                  `thenRn` \ cname' ->
 150     lookupBndrRn tname                                  `thenRn` \ tname' ->
 151     lookupBndrRn dname                                  `thenRn` \ dname' ->
 152
 153     bindTyVarsRn cls_doc tyvars                                 ( \ tyvars' ->
 154         rnContext cls_doc context                               `thenRn` \ context' ->
 155
 156              -- Check the signatures
 157         let
 158           clas_tyvar_names = map getTyVarName tyvars'
 159         in
 160         checkDupOrQualNames sig_doc sig_rdr_names_w_locs        `thenRn_`
 161         mapRn (rn_op cname' clas_tyvar_names) sigs              `thenRn` \ sigs' ->
 162         returnRn (tyvars', context', sigs')
 163     )                                                   `thenRn` \ (tyvars', context', sigs') ->
 164
 165         -- Check the methods
 166     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 167     rnMethodBinds mbinds                                `thenRn` \ mbinds' ->
 168
 169         -- Typechecker is responsible for checking that we only
 170         -- give default-method bindings for things in this class.
 171         -- The renamer *could* check this for class decls, but can't
 172         -- for instance decls.
 173
 174     ASSERT(isNoClassPragmas pragmas)
 175     returnRn (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc))
 176   where
 177     cls_doc  = text "the declaration for class"         <+> ppr cname
 178     sig_doc  = text "the signatures for class"          <+> ppr cname
 179     meth_doc = text "the default-methods for class"     <+> ppr cname
 180
 181     sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 182     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
 183     meth_rdr_names        = map fst meth_rdr_names_w_locs
 184
 185     rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
 186       = pushSrcLocRn locn $
 187         lookupBndrRn op                         `thenRn` \ op_name ->
 188         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ new_ty  ->
 189
 190                 -- Make the default-method name
 191         let
 192             dm_occ = mkDefaultMethodName (rdrNameOcc op)
 193         in
 194         getModuleRn                     `thenRn` \ mod_name ->
 195         getModeRn                       `thenRn` \ mode ->
 196         (case (mode, maybe_dm) of
 197             (SourceMode, _) | op `elem` meth_rdr_names
 198                 ->      -- There's an explicit method decl
 199                    newLocallyDefinedGlobalName mod_name dm_occ
 200                                                (\_ -> Exported) locn    `thenRn` \ dm_name ->
 201                    returnRn (Just dm_name)
 202
 203             (InterfaceMode _ _, Just _)
 204                 ->      -- Imported class that has a default method decl
 205                     newImportedGlobalName mod_name dm_occ (ifaceFlavour clas)   `thenRn` \ dm_name ->
 206                     addOccurrenceName dm_name                                   `thenRn_`
 207                     returnRn (Just dm_name)
 208
 209             other -> returnRn Nothing
 210         )                                       `thenRn` \ maybe_dm_name ->
 211
 212                 -- Check that each class tyvar appears in op_ty
 213         let
 214             (ctxt, op_ty) = case new_ty of
 215                                 HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
 216                                 other                     -> ([], new_ty)
 217             ctxt_fvs  = extractHsCtxtTyNames ctxt       -- Includes tycons/classes but we
 218             op_ty_fvs = extractHsTyNames op_ty          -- don't care about that
 219
 220             check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
 221                                                 (classTyVarNotInOpTyErr clas_tyvar sig)
 222         in
 223         mapRn check_in_op_ty clas_tyvars                 `thenRn_`
 224
 225         returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
 226 \end{code}
 227
 228
 229 %*********************************************************
 230 %*                                                      *
 231 \subsection{Instance declarations}
 232 %*                                                      *
 233 %*********************************************************
 234
 235 \begin{code}
 236 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
 237   = pushSrcLocRn src_loc $
 238     rnHsSigType (text "an instance decl") inst_ty       `thenRn` \ inst_ty' ->
 239
 240
 241         -- Rename the bindings
 242         -- NB meth_names can be qualified!
 243     checkDupNames meth_doc meth_names           `thenRn_`
 244     rnMethodBinds mbinds                        `thenRn` \ mbinds' ->
 245     let
 246         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 247     in
 248     renameSigs NotTopLevel True binders uprags  `thenRn` \ new_uprags ->
 249
 250     let
 251      -- We use the class name and the name of the first
 252      -- type constructor the class is applied to.
 253      (cl_nm, tycon_nm) = mkDictPrefix inst_ty'
 254
 255      mkDictPrefix (MonoDictTy cl tys) =
 256         case tys of
 257           []     -> (c_nm, nilOccName )
 258           (ty:_) -> (c_nm, getInstHeadTy ty)
 259         where
 260          c_nm = nameOccName (getName cl)
 261
 262      mkDictPrefix (HsForAllTy _ _ ty)  = mkDictPrefix ty  -- can this
 263      mkDictPrefix _                    = (nilOccName, nilOccName)
 264
 265      getInstHeadTy t
 266       = case t of
 267           MonoTyVar tv    -> nameOccName (getName tv)
 268           MonoTyApp t _   -> getInstHeadTy t
 269           _               -> nilOccName
 270             -- I cannot see how the rest of HsType constructors
 271             -- can occur, but this isn't really a failure condition,
 272             -- so we return silently.
 273
 274      nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
 275     in
 276     newDfunName cl_nm tycon_nm maybe_dfun src_loc  `thenRn` \ dfun_name ->
 277     addOccurrenceName dfun_name                    `thenRn_`
 278                         -- The dfun is not optional, because we use its version number
 279                         -- to identify the version of the instance declaration
 280
 281         -- The typechecker checks that all the bindings are for the right class.
 282     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
 283   where
 284     meth_doc = text "the bindings in an instance declaration"
 285     meth_names   = bagToList (collectMonoBinders mbinds)
 286 \end{code}
 287
 288 %*********************************************************
 289 %*                                                      *
 290 \subsection{Default declarations}
 291 %*                                                      *
 292 %*********************************************************
 293
 294 \begin{code}
 295 rnDecl (DefD (DefaultDecl tys src_loc))
 296   = pushSrcLocRn src_loc $
 297     mapRn (rnHsType doc_str) tys        `thenRn` \ tys' ->
 298     lookupImplicitOccRn numClass_RDR    `thenRn_`
 299     returnRn (DefD (DefaultDecl tys' src_loc))
 300   where
 301     doc_str = text "a `default' declaration"
 302 \end{code}
 303
 304 %*********************************************************
 305 %*                                                      *
 306 \subsection{Foreign declarations}
 307 %*                                                      *
 308 %*********************************************************
 309
 310 \begin{code}
 311 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 312   = pushSrcLocRn src_loc $
 313     lookupBndrRn name                   `thenRn` \ name' ->
 314     (case imp_exp of
 315         FoImport _ | not isDyn -> addImplicitOccRn name'
 316         FoLabel    -> addImplicitOccRn name'
 317         FoExport   | isDyn ->
 318            addImplicitOccRn makeStablePtr_NAME  `thenRn_`
 319            addImplicitOccRn deRefStablePtr_NAME `thenRn_`
 320            addImplicitOccRn bindIO_NAME         `thenRn_`
 321            returnRn name'
 322         _ -> returnRn name')            `thenRn_`
 323     rnHsSigType fo_decl_msg ty          `thenRn` \ ty' ->
 324     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
 325  where
 326   fo_decl_msg = ptext SLIT("a foreign declaration")
 327   isDyn       = isDynamic ext_nm
 328
 329 \end{code}
 330
 331 %*********************************************************
 332 %*                                                      *
 333 \subsection{Support code for type/data declarations}
 334 %*                                                      *
 335 %*********************************************************
 336
 337 \begin{code}
 338 rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
 339
 340 rnDerivs Nothing -- derivs not specified
 341   = returnRn Nothing
 342
 343 rnDerivs (Just ds)
 344   = mapRn rn_deriv ds `thenRn` \ derivs ->
 345     returnRn (Just derivs)
 346   where
 347     rn_deriv clas
 348       = lookupOccRn clas            `thenRn` \ clas_name ->
 349
 350                 -- Now add extra "occurrences" for things that
 351                 -- the deriving mechanism will later need in order to
 352                 -- generate code for this class.
 353         case lookupUFM derivingOccurrences clas_name of
 354                 Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
 355                            returnRn clas_name
 356
 357                 Just occs -> mapRn lookupImplicitOccRn occs     `thenRn_`
 358                              returnRn clas_name
 359 \end{code}
 360
 361 \begin{code}
 362 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 363 conDeclName (ConDecl n _ _ _ l) = (n,l)
 364
 365 rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
 366 rnConDecl (ConDecl name tvs cxt details locn)
 367   = pushSrcLocRn locn $
 368     checkConName name                   `thenRn_`
 369     lookupBndrRn name                   `thenRn` \ new_name ->
 370     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 371     rnContext doc cxt                   `thenRn` \ new_context ->
 372     rnConDetails doc locn details       `thenRn` \ new_details ->
 373     returnRn (ConDecl new_name new_tyvars new_context new_details locn)
 374   where
 375     doc = text "the definition of data constructor" <+> quotes (ppr name)
 376
 377 rnConDetails doc locn (VanillaCon tys)
 378   = mapRn (rnBangTy doc) tys            `thenRn` \ new_tys  ->
 379     returnRn (VanillaCon new_tys)
 380
 381 rnConDetails doc locn (InfixCon ty1 ty2)
 382   = rnBangTy doc ty1            `thenRn` \ new_ty1 ->
 383     rnBangTy doc ty2            `thenRn` \ new_ty2 ->
 384     returnRn (InfixCon new_ty1 new_ty2)
 385
 386 rnConDetails doc locn (NewCon ty)
 387   = rnHsType doc ty                     `thenRn` \ new_ty  ->
 388     returnRn (NewCon new_ty)
 389
 390 rnConDetails doc locn (RecCon fields)
 391   = checkDupOrQualNames doc field_names `thenRn_`
 392     mapRn (rnField doc) fields          `thenRn` \ new_fields ->
 393     returnRn (RecCon new_fields)
 394   where
 395     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 396
 397 rnField doc (names, ty)
 398   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 399     rnBangTy doc ty             `thenRn` \ new_ty ->
 400     returnRn (new_names, new_ty)
 401
 402 rnBangTy doc (Banged ty)
 403   = rnHsType doc ty `thenRn` \ new_ty ->
 404     returnRn (Banged new_ty)
 405
 406 rnBangTy doc (Unbanged ty)
 407   = rnHsType doc ty `thenRn` \ new_ty ->
 408     returnRn (Unbanged new_ty)
 409
 410 -- This data decl will parse OK
 411 --      data T = a Int
 412 -- treating "a" as the constructor.
 413 -- It is really hard to make the parser spot this malformation.
 414 -- So the renamer has to check that the constructor is legal
 415 --
 416 -- We can get an operator as the constructor, even in the prefix form:
 417 --      data T = :% Int Int
 418 -- from interface files, which always print in prefix form
 419
 420 checkConName name
 421   = checkRn (isLexCon (occNameString (rdrNameOcc name)))
 422             (badDataCon name)
 423 \end{code}
 424
 425
 426 %*********************************************************
 427 %*                                                      *
 428 \subsection{Support code to rename types}
 429 %*                                                      *
 430 %*********************************************************
 431
 432 \begin{code}
 433 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
 434         -- rnHsSigType is used for source-language type signatures,
 435         -- which use *implicit* universal quantification.
 436 rnHsSigType doc_str ty = rnHsType (text "the type signature for" <+> doc_str) ty
 437
 438
 439
 440
 441 rnHsType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
 442
 443 rnHsType doc (HsForAllTy [] ctxt ty)
 444         -- From source code (no kinds on tyvars)
 445
 446         -- Given the signature  C => T  we universally quantify
 447         -- over FV(T) \ {in-scope-tyvars}
 448         --
 449         -- We insist that the universally quantified type vars is a superset of FV(C)
 450         -- It follows that FV(T) is a superset of FV(C), so that the context constrains
 451         -- no type variables that don't appear free in the tau-type part.
 452
 453   = getLocalNameEnv             `thenRn` \ name_env ->
 454     let
 455         mentioned_tyvars = extractHsTyVars ty
 456         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_tyvars
 457
 458         ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])]
 459         ctxt_w_ftvs  = [ (constraint, foldr ((++) . extractHsTyVars) [] tys)
 460                        | constraint@(_,tys) <- ctxt]
 461
 462         -- A 'non-poly constraint' is one that does not mention *any*
 463         -- of the forall'd type variables
 464         non_poly_constraints = filter non_poly ctxt_w_ftvs
 465         non_poly (c,ftvs)    = not (any (`elem` forall_tyvars) ftvs)
 466
 467         -- A 'non-mentioned' constraint is one that mentions a
 468         -- type variable that does not appear in 'ty'
 469         non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs
 470         non_mentioned (c,ftvs)    = any (not . (`elem` mentioned_tyvars)) ftvs
 471
 472         -- Zap the context if there's a problem, to avoid duplicate error message.
 473         ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt
 474               | otherwise = []
 475     in
 476     mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints          `thenRn_`
 477     mapRn (ctxtErr2 doc ty)               non_mentioned_constraints     `thenRn_`
 478
 479     (bindTyVarsRn doc (map UserTyVar forall_tyvars)     $ \ new_tyvars ->
 480     rnContext doc ctxt'                                 `thenRn` \ new_ctxt ->
 481     rnHsType doc ty                                     `thenRn` \ new_ty ->
 482     returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty))
 483
 484 rnHsType doc (HsForAllTy tvs ctxt ty)
 485         -- tvs are non-empty, hence must be from an interface file
 486         --      (tyvars may be kinded)
 487   = bindTyVarsRn doc tvs                $ \ new_tyvars ->
 488     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 489     rnHsType doc ty                     `thenRn` \ new_ty ->
 490     returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty)
 491
 492
 493 rnHsType doc (MonoTyVar tyvar)
 494   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 495     returnRn (MonoTyVar tyvar')
 496
 497 rnHsType doc (MonoFunTy ty1 ty2)
 498   = andRn MonoFunTy (rnHsType doc ty1) (rnHsType doc ty2)
 499
 500 rnHsType doc (MonoListTy ty)
 501   = addImplicitOccRn listTyCon_name             `thenRn_`
 502     rnHsType doc ty                             `thenRn` \ ty' ->
 503     returnRn (MonoListTy ty')
 504
 505 rnHsType doc (MonoTupleTy tys boxed)
 506   = addImplicitOccRn (tupleTyCon_name boxed (length tys)) `thenRn_`
 507     mapRn (rnHsType doc) tys                              `thenRn` \ tys' ->
 508     returnRn (MonoTupleTy tys' boxed)
 509
 510 rnHsType doc (MonoTyApp ty1 ty2)
 511   = rnHsType doc ty1            `thenRn` \ ty1' ->
 512     rnHsType doc ty2            `thenRn` \ ty2' ->
 513     returnRn (MonoTyApp ty1' ty2')
 514
 515 rnHsType doc (MonoDictTy clas tys)
 516   = lookupOccRn clas            `thenRn` \ clas' ->
 517     mapRn (rnHsType doc) tys    `thenRn` \ tys' ->
 518     returnRn (MonoDictTy clas' tys')
 519 \end{code}
 520
 521
 522 \begin{code}
 523 rnContext :: SDoc -> RdrNameContext -> RnMS s RenamedContext
 524
 525 rnContext doc ctxt
 526   = mapRn rn_ctxt ctxt          `thenRn` \ theta  ->
 527     let
 528         (_, dup_asserts) = removeDups cmp_assert theta
 529     in
 530         -- Check for duplicate assertions
 531         -- If this isn't an error, then it ought to be:
 532     mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts    `thenRn_`
 533
 534     returnRn theta
 535   where
 536     rn_ctxt (clas, tys)
 537       = lookupBndrRn clas               `thenRn` \ clas_name ->
 538         addOccurrenceName clas_name     `thenRn_`
 539         mapRn (rnHsType doc) tys        `thenRn` \ tys' ->
 540         returnRn (clas_name, tys')
 541
 542     cmp_assert (c1,tys1) (c2,tys2)
 543       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 544 \end{code}
 545
 546
 547 %*********************************************************
 548 %*                                                      *
 549 \subsection{IdInfo}
 550 %*                                                      *
 551 %*********************************************************
 552
 553 \begin{code}
 554 rnIdInfo (HsStrictness strict)
 555   = rnStrict strict     `thenRn` \ strict' ->
 556     returnRn (HsStrictness strict')
 557
 558 rnIdInfo (HsUnfold inline (Just expr))  = rnCoreExpr expr       `thenRn` \ expr' ->
 559                                           returnRn (HsUnfold inline (Just expr'))
 560 rnIdInfo (HsUnfold inline Nothing)      = returnRn (HsUnfold inline Nothing)
 561 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 562 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update)
 563 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs)
 564 rnIdInfo (HsSpecialise tyvars tys expr)
 565   = bindTyVarsRn doc tyvars     $ \ tyvars' ->
 566     rnCoreExpr expr             `thenRn` \ expr' ->
 567     mapRn (rnHsType doc) tys    `thenRn` \ tys' ->
 568     returnRn (HsSpecialise tyvars' tys' expr')
 569   where
 570     doc = text "Specialise in interface pragma"
 571
 572
 573 rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
 574         -- The sole purpose of the "cons" field is so that we can mark the constructors
 575         -- needed to build the wrapper as "needed", so that their data type decl will be
 576         -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
 577   = lookupOccRn worker                  `thenRn` \ worker' ->
 578     mapRn lookupOccRn cons              `thenRn_`
 579     returnRn (HsStrictnessInfo demands (Just (worker',[])))
 580
 581 -- Boring, but necessary for the type checker.
 582 rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
 583 rnStrict HsBottom                         = returnRn HsBottom
 584 \end{code}
 585
 586 UfCore expressions.
 587
 588 \begin{code}
 589 rnCoreExpr (UfType ty)
 590   = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
 591     returnRn (UfType ty')
 592
 593 rnCoreExpr (UfVar v)
 594   = lookupOccRn v       `thenRn` \ v' ->
 595     returnRn (UfVar v')
 596
 597 rnCoreExpr (UfCon con args)
 598   = rnUfCon con                 `thenRn` \ con' ->
 599     mapRn rnCoreExpr args       `thenRn` \ args' ->
 600     returnRn (UfCon con' args')
 601
 602 rnCoreExpr (UfTuple con args)
 603   = lookupOccRn con             `thenRn` \ con' ->
 604     mapRn rnCoreExpr args       `thenRn` \ args' ->
 605     returnRn (UfTuple con' args')
 606
 607 rnCoreExpr (UfApp fun arg)
 608   = rnCoreExpr fun              `thenRn` \ fun' ->
 609     rnCoreExpr arg              `thenRn` \ arg' ->
 610     returnRn (UfApp fun' arg')
 611
 612 rnCoreExpr (UfCase scrut bndr alts)
 613   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 614     bindLocalsRn "UfCase" [bndr]        $ \ [bndr'] ->
 615     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 616     returnRn (UfCase scrut' bndr' alts')
 617
 618 rnCoreExpr (UfNote note expr)
 619   = rnNote note                 `thenRn` \ note' ->
 620     rnCoreExpr expr             `thenRn` \ expr' ->
 621     returnRn  (UfNote note' expr')
 622
 623 rnCoreExpr (UfLam bndr body)
 624   = rnCoreBndr bndr             $ \ bndr' ->
 625     rnCoreExpr body             `thenRn` \ body' ->
 626     returnRn (UfLam bndr' body')
 627
 628 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 629   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 630     rnCoreBndr bndr             $ \ bndr' ->
 631     rnCoreExpr body             `thenRn` \ body' ->
 632     returnRn (UfLet (UfNonRec bndr' rhs') body')
 633
 634 rnCoreExpr (UfLet (UfRec pairs) body)
 635   = rnCoreBndrs bndrs           $ \ bndrs' ->
 636     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 637     rnCoreExpr body             `thenRn` \ body' ->
 638     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 639   where
 640     (bndrs, rhss) = unzip pairs
 641 \end{code}
 642
 643 \begin{code}
 644 rnCoreBndr (UfValBinder name ty) thing_inside
 645   = rnHsType (text str) ty      `thenRn` \ ty' ->
 646     bindLocalsRn str [name]     $ \ [name'] ->
 647     thing_inside (UfValBinder name' ty')
 648   where
 649     str = "unfolding id"
 650
 651 rnCoreBndr (UfTyBinder name kind) thing_inside
 652   = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
 653     thing_inside (UfTyBinder name' kind)
 654
 655 rnCoreBndrs bndrs thing_inside          -- Expect them all to be ValBinders
 656   = mapRn (rnHsType (text str)) tys     `thenRn` \ tys' ->
 657     bindLocalsRn str names              $ \ names' ->
 658     thing_inside (zipWith UfValBinder names' tys')
 659   where
 660     str   = "unfolding id"
 661     names = map (\ (UfValBinder name _ ) -> name) bndrs
 662     tys   = map (\ (UfValBinder _    ty) -> ty)   bndrs
 663 \end{code}
 664
 665 \begin{code}
 666 rnCoreAlt (con, bndrs, rhs)
 667   = rnUfCon con                         `thenRn` \ con' ->
 668     bindLocalsRn "unfolding alt" bndrs  $ \ bndrs' ->
 669     rnCoreExpr rhs                      `thenRn` \ rhs' ->
 670     returnRn (con', bndrs', rhs')
 671
 672
 673 rnNote (UfCoerce ty)
 674   = rnHsType (text "unfolding coerce") ty       `thenRn` \ ty' ->
 675     returnRn (UfCoerce ty')
 676
 677 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 678 rnNote UfInlineCall = returnRn UfInlineCall
 679
 680
 681 rnUfCon UfDefault
 682   = returnRn UfDefault
 683
 684 rnUfCon (UfDataCon con)
 685   = lookupOccRn con             `thenRn` \ con' ->
 686     returnRn (UfDataCon con')
 687
 688 rnUfCon (UfLitCon lit)
 689   = returnRn (UfLitCon lit)
 690
 691 rnUfCon (UfLitLitCon lit ty)
 692   = rnHsType (text "litlit") ty         `thenRn` \ ty' ->
 693     returnRn (UfLitLitCon lit ty')
 694
 695 rnUfCon (UfPrimOp op)
 696   = lookupOccRn op              `thenRn` \ op' ->
 697     returnRn (UfPrimOp op')
 698
 699 rnUfCon (UfCCallOp str casm gc)
 700   = returnRn (UfCCallOp str casm gc)
 701 \end{code}
 702
 703 %*********************************************************
 704 %*                                                      *
 705 \subsection{Errors}
 706 %*                                                      *
 707 %*********************************************************
 708
 709 \begin{code}
 710 derivingNonStdClassErr clas
 711   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 712
 713 classTyVarNotInOpTyErr clas_tyvar sig
 714   = hang (hsep [ptext SLIT("Class type variable"),
 715                        quotes (ppr clas_tyvar),
 716                        ptext SLIT("does not appear in method signature")])
 717          4 (ppr sig)
 718
 719 dupClassAssertWarn ctxt (assertion : dups)
 720   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 721                quotes (pprClassAssertion assertion),
 722                ptext SLIT("in the context:")],
 723          nest 4 (pprContext ctxt)]
 724
 725 badDataCon name
 726    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 727
 728 ctxtErr1 doc tyvars ty (constraint, _)
 729   = addErrRn (
 730       sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
 731                    ptext SLIT("does not mention any of"),
 732            nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)),
 733            nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty))
 734       ]
 735       $$
 736       (ptext SLIT("In") <+> doc)
 737     )
 738
 739 ctxtErr2 doc ty (constraint,_)
 740   = addErrRn (
 741         sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint),
 742         nest 4 (ptext SLIT("mentions type variables that do not appear in the type")),
 743         nest 4 (quotes (ppr ty))]
 744         $$
 745         (ptext SLIT("In") <+> doc)
 746     )
 747 \end{code}