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