ghc/compiler/rename/RnTypes.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 RnTypes (  rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs,
   8                   rnContext, precParseErr, sectionPrecErr ) where
   9
  10 import CmdLineOpts      ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) )
  11
  12 import HsSyn
  13 import RdrHsSyn ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars )
  14 import RnHsSyn  ( RenamedContext, RenamedHsType, extractHsTyNames, tupleTyCon_name )
  15 import RnEnv    ( lookupOccRn, newIPName, bindTyVarsRn, lookupFixityRn )
  16 import RnMonad
  17
  18 import PrelInfo ( cCallishClassKeys )
  19 import RdrName  ( elemRdrEnv )
  20 import NameSet  ( FreeVars )
  21 import Unique   ( Uniquable(..) )
  22
  23 import BasicTypes       ( compareFixity, arrowFixity )
  24 import List             ( nub )
  25 import ListSetOps       ( removeDupsEq )
  26 import Outputable
  27
  28 #include "HsVersions.h"
  29 \end{code}
  30
  31 These type renamers are in a separate module, rather than in (say) RnSource,
  32 to break several loop.
  33
  34 %*********************************************************
  35 %*                                                      *
  36 \subsection{Renaming types}
  37 %*                                                      *
  38 %*********************************************************
  39
  40 \begin{code}
  41 rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
  42 rnHsTypeFVs doc_str ty
  43   = rnHsType doc_str ty         `thenRn` \ ty' ->
  44     returnRn (ty', extractHsTyNames ty')
  45
  46 rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
  47 rnHsSigTypeFVs doc_str ty
  48   = rnHsSigType doc_str ty      `thenRn` \ ty' ->
  49     returnRn (ty', extractHsTyNames ty')
  50
  51 rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
  52         -- rnHsSigType is used for source-language type signatures,
  53         -- which use *implicit* universal quantification.
  54 rnHsSigType doc_str ty
  55   = rnHsType (text "In the type signature for" <+> doc_str) ty
  56 \end{code}
  57
  58 rnHsType is here because we call it from loadInstDecl, and I didn't
  59 want a gratuitous knot.
  60
  61 \begin{code}
  62 rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
  63
  64 rnHsType doc (HsForAllTy Nothing ctxt ty)
  65         -- Implicit quantifiction in source code (no kinds on tyvars)
  66         -- Given the signature  C => T  we universally quantify
  67         -- over FV(T) \ {in-scope-tyvars}
  68   = getLocalNameEnv             `thenRn` \ name_env ->
  69     let
  70         mentioned_in_tau  = extractHsTyRdrTyVars ty
  71         mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
  72         mentioned         = nub (mentioned_in_tau ++ mentioned_in_ctxt)
  73
  74         -- Don't quantify over type variables that are in scope;
  75         -- when GlasgowExts is off, there usually won't be any, except for
  76         -- class signatures:
  77         --      class C a where { op :: a -> a }
  78         forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned
  79     in
  80     rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
  81
  82 rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
  83         -- Explicit quantification.
  84         -- Check that the forall'd tyvars are actually
  85         -- mentioned in the type, and produce a warning if not
  86   = let
  87         mentioned_in_tau                = extractHsTyRdrTyVars tau
  88         mentioned_in_ctxt               = extractHsCtxtRdrTyVars ctxt
  89         mentioned                       = nub (mentioned_in_tau ++ mentioned_in_ctxt)
  90         forall_tyvar_names              = hsTyVarNames forall_tyvars
  91
  92         -- Explicitly quantified but not mentioned in ctxt or tau
  93         warn_guys                       = filter (`notElem` mentioned) forall_tyvar_names
  94     in
  95     mapRn_ (forAllWarn doc tau) warn_guys       `thenRn_`
  96     rnForAll doc forall_tyvars ctxt tau
  97
  98 rnHsType doc (HsTyVar tyvar)
  99   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 100     returnRn (HsTyVar tyvar')
 101
 102 rnHsType doc (HsOpTy ty1 op ty2)
 103   = (case op of
 104         HsArrow  -> returnRn HsArrow
 105         HsTyOp n -> lookupOccRn n    `thenRn` \ n' ->
 106                     returnRn (HsTyOp n')
 107     )                           `thenRn` \ op' ->
 108     rnHsType doc ty1            `thenRn` \ ty1' ->
 109     rnHsType doc ty2            `thenRn` \ ty2' ->
 110     lookupTyFixityRn op'        `thenRn` \ fix ->
 111     mkHsOpTyRn op' fix ty1' ty2'
 112
 113
 114 rnHsType doc (HsNumTy i)
 115   | i == 1    = returnRn (HsNumTy i)
 116   | otherwise = failWithRn (HsNumTy i)
 117                            (ptext SLIT("Only unit numeric type pattern is valid"))
 118
 119 rnHsType doc (HsFunTy ty1 ty2)
 120   = rnHsType doc ty1    `thenRn` \ ty1' ->
 121         -- Might find a for-all as the arg of a function type
 122     rnHsType doc ty2    `thenRn` \ ty2' ->
 123         -- Or as the result.  This happens when reading Prelude.hi
 124         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 125     returnRn (HsFunTy ty1' ty2')
 126
 127 rnHsType doc (HsListTy ty)
 128   = rnHsType doc ty                             `thenRn` \ ty' ->
 129     returnRn (HsListTy ty')
 130
 131 rnHsType doc (HsKindSig ty k)
 132   = rnHsType doc ty                             `thenRn` \ ty' ->
 133     returnRn (HsKindSig ty' k)
 134
 135 rnHsType doc (HsPArrTy ty)
 136   = rnHsType doc ty                             `thenRn` \ ty' ->
 137     returnRn (HsPArrTy ty')
 138
 139 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 140 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 141 rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
 142         -- Don't do lookupOccRn, because this is built-in syntax
 143         -- so it doesn't need to be in scope
 144   = mapRn (rnHsType doc) tys            `thenRn` \ tys' ->
 145     returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
 146   where
 147     tup_name = tupleTyCon_name boxity arity
 148
 149
 150 rnHsType doc (HsAppTy ty1 ty2)
 151   = rnHsType doc ty1            `thenRn` \ ty1' ->
 152     rnHsType doc ty2            `thenRn` \ ty2' ->
 153     returnRn (HsAppTy ty1' ty2')
 154
 155 rnHsType doc (HsPredTy pred)
 156   = rnPred doc pred     `thenRn` \ pred' ->
 157     returnRn (HsPredTy pred')
 158
 159 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 160 \end{code}
 161
 162
 163 \begin{code}
 164 rnForAll doc forall_tyvars ctxt ty
 165   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
 166     rnContext doc ctxt                  `thenRn` \ new_ctxt ->
 167     rnHsType doc ty                     `thenRn` \ new_ty ->
 168     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 169 \end{code}
 170
 171
 172 %*********************************************************
 173 %*                                                      *
 174 \subsection{Fixities}
 175 %*                                                      *
 176 %*********************************************************
 177
 178 Infix types are read in a *right-associative* way, so that
 179         a `op` b `op` c
 180 is always read in as
 181         a `op` (b `op` c)
 182
 183 mkHsOpTyRn rearranges where necessary.  The two arguments
 184 have already been renamed and rearranged.  It's made rather tiresome
 185 by the presence of ->
 186
 187 \begin{code}
 188 lookupTyFixityRn HsArrow    = returnRn arrowFixity
 189 lookupTyFixityRn (HsTyOp n)
 190   = doptRn Opt_GlasgowExts                      `thenRn` \ glaExts ->
 191     warnCheckRn glaExts (infixTyConWarn n)      `thenRn_`
 192     lookupFixityRn n
 193
 194 -- Building (ty1 `op1` (ty21 `op2` ty22))
 195 mkHsOpTyRn :: HsTyOp Name -> Fixity
 196            -> RenamedHsType -> RenamedHsType
 197            -> RnMS RenamedHsType
 198
 199 mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22)
 200   = lookupTyFixityRn op2                `thenRn` \ fix2 ->
 201     let
 202         (nofix_error, associate_right) = compareFixity fix1 fix2
 203     in
 204     if nofix_error then
 205         addErrRn (precParseErr (quotes (ppr op1),fix1)
 206                                (quotes (ppr op2),fix2)) `thenRn_`
 207         returnRn (HsOpTy ty1 op1 ty2)
 208     else
 209     if not associate_right then
 210         -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
 211         mkHsOpTyRn op1 fix1 ty1 ty21            `thenRn` \ new_ty ->
 212         returnRn (HsOpTy new_ty op2 ty22)
 213     else
 214     returnRn (HsOpTy ty1 op1 ty2)
 215
 216 mkHsOpTyRn op fix ty1 ty2                       -- Default case, no rearrangment
 217   = returnRn (HsOpTy ty1 op ty2)
 218
 219 mkHsFunTyRn ty1 ty2                     -- Precedence of function arrow is 0
 220   = returnRn (HsFunTy ty1 ty2)          -- so no rearrangement reqd.  Change
 221                                         -- this if fixity of -> increases.
 222
 223 not_op_ty (HsOpTy _ _ _) = False
 224 not_op_ty other          = True
 225 \end{code}
 226
 227 %*********************************************************
 228 %*                                                      *
 229 \subsection{Contexts and predicates}
 230 %*                                                      *
 231 %*********************************************************
 232
 233 \begin{code}
 234 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 235 rnContext doc ctxt
 236   = mapRn rn_pred ctxt          `thenRn` \ theta ->
 237
 238         -- Check for duplicate assertions
 239         -- If this isn't an error, then it ought to be:
 240     ifOptRn Opt_WarnMisc (
 241         let
 242             (_, dups) = removeDupsEq theta
 243                 -- We only have equality, not ordering
 244         in
 245         mapRn (addWarnRn . dupClassAssertWarn theta) dups
 246     )                           `thenRn_`
 247
 248     returnRn theta
 249   where
 250         --Someone discovered that @CCallable@ and @CReturnable@
 251         -- could be used in contexts such as:
 252         --      foo :: CCallable a => a -> PrimIO Int
 253         -- Doing this utterly wrecks the whole point of introducing these
 254         -- classes so we specifically check that this isn't being done.
 255     rn_pred pred = rnPred doc pred                              `thenRn` \ pred'->
 256                    checkRn (not (bad_pred pred'))
 257                            (naughtyCCallContextErr pred')       `thenRn_`
 258                    returnRn pred'
 259
 260     bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
 261     bad_pred other             = False
 262
 263
 264 rnPred doc (HsClassP clas tys)
 265   = lookupOccRn clas            `thenRn` \ clas_name ->
 266     rnHsTypes doc tys           `thenRn` \ tys' ->
 267     returnRn (HsClassP clas_name tys')
 268
 269 rnPred doc (HsIParam n ty)
 270   = newIPName n                 `thenRn` \ name ->
 271     rnHsType doc ty             `thenRn` \ ty' ->
 272     returnRn (HsIParam name ty')
 273 \end{code}
 274
 275
 276 %*********************************************************
 277 %*                                                      *
 278 \subsection{Errors}
 279 %*                                                      *
 280 %*********************************************************
 281
 282 \end{code}
 283 \begin{code}
 284 forAllWarn doc ty tyvar
 285   = ifOptRn Opt_WarnUnusedMatches       $
 286     getModeRn                           `thenRn` \ mode ->
 287     case mode of {
 288 #ifndef DEBUG
 289              InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 290                                             -- unless DEBUG is on, in which case it is slightly
 291                                             -- informative.  They can arise from mkRhsTyLam,
 292 #endif                                      -- leading to (say)         f :: forall a b. [b] -> [b]
 293              other ->
 294                 addWarnRn (
 295                    sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
 296                    nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 297                    $$
 298                    doc
 299                 )
 300           }
 301
 302 dupClassAssertWarn ctxt (assertion : dups)
 303   = sep [hsep [ptext SLIT("Duplicate class assertion"),
 304                quotes (ppr assertion),
 305                ptext SLIT("in the context:")],
 306          nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
 307
 308 naughtyCCallContextErr (HsClassP clas _)
 309   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
 310          ptext SLIT("in a context")]
 311
 312 precParseErr op1 op2
 313   = hang (ptext SLIT("precedence parsing error"))
 314       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
 315                ppr_opfix op2,
 316                ptext SLIT("in the same infix expression")])
 317
 318 sectionPrecErr op arg_op section
 319  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
 320          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
 321          nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 322
 323 infixTyConWarn op
 324   = ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op)
 325
 326 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 327 \end{code}