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