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