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