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
  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     newDfunName maybe_dfun src_loc              `thenRn` \ dfun_name ->
 245     addOccurrenceName dfun_name                 `thenRn_`
 246                         -- The dfun is not optional, because we use its version number
 247                         -- to identify the version of the instance declaration
 248
 249         -- The typechecker checks that all the bindings are for the right class.
 250     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
 251   where
 252     meth_doc = text "the bindings in an instance declaration"
 253     meth_names   = bagToList (collectMonoBinders mbinds)
 254
 255     rn_uprag (SpecSig op ty using locn)
 256       = pushSrcLocRn src_loc $
 257         lookupBndrRn op                         `thenRn` \ op_name ->
 258         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ new_ty ->
 259         rn_using using                          `thenRn` \ new_using ->
 260         returnRn (SpecSig op_name new_ty new_using locn)
 261
 262     rn_uprag (InlineSig op locn)
 263       = pushSrcLocRn locn $
 264         lookupBndrRn op                 `thenRn` \ op_name ->
 265         returnRn (InlineSig op_name locn)
 266
 267     rn_uprag (MagicUnfoldingSig op str locn)
 268       = pushSrcLocRn locn $
 269         lookupBndrRn op                 `thenRn` \ op_name ->
 270         returnRn (MagicUnfoldingSig op_name str locn)
 271
 272     rn_using Nothing  = returnRn Nothing
 273     rn_using (Just v) = lookupOccRn v   `thenRn` \ new_v ->
 274                         returnRn (Just new_v)
 275 \end{code}
 276
 277 %*********************************************************
 278 %*                                                      *
 279 \subsection{Default declarations}
 280 %*                                                      *
 281 %*********************************************************
 282
 283 \begin{code}
 284 rnDecl (DefD (DefaultDecl tys src_loc))
 285   = pushSrcLocRn src_loc $
 286     mapRn rnHsType tys                  `thenRn` \ tys' ->
 287     lookupImplicitOccRn numClass_RDR    `thenRn_`
 288     returnRn (DefD (DefaultDecl tys' src_loc))
 289 \end{code}
 290
 291 %*********************************************************
 292 %*                                                      *
 293 \subsection{Support code for type/data declarations}
 294 %*                                                      *
 295 %*********************************************************
 296
 297 \begin{code}
 298 rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
 299
 300 rnDerivs Nothing -- derivs not specified
 301   = lookupImplicitOccRn evalClass_RDR           `thenRn_`
 302     returnRn Nothing
 303
 304 rnDerivs (Just ds)
 305   = lookupImplicitOccRn evalClass_RDR           `thenRn_`
 306     mapRn rn_deriv ds `thenRn` \ derivs ->
 307     returnRn (Just derivs)
 308   where
 309     rn_deriv clas
 310       = lookupOccRn clas            `thenRn` \ clas_name ->
 311
 312                 -- Now add extra "occurrences" for things that
 313                 -- the deriving mechanism will later need in order to
 314                 -- generate code for this class.
 315         case lookupUFM derivingOccurrences clas_name of
 316                 Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
 317                            returnRn clas_name
 318
 319                 Just occs -> mapRn lookupImplicitOccRn occs     `thenRn_`
 320                              returnRn clas_name
 321 \end{code}
 322
 323 \begin{code}
 324 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 325 conDeclName (ConDecl n _ _ l)     = (n,l)
 326
 327 rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
 328 rnConDecl (ConDecl name cxt details locn)
 329   = pushSrcLocRn locn $
 330     checkConName name                   `thenRn_`
 331     lookupBndrRn name                   `thenRn` \ new_name ->
 332     rnConDetails name locn details      `thenRn` \ new_details ->
 333     rnContext cxt                       `thenRn` \ new_context ->
 334     returnRn (ConDecl new_name new_context new_details locn)
 335
 336 rnConDetails con locn (VanillaCon tys)
 337   = mapRn rnBangTy tys          `thenRn` \ new_tys  ->
 338     returnRn (VanillaCon new_tys)
 339
 340 rnConDetails con locn (InfixCon ty1 ty2)
 341   = rnBangTy ty1                `thenRn` \ new_ty1 ->
 342     rnBangTy ty2                `thenRn` \ new_ty2 ->
 343     returnRn (InfixCon new_ty1 new_ty2)
 344
 345 rnConDetails con locn (NewCon ty)
 346   = rnHsType ty                 `thenRn` \ new_ty  ->
 347     returnRn (NewCon new_ty)
 348
 349 rnConDetails con locn (RecCon fields)
 350   = checkDupOrQualNames fld_doc field_names     `thenRn_`
 351     mapRn rnField fields                        `thenRn` \ new_fields ->
 352     returnRn (RecCon new_fields)
 353   where
 354     fld_doc = text "the fields of constructor" <> ppr con
 355     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 356
 357 rnField (names, ty)
 358   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 359     rnBangTy ty                 `thenRn` \ new_ty ->
 360     returnRn (new_names, new_ty)
 361
 362 rnBangTy (Banged ty)
 363   = rnHsType ty `thenRn` \ new_ty ->
 364     returnRn (Banged new_ty)
 365
 366 rnBangTy (Unbanged ty)
 367   = rnHsType ty `thenRn` \ new_ty ->
 368     returnRn (Unbanged new_ty)
 369
 370 -- This data decl will parse OK
 371 --      data T = a Int
 372 -- treating "a" as the constructor.
 373 -- It is really hard to make the parser spot this malformation.
 374 -- So the renamer has to check that the constructor is legal
 375 --
 376 -- We can get an operator as the constructor, even in the prefix form:
 377 --      data T = :% Int Int
 378 -- from interface files, which always print in prefix form
 379
 380 checkConName name
 381   = checkRn (isLexCon (occNameString (rdrNameOcc name)))
 382             (badDataCon name)
 383 \end{code}
 384
 385
 386 %*********************************************************
 387 %*                                                      *
 388 \subsection{Support code to rename types}
 389 %*                                                      *
 390 %*********************************************************
 391
 392 \begin{code}
 393 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
 394         -- rnHsSigType is used for source-language type signatures,
 395         -- which use *implicit* universal quantification.
 396
 397 -- Given the signature  C => T  we universally quantify over FV(T) \ {in-scope-tyvars}
 398 --
 399 -- We insist that the universally quantified type vars is a superset of FV(C)
 400 -- It follows that FV(T) is a superset of FV(C), so that the context constrains
 401 -- no type variables that don't appear free in the tau-type part.
 402
 403 rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty)     -- From source code (no kinds on tyvars)
 404   = getLocalNameEnv             `thenRn` \ name_env ->
 405     let
 406         mentioned_tyvars = extractHsTyVars ty
 407         forall_tyvars    = filter (not . in_scope) mentioned_tyvars
 408         in_scope tv      = maybeToBool (lookupFM name_env tv)
 409
 410         constrained_tyvars            = extractHsCtxtTyVars ctxt
 411         constrained_and_in_scope      = filter in_scope constrained_tyvars
 412         constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
 413
 414         -- Zap the context if there's a problem, to avoid duplicate error message.
 415         ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
 416               | otherwise = []
 417     in
 418     checkRn (null constrained_and_in_scope)
 419             (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
 420     checkRn (null constrained_and_not_mentioned)
 421             (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
 422
 423     (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
 424      rnContext ctxt'                                    `thenRn` \ new_ctxt ->
 425      rnHsType ty                                        `thenRn` \ new_ty ->
 426      returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 427     )
 428   where
 429     sig_doc = text "the type signature for" <+> doc_str
 430
 431
 432 rnHsSigType doc_str other_ty = rnHsType other_ty
 433
 434 rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
 435 rnHsType (HsForAllTy tvs ctxt ty)               -- From an interface file (tyvars may be kinded)
 436   = rn_poly_help tvs ctxt ty
 437
 438 rnHsType full_ty@(HsPreForAllTy ctxt ty)        -- A (context => ty) embedded in a type.
 439                                                 -- Universally quantify over tyvars in context
 440   = getLocalNameEnv             `thenRn` \ name_env ->
 441     let
 442         forall_tyvars = extractHsCtxtTyVars ctxt
 443     in
 444     rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
 445
 446 rnHsType (MonoTyVar tyvar)
 447   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 448     returnRn (MonoTyVar tyvar')
 449
 450 rnHsType (MonoFunTy ty1 ty2)
 451   = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
 452
 453 rnHsType (MonoListTy _ ty)
 454   = lookupImplicitOccRn listType_RDR            `thenRn` \ tycon_name ->
 455     rnHsType ty                                 `thenRn` \ ty' ->
 456     returnRn (MonoListTy tycon_name ty')
 457
 458 rnHsType (MonoTupleTy _ tys)
 459   = lookupImplicitOccRn (tupleType_RDR (length tys))    `thenRn` \ tycon_name ->
 460     mapRn rnHsType tys                                  `thenRn` \ tys' ->
 461     returnRn (MonoTupleTy tycon_name tys')
 462
 463 rnHsType (MonoTyApp ty1 ty2)
 464   = rnHsType ty1                `thenRn` \ ty1' ->
 465     rnHsType ty2                `thenRn` \ ty2' ->
 466     returnRn (MonoTyApp ty1' ty2')
 467
 468 rnHsType (MonoDictTy clas tys)
 469   = lookupOccRn clas            `thenRn` \ clas' ->
 470     mapRn rnHsType tys          `thenRn` \ tys' ->
 471     returnRn (MonoDictTy clas' tys')
 472
 473 rn_poly_help :: [HsTyVar RdrName]               -- Universally quantified tyvars
 474              -> RdrNameContext
 475              -> RdrNameHsType
 476              -> RnMS s RenamedHsType
 477 rn_poly_help tyvars ctxt ty
 478   = bindTyVarsRn sig_doc tyvars                         $ \ new_tyvars ->
 479     rnContext ctxt                                      `thenRn` \ new_ctxt ->
 480     rnHsType ty                                         `thenRn` \ new_ty ->
 481     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 482   where
 483     sig_doc = text "a nested for-all type"
 484 \end{code}
 485
 486
 487 \begin{code}
 488 rnContext :: RdrNameContext -> RnMS s RenamedContext
 489
 490 rnContext  ctxt
 491   = mapRn rn_ctxt ctxt  `thenRn` \ result ->
 492     let
 493         (_, dup_asserts) = removeDups cmp_assert result
 494         (alls, theta)    = partition (\(c,_) -> c == allClass_NAME) result
 495     in
 496
 497         -- Check for duplicate assertions
 498         -- If this isn't an error, then it ought to be:
 499     mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts    `thenRn_`
 500
 501         -- Check for All constraining a non-type-variable
 502     mapRn check_All alls                                        `thenRn_`
 503
 504         -- Done.  Return a theta omitting all the "All" constraints.
 505         -- They have done done their work by ensuring that we universally
 506         -- quantify over their tyvar.
 507     returnRn theta
 508   where
 509     rn_ctxt (clas, tys)
 510       =         -- Mini hack here.  If the class is our pseudo-class "All",
 511                 -- then we don't want to record it as an occurrence, otherwise
 512                 -- we try to slurp it in later and it doesn't really exist at all.
 513                 -- Easiest thing is simply not to put it in the occurrence set.
 514         lookupBndrRn clas       `thenRn` \ clas_name ->
 515         (if clas_name /= allClass_NAME then
 516                 addOccurrenceName clas_name
 517          else
 518                 returnRn clas_name
 519         )                       `thenRn_`
 520         mapRn rnHsType tys      `thenRn` \ tys' ->
 521         returnRn (clas_name, tys')
 522
 523
 524     cmp_assert (c1,tys1) (c2,tys2)
 525       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 526
 527     check_All (c, [MonoTyVar _]) = returnRn ()  -- OK!
 528     check_All assertion          = addErrRn (wierdAllErr assertion)
 529 \end{code}
 530
 531
 532 %*********************************************************
 533 %*                                                      *
 534 \subsection{IdInfo}
 535 %*                                                      *
 536 %*********************************************************
 537
 538 \begin{code}
 539 rnIdInfo (HsStrictness strict)
 540   = rnStrict strict     `thenRn` \ strict' ->
 541     returnRn (HsStrictness strict')
 542
 543 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr       `thenRn` \ expr' ->
 544                                   returnRn (HsUnfold inline expr')
 545 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 546 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update)
 547 rnIdInfo (HsFBType fb)          = returnRn (HsFBType fb)
 548 rnIdInfo (HsArgUsage au)        = returnRn (HsArgUsage au)
 549
 550 rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
 551         -- The sole purpose of the "cons" field is so that we can mark the constructors
 552         -- needed to build the wrapper as "needed", so that their data type decl will be
 553         -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
 554   = lookupOccRn worker                  `thenRn` \ worker' ->
 555     mapRn lookupOccRn cons              `thenRn_`
 556     returnRn (HsStrictnessInfo demands (Just (worker',[])))
 557
 558 -- Boring, but necessary for the type checker.
 559 rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
 560 rnStrict HsBottom                         = returnRn HsBottom
 561 \end{code}
 562
 563 UfCore expressions.
 564
 565 \begin{code}
 566 rnCoreExpr (UfVar v)
 567   = lookupOccRn v       `thenRn` \ v' ->
 568     returnRn (UfVar v')
 569
 570 rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
 571
 572 rnCoreExpr (UfCon con args)
 573   = lookupOccRn con             `thenRn` \ con' ->
 574     mapRn rnCoreArg args        `thenRn` \ args' ->
 575     returnRn (UfCon con' args')
 576
 577 rnCoreExpr (UfPrim prim args)
 578   = rnCorePrim prim             `thenRn` \ prim' ->
 579     mapRn rnCoreArg args        `thenRn` \ args' ->
 580     returnRn (UfPrim prim' args')
 581
 582 rnCoreExpr (UfApp fun arg)
 583   = rnCoreExpr fun              `thenRn` \ fun' ->
 584     rnCoreArg arg               `thenRn` \ arg' ->
 585     returnRn (UfApp fun' arg')
 586
 587 rnCoreExpr (UfCase scrut alts)
 588   = rnCoreExpr scrut            `thenRn` \ scrut' ->
 589     rnCoreAlts alts             `thenRn` \ alts' ->
 590     returnRn (UfCase scrut' alts')
 591
 592 rnCoreExpr (UfSCC cc expr)
 593   = rnCoreExpr expr             `thenRn` \ expr' ->
 594     returnRn  (UfSCC cc expr')
 595
 596 rnCoreExpr(UfCoerce coercion ty body)
 597   = rnCoercion coercion         `thenRn` \ coercion' ->
 598     rnHsType ty                 `thenRn` \ ty' ->
 599     rnCoreExpr body             `thenRn` \ body' ->
 600     returnRn (UfCoerce coercion' ty' body')
 601
 602 rnCoreExpr (UfLam bndr body)
 603   = rnCoreBndr bndr             $ \ bndr' ->
 604     rnCoreExpr body             `thenRn` \ body' ->
 605     returnRn (UfLam bndr' body')
 606
 607 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 608   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 609     rnCoreBndr bndr             $ \ bndr' ->
 610     rnCoreExpr body             `thenRn` \ body' ->
 611     returnRn (UfLet (UfNonRec bndr' rhs') body')
 612
 613 rnCoreExpr (UfLet (UfRec pairs) body)
 614   = rnCoreBndrs bndrs           $ \ bndrs' ->
 615     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 616     rnCoreExpr body             `thenRn` \ body' ->
 617     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 618   where
 619     (bndrs, rhss) = unzip pairs
 620 \end{code}
 621
 622 \begin{code}
 623 rnCoreBndr (UfValBinder name ty) thing_inside
 624   = rnHsType ty                 `thenRn` \ ty' ->
 625     bindLocalsRn "unfolding value" [name] $ \ [name'] ->
 626     thing_inside (UfValBinder name' ty')
 627
 628 rnCoreBndr (UfTyBinder name kind) thing_inside
 629   = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
 630     thing_inside (UfTyBinder name' kind)
 631
 632 rnCoreBndrs bndrs thing_inside          -- Expect them all to be ValBinders
 633   = mapRn rnHsType tys                  `thenRn` \ tys' ->
 634     bindLocalsRn "unfolding value" names $ \ names' ->
 635     thing_inside (zipWith UfValBinder names' tys')
 636   where
 637     names = map (\ (UfValBinder name _) -> name) bndrs
 638     tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
 639
 640 rnCoreBndrNamess names thing_inside
 641   = bindLocalsRn "unfolding value" names $ \ names' ->
 642     thing_inside names'
 643 \end{code}
 644
 645 \begin{code}
 646 rnCoreArg (UfVarArg v)   = lookupOccRn v        `thenRn` \ v' -> returnRn (UfVarArg v')
 647 rnCoreArg (UfTyArg ty)   = rnHsType ty          `thenRn` \ ty' -> returnRn (UfTyArg ty')
 648 rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
 649
 650 rnCoreAlts (UfAlgAlts alts deflt)
 651   = mapRn rn_alt alts           `thenRn` \ alts' ->
 652     rnCoreDefault deflt         `thenRn` \ deflt' ->
 653     returnRn (UfAlgAlts alts' deflt')
 654   where
 655     rn_alt (con, bndrs, rhs) =  lookupOccRn con                 `thenRn` \ con' ->
 656                                 bindLocalsRn "unfolding alt" bndrs      $ \ bndrs' ->
 657                                 rnCoreExpr rhs                          `thenRn` \ rhs' ->
 658                                 returnRn (con', bndrs', rhs')
 659
 660 rnCoreAlts (UfPrimAlts alts deflt)
 661   = mapRn rn_alt alts           `thenRn` \ alts' ->
 662     rnCoreDefault deflt         `thenRn` \ deflt' ->
 663     returnRn (UfPrimAlts alts' deflt')
 664   where
 665     rn_alt (lit, rhs) = rnCoreExpr rhs          `thenRn` \ rhs' ->
 666                         returnRn (lit, rhs')
 667
 668 rnCoreDefault UfNoDefault = returnRn UfNoDefault
 669 rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr]        $ \ [bndr'] ->
 670                                          rnCoreExpr rhs                                 `thenRn` \ rhs' ->
 671                                          returnRn (UfBindDefault bndr' rhs')
 672
 673 rnCoercion (UfIn  n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn  n')
 674 rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n')
 675
 676 rnCorePrim (UfOtherOp op)
 677   = lookupOccRn op      `thenRn` \ op' ->
 678     returnRn (UfOtherOp op')
 679
 680 rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
 681   = mapRn rnHsType arg_tys      `thenRn` \ arg_tys' ->
 682     rnHsType res_ty             `thenRn` \ res_ty' ->
 683     returnRn (UfCCallOp str casm gc arg_tys' res_ty')
 684 \end{code}
 685
 686 %*********************************************************
 687 %*                                                      *
 688 \subsection{Errors}
 689 %*                                                      *
 690 %*********************************************************
 691
 692 \begin{code}
 693 derivingNonStdClassErr clas
 694   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 695
 696 classTyVarNotInOpTyErr clas_tyvar sig
 697   = hang (hsep [ptext SLIT("Class type variable"),
 698                        quotes (ppr clas_tyvar),
 699                        ptext SLIT("does not appear in method signature")])
 700          4 (ppr sig)
 701
 702 dupClassAssertWarn ctxt (assertion : dups)
 703   = sep [hsep [ptext SLIT("Duplicated class assertion"),
 704                quotes (pprClassAssertion assertion),
 705                ptext SLIT("in the context:")],
 706          nest 4 (pprContext ctxt)]
 707
 708 badDataCon name
 709    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 710
 711 wierdAllErr assertion
 712   = ptext SLIT("Mal-formed use of `All':") <+> pprClassAssertion assertion
 713
 714 ctxtErr1 doc tyvars
 715   = hsep [ptext SLIT("Context constrains in-scope type variable(s)"),
 716           pprQuotedList tyvars]
 717     $$
 718     nest 4 (ptext SLIT("in") <+> doc)
 719
 720 ctxtErr2 doc tyvars ty
 721   = (ptext SLIT("Context constrains type variable(s)")
 722         <+> pprQuotedList tyvars)
 723     $$
 724     nest 4 (vcat [ptext SLIT("that do not appear in") <+> quotes (ppr ty),
 725                   ptext SLIT("in") <+> doc])
 726 \end{code}