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 dm_rdr_name explicit_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 of
 244             SourceMode -> -- Source class decl
 245                    newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn     `thenRn` \ dm_name ->
 246                    returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
 247
 248             InterfaceMode
 249                 ->      -- Imported class that has a default method decl
 250                         -- See comments with tname, snames, above
 251                     lookupImplicitOccRn dm_rdr_name     `thenRn` \ dm_name ->
 252                     returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
 253                         -- An imported class decl for a class decl that had an explicit default
 254                         -- method, mentions, rather than defines,
 255                         -- the default method, so we must arrange to pull it in
 256         )                                               `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
 257
 258         returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
 259 \end{code}
 260
 261
 262 %*********************************************************
 263 %*                                                      *
 264 \subsection{Instance declarations}
 265 %*                                                      *
 266 %*********************************************************
 267
 268 \begin{code}
 269 rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
 270   = pushSrcLocRn src_loc $
 271     rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
 272     let
 273         inst_tyvars = case inst_ty' of
 274                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 275                         other                             -> []
 276         -- (Slightly strangely) the forall-d tyvars scope over
 277         -- the method bindings too
 278     in
 279
 280         -- Rename the bindings
 281         -- NB meth_names can be qualified!
 282     checkDupNames meth_doc meth_names           `thenRn_`
 283     extendTyVarEnvFVRn inst_tyvars (
 284         rnMethodBinds mbinds
 285     )                                           `thenRn` \ (mbinds', meth_fvs) ->
 286     let
 287         binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
 288
 289         -- Delete sigs (&report) sigs that aren't allowed inside an
 290         -- instance decl:
 291         --
 292         --  + type signatures
 293         --  + fixity decls
 294         --
 295         (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
 296
 297         okInInstDecl (FixSig _)  = False
 298         okInInstDecl (Sig _ _ _) = False
 299         okInInstDecl _           = True
 300
 301     in
 302       -- You can't have fixity decls & type signatures
 303       -- within an instance declaration.
 304     mapRn_ unknownSigErr not_ok_idecl_sigs       `thenRn_`
 305
 306         -- Rename the prags and signatures.
 307         -- Note that the type variables are not in scope here,
 308         -- so that      instance Eq a => Eq (T a) where
 309         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 310         -- works OK.
 311     renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
 312
 313     getModeRn           `thenRn` \ mode ->
 314     (case mode of
 315         InterfaceMode -> lookupImplicitOccRn dfun_rdr_name      `thenRn` \ dfun_name ->
 316                          returnRn (dfun_name, unitFV dfun_name)
 317         SourceMode    -> newDFunName (getDFunKey inst_ty') src_loc
 318                          `thenRn` \ dfun_name ->
 319                          returnRn (dfun_name, emptyFVs)
 320     )
 321     `thenRn` \ (dfun_name, dfun_fv) ->
 322
 323     -- The typechecker checks that all the bindings are for the right class.
 324     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
 325               inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
 326   where
 327     meth_doc = text "the bindings in an instance declaration"
 328     meth_names   = bagToList (collectMonoBinders mbinds)
 329 \end{code}
 330
 331 %*********************************************************
 332 %*                                                      *
 333 \subsection{Default declarations}
 334 %*                                                      *
 335 %*********************************************************
 336
 337 \begin{code}
 338 rnDecl (DefD (DefaultDecl tys src_loc))
 339   = pushSrcLocRn src_loc $
 340     rnHsTypes doc_str tys               `thenRn` \ (tys', fvs) ->
 341     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 342   where
 343     doc_str = text "a `default' declaration"
 344 \end{code}
 345
 346 %*********************************************************
 347 %*                                                      *
 348 \subsection{Foreign declarations}
 349 %*                                                      *
 350 %*********************************************************
 351
 352 \begin{code}
 353 rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
 354   = pushSrcLocRn src_loc $
 355     lookupOccRn name                    `thenRn` \ name' ->
 356     let
 357         fvs1 = case imp_exp of
 358                 FoImport _ | not isDyn  -> emptyFVs
 359                 FoLabel                 -> emptyFVs
 360                 FoExport   | isDyn      -> mkNameSet [makeStablePtr_NAME,
 361                                                       deRefStablePtr_NAME,
 362                                                       bindIO_NAME]
 363                            | otherwise  -> mkNameSet [name']
 364                 _ -> emptyFVs
 365     in
 366     rnHsSigType fo_decl_msg ty                  `thenRn` \ (ty', fvs2) ->
 367     returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
 368               fvs1 `plusFV` fvs2)
 369  where
 370   fo_decl_msg = ptext SLIT("a foreign declaration")
 371   isDyn       = isDynamic ext_nm
 372 \end{code}
 373
 374 %*********************************************************
 375 %*                                                      *
 376 \subsection{Rules}
 377 %*                                                      *
 378 %*********************************************************
 379
 380 \begin{code}
 381 rnDecl (RuleD (IfaceRuleDecl var body src_loc))
 382   = pushSrcLocRn src_loc                        $
 383     lookupOccRn var             `thenRn` \ var' ->
 384     rnRuleBody body             `thenRn` \ (body', fvs) ->
 385     returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
 386
 387 rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
 388   = ASSERT( null tvs )
 389     pushSrcLocRn src_loc                        $
 390
 391     bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
 392     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 393     mapFvRn rn_var (vars `zip` ids)             `thenRn` \ (vars', fv_vars) ->
 394
 395     rnExpr lhs                                  `thenRn` \ (lhs', fv_lhs) ->
 396     rnExpr rhs                                  `thenRn` \ (rhs', fv_rhs) ->
 397     checkRn (validRuleLhs ids lhs')
 398             (badRuleLhsErr rule_name lhs')      `thenRn_`
 399     let
 400         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 401     in
 402     mapRn (addErrRn . badRuleVar rule_name) bad_vars    `thenRn_`
 403     returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
 404               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 405   where
 406     doc = text "the transformation rule" <+> ptext rule_name
 407     sig_tvs = extractRuleBndrsTyVars vars
 408
 409     get_var (RuleBndr v)      = v
 410     get_var (RuleBndrSig v _) = v
 411
 412     rn_var (RuleBndr v, id)      = returnRn (RuleBndr id, emptyFVs)
 413     rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t   `thenRn` \ (t', fvs) ->
 414                                    returnRn (RuleBndrSig id t', fvs)
 415 \end{code}
 416
 417
 418 %*********************************************************
 419 %*                                                      *
 420 \subsection{Support code for type/data declarations}
 421 %*                                                      *
 422 %*********************************************************
 423
 424 \begin{code}
 425 rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
 426
 427 rnDerivs Nothing -- derivs not specified
 428   = returnRn (Nothing, emptyFVs)
 429
 430 rnDerivs (Just clss)
 431   = mapRn do_one clss   `thenRn` \ clss' ->
 432     returnRn (Just clss', mkNameSet clss')
 433   where
 434     do_one cls = lookupOccRn cls        `thenRn` \ clas_name ->
 435                  checkRn (getUnique clas_name `elem` derivableClassKeys)
 436                          (derivingNonStdClassErr clas_name)     `thenRn_`
 437                  returnRn clas_name
 438 \end{code}
 439
 440 \begin{code}
 441 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 442 conDeclName (ConDecl n _ _ _ l) = (n,l)
 443
 444 rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
 445 rnConDecl (ConDecl name tvs cxt details locn)
 446   = pushSrcLocRn locn $
 447     checkConName name                   `thenRn_`
 448     lookupBndrRn name                   `thenRn` \ new_name ->
 449     bindTyVarsFVRn doc tvs              $ \ new_tyvars ->
 450     rnContext doc cxt                   `thenRn` \ (new_context, cxt_fvs) ->
 451     rnConDetails doc locn details       `thenRn` \ (new_details, det_fvs) ->
 452     returnRn (ConDecl new_name new_tyvars new_context new_details locn,
 453               cxt_fvs `plusFV` det_fvs)
 454   where
 455     doc = text "the definition of data constructor" <+> quotes (ppr name)
 456
 457 rnConDetails doc locn (VanillaCon tys)
 458   = mapFvRn (rnBangTy doc) tys  `thenRn` \ (new_tys, fvs)  ->
 459     returnRn (VanillaCon new_tys, fvs)
 460
 461 rnConDetails doc locn (InfixCon ty1 ty2)
 462   = rnBangTy doc ty1            `thenRn` \ (new_ty1, fvs1) ->
 463     rnBangTy doc ty2            `thenRn` \ (new_ty2, fvs2) ->
 464     returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
 465
 466 rnConDetails doc locn (NewCon ty mb_field)
 467   = rnHsPolyType doc ty                 `thenRn` \ (new_ty, fvs) ->
 468     rn_field mb_field                   `thenRn` \ new_mb_field  ->
 469     returnRn (NewCon new_ty new_mb_field, fvs)
 470   where
 471     rn_field Nothing  = returnRn Nothing
 472     rn_field (Just f) =
 473        lookupBndrRn f       `thenRn` \ new_f ->
 474        returnRn (Just new_f)
 475
 476 rnConDetails doc locn (RecCon fields)
 477   = checkDupOrQualNames doc field_names `thenRn_`
 478     mapFvRn (rnField doc) fields        `thenRn` \ (new_fields, fvs) ->
 479     returnRn (RecCon new_fields, fvs)
 480   where
 481     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 482
 483 rnField doc (names, ty)
 484   = mapRn lookupBndrRn names    `thenRn` \ new_names ->
 485     rnBangTy doc ty             `thenRn` \ (new_ty, fvs) ->
 486     returnRn ((new_names, new_ty), fvs)
 487
 488 rnBangTy doc (Banged ty)
 489   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 490     returnRn (Banged new_ty, fvs)
 491
 492 rnBangTy doc (Unbanged ty)
 493   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 494     returnRn (Unbanged new_ty, fvs)
 495
 496 rnBangTy doc (Unpacked ty)
 497   = rnHsPolyType doc ty         `thenRn` \ (new_ty, fvs) ->
 498     returnRn (Unpacked new_ty, fvs)
 499
 500 -- This data decl will parse OK
 501 --      data T = a Int
 502 -- treating "a" as the constructor.
 503 -- It is really hard to make the parser spot this malformation.
 504 -- So the renamer has to check that the constructor is legal
 505 --
 506 -- We can get an operator as the constructor, even in the prefix form:
 507 --      data T = :% Int Int
 508 -- from interface files, which always print in prefix form
 509
 510 checkConName name
 511   = checkRn (isRdrDataCon name)
 512             (badDataCon name)
 513 \end{code}
 514
 515
 516 %*********************************************************
 517 %*                                                      *
 518 \subsection{Support code to rename types}
 519 %*                                                      *
 520 %*********************************************************
 521
 522 \begin{code}
 523 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 524         -- rnHsSigType is used for source-language type signatures,
 525         -- which use *implicit* universal quantification.
 526 rnHsSigType doc_str ty
 527   = rnHsPolyType (text "the type signature for" <+> doc_str) ty
 528
 529 ---------------------------------------
 530 rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 531 -- rnHsPolyType is prepared to see a for-all; rnHsType is not
 532 -- The former is called for the top level of type sigs and function args.
 533
 534 ---------------------------------------
 535 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
 536         -- From source code (no kinds on tyvars)
 537         -- Given the signature  C => T  we universally quantify
 538         -- over FV(T) \ {in-scope-tyvars}
 539   = getLocalNameEnv             `thenRn` \ name_env ->
 540     let
 541         mentioned_in_tau = extractHsTyRdrTyVars ty
 542         forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_in_tau
 543     in
 544     checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
 545     rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
 546
 547 rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 548         -- Explicit quantification.
 549         -- Check that the forall'd tyvars are a subset of the
 550         -- free tyvars in the tau-type part
 551         -- That's only a warning... unless the tyvar is constrained by a
 552         -- context in which case it's an error
 553   = let
 554         mentioned_in_tau  = extractHsTyRdrTyVars tau
 555         mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
 556                                       ty <- tys,
 557                                       tv <- extractHsTyRdrTyVars ty]
 558
 559         dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
 560                 -- dubious = explicitly quantified but not mentioned in tau type
 561
 562         (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
 563                 -- bad  = explicitly quantified and constrained, but not mentioned in tau
 564                 -- warn = explicitly quantified but not mentioned in ctxt or tau
 565
 566         forall_tyvar_names    = map getTyVarName forall_tyvars
 567     in
 568     mapRn_ (forAllErr doc tau) bad_guys                                         `thenRn_`
 569     mapRn_ (forAllWarn doc tau) warn_guys                                       `thenRn_`
 570     checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau   `thenRn` \ ctxt' ->
 571     rnForAll doc forall_tyvars ctxt' tau
 572
 573 rnHsPolyType doc other_ty = rnHsType doc other_ty
 574
 575
 576 -- Check that each constraint mentions at least one of the forall'd type variables
 577 -- Since the forall'd type variables are a subset of the free tyvars
 578 -- of the tau-type part, this guarantees that every constraint mentions
 579 -- at least one of the free tyvars in ty
 580 checkConstraints doc forall_tyvars tau_vars ctxt ty
 581    = mapRn check ctxt                   `thenRn` \ maybe_ctxt' ->
 582      returnRn (catMaybes maybe_ctxt')
 583             -- Remove problem ones, to avoid duplicate error message.
 584    where
 585      check ct@(_,tys)
 586         | ambiguous = failWithRn Nothing (ambigErr doc ct ty)
 587         | not_univ  = failWithRn Nothing (univErr  doc ct ty)
 588         | otherwise = returnRn (Just ct)
 589         where
 590           ct_vars    = extractHsTysRdrTyVars tys
 591
 592           ambiguous  =  -- All the universally-quantified tyvars in the constraint must appear in the tau ty
 593                         -- (will change when we get functional dependencies)
 594                         not (all (\ct_var -> not (ct_var `elem` forall_tyvars) || ct_var `elem` tau_vars) ct_vars)
 595
 596           not_univ   =  -- At least one of the tyvars in each constraint must
 597                         -- be universally quantified. This restriction isn't in Hugs
 598                         not (any (`elem` forall_tyvars) ct_vars)
 599
 600
 601 rnForAll doc forall_tyvars ctxt ty
 602   = bindTyVarsFVRn doc forall_tyvars    $ \ new_tyvars ->
 603     rnContext doc ctxt                  `thenRn` \ (new_ctxt, cxt_fvs) ->
 604     rnHsType doc ty                     `thenRn` \ (new_ty, ty_fvs) ->
 605     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
 606               cxt_fvs `plusFV` ty_fvs)
 607
 608 ---------------------------------------
 609 rnHsType doc ty@(HsForAllTy _ _ inner_ty)
 610   = addWarnRn (unexpectedForAllTy ty)   `thenRn_`
 611     rnHsPolyType doc ty
 612
 613 rnHsType doc (MonoTyVar tyvar)
 614   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 615     returnRn (MonoTyVar tyvar', unitFV tyvar')
 616
 617 rnHsType doc (MonoFunTy ty1 ty2)
 618   = rnHsPolyType doc ty1        `thenRn` \ (ty1', fvs1) ->
 619         -- Might find a for-all as the arg of a function type
 620     rnHsPolyType doc ty2        `thenRn` \ (ty2', fvs2) ->
 621         -- Or as the result.  This happens when reading Prelude.hi
 622         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 623     returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
 624
 625 rnHsType doc (MonoListTy ty)
 626   = rnHsType doc ty                             `thenRn` \ (ty', fvs) ->
 627     returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
 628
 629 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 630 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 631 rnHsType doc (MonoTupleTy tys boxed)
 632   = (if boxed
 633       then mapFvRn (rnHsType doc)     tys
 634       else mapFvRn (rnHsPolyType doc) tys)  `thenRn` \ (tys', fvs) ->
 635     returnRn (MonoTupleTy tys' boxed, fvs   `addOneFV` tup_con_name)
 636   where
 637     tup_con_name = tupleTyCon_name boxed (length tys)
 638
 639 rnHsType doc (MonoTyApp ty1 ty2)
 640   = rnHsType doc ty1            `thenRn` \ (ty1', fvs1) ->
 641     rnHsType doc ty2            `thenRn` \ (ty2', fvs2) ->
 642     returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
 643
 644 rnHsType doc (MonoDictTy clas tys)
 645   = lookupOccRn clas            `thenRn` \ clas' ->
 646     rnHsTypes doc tys           `thenRn` \ (tys', fvs) ->
 647     returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
 648
 649 rnHsType doc (MonoUsgForAllTy uv_rdr ty)
 650   = bindUVarRn doc uv_rdr $ \ uv_name ->
 651     rnHsType doc ty       `thenRn` \ (ty', fvs) ->
 652     returnRn (MonoUsgForAllTy uv_name ty',
 653               fvs )
 654
 655 rnHsType doc (MonoUsgTy usg ty)
 656   = newUsg usg                          `thenRn` \ (usg', usg_fvs) ->
 657     rnHsType doc ty                     `thenRn` \ (ty', ty_fvs) ->
 658     returnRn (MonoUsgTy usg' ty',
 659               usg_fvs `plusFV` ty_fvs)
 660   where
 661     newUsg usg = case usg of
 662                    MonoUsOnce       -> returnRn (MonoUsOnce, emptyFVs)
 663                    MonoUsMany       -> returnRn (MonoUsMany, emptyFVs)
 664                    MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
 665                                        returnRn (MonoUsVar uv_name, emptyFVs)
 666
 667 rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 668 \end{code}
 669
 670
 671 \begin{code}
 672 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 673
 674 rnContext doc ctxt
 675   = mapAndUnzipRn rn_ctxt ctxt          `thenRn` \ (theta, fvs_s) ->
 676     let
 677         (_, dup_asserts) = removeDups cmp_assert theta
 678     in
 679         -- Check for duplicate assertions
 680         -- If this isn't an error, then it ought to be:
 681     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts   `thenRn_`
 682
 683     returnRn (theta, plusFVs fvs_s)
 684   where
 685     rn_ctxt (clas, tys)
 686       = lookupOccRn clas                `thenRn` \ clas_name ->
 687         rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
 688         returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
 689
 690     cmp_assert (c1,tys1) (c2,tys2)
 691       = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
 692 \end{code}
 693
 694
 695 %*********************************************************
 696 %*                                                       *
 697 \subsection{IdInfo}
 698 %*                                                       *
 699 %*********************************************************
 700
 701 \begin{code}
 702 rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs)
 703
 704 rnIdInfo (HsWorker worker)
 705   = lookupOccRn worker                  `thenRn` \ worker' ->
 706     returnRn (HsWorker worker', unitFV worker')
 707
 708 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
 709                                   returnRn (HsUnfold inline expr', fvs)
 710 rnIdInfo (HsArity arity)        = returnRn (HsArity arity, emptyFVs)
 711 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update, emptyFVs)
 712 rnIdInfo (HsNoCafRefs)          = returnRn (HsNoCafRefs, emptyFVs)
 713 rnIdInfo (HsCprInfo cpr_info)   = returnRn (HsCprInfo cpr_info, emptyFVs)
 714 rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
 715                                     `thenRn` \ (rule_body', fvs) ->
 716                                     returnRn (HsSpecialise rule_body', fvs)
 717
 718 rnRuleBody (UfRuleBody str vars args rhs)
 719   = rnCoreBndrs vars            $ \ vars' ->
 720     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs1) ->
 721     rnCoreExpr rhs              `thenRn` \ (rhs',  fvs2) ->
 722     returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
 723 \end{code}
 724
 725 @UfCore@ expressions.
 726
 727 \begin{code}
 728 rnCoreExpr (UfType ty)
 729   = rnHsPolyType (text "unfolding type") ty     `thenRn` \ (ty', fvs) ->
 730     returnRn (UfType ty', fvs)
 731
 732 rnCoreExpr (UfVar v)
 733   = lookupOccRn v       `thenRn` \ v' ->
 734     returnRn (UfVar v', unitFV v')
 735
 736 rnCoreExpr (UfCon con args)
 737   = rnUfCon con                 `thenRn` \ (con', fvs1) ->
 738     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs2) ->
 739     returnRn (UfCon con' args', fvs1 `plusFV` fvs2)
 740
 741 rnCoreExpr (UfTuple con args)
 742   = lookupOccRn con             `thenRn` \ con' ->
 743     mapFvRn rnCoreExpr args     `thenRn` \ (args', fvs) ->
 744     returnRn (UfTuple con' args', fvs `addOneFV` con')
 745
 746 rnCoreExpr (UfApp fun arg)
 747   = rnCoreExpr fun              `thenRn` \ (fun', fv1) ->
 748     rnCoreExpr arg              `thenRn` \ (arg', fv2) ->
 749     returnRn (UfApp fun' arg', fv1 `plusFV` fv2)
 750
 751 rnCoreExpr (UfCase scrut bndr alts)
 752   = rnCoreExpr scrut                    `thenRn` \ (scrut', fvs1) ->
 753     bindCoreLocalFVRn bndr              ( \ bndr' ->
 754         mapFvRn rnCoreAlt alts          `thenRn` \ (alts', fvs2) ->
 755         returnRn (UfCase scrut' bndr' alts', fvs2)
 756     )                                           `thenRn` \ (case', fvs3) ->
 757     returnRn (case', fvs1 `plusFV` fvs3)
 758
 759 rnCoreExpr (UfNote note expr)
 760   = rnNote note                 `thenRn` \ (note', fvs1) ->
 761     rnCoreExpr expr             `thenRn` \ (expr', fvs2) ->
 762     returnRn  (UfNote note' expr', fvs1 `plusFV` fvs2)
 763
 764 rnCoreExpr (UfLam bndr body)
 765   = rnCoreBndr bndr             $ \ bndr' ->
 766     rnCoreExpr body             `thenRn` \ (body', fvs) ->
 767     returnRn (UfLam bndr' body', fvs)
 768
 769 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 770   = rnCoreExpr rhs              `thenRn` \ (rhs', fvs1) ->
 771     rnCoreBndr bndr             ( \ bndr' ->
 772         rnCoreExpr body         `thenRn` \ (body', fvs2) ->
 773         returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2)
 774     )                           `thenRn` \ (result, fvs3) ->
 775     returnRn (result, fvs1 `plusFV` fvs3)
 776
 777 rnCoreExpr (UfLet (UfRec pairs) body)
 778   = rnCoreBndrs bndrs           $ \ bndrs' ->
 779     mapFvRn rnCoreExpr rhss     `thenRn` \ (rhss', fvs1) ->
 780     rnCoreExpr body             `thenRn` \ (body', fvs2) ->
 781     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2)
 782   where
 783     (bndrs, rhss) = unzip pairs
 784 \end{code}
 785
 786 \begin{code}
 787 rnCoreBndr (UfValBinder name ty) thing_inside
 788   = rnHsPolyType doc ty         `thenRn` \ (ty', fvs1) ->
 789     bindCoreLocalFVRn name      ( \ name' ->
 790             thing_inside (UfValBinder name' ty')
 791     )                           `thenRn` \ (result, fvs2) ->
 792     returnRn (result, fvs1 `plusFV` fvs2)
 793   where
 794     doc = text "unfolding id"
 795
 796 rnCoreBndr (UfTyBinder name kind) thing_inside
 797   = bindCoreLocalFVRn name              $ \ name' ->
 798     thing_inside (UfTyBinder name' kind)
 799
 800 rnCoreBndrs []     thing_inside = thing_inside []
 801 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 802                                   rnCoreBndrs bs        $ \ names' ->
 803                                   thing_inside (name':names')
 804 \end{code}
 805
 806 \begin{code}
 807 rnCoreAlt (con, bndrs, rhs)
 808   = rnUfCon con                         `thenRn` \ (con', fvs1) ->
 809     bindCoreLocalsFVRn bndrs            ( \ bndrs' ->
 810         rnCoreExpr rhs                  `thenRn` \ (rhs', fvs2) ->
 811         returnRn ((con', bndrs', rhs'), fvs2)
 812     )                                   `thenRn` \ (result, fvs3) ->
 813     returnRn (result, fvs1 `plusFV` fvs3)
 814
 815 rnNote (UfCoerce ty)
 816   = rnHsPolyType (text "unfolding coerce") ty   `thenRn` \ (ty', fvs) ->
 817     returnRn (UfCoerce ty', fvs)
 818
 819 rnNote (UfSCC cc)   = returnRn (UfSCC cc, emptyFVs)
 820 rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs)
 821 rnNote UfInlineMe   = returnRn (UfInlineMe, emptyFVs)
 822
 823
 824 rnUfCon UfDefault
 825   = returnRn (UfDefault, emptyFVs)
 826
 827 rnUfCon (UfDataCon con)
 828   = lookupOccRn con             `thenRn` \ con' ->
 829     returnRn (UfDataCon con', unitFV con')
 830
 831 rnUfCon (UfLitCon lit)
 832   = returnRn (UfLitCon lit, emptyFVs)
 833
 834 rnUfCon (UfLitLitCon lit ty)
 835   = rnHsPolyType (text "litlit") ty             `thenRn` \ (ty', fvs) ->
 836     returnRn (UfLitLitCon lit ty', fvs)
 837
 838 rnUfCon (UfPrimOp op)
 839   = lookupOccRn op              `thenRn` \ op' ->
 840     returnRn (UfPrimOp op', emptyFVs)
 841
 842 rnUfCon (UfCCallOp str is_dyn casm gc)
 843   = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs)
 844 \end{code}
 845
 846 %*********************************************************
 847 %*                                                       *
 848 \subsection{Rule shapes}
 849 %*                                                       *
 850 %*********************************************************
 851
 852 Check the shape of a transformation rule LHS.  Currently
 853 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 854 not one of the @forall@'d variables.
 855
 856 \begin{code}
 857 validRuleLhs foralls lhs
 858   = check lhs
 859   where
 860     check (HsApp e1 e2)                   = check e1
 861     check (HsVar v) | v `notElem` foralls = True
 862     check other                           = False
 863 \end{code}
 864
 865
 866 %*********************************************************
 867 %*                                                       *
 868 \subsection{Errors}
 869 %*                                                       *
 870 %*********************************************************
 871
 872 \begin{code}
 873 derivingNonStdClassErr clas
 874   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 875
 876 classTyVarNotInOpTyErr clas_tyvar sig
 877   = hang (hsep [ptext SLIT("Class type variable"),
 878                        quotes (ppr clas_tyvar),
 879                        ptext SLIT("does not appear in method signature")])
 880          4 (ppr sig)
 881
 882 dupClassAssertWarn ctxt (assertion : dups)
 883   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 884                quotes (pprClassAssertion assertion),
 885                ptext SLIT("in the context:")],
 886          nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
 887
 888 badDataCon name
 889    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 890
 891 forAllWarn doc ty tyvar
 892   | not opt_WarnUnusedMatches = returnRn ()
 893   | otherwise
 894   = getModeRn           `thenRn` \ mode ->
 895     case mode of {
 896 #ifndef DEBUG
 897         InterfaceMode -> returnRn () ;  -- Don't warn of unused tyvars in interface files
 898                                         -- unless DEBUG is on, in which case it is slightly
 899                                         -- informative.  They can arise from mkRhsTyLam,
 900 #endif                                  -- leading to (say)     f :: forall a b. [b] -> [b]
 901         other ->
 902
 903     addWarnRn (
 904       sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 905            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 906       $$
 907       (ptext SLIT("In") <+> doc))
 908     }
 909
 910 forAllErr doc ty tyvar
 911   = addErrRn (
 912       sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
 913            nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 914       $$
 915       (ptext SLIT("In") <+> doc))
 916
 917 univErr doc constraint ty
 918   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 919           <+> quotes (pprClassAssertion constraint)
 920           <+> ptext SLIT("are already in scope"),
 921          nest 4 (ptext SLIT("At least one must be universally quantified here"))
 922     ]
 923     $$
 924     (ptext SLIT("In") <+> doc)
 925
 926 ambigErr doc constraint ty
 927   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint),
 928          nest 4 (ptext SLIT("in the type:") <+> ppr ty),
 929          nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
 930     $$
 931     (ptext SLIT("In") <+> doc)
 932
 933 unexpectedForAllTy ty
 934   = ptext SLIT("Unexpected forall type:") <+> ppr ty
 935
 936 badRuleLhsErr name lhs
 937   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 938          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 939     $$
 940     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 941
 942 badRuleVar name var
 943   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 944          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 945                 ptext SLIT("does not appear on left hand side")]
 946 \end{code}