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, pprClassAssertion, 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,
  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 | (_,tys) <- ctxt,
 564                                       ty <- tys,
 565                                       tv <- extractHsTyRdrTyVars ty]
 566
 567         dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
 568                 -- dubious = explicitly quantified but not mentioned in tau type
 569
 570         (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
 571                 -- bad  = explicitly quantified and constrained, but not mentioned in tau
 572                 -- warn = explicitly quantified but not mentioned in ctxt or tau
 573
 574         forall_tyvar_names    = map getTyVarName forall_tyvars
 575     in
 576     -- mapRn_ (forAllErr doc tau) bad_guys                                      `thenRn_`
 577     mapRn_ (forAllWarn doc tau) warn_guys                                       `thenRn_`
 578     checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau   `thenRn` \ ctxt' ->
 579     rnForAll doc forall_tyvars ctxt' tau
 580
 581 rnHsPolyType doc other_ty = rnHsType doc other_ty
 582
 583
 584 -- Check that each constraint mentions at least one of the forall'd type variables
 585 -- Since the forall'd type variables are a subset of the free tyvars
 586 -- of the tau-type part, this guarantees that every constraint mentions
 587 -- at least one of the free tyvars in ty
 588 checkConstraints doc forall_tyvars tau_vars ctxt ty
 589    = mapRn check ctxt                   `thenRn` \ maybe_ctxt' ->
 590      returnRn (catMaybes maybe_ctxt')
 591             -- Remove problem ones, to avoid duplicate error message.
 592    where
 593      check ct@(_,tys)
 594         | not_univ  = failWithRn Nothing (univErr  doc ct ty)
 595         | otherwise = returnRn (Just ct)
 596         where
 597           ct_vars    = extractHsTysRdrTyVars tys
 598
 599           not_univ   =  -- At least one of the tyvars in each constraint must
 600                         -- be universally quantified. This restriction isn't in Hugs
 601                         not (any (`elem` forall_tyvars) ct_vars)
 602
 603
 604 rnForAll doc forall_tyvars ctxt ty
 605   = bindTyVarsFVRn doc forall_tyvars    $ \ new_tyvars ->
 606     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 607     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 608     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
 609               cxt_fvs `plusFV` ty_fvs)
 610
 611 ---------------------------------------
 612 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
 613   = addWarnRn (unexpectedForAllTy ty)   `thenRn_`
 614     rnHsPolyType doc ty
 615
 616 rnHsType doc (MonoTyVar tyvar)
 617   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 618     returnRn (MonoTyVar tyvar', unitFV tyvar')
 619
 620 rnHsType doc (MonoFunTy ty1 ty2)
 621   = rnHsPolyType doc ty1        `thenRn` \ (ty1', fvs1) ->
 622         -- Might find a for-all as the arg of a function type
 623     rnHsPolyType doc ty2        `thenRn` \ (ty2', fvs2) ->
 624         -- Or as the result.  This happens when reading Prelude.hi
 625         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 626     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 627
 628 rnHsType doc (MonoListTy ty)
 629   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 630     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 631
 632 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 633 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 634 rnHsType doc (MonoTupleTy tys boxed)
 635   = (if boxed
 636       then mapFvRn (rnHsType doc)     tys
 637       else mapFvRn (rnHsPolyType doc) tys)  `thenRn` \ (tys', fvs) ->
 638     returnRn (MonoTupleTy tys' boxed, fvs   `addOneFV` tup_con_name)
 639   where
 640     tup_con_name = tupleTyCon_name boxed (length tys)
 641
 642 rnHsType doc (MonoTyApp ty1 ty2)
 643   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 644     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 645     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 646
 647 rnHsType doc (MonoDictTy clas tys)
 648   = lookupOccRn clas            `thenRn` \ clas' ->
 649     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 650     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 651
 652 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
 653   = bindUVarRn doc uv_rdr $ \ uv_name ->
 654     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 655     returnRn (MonoUsgForAllTy uv_name ty',
 656               fvs )
 657
 658 rnHsType doc (MonoUsgTy usg ty)
 659   = newUsg usg                          `thenRn` \ (usg', usg_fvs) ->
 660     rnHsPolyType doc ty                 `thenRn` \ (ty', ty_fvs) ->
 661         -- A for-all can occur inside a usage annotation
 662     returnRn (MonoUsgTy usg' ty',
 663               usg_fvs `plusFV` ty_fvs)
 664   where
 665     newUsg usg = case usg of
 666                    MonoUsOnce       -> returnRn (MonoUsOnce, emptyFVs)
 667                    MonoUsMany       -> returnRn (MonoUsMany, emptyFVs)
 668                    MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 669                                        returnRn (MonoUsVar uv_name, emptyFVs)
 670
 671 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 672 \end{code}
 673
 674
 675 \begin{code}
 676 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 677
 678 rnContext doc ctxt
 679   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 680     let
 681         (_, dup_asserts) = removeDups cmp_assert theta
 682     in
 683         -- Check for duplicate assertions
 684         -- If this isn't an error, then it ought to be:
 685     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 686
 687     returnRn (theta, plusFVs fvs_s)
 688   where
 689     rn_ctxt (clas, tys)
 690       = lookupOccRn clas                `thenRn` \ clas_name ->
 691         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 692         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 693
 694     cmp_assert (c1,tys1) (c2,tys2)
 695       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 696 \end{code}
 697
 698 \begin{code}
 699 rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
 700
 701 rnFds doc fds
 702   = mapAndUnzipRn rn_fds fds            `thenRn` \ (theta, fvs_s) ->
 703     returnRn (theta, plusFVs fvs_s)
 704   where
 705     rn_fds (tys1, tys2)
 706       = rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
 707         rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
 708         returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
 709
 710 rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
 711 rnHsTyvar doc tyvar
 712   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 713     returnRn (tyvar', unitFV tyvar')
 714 \end{code}
 715
 716 %*********************************************************
 717 %*                                                       *
 718 \subsection{IdInfo}
 719 %*                                                       *
 720 %*********************************************************
 721
 722 \begin{code}
 723 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 724
 725 rnIdInfo (HsWorker worker)
 726   = lookupOccRn worker                  `thenRn` \ worker' ->
 727     returnRn (HsWorker worker', unitFV worker')
 728
 729 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 730                                   returnRn (HsUnfold inline expr', fvs)
 731 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 732 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 733 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs, emptyFVs)
 734 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info, emptyFVs)
 735 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
 736                                     `thenRn` \ (rule_body', fvs) ->
 737                                     returnRn (HsSpecialise rule_body', fvs)
 738
 739 rnRuleBody (UfRuleBody str vars args rhs)
 740   = rnCoreBndrs vars            $ \ vars' ->
 741     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 742     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 743     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 744 \end{code}
 745
 746 @UfCore@ expressions.
 747
 748 \begin{code}
 749 rnCoreExpr (UfType ty)
 750   = rnHsPolyType (text "unfolding type") ty     `thenRn` \ (ty', fvs) ->
 751     returnRn (UfType ty', fvs)
 752
 753 rnCoreExpr (UfVar v)
 754   = lookupOccRn v       `thenRn` \ v' ->
 755     returnRn (UfVar v', unitFV v')
 756
 757 rnCoreExpr (UfCon con args)
 758   = rnUfCon con                 `thenRn` \ (con', fvs1) ->
 759     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs2) ->
 760     returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 761
 762 rnCoreExpr (UfTuple con args)
 763   = lookupOccRn con             `thenRn` \ con' ->
 764     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 765     returnRn (UfTuple con' args', fvs `addOneFV` con')
 766
 767 rnCoreExpr (UfApp fun arg)
 768   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 769     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 770     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 771
 772 rnCoreExpr (UfCase scrut bndr alts)
 773   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 774     bindCoreLocalFVRn bndr              ( \ bndr' ->
 775         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 776         returnRn (UfCase scrut' bndr' alts', fvs2)
 777     )                                           `thenRn` \ (case', fvs3) ->
 778     returnRn (case', fvs1 `plusFV` fvs3)
 779
 780 rnCoreExpr (UfNote note expr)
 781   = rnNote note                 `thenRn` \ (note', fvs1) ->
 782     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 783     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 784
 785 rnCoreExpr (UfLam bndr body)
 786   = rnCoreBndr bndr             $ \ bndr' ->
 787     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 788     returnRn (UfLam bndr' body', fvs)
 789
 790 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 791   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 792     rnCoreBndr bndr             ( \ bndr' ->
 793         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 794         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 795     )                           `thenRn` \ (result, fvs3) ->
 796     returnRn (result, fvs1 `plusFV` fvs3)
 797
 798 rnCoreExpr (UfLet (UfRec pairs) body)
 799   = rnCoreBndrs bndrs           $ \ bndrs' ->
 800     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 801     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 802     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 803   where
 804     (bndrs, rhss) = unzip pairs
 805 \end{code}
 806
 807 \begin{code}
 808 rnCoreBndr (UfValBinder name ty) thing_inside
 809   = rnHsPolyType doc ty         `thenRn` \ (ty', fvs1) ->
 810     bindCoreLocalFVRn name      ( \ name' ->
 811             thing_inside (UfValBinder name' ty')
 812     )                           `thenRn` \ (result, fvs2) ->
 813     returnRn (result, fvs1 `plusFV` fvs2)
 814   where
 815     doc = text "unfolding id"
 816
 817 rnCoreBndr (UfTyBinder name kind) thing_inside
 818   = bindCoreLocalFVRn name              $ \ name' ->
 819     thing_inside (UfTyBinder name' kind)
 820
 821 rnCoreBndrs []     thing_inside = thing_inside []
 822 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 823                                   rnCoreBndrs bs        $ \ names' ->
 824                                   thing_inside (name':names')
 825 \end{code}
 826
 827 \begin{code}
 828 rnCoreAlt (con, bndrs, rhs)
 829   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 830     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 831         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 832         returnRn ((con', bndrs', rhs'), fvs2)
 833     )                                   `thenRn` \ (result, fvs3) ->
 834     returnRn (result, fvs1 `plusFV` fvs3)
 835
 836 rnNote (UfCoerce ty)
 837   = rnHsPolyType (text "unfolding coerce") ty   `thenRn` \ (ty', fvs) ->
 838     returnRn (UfCoerce ty', fvs)
 839
 840 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 841 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 842 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 843
 844
 845 rnUfCon UfDefault
 846   = returnRn (UfDefault, emptyFVs)
 847
 848 rnUfCon (UfDataCon con)
 849   = lookupOccRn con             `thenRn` \ con' ->
 850     returnRn (UfDataCon con', unitFV con')
 851
 852 rnUfCon (UfLitCon lit)
 853   = returnRn (UfLitCon lit, emptyFVs)
 854
 855 rnUfCon (UfLitLitCon lit ty)
 856   = rnHsPolyType (text "litlit") ty             `thenRn` \ (ty', fvs) ->
 857     returnRn (UfLitLitCon lit ty', fvs)
 858
 859 rnUfCon (UfPrimOp op)
 860   = lookupOccRn op              `thenRn` \ op' ->
 861     returnRn (UfPrimOp op', emptyFVs)
 862
 863 rnUfCon (UfCCallOp str is_dyn casm gc)
 864   = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 865 \end{code}
 866
 867 %*********************************************************
 868 %*                                                       *
 869 \subsection{Rule shapes}
 870 %*                                                       *
 871 %*********************************************************
 872
 873 Check the shape of a transformation rule LHS.  Currently
 874 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 875 not one of the @forall@'d variables.
 876
 877 \begin{code}
 878 validRuleLhs foralls lhs
 879   = check lhs
 880   where
 881     check (HsApp e1 e2)                   = check e1
 882     check (HsVar v) | v `notElem` foralls = True
 883     check other                           = False
 884 \end{code}
 885
 886
 887 %*********************************************************
 888 %*                                                       *
 889 \subsection{Errors}
 890 %*                                                       *
 891 %*********************************************************
 892
 893 \begin{code}
 894 derivingNonStdClassErr clas
 895   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 896
 897 classTyVarNotInOpTyErr clas_tyvar sig
 898   = hang (hsep [ptext SLIT("Class type variable"),
 899                        quotes (ppr clas_tyvar),
 900                        ptext SLIT("does not appear in method signature")])
 901          4 (ppr sig)
 902
 903 dupClassAssertWarn ctxt (assertion : dups)
 904   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 905                quotes (pprClassAssertion assertion),
 906                ptext SLIT("in the context:")],
 907          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 908
 909 badDataCon name
 910    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 911
 912 forAllWarn doc ty tyvar
 913   | not opt_WarnUnusedMatches = returnRn ()
 914   | otherwise
 915   = getModeRn           `thenRn` \ mode ->
 916     case mode of {
 917 #ifndef DEBUG
 918         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 919                                         -- unless DEBUG is on, in which case it is slightly
 920                                         -- informative.  They can arise from mkRhsTyLam,
 921 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 922         other ->
 923
 924     addWarnRn (
 925       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 926            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 927       $$
 928       (ptext SLIT("In") <+> doc))
 929     }
 930
 931 forAllErr doc ty tyvar
 932   = addErrRn (
 933       sep [ptext SLIT("The constrained 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 univErr doc constraint ty
 939   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 940           <+> quotes (pprClassAssertion constraint)
 941           <+> ptext SLIT("are already in scope"),
 942          nest 4 (ptext SLIT("At least one must be universally quantified here"))
 943     ]
 944     $$
 945     (ptext SLIT("In") <+> doc)
 946
 947 ambigErr doc constraint ty
 948   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint),
 949          nest 4 (ptext SLIT("in the type:") <+> ppr ty),
 950          nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
 951     $$
 952     (ptext SLIT("In") <+> doc)
 953
 954 unexpectedForAllTy ty
 955   = ptext SLIT("Unexpected forall type:") <+> ppr ty
 956
 957 badRuleLhsErr name lhs
 958   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 959          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 960     $$
 961     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 962
 963 badRuleVar name var
 964   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 965          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 966                 ptext SLIT("does not appear on left hand side")]
 967 \end{code}