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