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 = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 291   = pushSrcLocRn loc                    $
 292     lookupTopBndrRn name                `thenRn` \ name' ->
 293     returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, 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     lookupTopBndrRn name                        `thenRn` \ name' ->
 326     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 327     rnHsType syn_doc ty                         `thenRn` \ ty' ->
 328     returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
 329   where
 330     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 331
 332 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
 333                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 334                        tcdSysNames = names, tcdLoc = src_loc})
 335         -- Used for both source and interface file decls
 336   = pushSrcLocRn src_loc $
 337
 338     lookupTopBndrRn cname                       `thenRn` \ cname' ->
 339
 340         -- Deal with the implicit tycon and datacon name
 341         -- They aren't in scope (because they aren't visible to the user)
 342         -- and what we want to do is simply look them up in the cache;
 343         -- we jolly well ought to get a 'hit' there!
 344     mapRn lookupSysBinder names                 `thenRn` \ names' ->
 345
 346         -- Tyvars scope over bindings and context
 347     bindTyVars2Rn cls_doc tyvars                $ \ clas_tyvar_names tyvars' ->
 348
 349         -- Check the superclasses
 350     rnContext cls_doc context                   `thenRn` \ context' ->
 351
 352         -- Check the functional dependencies
 353     rnFds cls_doc fds                           `thenRn` \ fds' ->
 354
 355         -- Check the signatures
 356         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 357     let
 358         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 359         sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 360     in
 361     checkDupOrQualNames sig_doc sig_rdr_names_w_locs            `thenRn_`
 362     mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs      `thenRn` \ sigs' ->
 363     let
 364         binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 365     in
 366     renameSigs (okClsDclSig binders) non_op_sigs          `thenRn` \ non_ops' ->
 367
 368         -- Typechecker is responsible for checking that we only
 369         -- give default-method bindings for things in this class.
 370         -- The renamer *could* check this for class decls, but can't
 371         -- for instance decls.
 372
 373     returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
 374                           tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
 375                           tcdSysNames = names', tcdLoc = src_loc})
 376   where
 377     cls_doc  = text "In the declaration for class"      <+> ppr cname
 378     sig_doc  = text "In the signatures for class"       <+> ppr cname
 379
 380 rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
 381   = pushSrcLocRn locn $
 382     lookupTopBndrRn op                  `thenRn` \ op_name ->
 383
 384         -- Check the signature
 385     rnHsSigType (quotes (ppr op)) ty    `thenRn` \ new_ty ->
 386
 387         -- Make the default-method name
 388     (case dm_stuff of
 389         DefMeth dm_rdr_name
 390             ->  -- Imported class that has a default method decl
 391                 -- See comments with tname, snames, above
 392                 lookupSysBinder dm_rdr_name     `thenRn` \ dm_name ->
 393                 returnRn (DefMeth dm_name)
 394                         -- An imported class decl for a class decl that had an explicit default
 395                         -- method, mentions, rather than defines,
 396                         -- the default method, so we must arrange to pull it in
 397
 398         GenDefMeth -> returnRn GenDefMeth
 399         NoDefMeth  -> returnRn NoDefMeth
 400     )                                           `thenRn` \ dm_stuff' ->
 401
 402     returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
 403
 404 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
 405         -- Used for source file decls only
 406         -- Renames the default-bindings of a class decl
 407         --         the derivings of a data decl
 408 finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc})       -- Derivings in here
 409                      rn_ty_decl                                                 -- Everything else is here
 410   = pushSrcLocRn src_loc         $
 411     mapRn rnDeriv derivs        `thenRn` \ derivs' ->
 412     returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')
 413
 414 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})     -- Get mbinds from here
 415          rn_cls_decl@(ClassDecl {tcdTyVars = tyvars})                           -- Everything else is here
 416   -- There are some default-method bindings (abeit possibly empty) so
 417   -- this is a source-code class declaration
 418   =     -- The newLocals call is tiresome: given a generic class decl
 419         --      class C a where
 420         --        op :: a -> a
 421         --        op {| x+y |} (Inl a) = ...
 422         --        op {| x+y |} (Inr b) = ...
 423         --        op {| a*b |} (a*b)   = ...
 424         -- we want to name both "x" tyvars with the same unique, so that they are
 425         -- easy to group together in the typechecker.
 426         -- Hence the
 427     pushSrcLocRn src_loc                                $
 428     extendTyVarEnvFVRn (map hsTyVarName tyvars)         $
 429     getLocalNameEnv                                     `thenRn` \ name_env ->
 430     let
 431         meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
 432         gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
 433                                                 not (tv `elemRdrEnv` name_env)]
 434     in
 435     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenRn_`
 436     newLocalsRn gen_rdr_tyvars_w_locs                   `thenRn` \ gen_tyvars ->
 437     rnMethodBinds gen_tyvars mbinds                     `thenRn` \ (mbinds', meth_fvs) ->
 438     returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
 439   where
 440     meth_doc = text "In the default-methods for class"  <+> ppr (tcdName rn_cls_decl)
 441
 442 finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 443         -- Not a class or data type declaration
 444 \end{code}
 445
 446
 447 %*********************************************************
 448 %*                                                      *
 449 \subsection{Support code for type/data declarations}
 450 %*                                                      *
 451 %*********************************************************
 452
 453 \begin{code}
 454 rnDeriv :: RdrName -> RnMS Name
 455 rnDeriv cls
 456   = lookupOccRn cls     `thenRn` \ clas_name ->
 457     checkRn (getUnique clas_name `elem` derivableClassKeys)
 458             (derivingNonStdClassErr clas_name)  `thenRn_`
 459     returnRn clas_name
 460 \end{code}
 461
 462 \begin{code}
 463 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 464 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 465
 466 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 467 rnConDecl (ConDecl name wkr tvs cxt details locn)
 468   = pushSrcLocRn locn $
 469     checkConName name           `thenRn_`
 470     lookupTopBndrRn name        `thenRn` \ new_name ->
 471
 472     lookupSysBinder wkr         `thenRn` \ new_wkr ->
 473         -- See comments with ClassDecl
 474
 475     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 476     rnContext doc cxt                   `thenRn` \ new_context ->
 477     rnConDetails doc locn details       `thenRn` \ new_details ->
 478     returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
 479   where
 480     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 481
 482 rnConDetails doc locn (VanillaCon tys)
 483   = mapRn (rnBangTy doc) tys    `thenRn` \ new_tys  ->
 484     returnRn (VanillaCon new_tys)
 485
 486 rnConDetails doc locn (InfixCon ty1 ty2)
 487   = rnBangTy doc ty1            `thenRn` \ new_ty1 ->
 488     rnBangTy doc ty2            `thenRn` \ new_ty2 ->
 489     returnRn (InfixCon new_ty1 new_ty2)
 490
 491 rnConDetails doc locn (RecCon fields)
 492   = checkDupOrQualNames doc field_names `thenRn_`
 493     mapRn (rnField doc) fields          `thenRn` \ new_fields ->
 494     returnRn (RecCon new_fields)
 495   where
 496     field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
 497
 498 rnField doc (names, ty)
 499   = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
 500     rnBangTy doc ty             `thenRn` \ new_ty ->
 501     returnRn (new_names, new_ty)
 502
 503 rnBangTy doc (BangType s ty)
 504   = rnHsType doc ty             `thenRn` \ new_ty ->
 505     returnRn (BangType s new_ty)
 506
 507 -- This data decl will parse OK
 508 --      data T = a Int
 509 -- treating "a" as the constructor.
 510 -- It is really hard to make the parser spot this malformation.
 511 -- So the renamer has to check that the constructor is legal
 512 --
 513 -- We can get an operator as the constructor, even in the prefix form:
 514 --      data T = :% Int Int
 515 -- from interface files, which always print in prefix form
 516
 517 checkConName name
 518   = checkRn (isRdrDataCon name)
 519             (badDataCon name)
 520 \end{code}
 521
 522
 523 %*********************************************************
 524 %*                                                      *
 525 \subsection{Support code to rename types}
 526 %*                                                      *
 527 %*********************************************************
 528
 529 \begin{code}
 530 rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 531 rnHsTypeFVs doc_str ty
 532   = rnHsType doc_str ty         `thenRn` \ ty' ->
 533     returnRn (ty', extractHsTyNames ty')
 534
 535 rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
 536 rnHsSigTypeFVs doc_str ty
 537   = rnHsSigType doc_str ty      `thenRn` \ ty' ->
 538     returnRn (ty', extractHsTyNames ty')
 539
 540 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 541         -- rnHsSigType is used for source-language type signatures,
 542         -- which use *implicit* universal quantification.
 543 rnHsSigType doc_str ty
 544   = rnHsType (text "In the type signature for" <+> doc_str) ty
 545
 546 ---------------------------------------
 547 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
 548
 549 rnHsType doc (HsForAllTy Nothing ctxt ty)
 550         -- Implicit quantifiction in source code (no kinds on tyvars)
 551         -- Given the signature  C => T  we universally quantify
 552         -- over FV(T) \ {in-scope-tyvars}
 553   = getLocalNameEnv             `thenRn` \ name_env ->
 554     let
 555         mentioned_in_tau  = extractHsTyRdrTyVars ty
 556         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
 557         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 558         forall_tyvars     = filter (not . (`elemRdrEnv` name_env)) mentioned
 559     in
 560     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
 561
 562 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
 563         -- Explicit quantification.
 564         -- Check that the forall'd tyvars are actually
 565         -- mentioned in the type, and produce a warning if not
 566   = let
 567         mentioned_in_tau                = extractHsTyRdrTyVars tau
 568         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
 569         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
 570         forall_tyvar_names              = hsTyVarNames forall_tyvars
 571
 572         -- Explicitly quantified but not mentioned in ctxt or tau
 573         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
 574     in
 575     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
 576     rnForAll doc forall_tyvars ctxt tau
 577
 578 rnHsType doc (HsTyVar tyvar)
 579   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 580     returnRn (HsTyVar tyvar')
 581
 582 rnHsType doc (HsOpTy ty1 opname ty2)
 583   = lookupOccRn opname  `thenRn` \ name' ->
 584     rnHsType doc ty1    `thenRn` \ ty1' ->
 585     rnHsType doc ty2    `thenRn` \ ty2' ->
 586     returnRn (HsOpTy ty1' name' ty2')
 587
 588 rnHsType doc (HsNumTy i)
 589   | i == 1    = returnRn (HsNumTy i)
 590   | otherwise = failWithRn (HsNumTy i)
 591                            (ptext SLIT("Only unit numeric type pattern is valid"))
 592
 593 rnHsType doc (HsFunTy ty1 ty2)
 594   = rnHsType doc ty1    `thenRn` \ ty1' ->
 595         -- Might find a for-all as the arg of a function type
 596     rnHsType doc ty2    `thenRn` \ ty2' ->
 597         -- Or as the result.  This happens when reading Prelude.hi
 598         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 599     returnRn (HsFunTy ty1' ty2')
 600
 601 rnHsType doc (HsListTy ty)
 602   = rnHsType doc ty                             `thenRn` \ ty' ->
 603     returnRn (HsListTy ty')
 604
 605 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 606 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 607 rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
 608         -- Don't do lookupOccRn, because this is built-in syntax
 609         -- so it doesn't need to be in scope
 610   = mapRn (rnHsType doc) tys            `thenRn` \ tys' ->
 611     returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
 612   where
 613     tup_name = tupleTyCon_name boxity arity
 614
 615
 616 rnHsType doc (HsAppTy ty1 ty2)
 617   = rnHsType doc ty1            `thenRn` \ ty1' ->
 618     rnHsType doc ty2            `thenRn` \ ty2' ->
 619     returnRn (HsAppTy ty1' ty2')
 620
 621 rnHsType doc (HsPredTy pred)
 622   = rnPred doc pred     `thenRn` \ pred' ->
 623     returnRn (HsPredTy pred')
 624
 625 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 626 \end{code}
 627
 628 \begin{code}
 629 rnForAll doc forall_tyvars ctxt ty
 630   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 631     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 632     rnHsType doc ty                     `thenRn` \ new_ty ->
 633     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 634 \end{code}
 635
 636 \begin{code}
 637 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 638 rnContext doc ctxt
 639   = mapRn rn_pred ctxt          `thenRn` \ theta ->
 640
 641         -- Check for duplicate assertions
 642         -- If this isn't an error, then it ought to be:
 643     ifOptRn Opt_WarnMisc (
 644         let
 645             (_, dups) = removeDupsEq theta
 646                 -- We only have equality, not ordering
 647         in
 648         mapRn (addWarnRn . dupClassAssertWarn theta) dups
 649     )                           `thenRn_`
 650
 651     returnRn theta
 652   where
 653         --Someone discovered that @CCallable@ and @CReturnable@
 654         -- could be used in contexts such as:
 655         --      foo :: CCallable a => a -> PrimIO Int
 656         -- Doing this utterly wrecks the whole point of introducing these
 657         -- classes so we specifically check that this isn't being done.
 658     rn_pred pred = rnPred doc pred                              `thenRn` \ pred'->
 659                    checkRn (not (bad_pred pred'))
 660                            (naughtyCCallContextErr pred')       `thenRn_`
 661                    returnRn pred'
 662
 663     bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
 664     bad_pred other             = False
 665
 666
 667 rnPred doc (HsClassP clas tys)
 668   = lookupOccRn clas            `thenRn` \ clas_name ->
 669     rnHsTypes doc tys           `thenRn` \ tys' ->
 670     returnRn (HsClassP clas_name tys')
 671
 672 rnPred doc (HsIParam n ty)
 673   = newIPName n                 `thenRn` \ name ->
 674     rnHsType doc ty             `thenRn` \ ty' ->
 675     returnRn (HsIParam name ty')
 676 \end{code}
 677
 678 \begin{code}
 679 rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
 680
 681 rnFds doc fds
 682   = mapRn rn_fds fds
 683   where
 684     rn_fds (tys1, tys2)
 685       = rnHsTyVars doc tys1             `thenRn` \ tys1' ->
 686         rnHsTyVars doc tys2             `thenRn` \ tys2' ->
 687         returnRn (tys1', tys2')
 688
 689 rnHsTyVars doc tvs  = mapRn (rnHsTyvar doc) tvs
 690 rnHsTyvar doc tyvar = lookupOccRn tyvar
 691 \end{code}
 692
 693 %*********************************************************
 694 %*                                                       *
 695 \subsection{IdInfo}
 696 %*                                                       *
 697 %*********************************************************
 698
 699 \begin{code}
 700 rnIdInfo (HsWorker worker arity)
 701   = lookupOccRn worker                  `thenRn` \ worker' ->
 702     returnRn (HsWorker worker' arity)
 703
 704 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
 705                                   returnRn (HsUnfold inline expr')
 706 rnIdInfo (HsStrictness str)     = returnRn (HsStrictness str)
 707 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 708 rnIdInfo HsNoCafRefs            = returnRn HsNoCafRefs
 709 \end{code}
 710
 711 @UfCore@ expressions.
 712
 713 \begin{code}
 714 rnCoreExpr (UfType ty)
 715   = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
 716     returnRn (UfType ty')
 717
 718 rnCoreExpr (UfVar v)
 719   = lookupOccRn v       `thenRn` \ v' ->
 720     returnRn (UfVar v')
 721
 722 rnCoreExpr (UfLit l)
 723   = returnRn (UfLit l)
 724
 725 rnCoreExpr (UfLitLit l ty)
 726   = rnHsType (text "litlit") ty `thenRn` \ ty' ->
 727     returnRn (UfLitLit l ty')
 728
 729 rnCoreExpr (UfFCall cc ty)
 730   = rnHsType (text "ccall") ty  `thenRn` \ ty' ->
 731     returnRn (UfFCall cc ty')
 732
 733 rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
 734   = mapRn rnCoreExpr args               `thenRn` \ args' ->
 735     returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
 736   where
 737     tup_name = getName (dataConId (tupleCon boxity arity))
 738         -- Get the *worker* name and use that
 739
 740 rnCoreExpr (UfApp fun arg)
 741   = rnCoreExpr fun              `thenRn` \ fun' ->
 742     rnCoreExpr arg              `thenRn` \ arg' ->
 743     returnRn (UfApp fun' arg')
 744
 745 rnCoreExpr (UfCase scrut bndr alts)
 746   = rnCoreExpr scrut                    `thenRn` \ scrut' ->
 747     bindCoreLocalRn bndr                $ \ bndr' ->
 748     mapRn rnCoreAlt alts                `thenRn` \ alts' ->
 749     returnRn (UfCase scrut' bndr' alts')
 750
 751 rnCoreExpr (UfNote note expr)
 752   = rnNote note                 `thenRn` \ note' ->
 753     rnCoreExpr expr             `thenRn` \ expr' ->
 754     returnRn  (UfNote note' expr')
 755
 756 rnCoreExpr (UfLam bndr body)
 757   = rnCoreBndr bndr             $ \ bndr' ->
 758     rnCoreExpr body             `thenRn` \ body' ->
 759     returnRn (UfLam bndr' body')
 760
 761 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 762   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 763     rnCoreBndr bndr             $ \ bndr' ->
 764     rnCoreExpr body             `thenRn` \ body' ->
 765     returnRn (UfLet (UfNonRec bndr' rhs') body')
 766
 767 rnCoreExpr (UfLet (UfRec pairs) body)
 768   = rnCoreBndrs bndrs           $ \ bndrs' ->
 769     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 770     rnCoreExpr body             `thenRn` \ body' ->
 771     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 772   where
 773     (bndrs, rhss) = unzip pairs
 774 \end{code}
 775
 776 \begin{code}
 777 rnCoreBndr (UfValBinder name ty) thing_inside
 778   = rnHsType doc ty             `thenRn` \ ty' ->
 779     bindCoreLocalRn name        $ \ name' ->
 780     thing_inside (UfValBinder name' ty')
 781   where
 782     doc = text "unfolding id"
 783
 784 rnCoreBndr (UfTyBinder name kind) thing_inside
 785   = bindCoreLocalRn name                $ \ name' ->
 786     thing_inside (UfTyBinder name' kind)
 787
 788 rnCoreBndrs []     thing_inside = thing_inside []
 789 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 790                                   rnCoreBndrs bs        $ \ names' ->
 791                                   thing_inside (name':names')
 792 \end{code}
 793
 794 \begin{code}
 795 rnCoreAlt (con, bndrs, rhs)
 796   = rnUfCon con                         `thenRn` \ con' ->
 797     bindCoreLocalsRn bndrs              $ \ bndrs' ->
 798     rnCoreExpr rhs                      `thenRn` \ rhs' ->
 799     returnRn (con', bndrs', rhs')
 800
 801 rnNote (UfCoerce ty)
 802   = rnHsType (text "unfolding coerce") ty       `thenRn` \ ty' ->
 803     returnRn (UfCoerce ty')
 804
 805 rnNote (UfSCC cc)   = returnRn (UfSCC cc)
 806 rnNote UfInlineCall = returnRn UfInlineCall
 807 rnNote UfInlineMe   = returnRn UfInlineMe
 808
 809
 810 rnUfCon UfDefault
 811   = returnRn UfDefault
 812
 813 rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
 814   = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
 815   where
 816     tup_name = getName (tupleCon boxity arity)
 817
 818 rnUfCon (UfDataAlt con)
 819   = lookupOccRn con             `thenRn` \ con' ->
 820     returnRn (UfDataAlt con')
 821
 822 rnUfCon (UfLitAlt lit)
 823   = returnRn (UfLitAlt lit)
 824
 825 rnUfCon (UfLitLitAlt lit ty)
 826   = rnHsType (text "litlit") ty         `thenRn` \ ty' ->
 827     returnRn (UfLitLitAlt lit ty')
 828 \end{code}
 829
 830 %*********************************************************
 831 %*                                                       *
 832 \subsection{Rule shapes}
 833 %*                                                       *
 834 %*********************************************************
 835
 836 Check the shape of a transformation rule LHS.  Currently
 837 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 838 not one of the @forall@'d variables.
 839
 840 \begin{code}
 841 validRuleLhs foralls lhs
 842   = check lhs
 843   where
 844     check (OpApp _ op _ _)                = check op
 845     check (HsApp e1 e2)                   = check e1
 846     check (HsVar v) | v `notElem` foralls = True
 847     check other                           = False
 848 \end{code}
 849
 850
 851 %*********************************************************
 852 %*                                                       *
 853 \subsection{Errors}
 854 %*                                                       *
 855 %*********************************************************
 856
 857 \begin{code}
 858 derivingNonStdClassErr clas
 859   = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
 860
 861 badDataCon name
 862    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 863
 864 forAllWarn doc ty tyvar
 865   = ifOptRn Opt_WarnUnusedMatches       $
 866     getModeRn                           `thenRn` \ mode ->
 867     case mode of {
 868 #ifndef DEBUG
 869              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 870                                             -- unless DEBUG is on, in which case it is slightly
 871                                             -- informative.  They can arise from mkRhsTyLam,
 872 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 873              other ->
 874                 addWarnRn (
 875                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 876                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 877                    $$
 878                    doc
 879                 )
 880           }
 881
 882 badRuleLhsErr name lhs
 883   = sep [ptext SLIT("Rule") <+> ptext name <> colon,
 884          nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
 885     $$
 886     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 887
 888 badRuleVar name var
 889   = sep [ptext SLIT("Rule") <+> doubleQuotes (ptext name) <> colon,
 890          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 891                 ptext SLIT("does not appear on left hand side")]
 892
 893 dupClassAssertWarn ctxt (assertion : dups)
 894   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 895                quotes (ppr assertion),
 896                ptext SLIT("in the context:")],
 897          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 898
 899 naughtyCCallContextErr (HsClassP clas _)
 900   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 901          ptext SLIT("in a context")]
 902 emptyConDeclsErr tycon
 903   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 904          nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
 905 \end{code}