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 ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
   8                   rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs
   9         ) where
  10
  11 #include "HsVersions.h"
  12
  13 import RnExpr
  14 import HsSyn
  15 import HscTypes         ( GlobalRdrEnv )
  16 import HsTypes          ( hsTyVarNames, pprHsContext )
  17 import RdrName          ( RdrName, isRdrDataCon, elemRdrEnv )
  18 import RdrHsSyn         ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
  19                           extractRuleBndrsTyVars, extractHsTyRdrTyVars,
  20                           extractHsCtxtRdrTyVars, extractGenericPatTyVars
  21                         )
  22 import RnHsSyn
  23 import HsCore
  24
  25 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
  26 import RnEnv            ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName,
  27                           lookupOrigNames, lookupSysBinder, newLocalsRn,
  28                           bindLocalsFVRn,
  29                           bindTyVarsRn, bindTyVars2Rn,
  30                           bindTyVarsFV2Rn, extendTyVarEnvFVRn,
  31                           bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
  32                           checkDupOrQualNames, checkDupNames, mapFvRn
  33                         )
  34 import RnMonad
  35
  36 import Class            ( FunDep, DefMeth (..) )
  37 import DataCon          ( dataConId )
  38 import Name             ( Name, NamedThing(..) )
  39 import NameSet
  40 import PrelInfo         ( derivableClassKeys, cCallishClassKeys )
  41 import PrelNames        ( deRefStablePtr_RDR, newStablePtr_RDR,
  42                           bindIO_RDR, returnIO_RDR
  43                         )
  44 import TysWiredIn       ( tupleCon )
  45 import List             ( partition, nub )
  46 import Outputable
  47 import SrcLoc           ( SrcLoc )
  48 import CmdLineOpts      ( DynFlag(..) )
  49                                 -- Warn of unused for-all'd tyvars
  50 import Unique           ( Uniquable(..) )
  51 import Maybes           ( maybeToBool )
  52 import ListSetOps       ( removeDupsEq )
  53 \end{code}
  54
  55 @rnSourceDecl@ `renames' declarations.
  56 It simultaneously performs dependency analysis and precedence parsing.
  57 It also does the following error checks:
  58 \begin{enumerate}
  59 \item
  60 Checks that tyvars are used properly. This includes checking
  61 for undefined tyvars, and tyvars in contexts that are ambiguous.
  62 (Some of this checking has now been moved to module @TcMonoType@,
  63 since we don't have functional dependency information at this point.)
  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{Source code declarations}
  74 %*                                                      *
  75 %*********************************************************
  76
  77 \begin{code}
  78 rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
  79               -> [RdrNameHsDecl]
  80               -> RnMG ([RenamedHsDecl], FreeVars)
  81         -- The decls get reversed, but that's ok
  82
  83 rnSourceDecls gbl_env local_fixity_env decls
  84   = initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
  85   where
  86         -- Fixity and deprecations have been dealt with already; ignore them
  87     go fvs ds' []             = returnRn (ds', fvs)
  88     go fvs ds' (FixD _:ds)    = go fvs ds' ds
  89     go fvs ds' (DeprecD _:ds) = go fvs ds' ds
  90     go fvs ds' (d:ds)         = rnSourceDecl d  `thenRn` \(d', fvs') ->
  91                                 go (fvs `plusFV` fvs') (d':ds') ds
  92
  93
  94 rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
  95
  96 rnSourceDecl (ValD binds) = rnTopBinds binds    `thenRn` \ (new_binds, fvs) ->
  97                             returnRn (ValD new_binds, fvs)
  98
  99 rnSourceDecl (TyClD tycl_decl)
 100   = rnTyClDecl tycl_decl                        `thenRn` \ new_decl ->
 101     finishSourceTyClDecl tycl_decl new_decl     `thenRn` \ (new_decl', fvs) ->
 102     returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
 103
 104 rnSourceDecl (InstD inst)
 105   = rnInstDecl inst                     `thenRn` \ new_inst ->
 106     finishSourceInstDecl inst new_inst  `thenRn` \ (new_inst', fvs) ->
 107     returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
 108
 109 rnSourceDecl (RuleD rule)
 110   = rnHsRuleDecl rule           `thenRn` \ (new_rule, fvs) ->
 111     returnRn (RuleD new_rule, fvs)
 112
 113 rnSourceDecl (ForD ford)
 114   = rnHsForeignDecl ford                `thenRn` \ (new_ford, fvs) ->
 115     returnRn (ForD new_ford, fvs)
 116
 117 rnSourceDecl (DefD (DefaultDecl tys src_loc))
 118   = pushSrcLocRn src_loc $
 119     mapFvRn (rnHsTypeFVs doc_str) tys           `thenRn` \ (tys', fvs) ->
 120     returnRn (DefD (DefaultDecl tys' src_loc), fvs)
 121   where
 122     doc_str = text "In a `default' declaration"
 123 \end{code}
 124
 125
 126 %*********************************************************
 127 %*                                                      *
 128 \subsection{Foreign declarations}
 129 %*                                                      *
 130 %*********************************************************
 131
 132 \begin{code}
 133 rnHsForeignDecl (ForeignImport name ty spec src_loc)
 134   = pushSrcLocRn src_loc                $
 135     lookupOccRn name                    `thenRn` \ name' ->
 136     rnHsTypeFVs (fo_decl_msg name) ty   `thenRn` \ (ty', fvs1) ->
 137     lookupOrigNames (extras spec)       `thenRn` \ fvs2 ->
 138     returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
 139   where
 140     extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
 141     extras other          = []
 142
 143 rnHsForeignDecl (ForeignExport name ty spec src_loc)
 144   = pushSrcLocRn src_loc                        $
 145     lookupOccRn name                            `thenRn` \ name' ->
 146     rnHsTypeFVs (fo_decl_msg name) ty           `thenRn` \ (ty', fvs1) ->
 147     lookupOrigNames [bindIO_RDR, returnIO_RDR]  `thenRn` \ fvs2 ->
 148     returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
 149
 150 fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
 151 \end{code}
 152
 153
 154 %*********************************************************
 155 %*                                                      *
 156 \subsection{Instance declarations}
 157 %*                                                      *
 158 %*********************************************************
 159
 160 \begin{code}
 161 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
 162         -- Used for both source and interface file decls
 163   = pushSrcLocRn src_loc $
 164     rnHsSigType (text "an instance decl") inst_ty       `thenRn` \ inst_ty' ->
 165
 166     (case maybe_dfun_rdr_name of
 167         Nothing            -> returnRn Nothing
 168         Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name     `thenRn` \ dfun_name ->
 169                               returnRn (Just dfun_name)
 170     )                                                   `thenRn` \ maybe_dfun_name ->
 171
 172     -- The typechecker checks that all the bindings are for the right class.
 173     returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
 174
 175 -- Compare finishSourceTyClDecl
 176 finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
 177                      (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
 178         -- Used for both source decls only
 179   = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
 180     let
 181         meth_doc    = text "In the bindings in an instance declaration"
 182         meth_names  = collectLocatedMonoBinders mbinds
 183         inst_tyvars = case inst_ty of
 184                         HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
 185                         other                             -> []
 186         -- (Slightly strangely) the forall-d tyvars scope over
 187         -- the method bindings too
 188     in
 189
 190         -- Rename the bindings
 191         -- NB meth_names can be qualified!
 192     checkDupNames meth_doc meth_names           `thenRn_`
 193     extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
 194         rnMethodBinds [] mbinds
 195     )                                           `thenRn` \ (mbinds', meth_fvs) ->
 196     let
 197         binders    = collectMonoBinders mbinds'
 198         binder_set = mkNameSet binders
 199     in
 200         -- Rename the prags and signatures.
 201         -- Note that the type variables are not in scope here,
 202         -- so that      instance Eq a => Eq (T a) where
 203         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 204         -- works OK.
 205         --
 206         -- But the (unqualified) method names are in scope
 207     bindLocalNames binders (
 208        renameSigsFVs (okInstDclSig binder_set) uprags
 209     )                                                   `thenRn` \ (uprags', prag_fvs) ->
 210
 211     returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
 212               meth_fvs `plusFV` prag_fvs)
 213 \end{code}
 214
 215 %*********************************************************
 216 %*                                                      *
 217 \subsection{Rules}
 218 %*                                                      *
 219 %*********************************************************
 220
 221 \begin{code}
 222 rnIfaceRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
 223   = pushSrcLocRn src_loc        $
 224     lookupOccRn fn              `thenRn` \ fn' ->
 225     rnCoreBndrs vars            $ \ vars' ->
 226     mapRn rnCoreExpr args       `thenRn` \ args' ->
 227     rnCoreExpr rhs              `thenRn` \ rhs' ->
 228     returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc)
 229
 230 rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
 231   = ASSERT( null tvs )
 232     pushSrcLocRn src_loc                        $
 233
 234     bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
 235     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 236     mapFvRn rn_var (vars `zip` ids)             `thenRn` \ (vars', fv_vars) ->
 237
 238     rnExpr lhs                                  `thenRn` \ (lhs', fv_lhs) ->
 239     rnExpr rhs                                  `thenRn` \ (rhs', fv_rhs) ->
 240     checkRn (validRuleLhs ids lhs')
 241             (badRuleLhsErr rule_name lhs')      `thenRn_`
 242     let
 243         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 244     in
 245     mapRn (addErrRn . badRuleVar rule_name) bad_vars    `thenRn_`
 246     returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
 247               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 248   where
 249     doc = text "In the transformation rule" <+> ptext rule_name
 250     sig_tvs = extractRuleBndrsTyVars vars
 251
 252     get_var (RuleBndr v)      = v
 253     get_var (RuleBndrSig v _) = v
 254
 255     rn_var (RuleBndr v, id)      = returnRn (RuleBndr id, emptyFVs)
 256     rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t    `thenRn` \ (t', fvs) ->
 257                                    returnRn (RuleBndrSig id t', fvs)
 258 \end{code}
 259
 260
 261 %*********************************************************
 262 %*                                                      *
 263 \subsection{Type, class and iface sig declarations}
 264 %*                                                      *
 265 %*********************************************************
 266
 267 @rnTyDecl@ uses the `global name function' to create a new type
 268 declaration in which local names have been replaced by their original
 269 names, reporting any unknown names.
 270
 271 Renaming type variables is a pain. Because they now contain uniques,
 272 it is necessary to pass in an association list which maps a parsed
 273 tyvar to its @Name@ representation.
 274 In some cases (type signatures of values),
 275 it is even necessary to go over the type first
 276 in order to get the set of tyvars used by it, make an assoc list,
 277 and then go over it again to rename the tyvars!
 278 However, we can also do some scoping checks at the same time.
 279
 280 \begin{code}
 281 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
 282   = pushSrcLocRn loc $
 283     lookupTopBndrRn name                `thenRn` \ name' ->
 284     rnHsType doc_str ty                 `thenRn` \ ty' ->
 285     mapRn rnIdInfo id_infos             `thenRn` \ id_infos' ->
 286     returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
 287   where
 288     doc_str = text "In the interface signature for" <+> quotes (ppr name)
 289
 290 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
 291   = pushSrcLocRn loc                    $
 292     lookupTopBndrRn name                `thenRn` \ name' ->
 293     returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc})
 294
 295 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 296                     tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
 297                     tcdLoc = src_loc, tcdSysNames = sys_names})
 298   = pushSrcLocRn src_loc $
 299     lookupTopBndrRn tycon                       `thenRn` \ tycon' ->
 300     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 301     rnContext data_doc context                  `thenRn` \ context' ->
 302     checkDupOrQualNames data_doc con_names      `thenRn_`
 303
 304         -- Check that there's at least one condecl,
 305         -- or else we're reading an interface file, or -fglasgow-exts
 306     (if null condecls then
 307         doptRn Opt_GlasgowExts  `thenRn` \ glaExts ->
 308         getModeRn               `thenRn` \ mode ->
 309         checkRn (glaExts || isInterfaceMode mode)
 310                 (emptyConDeclsErr tycon)
 311      else returnRn ()
 312     )                                           `thenRn_`
 313
 314     mapRn rnConDecl condecls                    `thenRn` \ condecls' ->
 315     mapRn lookupSysBinder sys_names             `thenRn` \ sys_names' ->
 316     returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
 317                       tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
 318                       tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
 319   where
 320     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 321     con_names = map conDeclName condecls
 322
 323 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
 324   = pushSrcLocRn src_loc $
 325     doptRn Opt_GlasgowExts                      `thenRn` \ glaExts ->
 326     lookupTopBndrRn name                        `thenRn` \ name' ->
 327     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 328     rnHsType syn_doc (unquantify glaExts ty)    `thenRn` \ ty' ->
 329     returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
 330   where
 331     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 332
 333         -- For H98 we do *not* universally quantify on the RHS of a synonym
 334         -- Silently discard context... but the tyvars in the rest won't be in scope
 335         -- In interface files all types are quantified, so this is a no-op
 336     unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
 337     unquantify glaExts ty                                     = ty
 338
 339 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
 340                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 341                        tcdSysNames = names, tcdLoc = src_loc})
 342         -- Used for both source and interface file decls
 343   = pushSrcLocRn src_loc $
 344
 345     lookupTopBndrRn cname                       `thenRn` \ cname' ->
 346
 347         -- Deal with the implicit tycon and datacon name
 348         -- They aren't in scope (because they aren't visible to the user)
 349         -- and what we want to do is simply look them up in the cache;
 350         -- we jolly well ought to get a 'hit' there!
 351     mapRn lookupSysBinder names                 `thenRn` \ names' ->
 352
 353         -- Tyvars scope over bindings and context
 354     bindTyVars2Rn cls_doc tyvars                $ \ clas_tyvar_names tyvars' ->
 355
 356         -- Check the superclasses
 357     rnContext cls_doc context                   `thenRn` \ context' ->
 358
 359         -- Check the functional dependencies
 360     rnFds cls_doc fds                           `thenRn` \ fds' ->
 361
 362         -- Check the signatures
 363         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 364     let
 365         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 366         sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 367     in
 368     checkDupOrQualNames sig_doc sig_rdr_names_w_locs            `thenRn_`
 369     mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs      `thenRn` \ sigs' ->
 370     let
 371         binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 372     in
 373     renameSigs (okClsDclSig binders) non_op_sigs          `thenRn` \ non_ops' ->
 374
 375         -- Typechecker is responsible for checking that we only
 376         -- give default-method bindings for things in this class.
 377         -- The renamer *could* check this for class decls, but can't
 378         -- for instance decls.
 379
 380     returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
 381                           tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
 382                           tcdSysNames = names', tcdLoc = src_loc})
 383   where
 384     cls_doc  = text "In the declaration for class"      <+> ppr cname
 385     sig_doc  = text "In the signatures for class"       <+> ppr cname
 386
 387 rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
 388   = pushSrcLocRn locn $
 389     lookupTopBndrRn op                  `thenRn` \ op_name ->
 390
 391         -- Check the signature
 392     rnHsSigType (quotes (ppr op)) ty    `thenRn` \ new_ty ->
 393
 394         -- Make the default-method name
 395     (case dm_stuff of
 396         DefMeth dm_rdr_name
 397             ->  -- Imported class that has a default method decl
 398                 -- See comments with tname, snames, above
 399                 lookupSysBinder dm_rdr_name     `thenRn` \ dm_name ->
 400                 returnRn (DefMeth dm_name)
 401                         -- An imported class decl for a class decl that had an explicit default
 402                         -- method, mentions, rather than defines,
 403                         -- the default method, so we must arrange to pull it in
 404
 405         GenDefMeth -> returnRn GenDefMeth
 406         NoDefMeth  -> returnRn NoDefMeth
 407     )                                           `thenRn` \ dm_stuff' ->
 408
 409     returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
 410
 411 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
 412         -- Used for source file decls only
 413         -- Renames the default-bindings of a class decl
 414         --         the derivings of a data decl
 415 finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc})       -- Derivings in here
 416                      rn_ty_decl                                                 -- Everything else is here
 417   = pushSrcLocRn src_loc         $
 418     mapRn rnDeriv derivs        `thenRn` \ derivs' ->
 419     returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')
 420
 421 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})     -- Get mbinds from here
 422          rn_cls_decl@(ClassDecl {tcdTyVars = tyvars})                           -- Everything else is here
 423   -- There are some default-method bindings (abeit possibly empty) so
 424   -- this is a source-code class declaration
 425   =     -- The newLocals call is tiresome: given a generic class decl
 426         --      class C a where
 427         --        op :: a -> a
 428         --        op {| x+y |} (Inl a) = ...
 429         --        op {| x+y |} (Inr b) = ...
 430         --        op {| a*b |} (a*b)   = ...
 431         -- we want to name both "x" tyvars with the same unique, so that they are
 432         -- easy to group together in the typechecker.
 433         -- Hence the
 434     pushSrcLocRn src_loc                                $
 435     extendTyVarEnvFVRn (map hsTyVarName tyvars)         $
 436     getLocalNameEnv                                     `thenRn` \ name_env ->
 437     let
 438         meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
 439         gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
 440                                                 not (tv `elemRdrEnv` name_env)]
 441     in
 442     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 443     newLocalsRn gen_rdr_tyvars_w_locs                   `thenRn` \ gen_tyvars ->
 444     rnMethodBinds gen_tyvars mbinds                     `thenRn` \ (mbinds', meth_fvs) ->
 445     returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
 446   where
 447     meth_doc = text "In the default-methods for class"  <+> ppr (tcdName rn_cls_decl)
 448
 449 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 450         -- Not a class or data type declaration
 451 \end{code}
 452
 453
 454 %*********************************************************
 455 %*                                                      *
 456 \subsection{Support code for type/data declarations}
 457 %*                                                      *
 458 %*********************************************************
 459
 460 \begin{code}
 461 rnDeriv :: RdrName -> RnMS Name
 462 rnDeriv cls
 463   = lookupOccRn cls     `thenRn` \ clas_name ->
 464     checkRn (getUnique clas_name `elem` derivableClassKeys)
 465             (derivingNonStdClassErr clas_name)  `thenRn_`
 466     returnRn clas_name
 467 \end{code}
 468
 469 \begin{code}
 470 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 471 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 472
 473 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 474 rnConDecl (ConDecl name wkr tvs cxt details locn)
 475   = pushSrcLocRn locn $
 476     checkConName name           `thenRn_`
 477     lookupTopBndrRn name        `thenRn` \ new_name ->
 478
 479     lookupSysBinder wkr         `thenRn` \ new_wkr ->
 480         -- See comments with ClassDecl
 481
 482     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 483     rnContext doc cxt                   `thenRn` \ new_context ->
 484     rnConDetails doc locn details       `thenRn` \ new_details ->
 485     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
 486   where
 487     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 488
 489 rnConDetails doc locn (VanillaCon tys)
 490   = mapRn (rnBangTy doc) tys    `thenRn` \ new_tys  ->
 491     returnRn (VanillaCon new_tys)
 492
 493 rnConDetails doc locn (InfixCon ty1 ty2)
 494   = rnBangTy doc ty1            `thenRn` \ new_ty1 ->
 495     rnBangTy doc ty2            `thenRn` \ new_ty2 ->
 496     returnRn (InfixCon new_ty1 new_ty2)
 497
 498 rnConDetails doc locn (RecCon fields)
 499   = checkDupOrQualNames doc field_names `thenRn_`
 500     mapRn (rnField doc) fields          `thenRn` \ new_fields ->
 501     returnRn (RecCon new_fields)
 502   where
 503     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 504
 505 rnField doc (names, ty)
 506   = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
 507     rnBangTy doc ty             `thenRn` \ new_ty ->
 508     returnRn (new_names, new_ty)
 509
 510 rnBangTy doc (BangType s ty)
 511   = rnHsType doc ty             `thenRn` \ new_ty ->
 512     returnRn (BangType s new_ty)
 513
 514 -- This data decl will parse OK
 515 --      data T = a Int
 516 -- treating "a" as the constructor.
 517 -- It is really hard to make the parser spot this malformation.
 518 -- So the renamer has to check that the constructor is legal
 519 --
 520 -- We can get an operator as the constructor, even in the prefix form:
 521 --      data T = :% Int Int
 522 -- from interface files, which always print in prefix form
 523
 524 checkConName name
 525   = checkRn (isRdrDataCon name)
 526             (badDataCon name)
 527 \end{code}
 528
 529
 530 %*********************************************************
 531 %*                                                      *
 532 \subsection{Support code to rename types}
 533 %*                                                      *
 534 %*********************************************************
 535
 536 \begin{code}
 537 rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 538 rnHsTypeFVs doc_str ty
 539   = rnHsType doc_str ty         `thenRn` \ ty' ->
 540     returnRn (ty', extractHsTyNames ty')
 541
 542 rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 543 rnHsSigTypeFVs doc_str ty
 544   = rnHsSigType doc_str ty      `thenRn` \ ty' ->
 545     returnRn (ty', extractHsTyNames ty')
 546
 547 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 548         -- rnHsSigType is used for source-language type signatures,
 549         -- which use *implicit* universal quantification.
 550 rnHsSigType doc_str ty
 551   = rnHsType (text "In the type signature for" <+> doc_str) ty
 552
 553 ---------------------------------------
 554 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 555
 556 rnHsType doc (HsForAllTy Nothing ctxt ty)
 557         -- Implicit quantifiction in source code (no kinds on tyvars)
 558         -- Given the signature  C => T  we universally quantify
 559         -- over FV(T) \ {in-scope-tyvars}
 560   = getLocalNameEnv             `thenRn` \ name_env ->
 561     let
 562         mentioned_in_tau  = extractHsTyRdrTyVars ty
 563         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 564         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 565         forall_tyvars     = filter (not . (`elemRdrEnv` name_env)) mentioned
 566     in
 567     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 568
 569 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 570         -- Explicit quantification.
 571         -- Check that the forall'd tyvars are actually
 572         -- mentioned in the type, and produce a warning if not
 573   = let
 574         mentioned_in_tau                = extractHsTyRdrTyVars tau
 575         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 576         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 577         forall_tyvar_names              = hsTyVarNames forall_tyvars
 578
 579         -- Explicitly quantified but not mentioned in ctxt or tau
 580         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 581     in
 582     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
 583     rnForAll doc forall_tyvars ctxt tau
 584
 585 rnHsType doc (HsTyVar tyvar)
 586   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 587     returnRn (HsTyVar tyvar')
 588
 589 rnHsType doc (HsOpTy ty1 opname ty2)
 590   = lookupOccRn opname  `thenRn` \ name' ->
 591     rnHsType doc ty1    `thenRn` \ ty1' ->
 592     rnHsType doc ty2    `thenRn` \ ty2' ->
 593     returnRn (HsOpTy ty1' name' ty2')
 594
 595 rnHsType doc (HsNumTy i)
 596   | i == 1    = returnRn (HsNumTy i)
 597   | otherwise = failWithRn (HsNumTy i)
 598                            (ptext SLIT("Only unit numeric type pattern is valid"))
 599
 600 rnHsType doc (HsFunTy ty1 ty2)
 601   = rnHsType doc ty1    `thenRn` \ ty1' ->
 602         -- Might find a for-all as the arg of a function type
 603     rnHsType doc ty2    `thenRn` \ ty2' ->
 604         -- Or as the result.  This happens when reading Prelude.hi
 605         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 606     returnRn (HsFunTy ty1' ty2')
 607
 608 rnHsType doc (HsListTy ty)
 609   = rnHsType doc ty                             `thenRn` \ ty' ->
 610     returnRn (HsListTy ty')
 611
 612 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 613 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 614 rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
 615         -- Don't do lookupOccRn, because this is built-in syntax
 616         -- so it doesn't need to be in scope
 617   = mapRn (rnHsType doc) tys            `thenRn` \ tys' ->
 618     returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
 619   where
 620     tup_name = tupleTyCon_name boxity arity
 621
 622
 623 rnHsType doc (HsAppTy ty1 ty2)
 624   = rnHsType doc ty1            `thenRn` \ ty1' ->
 625     rnHsType doc ty2            `thenRn` \ ty2' ->
 626     returnRn (HsAppTy ty1' ty2')
 627
 628 rnHsType doc (HsPredTy pred)
 629   = rnPred doc pred     `thenRn` \ pred' ->
 630     returnRn (HsPredTy pred')
 631
 632 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 633 \end{code}
 634
 635 \begin{code}
 636 rnForAll doc forall_tyvars ctxt ty
 637   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 638     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 639     rnHsType doc ty                     `thenRn` \ new_ty ->
 640     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 641 \end{code}
 642
 643 \begin{code}
 644 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 645 rnContext doc ctxt
 646   = mapRn rn_pred ctxt          `thenRn` \ theta ->
 647
 648         -- Check for duplicate assertions
 649         -- If this isn't an error, then it ought to be:
 650     ifOptRn Opt_WarnMisc (
 651         let
 652             (_, dups) = removeDupsEq theta
 653                 -- We only have equality, not ordering
 654         in
 655         mapRn (addWarnRn . dupClassAssertWarn theta) dups
 656     )                           `thenRn_`
 657
 658     returnRn theta
 659   where
 660         --Someone discovered that @CCallable@ and @CReturnable@
 661         -- could be used in contexts such as:
 662         --      foo :: CCallable a => a -> PrimIO Int
 663         -- Doing this utterly wrecks the whole point of introducing these
 664         -- classes so we specifically check that this isn't being done.
 665     rn_pred pred = rnPred doc pred                              `thenRn` \ pred'->
 666                    checkRn (not (bad_pred pred'))
 667                            (naughtyCCallContextErr pred')       `thenRn_`
 668                    returnRn pred'
 669
 670     bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
 671     bad_pred other             = False
 672
 673
 674 rnPred doc (HsClassP clas tys)
 675   = lookupOccRn clas            `thenRn` \ clas_name ->
 676     rnHsTypes doc tys           `thenRn` \ tys' ->
 677     returnRn (HsClassP clas_name tys')
 678
 679 rnPred doc (HsIParam n ty)
 680   = newIPName n                 `thenRn` \ name ->
 681     rnHsType doc ty             `thenRn` \ ty' ->
 682     returnRn (HsIParam name ty')
 683 \end{code}
 684
 685 \begin{code}
 686 rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
 687
 688 rnFds doc fds
 689   = mapRn rn_fds fds
 690   where
 691     rn_fds (tys1, tys2)
 692       = rnHsTyVars doc tys1             `thenRn` \ tys1' ->
 693         rnHsTyVars doc tys2             `thenRn` \ tys2' ->
 694         returnRn (tys1', tys2')
 695
 696 rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
 697 rnHsTyvar doc tyvar = lookupOccRn tyvar
 698 \end{code}
 699
 700 %*********************************************************
 701 %*                                                       *
 702 \subsection{IdInfo}
 703 %*                                                       *
 704 %*********************************************************
 705
 706 \begin{code}
 707 rnIdInfo (HsWorker worker arity)
 708   = lookupOccRn worker                  `thenRn` \ worker' ->
 709     returnRn (HsWorker worker' arity)
 710
 711 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
 712                                   returnRn (HsUnfold inline expr')
 713 rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
 714 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 715 rnIdInfo HsNoCafRefs            = returnRn HsNoCafRefs
 716 rnIdInfo HsCprInfo              = returnRn HsCprInfo
 717 \end{code}
 718
 719 @UfCore@ expressions.
 720
 721 \begin{code}
 722 rnCoreExpr (UfType ty)
 723   = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
 724     returnRn (UfType ty')
 725
 726 rnCoreExpr (UfVar v)
 727   = lookupOccRn v       `thenRn` \ v' ->
 728     returnRn (UfVar v')
 729
 730 rnCoreExpr (UfLit l)
 731   = returnRn (UfLit l)
 732
 733 rnCoreExpr (UfLitLit l ty)
 734   = rnHsType (text "litlit") ty `thenRn` \ ty' ->
 735     returnRn (UfLitLit l ty')
 736
 737 rnCoreExpr (UfFCall cc ty)
 738   = rnHsType (text "ccall") ty  `thenRn` \ ty' ->
 739     returnRn (UfFCall cc ty')
 740
 741 rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
 742   = mapRn rnCoreExpr args               `thenRn` \ args' ->
 743     returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
 744   where
 745     tup_name = getName (dataConId (tupleCon boxity arity))
 746         -- Get the *worker* name and use that
 747
 748 rnCoreExpr (UfApp fun arg)
 749   = rnCoreExpr fun              `thenRn` \ fun' ->
 750     rnCoreExpr arg              `thenRn` \ arg' ->
 751     returnRn (UfApp fun' arg')
 752
 753 rnCoreExpr (UfCase scrut bndr alts)
 754   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 755     bindCoreLocalRn bndr                $ \ bndr' ->
 756     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 757     returnRn (UfCase scrut' bndr' alts')
 758
 759 rnCoreExpr (UfNote note expr)
 760   = rnNote note                 `thenRn` \ note' ->
 761     rnCoreExpr expr             `thenRn` \ expr' ->
 762     returnRn  (UfNote note' expr')
 763
 764 rnCoreExpr (UfLam bndr body)
 765   = rnCoreBndr bndr             $ \ bndr' ->
 766     rnCoreExpr body             `thenRn` \ body' ->
 767     returnRn (UfLam bndr' body')
 768
 769 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 770   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 771     rnCoreBndr bndr             $ \ bndr' ->
 772     rnCoreExpr body             `thenRn` \ body' ->
 773     returnRn (UfLet (UfNonRec bndr' rhs') body')
 774
 775 rnCoreExpr (UfLet (UfRec pairs) body)
 776   = rnCoreBndrs bndrs           $ \ bndrs' ->
 777     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 778     rnCoreExpr body             `thenRn` \ body' ->
 779     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 780   where
 781     (bndrs, rhss) = unzip pairs
 782 \end{code}
 783
 784 \begin{code}
 785 rnCoreBndr (UfValBinder name ty) thing_inside
 786   = rnHsType doc ty             `thenRn` \ ty' ->
 787     bindCoreLocalRn name        $ \ name' ->
 788     thing_inside (UfValBinder name' ty')
 789   where
 790     doc = text "unfolding id"
 791
 792 rnCoreBndr (UfTyBinder name kind) thing_inside
 793   = bindCoreLocalRn name                $ \ name' ->
 794     thing_inside (UfTyBinder name' kind)
 795
 796 rnCoreBndrs []     thing_inside = thing_inside []
 797 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 798                                   rnCoreBndrs bs        $ \ names' ->
 799                                   thing_inside (name':names')
 800 \end{code}
 801
 802 \begin{code}
 803 rnCoreAlt (con, bndrs, rhs)
 804   = rnUfCon con                         `thenRn` \ con' ->
 805     bindCoreLocalsRn bndrs              $ \ bndrs' ->
 806     rnCoreExpr rhs                      `thenRn` \ rhs' ->
 807     returnRn (con', bndrs', rhs')
 808
 809 rnNote (UfCoerce ty)
 810   = rnHsType (text "unfolding coerce") ty       `thenRn` \ ty' ->
 811     returnRn (UfCoerce ty')
 812
 813 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 814 rnNote UfInlineCall = returnRn UfInlineCall
 815 rnNote UfInlineMe   = returnRn UfInlineMe
 816
 817
 818 rnUfCon UfDefault
 819   = returnRn UfDefault
 820
 821 rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
 822   = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
 823   where
 824     tup_name = getName (tupleCon boxity arity)
 825
 826 rnUfCon (UfDataAlt con)
 827   = lookupOccRn con             `thenRn` \ con' ->
 828     returnRn (UfDataAlt con')
 829
 830 rnUfCon (UfLitAlt lit)
 831   = returnRn (UfLitAlt lit)
 832
 833 rnUfCon (UfLitLitAlt lit ty)
 834   = rnHsType (text "litlit") ty         `thenRn` \ ty' ->
 835     returnRn (UfLitLitAlt lit ty')
 836 \end{code}
 837
 838 %*********************************************************
 839 %*                                                       *
 840 \subsection{Rule shapes}
 841 %*                                                       *
 842 %*********************************************************
 843
 844 Check the shape of a transformation rule LHS.  Currently
 845 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 846 not one of the @forall@'d variables.
 847
 848 \begin{code}
 849 validRuleLhs foralls lhs
 850   = check lhs
 851   where
 852     check (OpApp _ op _ _)                = check op
 853     check (HsApp e1 e2)                   = check e1
 854     check (HsVar v) | v `notElem` foralls = True
 855     check other                           = False
 856 \end{code}
 857
 858
 859 %*********************************************************
 860 %*                                                       *
 861 \subsection{Errors}
 862 %*                                                       *
 863 %*********************************************************
 864
 865 \begin{code}
 866 derivingNonStdClassErr clas
 867   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 868
 869 badDataCon name
 870    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 871
 872 forAllWarn doc ty tyvar
 873   = ifOptRn Opt_WarnUnusedMatches       $
 874     getModeRn                           `thenRn` \ mode ->
 875     case mode of {
 876 #ifndef DEBUG
 877              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 878                                             -- unless DEBUG is on, in which case it is slightly
 879                                             -- informative.  They can arise from mkRhsTyLam,
 880 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 881              other ->
 882                 addWarnRn (
 883                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 884                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 885                    $$
 886                    doc
 887                 )
 888           }
 889
 890 badRuleLhsErr name lhs
 891   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 892          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 893     $$
 894     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 895
 896 badRuleVar name var
 897   = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
 898          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 899                 ptext SLIT("does not appear on left hand side")]
 900
 901 dupClassAssertWarn ctxt (assertion : dups)
 902   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 903                quotes (ppr assertion),
 904                ptext SLIT("in the context:")],
 905          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 906
 907 naughtyCCallContextErr (HsClassP clas _)
 908   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 909          ptext SLIT("in a context")]
 910 emptyConDeclsErr tycon
 911   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 912          nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
 913 \end{code}