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