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