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