ghc/compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
   8
   9 #include "HsVersions.h"
  10
  11 import RnExpr
  12 import HsSyn
  13 import HsPragmas
  14 import HsTypes          ( getTyVarName, pprHsPred, cmpHsTypes )
  15 import RdrName          ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
  16 import RdrHsSyn         ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
  17                           extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
  18                         )
  19 import RnHsSyn
  20 import HsCore
  21
  22 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
  23 import RnEnv            ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
  24                           lookupImplicitOccRn,
  25                           bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
  26                           bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
  27                           bindCoreLocalFVRn, bindCoreLocalsFVRn,
  28                           checkDupOrQualNames, checkDupNames,
  29                           mkImportedGlobalName, mkImportedGlobalFromRdrName,
  30                           newDFunName, getDFunKey, newImplicitBinder,
  31                           FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
  32                         )
  33 import RnMonad
  34
  35 import FunDeps          ( oclose )
  36
  37 import Name             ( Name, OccName,
  38                           ExportFlag(..), Provenance(..),
  39                           nameOccName, NamedThing(..)
  40                         )
  41 import NameSet
  42 import OccName          ( mkDefaultMethodOcc )
  43 import BasicTypes       ( TopLevelFlag(..) )
  44 import FiniteMap        ( elemFM )
  45 import PrelInfo         ( derivableClassKeys,
  46                           deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME
  47                         )
  48 import Bag              ( bagToList )
  49 import List             ( partition, nub )
  50 import Outputable
  51 import SrcLoc           ( SrcLoc )
  52 import CmdLineOpts      ( opt_WarnUnusedMatches )       -- Warn of unused for-all'd tyvars
  53 import Unique           ( Uniquable(..) )
  54 import UniqFM           ( lookupUFM )
  55 import Maybes           ( maybeToBool, catMaybes )
  56 import Util
  57 \end{code}
  58
  59 @rnDecl@ `renames' declarations.
  60 It simultaneously performs dependency analysis and precedence parsing.
  61 It also does the following error checks:
  62 \begin{enumerate}
  63 \item
  64 Checks that tyvars are used properly. This includes checking
  65 for undefined tyvars, and tyvars in contexts that are ambiguous.
  66 (Some of this checking has now been moved to module @TcMonoType@,
  67 since we don't have functional dependency information at this point.)
  68 \item
  69 Checks that all variable occurences are defined.
  70 \item
  71 Checks the @(..)@ etc constraints in the export list.
  72 \end{enumerate}
  73
  74
  75 %*********************************************************
  76 %*                                                      *
  77 \subsection{Value declarations}
  78 %*                                                      *
  79 %*********************************************************
  80
  81 \begin{code}
  82 rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
  83         -- The decls get reversed, but that's ok
  84
  85 rnSourceDecls decls
  86   = go emptyFVs [] decls
  87   where
  88         -- Fixity decls have been dealt with already; ignore them
  89     go fvs ds' []          = returnRn (ds', fvs)
  90     go fvs ds' (FixD _:ds) = go fvs ds' ds
  91     go fvs ds' (d:ds)      = rnDecl d   `thenRn` \(d', fvs') ->
  92                              go (fvs `plusFV` fvs') (d':ds') ds
  93 \end{code}
  94
  95
  96 %*********************************************************
  97 %*                                                      *
  98 \subsection{Value declarations}
  99 %*                                                      *
 100 %*********************************************************
 101
 102 \begin{code}
 103 -- rnDecl does all the work
 104 rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
 105
 106 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ (new_binds, fvs) ->
 107                       returnRn (ValD new_binds, fvs)
 108
 109
 110 rnDecl (SigD (IfaceSig name ty id_infos loc))
 111   = pushSrcLocRn loc $
 112     lookupBndrRn name           `thenRn` \ name' ->
 113     rnHsPolyType doc_str ty     `thenRn` \ (ty',fvs1) ->
 114     mapFvRn rnIdInfo id_infos   `thenRn` \ (id_infos', fvs2) ->
 115     returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
 116   where
 117     doc_str = text "the interface signature for" <+> quotes (ppr name)
 118 \end{code}
 119
 120 %*********************************************************
 121 %*                                                      *
 122 \subsection{Type declarations}
 123 %*                                                      *
 124 %*********************************************************
 125
 126 @rnTyDecl@ uses the `global name function' to create a new type
 127 declaration in which local names have been replaced by their original
 128 names, reporting any unknown names.
 129
 130 Renaming type variables is a pain. Because they now contain uniques,
 131 it is necessary to pass in an association list which maps a parsed
 132 tyvar to its @Name@ representation.
 133 In some cases (type signatures of values),
 134 it is even necessary to go over the type first
 135 in order to get the set of tyvars used by it, make an assoc list,
 136 and then go over it again to rename the tyvars!
 137 However, we can also do some scoping checks at the same time.
 138
 139 \begin{code}
 140 rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
 141   = pushSrcLocRn src_loc $
 142     lookupBndrRn tycon                          `thenRn` \ tycon' ->
 143     bindTyVarsFVRn data_doc tyvars              $ \ tyvars' ->
 144     rnContext data_doc context                  `thenRn` \ (context', cxt_fvs) ->
 145     checkDupOrQualNames data_doc con_names      `thenRn_`
 146     mapFvRn rnConDecl condecls                  `thenRn` \ (condecls', con_fvs) ->
 147     rnDerivs derivings                          `thenRn` \ (derivings', deriv_fvs) ->
 148     ASSERT(isNoDataPragmas pragmas)
 149     returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
 150                      derivings' noDataPragmas src_loc),
 151               cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
 152   where
 153     data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
 154     con_names = map conDeclName condecls
 155
 156 rnDecl (TyClD (TySynonym name tyvars ty src_loc))
 157   = pushSrcLocRn src_loc $
 158     lookupBndrRn name                           `thenRn` \ name' ->
 159     bindTyVarsFVRn syn_doc tyvars               $ \ tyvars' ->
 160     rnHsType syn_doc ty                         `thenRn` \ (ty', ty_fvs) ->
 161     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
 162   where
 163     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 164
 165 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
 166                tname dname snames src_loc))
 167   = pushSrcLocRn src_loc $
 168
 169     lookupBndrRn cname                                  `thenRn` \ cname' ->
 170
 171         -- Deal with the implicit tycon and datacon name
 172         -- They aren't in scope (because they aren't visible to the user)
 173         -- and what we want to do is simply look them up in the cache;
 174         -- we jolly well ought to get a 'hit' there!
 175         -- So the 'Imported' part of this call is not relevant.
 176         -- Unclean; but since these two are the only place this happens
 177         -- I can't work up the energy to do it more beautifully
 178     mkImportedGlobalFromRdrName tname                   `thenRn` \ tname' ->
 179     mkImportedGlobalFromRdrName dname                   `thenRn` \ dname' ->
 180     mapRn mkImportedGlobalFromRdrName snames            `thenRn` \ snames' ->
 181
 182         -- Tyvars scope over bindings and context
 183     bindTyVarsFV2Rn cls_doc tyvars              ( \ clas_tyvar_names tyvars' ->
 184
 185         -- Check the superclasses
 186     rnContext cls_doc context                   `thenRn` \ (context', cxt_fvs) ->
 187
 188         -- Check the functional dependencies
 189     rnFds cls_doc fds                   `thenRn` \ (fds', fds_fvs) ->
 190
 191         -- Check the signatures
 192     let
 193             -- First process the class op sigs, then the fixity sigs.
 194           (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 195           (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
 196     in
 197     checkDupOrQualNames sig_doc sig_rdr_names_w_locs    `thenRn_`
 198     mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs
 199     `thenRn` \ (sigs', sig_fvs) ->
 200     mapRn_  (unknownSigErr) non_sigs                    `thenRn_`
 201     let
 202      binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
 203     in
 204     renameSigs False binders lookupOccRn fix_sigs
 205     `thenRn` \ (fixs', fix_fvs) ->
 206
 207         -- Check the methods
 208     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 209     rnMethodBinds mbinds
 210     `thenRn` \ (mbinds', meth_fvs) ->
 211
 212         -- Typechecker is responsible for checking that we only
 213         -- give default-method bindings for things in this class.
 214         -- The renamer *could* check this for class decls, but can't
 215         -- for instance decls.
 216
 217     ASSERT(isNoClassPragmas pragmas)
 218     returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'
 219                                NoClassPragmas tname' dname' snames' src_loc),
 220               sig_fvs   `plusFV`
 221               fix_fvs   `plusFV`
 222               cxt_fvs   `plusFV`
 223               fds_fvs   `plusFV`
 224               meth_fvs
 225              )
 226     )
 227   where
 228     cls_doc  = text "the declaration for class"         <+> ppr cname
 229     sig_doc  = text "the signatures for class"          <+> ppr cname
 230     meth_doc = text "the default-methods for class"     <+> ppr cname
 231
 232     sig_rdr_names_w_locs  = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
 233     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
 234     meth_rdr_names        = map fst meth_rdr_names_w_locs
 235
 236     rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
 237       = pushSrcLocRn locn $
 238         lookupBndrRn op                         `thenRn` \ op_name ->
 239
 240                 -- Check the signature
 241         rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
 242         let
 243             check_in_op_ty clas_tyvar =
 244                  checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)
 245                          (classTyVarNotInOpTyErr clas_tyvar sig)
 246         in
 247         mapRn_ check_in_op_ty clas_tyvars                `thenRn_`
 248
 249                 -- Make the default-method name
 250         getModeRn                                       `thenRn` \ mode ->
 251         (case mode of
 252             SourceMode -> -- Source class decl
 253                    newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
 254                    returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
 255
 256             InterfaceMode
 257                 ->      -- Imported class that has a default method decl
 258                         -- See comments with tname, snames, above
 259                     lookupImplicitOccRn dm_rdr_name     `thenRn` \ dm_name ->
 260                     returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
 261                         -- An imported class decl for a class decl that had an explicit default
 262                         -- method, mentions, rather than defines,
 263                         -- the default method, so we must arrange to pull it in
 264         )                                               `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
 265
 266         returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 267 \end{code}
 268
 269
 270 %*********************************************************
 271 %*                                                      *
 272 \subsection{Instance declarations}
 273 %*                                                      *
 274 %*********************************************************
 275
 276 \begin{code}
 277 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
 278   = pushSrcLocRn src_loc $
 279     rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
 280     let
 281         inst_tyvars = case inst_ty' of
 282                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 283                         other                             -> []
 284         -- (Slightly strangely) the forall-d tyvars scope over
 285         -- the method bindings too
 286     in
 287
 288         -- Rename the bindings
 289         -- NB meth_names can be qualified!
 290     checkDupNames meth_doc meth_names           `thenRn_`
 291     extendTyVarEnvFVRn inst_tyvars (
 292         rnMethodBinds mbinds
 293     )                                           `thenRn` \ (mbinds', meth_fvs) ->
 294     let
 295         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 296
 297         -- Delete sigs (&report) sigs that aren't allowed inside an
 298         -- instance decl:
 299         --
 300         --  + type signatures
 301         --  + fixity decls
 302         --
 303         (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
 304
 305         okInInstDecl (FixSig _)  = False
 306         okInInstDecl (Sig _ _ _) = False
 307         okInInstDecl _           = True
 308
 309     in
 310       -- You can't have fixity decls & type signatures
 311       -- within an instance declaration.
 312     mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
 313
 314         -- Rename the prags and signatures.
 315         -- Note that the type variables are not in scope here,
 316         -- so that      instance Eq a => Eq (T a) where
 317         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 318         -- works OK.
 319     renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
 320
 321     getModeRn           `thenRn` \ mode ->
 322     (case mode of
 323         InterfaceMode -> lookupImplicitOccRn dfun_rdr_name      `thenRn` \ dfun_name ->
 324                          returnRn (dfun_name, unitFV dfun_name)
 325         SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc
 326                          `thenRn` \ dfun_name ->
 327                          returnRn (dfun_name, emptyFVs)
 328     )
 329     `thenRn` \ (dfun_name, dfun_fv) ->
 330
 331     -- The typechecker checks that all the bindings are for the right class.
 332     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
 333               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
 334   where
 335     meth_doc = text "the bindings in an instance declaration"
 336     meth_names   = bagToList (collectMonoBinders mbinds)
 337 \end{code}
 338
 339 %*********************************************************
 340 %*                                                      *
 341 \subsection{Default declarations}
 342 %*                                                      *
 343 %*********************************************************
 344
 345 \begin{code}
 346 rnDecl (DefD (DefaultDecl tys src_loc))
 347   = pushSrcLocRn src_loc $
 348     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 349     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 350   where
 351     doc_str = text "a `default' declaration"
 352 \end{code}
 353
 354 %*********************************************************
 355 %*                                                      *
 356 \subsection{Foreign declarations}
 357 %*                                                      *
 358 %*********************************************************
 359
 360 \begin{code}
 361 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 362   = pushSrcLocRn src_loc $
 363     lookupOccRn name                    `thenRn` \ name' ->
 364     let
 365         fvs1 = case imp_exp of
 366                 FoImport _ | not isDyn  -> emptyFVs
 367                 FoLabel                 -> emptyFVs
 368                 FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
 369                                                       deRefStablePtr_NAME,
 370                                                       bindIO_NAME]
 371                            | otherwise  -> mkNameSet [name']
 372                 _ -> emptyFVs
 373     in
 374     rnHsSigType fo_decl_msg ty                  `thenRn` \ (ty', fvs2) ->
 375     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
 376               fvs1 `plusFV` fvs2)
 377  where
 378   fo_decl_msg = ptext SLIT("a foreign declaration")
 379   isDyn       = isDynamic ext_nm
 380 \end{code}
 381
 382 %*********************************************************
 383 %*                                                      *
 384 \subsection{Rules}
 385 %*                                                      *
 386 %*********************************************************
 387
 388 \begin{code}
 389 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
 390   = pushSrcLocRn src_loc                        $
 391     lookupOccRn var             `thenRn` \ var' ->
 392     rnRuleBody body             `thenRn` \ (body', fvs) ->
 393     returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
 394
 395 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
 396   = ASSERT( null tvs )
 397     pushSrcLocRn src_loc                        $
 398
 399     bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
 400     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 401     mapFvRn rn_var (vars `zip` ids)             `thenRn` \ (vars', fv_vars) ->
 402
 403     rnExpr lhs                                  `thenRn` \ (lhs', fv_lhs) ->
 404     rnExpr rhs                                  `thenRn` \ (rhs', fv_rhs) ->
 405     checkRn (validRuleLhs ids lhs')
 406             (badRuleLhsErr rule_name lhs')      `thenRn_`
 407     let
 408         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 409     in
 410     mapRn (addErrRn . badRuleVar rule_name) bad_vars    `thenRn_`
 411     returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
 412               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 413   where
 414     doc = text "the transformation rule" <+> ptext rule_name
 415     sig_tvs = extractRuleBndrsTyVars vars
 416
 417     get_var (RuleBndr v)      = v
 418     get_var (RuleBndrSig v _) = v
 419
 420     rn_var (RuleBndr v, id)      = returnRn (RuleBndr id, emptyFVs)
 421     rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t   `thenRn` \ (t', fvs) ->
 422                                    returnRn (RuleBndrSig id t', fvs)
 423 \end{code}
 424
 425
 426 %*********************************************************
 427 %*                                                      *
 428 \subsection{Support code for type/data declarations}
 429 %*                                                      *
 430 %*********************************************************
 431
 432 \begin{code}
 433 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 434
 435 rnDerivs Nothing -- derivs not specified
 436   = returnRn (Nothing, emptyFVs)
 437
 438 rnDerivs (Just clss)
 439   = mapRn do_one clss   `thenRn` \ clss' ->
 440     returnRn (Just clss', mkNameSet clss')
 441   where
 442     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 443                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 444                          (derivingNonStdClassErr clas_name)     `thenRn_`
 445                  returnRn clas_name
 446 \end{code}
 447
 448 \begin{code}
 449 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 450 conDeclName (ConDecl n _ _ _ l) = (n,l)
 451
 452 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
 453 rnConDecl (ConDecl name tvs cxt details locn)
 454   = pushSrcLocRn locn $
 455     checkConName name                   `thenRn_`
 456     lookupBndrRn name                   `thenRn` \ new_name ->
 457     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 458     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 459     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 460     returnRn (ConDecl new_name new_tyvars new_context new_details locn,
 461               cxt_fvs `plusFV` det_fvs)
 462   where
 463     doc = text "the definition of data constructor" <+> quotes (ppr name)
 464
 465 rnConDetails doc locn (VanillaCon tys)
 466   = mapFvRn (rnBangTy doc) tys  `thenRn` \ (new_tys, fvs)  ->
 467     returnRn (VanillaCon new_tys, fvs)
 468
 469 rnConDetails doc locn (InfixCon ty1 ty2)
 470   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 471     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 472     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 473
 474 rnConDetails doc locn (NewCon ty mb_field)
 475   = rnHsPolyType doc ty                 `thenRn` \ (new_ty, fvs) ->
 476     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 477     returnRn (NewCon new_ty new_mb_field, fvs)
 478   where
 479     rn_field Nothing  = returnRn Nothing
 480     rn_field (Just f) =
 481        lookupBndrRn f       `thenRn` \ new_f ->
 482        returnRn (Just new_f)
 483
 484 rnConDetails doc locn (RecCon fields)
 485   = checkDupOrQualNames doc field_names `thenRn_`
 486     mapFvRn (rnField doc) fields        `thenRn` \ (new_fields, fvs) ->
 487     returnRn (RecCon new_fields, fvs)
 488   where
 489     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 490
 491 rnField doc (names, ty)
 492   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 493     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 494     returnRn ((new_names, new_ty), fvs)
 495
 496 rnBangTy doc (Banged ty)
 497   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 498     returnRn (Banged new_ty, fvs)
 499
 500 rnBangTy doc (Unbanged ty)
 501   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 502     returnRn (Unbanged new_ty, fvs)
 503
 504 rnBangTy doc (Unpacked ty)
 505   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 506     returnRn (Unpacked new_ty, fvs)
 507
 508 -- This data decl will parse OK
 509 --      data T = a Int
 510 -- treating "a" as the constructor.
 511 -- It is really hard to make the parser spot this malformation.
 512 -- So the renamer has to check that the constructor is legal
 513 --
 514 -- We can get an operator as the constructor, even in the prefix form:
 515 --      data T = :% Int Int
 516 -- from interface files, which always print in prefix form
 517
 518 checkConName name
 519   = checkRn (isRdrDataCon name)
 520             (badDataCon name)
 521 \end{code}
 522
 523
 524 %*********************************************************
 525 %*                                                      *
 526 \subsection{Support code to rename types}
 527 %*                                                      *
 528 %*********************************************************
 529
 530 \begin{code}
 531 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 532         -- rnHsSigType is used for source-language type signatures,
 533         -- which use *implicit* universal quantification.
 534 rnHsSigType doc_str ty
 535   = rnHsPolyType (text "the type signature for" <+> doc_str) ty
 536
 537 ---------------------------------------
 538 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 539 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
 540 -- The former is called for the top level of type sigs and function args.
 541
 542 ---------------------------------------
 543 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
 544         -- From source code (no kinds on tyvars)
 545         -- Given the signature  C => T  we universally quantify
 546         -- over FV(T) \ {in-scope-tyvars}
 547   = getLocalNameEnv             `thenRn` \ name_env ->
 548     let
 549         mentioned_in_tau = extractHsTyRdrTyVars ty
 550         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
 551     in
 552     checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
 553     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 554
 555 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 556         -- Explicit quantification.
 557         -- Check that the forall'd tyvars are a subset of the
 558         -- free tyvars in the tau-type part
 559         -- That's only a warning... unless the tyvar is constrained by a
 560         -- context in which case it's an error
 561   = let
 562         mentioned_in_tau  = extractHsTyRdrTyVars tau
 563         mentioned_in_ctxt = nub [tv | p <- ctxt,
 564                                       ty <- tys_of_pred p,
 565                                       tv <- extractHsTyRdrTyVars ty]
 566         tys_of_pred (HsPClass clas tys) = tys
 567         tys_of_pred (HsPIParam n ty) = [ty]
 568
 569         dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
 570                 -- dubious = explicitly quantified but not mentioned in tau type
 571
 572         (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
 573                 -- bad  = explicitly quantified and constrained, but not mentioned in tau
 574                 -- warn = explicitly quantified but not mentioned in ctxt or tau
 575
 576         forall_tyvar_names    = map getTyVarName forall_tyvars
 577     in
 578     -- mapRn_ (forAllErr doc tau) bad_guys                                      `thenRn_`
 579     mapRn_ (forAllWarn doc tau) warn_guys                                       `thenRn_`
 580     checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau   `thenRn` \ ctxt' ->
 581     rnForAll doc forall_tyvars ctxt' tau
 582
 583 rnHsPolyType doc other_ty = rnHsType doc other_ty
 584
 585
 586 -- Check that each constraint mentions at least one of the forall'd type variables
 587 -- Since the forall'd type variables are a subset of the free tyvars
 588 -- of the tau-type part, this guarantees that every constraint mentions
 589 -- at least one of the free tyvars in ty
 590 checkConstraints doc forall_tyvars tau_vars ctxt ty
 591    = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
 592      returnRn (catMaybes maybe_ctxt')
 593             -- Remove problem ones, to avoid duplicate error message.
 594
 595 checkPred doc forall_tyvars ty p@(HsPClass clas tys)
 596   | not_univ  = failWithRn Nothing (univErr  doc p ty)
 597   | otherwise = returnRn (Just p)
 598   where
 599       ct_vars  = extractHsTysRdrTyVars tys
 600       not_univ =  -- At least one of the tyvars in each constraint must
 601                   -- be universally quantified. This restriction isn't in Hugs
 602                   not (any (`elem` forall_tyvars) ct_vars)
 603 checkPred doc forall_tyvars ty p@(HsPIParam _ _)
 604   = returnRn (Just p)
 605
 606 rnForAll doc forall_tyvars ctxt ty
 607   = bindTyVarsFVRn doc forall_tyvars    $ \ new_tyvars ->
 608     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 609     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 610     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
 611               cxt_fvs `plusFV` ty_fvs)
 612
 613 ---------------------------------------
 614 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
 615   = addWarnRn (unexpectedForAllTy ty)   `thenRn_`
 616     rnHsPolyType doc ty
 617
 618 rnHsType doc (MonoTyVar tyvar)
 619   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 620     returnRn (MonoTyVar tyvar', unitFV tyvar')
 621
 622 rnHsType doc (MonoFunTy ty1 ty2)
 623   = rnHsPolyType doc ty1        `thenRn` \ (ty1', fvs1) ->
 624         -- Might find a for-all as the arg of a function type
 625     rnHsPolyType doc ty2        `thenRn` \ (ty2', fvs2) ->
 626         -- Or as the result.  This happens when reading Prelude.hi
 627         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 628     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 629
 630 rnHsType doc (MonoListTy ty)
 631   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 632     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 633
 634 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 635 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 636 rnHsType doc (MonoTupleTy tys boxed)
 637   = (if boxed
 638       then mapFvRn (rnHsType doc)     tys
 639       else mapFvRn (rnHsPolyType doc) tys)  `thenRn` \ (tys', fvs) ->
 640     returnRn (MonoTupleTy tys' boxed, fvs   `addOneFV` tup_con_name)
 641   where
 642     tup_con_name = tupleTyCon_name boxed (length tys)
 643
 644 rnHsType doc (MonoTyApp ty1 ty2)
 645   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 646     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 647     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 648
 649 rnHsType doc (MonoIParamTy n ty)
 650   = getIPName n                 `thenRn` \ name ->
 651     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 652     returnRn (MonoIParamTy name ty', fvs)
 653
 654 rnHsType doc (MonoDictTy clas tys)
 655   = lookupOccRn clas            `thenRn` \ clas' ->
 656     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 657     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 658
 659 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
 660   = bindUVarRn doc uv_rdr $ \ uv_name ->
 661     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 662     returnRn (MonoUsgForAllTy uv_name ty',
 663               fvs )
 664
 665 rnHsType doc (MonoUsgTy usg ty)
 666   = newUsg usg                          `thenRn` \ (usg', usg_fvs) ->
 667     rnHsPolyType doc ty                 `thenRn` \ (ty', ty_fvs) ->
 668         -- A for-all can occur inside a usage annotation
 669     returnRn (MonoUsgTy usg' ty',
 670               usg_fvs `plusFV` ty_fvs)
 671   where
 672     newUsg usg = case usg of
 673                    MonoUsOnce       -> returnRn (MonoUsOnce, emptyFVs)
 674                    MonoUsMany       -> returnRn (MonoUsMany, emptyFVs)
 675                    MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 676                                        returnRn (MonoUsVar uv_name, emptyFVs)
 677
 678 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 679 \end{code}
 680
 681
 682 \begin{code}
 683 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 684
 685 rnContext doc ctxt
 686   = mapAndUnzipRn (rnPred doc) ctxt     `thenRn` \ (theta, fvs_s) ->
 687     let
 688         (_, dup_asserts) = removeDups (cmpHsPred compare) theta
 689     in
 690         -- Check for duplicate assertions
 691         -- If this isn't an error, then it ought to be:
 692     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 693
 694     returnRn (theta, plusFVs fvs_s)
 695
 696 rnPred doc (HsPClass clas tys)
 697   = lookupOccRn clas            `thenRn` \ clas_name ->
 698     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 699     returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
 700 rnPred doc (HsPIParam n ty)
 701   = getIPName n                 `thenRn` \ name ->
 702     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 703     returnRn (HsPIParam name ty', fvs)
 704 \end{code}
 705
 706 \begin{code}
 707 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
 708
 709 rnFds doc fds
 710   = mapAndUnzipRn rn_fds fds            `thenRn` \ (theta, fvs_s) ->
 711     returnRn (theta, plusFVs fvs_s)
 712   where
 713     rn_fds (tys1, tys2)
 714       = rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
 715         rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
 716         returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
 717
 718 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
 719 rnHsTyvar doc tyvar
 720   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 721     returnRn (tyvar', unitFV tyvar')
 722 \end{code}
 723
 724 %*********************************************************
 725 %*                                                       *
 726 \subsection{IdInfo}
 727 %*                                                       *
 728 %*********************************************************
 729
 730 \begin{code}
 731 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 732
 733 rnIdInfo (HsWorker worker)
 734   = lookupOccRn worker                  `thenRn` \ worker' ->
 735     returnRn (HsWorker worker', unitFV worker')
 736
 737 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 738                                   returnRn (HsUnfold inline expr', fvs)
 739 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 740 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 741 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs, emptyFVs)
 742 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info, emptyFVs)
 743 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
 744                                     `thenRn` \ (rule_body', fvs) ->
 745                                     returnRn (HsSpecialise rule_body', fvs)
 746
 747 rnRuleBody (UfRuleBody str vars args rhs)
 748   = rnCoreBndrs vars            $ \ vars' ->
 749     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 750     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 751     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 752 \end{code}
 753
 754 @UfCore@ expressions.
 755
 756 \begin{code}
 757 rnCoreExpr (UfType ty)
 758   = rnHsPolyType (text "unfolding type") ty     `thenRn` \ (ty', fvs) ->
 759     returnRn (UfType ty', fvs)
 760
 761 rnCoreExpr (UfVar v)
 762   = lookupOccRn v       `thenRn` \ v' ->
 763     returnRn (UfVar v', unitFV v')
 764
 765 rnCoreExpr (UfCon con args)
 766   = rnUfCon con                 `thenRn` \ (con', fvs1) ->
 767     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs2) ->
 768     returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 769
 770 rnCoreExpr (UfTuple con args)
 771   = lookupOccRn con             `thenRn` \ con' ->
 772     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 773     returnRn (UfTuple con' args', fvs `addOneFV` con')
 774
 775 rnCoreExpr (UfApp fun arg)
 776   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 777     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 778     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 779
 780 rnCoreExpr (UfCase scrut bndr alts)
 781   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 782     bindCoreLocalFVRn bndr              ( \ bndr' ->
 783         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 784         returnRn (UfCase scrut' bndr' alts', fvs2)
 785     )                                           `thenRn` \ (case', fvs3) ->
 786     returnRn (case', fvs1 `plusFV` fvs3)
 787
 788 rnCoreExpr (UfNote note expr)
 789   = rnNote note                 `thenRn` \ (note', fvs1) ->
 790     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 791     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 792
 793 rnCoreExpr (UfLam bndr body)
 794   = rnCoreBndr bndr             $ \ bndr' ->
 795     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 796     returnRn (UfLam bndr' body', fvs)
 797
 798 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 799   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 800     rnCoreBndr bndr             ( \ bndr' ->
 801         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 802         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 803     )                           `thenRn` \ (result, fvs3) ->
 804     returnRn (result, fvs1 `plusFV` fvs3)
 805
 806 rnCoreExpr (UfLet (UfRec pairs) body)
 807   = rnCoreBndrs bndrs           $ \ bndrs' ->
 808     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 809     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 810     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 811   where
 812     (bndrs, rhss) = unzip pairs
 813 \end{code}
 814
 815 \begin{code}
 816 rnCoreBndr (UfValBinder name ty) thing_inside
 817   = rnHsPolyType doc ty         `thenRn` \ (ty', fvs1) ->
 818     bindCoreLocalFVRn name      ( \ name' ->
 819             thing_inside (UfValBinder name' ty')
 820     )                           `thenRn` \ (result, fvs2) ->
 821     returnRn (result, fvs1 `plusFV` fvs2)
 822   where
 823     doc = text "unfolding id"
 824
 825 rnCoreBndr (UfTyBinder name kind) thing_inside
 826   = bindCoreLocalFVRn name              $ \ name' ->
 827     thing_inside (UfTyBinder name' kind)
 828
 829 rnCoreBndrs []     thing_inside = thing_inside []
 830 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 831                                   rnCoreBndrs bs        $ \ names' ->
 832                                   thing_inside (name':names')
 833 \end{code}
 834
 835 \begin{code}
 836 rnCoreAlt (con, bndrs, rhs)
 837   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 838     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 839         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 840         returnRn ((con', bndrs', rhs'), fvs2)
 841     )                                   `thenRn` \ (result, fvs3) ->
 842     returnRn (result, fvs1 `plusFV` fvs3)
 843
 844 rnNote (UfCoerce ty)
 845   = rnHsPolyType (text "unfolding coerce") ty   `thenRn` \ (ty', fvs) ->
 846     returnRn (UfCoerce ty', fvs)
 847
 848 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 849 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 850 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 851
 852
 853 rnUfCon UfDefault
 854   = returnRn (UfDefault, emptyFVs)
 855
 856 rnUfCon (UfDataCon con)
 857   = lookupOccRn con             `thenRn` \ con' ->
 858     returnRn (UfDataCon con', unitFV con')
 859
 860 rnUfCon (UfLitCon lit)
 861   = returnRn (UfLitCon lit, emptyFVs)
 862
 863 rnUfCon (UfLitLitCon lit ty)
 864   = rnHsPolyType (text "litlit") ty             `thenRn` \ (ty', fvs) ->
 865     returnRn (UfLitLitCon lit ty', fvs)
 866
 867 rnUfCon (UfPrimOp op)
 868   = lookupOccRn op              `thenRn` \ op' ->
 869     returnRn (UfPrimOp op', emptyFVs)
 870
 871 rnUfCon (UfCCallOp str is_dyn casm gc)
 872   = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 873 \end{code}
 874
 875 %*********************************************************
 876 %*                                                       *
 877 \subsection{Rule shapes}
 878 %*                                                       *
 879 %*********************************************************
 880
 881 Check the shape of a transformation rule LHS.  Currently
 882 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 883 not one of the @forall@'d variables.
 884
 885 \begin{code}
 886 validRuleLhs foralls lhs
 887   = check lhs
 888   where
 889     check (HsApp e1 e2)                   = check e1
 890     check (HsVar v) | v `notElem` foralls = True
 891     check other                           = False
 892 \end{code}
 893
 894
 895 %*********************************************************
 896 %*                                                       *
 897 \subsection{Errors}
 898 %*                                                       *
 899 %*********************************************************
 900
 901 \begin{code}
 902 derivingNonStdClassErr clas
 903   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 904
 905 classTyVarNotInOpTyErr clas_tyvar sig
 906   = hang (hsep [ptext SLIT("Class type variable"),
 907                        quotes (ppr clas_tyvar),
 908                        ptext SLIT("does not appear in method signature")])
 909          4 (ppr sig)
 910
 911 dupClassAssertWarn ctxt (assertion : dups)
 912   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 913                quotes (pprHsPred assertion),
 914                ptext SLIT("in the context:")],
 915          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 916
 917 badDataCon name
 918    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 919
 920 forAllWarn doc ty tyvar
 921   | not opt_WarnUnusedMatches = returnRn ()
 922   | otherwise
 923   = getModeRn           `thenRn` \ mode ->
 924     case mode of {
 925 #ifndef DEBUG
 926         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 927                                         -- unless DEBUG is on, in which case it is slightly
 928                                         -- informative.  They can arise from mkRhsTyLam,
 929 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 930         other ->
 931
 932     addWarnRn (
 933       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 934            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 935       $$
 936       (ptext SLIT("In") <+> doc))
 937     }
 938
 939 forAllErr doc ty tyvar
 940   = addErrRn (
 941       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 942            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 943       $$
 944       (ptext SLIT("In") <+> doc))
 945
 946 univErr doc constraint ty
 947   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 948           <+> quotes (pprHsPred constraint)
 949           <+> ptext SLIT("are already in scope"),
 950          nest 4 (ptext SLIT("At least one must be universally quantified here"))
 951     ]
 952     $$
 953     (ptext SLIT("In") <+> doc)
 954
 955 ambigErr doc constraint ty
 956   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
 957          nest 4 (ptext SLIT("in the type:") <+> ppr ty),
 958          nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
 959     $$
 960     (ptext SLIT("In") <+> doc)
 961
 962 unexpectedForAllTy ty
 963   = ptext SLIT("Unexpected forall type:") <+> ppr ty
 964
 965 badRuleLhsErr name lhs
 966   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 967          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 968     $$
 969     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 970
 971 badRuleVar name var
 972   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 973          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 974                 ptext SLIT("does not appear on left hand side")]
 975 \end{code}