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