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 (MonoDictTy clas tys)
 650   = lookupOccRn clas            `thenRn` \ clas' ->
 651     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 652     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 653
 654 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
 655   = bindUVarRn doc uv_rdr $ \ uv_name ->
 656     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 657     returnRn (MonoUsgForAllTy uv_name ty',
 658               fvs )
 659
 660 rnHsType doc (MonoUsgTy usg ty)
 661   = newUsg usg                          `thenRn` \ (usg', usg_fvs) ->
 662     rnHsPolyType doc ty                 `thenRn` \ (ty', ty_fvs) ->
 663         -- A for-all can occur inside a usage annotation
 664     returnRn (MonoUsgTy usg' ty',
 665               usg_fvs `plusFV` ty_fvs)
 666   where
 667     newUsg usg = case usg of
 668                    MonoUsOnce       -> returnRn (MonoUsOnce, emptyFVs)
 669                    MonoUsMany       -> returnRn (MonoUsMany, emptyFVs)
 670                    MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 671                                        returnRn (MonoUsVar uv_name, emptyFVs)
 672
 673 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 674 \end{code}
 675
 676
 677 \begin{code}
 678 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 679
 680 rnContext doc ctxt
 681   = mapAndUnzipRn (rnPred doc) ctxt     `thenRn` \ (theta, fvs_s) ->
 682     let
 683         (_, dup_asserts) = removeDups (cmpHsPred compare) theta
 684     in
 685         -- Check for duplicate assertions
 686         -- If this isn't an error, then it ought to be:
 687     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 688
 689     returnRn (theta, plusFVs fvs_s)
 690
 691 rnPred doc (HsPClass clas tys)
 692   = lookupOccRn clas            `thenRn` \ clas_name ->
 693     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 694     returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
 695 rnPred doc (HsPIParam n ty)
 696   = getIPName n                 `thenRn` \ name ->
 697     rnHsType doc ty             `thenRn` \ (ty', fvs) ->
 698     returnRn (HsPIParam name ty', fvs)
 699 \end{code}
 700
 701 \begin{code}
 702 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
 703
 704 rnFds doc fds
 705   = mapAndUnzipRn rn_fds fds            `thenRn` \ (theta, fvs_s) ->
 706     returnRn (theta, plusFVs fvs_s)
 707   where
 708     rn_fds (tys1, tys2)
 709       = rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
 710         rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
 711         returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
 712
 713 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
 714 rnHsTyvar doc tyvar
 715   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 716     returnRn (tyvar', unitFV tyvar')
 717 \end{code}
 718
 719 %*********************************************************
 720 %*                                                       *
 721 \subsection{IdInfo}
 722 %*                                                       *
 723 %*********************************************************
 724
 725 \begin{code}
 726 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 727
 728 rnIdInfo (HsWorker worker)
 729   = lookupOccRn worker                  `thenRn` \ worker' ->
 730     returnRn (HsWorker worker', unitFV worker')
 731
 732 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 733                                   returnRn (HsUnfold inline expr', fvs)
 734 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 735 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 736 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs, emptyFVs)
 737 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info, emptyFVs)
 738 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
 739                                     `thenRn` \ (rule_body', fvs) ->
 740                                     returnRn (HsSpecialise rule_body', fvs)
 741
 742 rnRuleBody (UfRuleBody str vars args rhs)
 743   = rnCoreBndrs vars            $ \ vars' ->
 744     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 745     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 746     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 747 \end{code}
 748
 749 @UfCore@ expressions.
 750
 751 \begin{code}
 752 rnCoreExpr (UfType ty)
 753   = rnHsPolyType (text "unfolding type") ty     `thenRn` \ (ty', fvs) ->
 754     returnRn (UfType ty', fvs)
 755
 756 rnCoreExpr (UfVar v)
 757   = lookupOccRn v       `thenRn` \ v' ->
 758     returnRn (UfVar v', unitFV v')
 759
 760 rnCoreExpr (UfCon con args)
 761   = rnUfCon con                 `thenRn` \ (con', fvs1) ->
 762     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs2) ->
 763     returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 764
 765 rnCoreExpr (UfTuple con args)
 766   = lookupOccRn con             `thenRn` \ con' ->
 767     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 768     returnRn (UfTuple con' args', fvs `addOneFV` con')
 769
 770 rnCoreExpr (UfApp fun arg)
 771   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 772     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 773     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 774
 775 rnCoreExpr (UfCase scrut bndr alts)
 776   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 777     bindCoreLocalFVRn bndr              ( \ bndr' ->
 778         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 779         returnRn (UfCase scrut' bndr' alts', fvs2)
 780     )                                           `thenRn` \ (case', fvs3) ->
 781     returnRn (case', fvs1 `plusFV` fvs3)
 782
 783 rnCoreExpr (UfNote note expr)
 784   = rnNote note                 `thenRn` \ (note', fvs1) ->
 785     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 786     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 787
 788 rnCoreExpr (UfLam bndr body)
 789   = rnCoreBndr bndr             $ \ bndr' ->
 790     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 791     returnRn (UfLam bndr' body', fvs)
 792
 793 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 794   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 795     rnCoreBndr bndr             ( \ bndr' ->
 796         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 797         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 798     )                           `thenRn` \ (result, fvs3) ->
 799     returnRn (result, fvs1 `plusFV` fvs3)
 800
 801 rnCoreExpr (UfLet (UfRec pairs) body)
 802   = rnCoreBndrs bndrs           $ \ bndrs' ->
 803     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 804     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 805     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 806   where
 807     (bndrs, rhss) = unzip pairs
 808 \end{code}
 809
 810 \begin{code}
 811 rnCoreBndr (UfValBinder name ty) thing_inside
 812   = rnHsPolyType doc ty         `thenRn` \ (ty', fvs1) ->
 813     bindCoreLocalFVRn name      ( \ name' ->
 814             thing_inside (UfValBinder name' ty')
 815     )                           `thenRn` \ (result, fvs2) ->
 816     returnRn (result, fvs1 `plusFV` fvs2)
 817   where
 818     doc = text "unfolding id"
 819
 820 rnCoreBndr (UfTyBinder name kind) thing_inside
 821   = bindCoreLocalFVRn name              $ \ name' ->
 822     thing_inside (UfTyBinder name' kind)
 823
 824 rnCoreBndrs []     thing_inside = thing_inside []
 825 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 826                                   rnCoreBndrs bs        $ \ names' ->
 827                                   thing_inside (name':names')
 828 \end{code}
 829
 830 \begin{code}
 831 rnCoreAlt (con, bndrs, rhs)
 832   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 833     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 834         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 835         returnRn ((con', bndrs', rhs'), fvs2)
 836     )                                   `thenRn` \ (result, fvs3) ->
 837     returnRn (result, fvs1 `plusFV` fvs3)
 838
 839 rnNote (UfCoerce ty)
 840   = rnHsPolyType (text "unfolding coerce") ty   `thenRn` \ (ty', fvs) ->
 841     returnRn (UfCoerce ty', fvs)
 842
 843 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 844 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 845 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 846
 847
 848 rnUfCon UfDefault
 849   = returnRn (UfDefault, emptyFVs)
 850
 851 rnUfCon (UfDataCon con)
 852   = lookupOccRn con             `thenRn` \ con' ->
 853     returnRn (UfDataCon con', unitFV con')
 854
 855 rnUfCon (UfLitCon lit)
 856   = returnRn (UfLitCon lit, emptyFVs)
 857
 858 rnUfCon (UfLitLitCon lit ty)
 859   = rnHsPolyType (text "litlit") ty             `thenRn` \ (ty', fvs) ->
 860     returnRn (UfLitLitCon lit ty', fvs)
 861
 862 rnUfCon (UfPrimOp op)
 863   = lookupOccRn op              `thenRn` \ op' ->
 864     returnRn (UfPrimOp op', emptyFVs)
 865
 866 rnUfCon (UfCCallOp str is_dyn casm gc)
 867   = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 868 \end{code}
 869
 870 %*********************************************************
 871 %*                                                       *
 872 \subsection{Rule shapes}
 873 %*                                                       *
 874 %*********************************************************
 875
 876 Check the shape of a transformation rule LHS.  Currently
 877 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 878 not one of the @forall@'d variables.
 879
 880 \begin{code}
 881 validRuleLhs foralls lhs
 882   = check lhs
 883   where
 884     check (HsApp e1 e2)                   = check e1
 885     check (HsVar v) | v `notElem` foralls = True
 886     check other                           = False
 887 \end{code}
 888
 889
 890 %*********************************************************
 891 %*                                                       *
 892 \subsection{Errors}
 893 %*                                                       *
 894 %*********************************************************
 895
 896 \begin{code}
 897 derivingNonStdClassErr clas
 898   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 899
 900 classTyVarNotInOpTyErr clas_tyvar sig
 901   = hang (hsep [ptext SLIT("Class type variable"),
 902                        quotes (ppr clas_tyvar),
 903                        ptext SLIT("does not appear in method signature")])
 904          4 (ppr sig)
 905
 906 dupClassAssertWarn ctxt (assertion : dups)
 907   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 908                quotes (pprHsPred assertion),
 909                ptext SLIT("in the context:")],
 910          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 911
 912 badDataCon name
 913    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 914
 915 forAllWarn doc ty tyvar
 916   | not opt_WarnUnusedMatches = returnRn ()
 917   | otherwise
 918   = getModeRn           `thenRn` \ mode ->
 919     case mode of {
 920 #ifndef DEBUG
 921         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 922                                         -- unless DEBUG is on, in which case it is slightly
 923                                         -- informative.  They can arise from mkRhsTyLam,
 924 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 925         other ->
 926
 927     addWarnRn (
 928       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 929            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 930       $$
 931       (ptext SLIT("In") <+> doc))
 932     }
 933
 934 forAllErr doc ty tyvar
 935   = addErrRn (
 936       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 937            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 938       $$
 939       (ptext SLIT("In") <+> doc))
 940
 941 univErr doc constraint ty
 942   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 943           <+> quotes (pprHsPred constraint)
 944           <+> ptext SLIT("are already in scope"),
 945          nest 4 (ptext SLIT("At least one must be universally quantified here"))
 946     ]
 947     $$
 948     (ptext SLIT("In") <+> doc)
 949
 950 ambigErr doc constraint ty
 951   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
 952          nest 4 (ptext SLIT("in the type:") <+> ppr ty),
 953          nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
 954     $$
 955     (ptext SLIT("In") <+> doc)
 956
 957 unexpectedForAllTy ty
 958   = ptext SLIT("Unexpected forall type:") <+> ppr ty
 959
 960 badRuleLhsErr name lhs
 961   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 962          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 963     $$
 964     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 965
 966 badRuleVar name var
 967   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 968          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 969                 ptext SLIT("does not appear on left hand side")]
 970 \end{code}