RnTypes.lhs 41.6 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnSource]{Main pass of renamer}

\begin{code}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
7 8 9
module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
dreixel's avatar
dreixel committed
10
        rnHsKind, rnLHsKind, rnLHsMaybeKind,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
11
        rnHsSigType, rnLHsInstType, rnConDeclFields,
12
        newTyVarNameRn,
13

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
14 15 16
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
        checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
17

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
18 19
        -- Splice related stuff
        rnSplice, checkTH,
dreixel's avatar
dreixel committed
20 21

        -- Binding related stuff
22 23
        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
24
        extractRdrKindSigVars, extractDataDefnKindVars, filterInScope
25
  ) where
26

27
import {-# SOURCE #-} RnExpr( rnLExpr )
28 29
#ifdef GHCI
import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
30
#endif  /* GHCI */
31

32
import DynFlags
33
import HsSyn
34
import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
35
import RnEnv
36
import TcRnMonad
37
import RdrName
38
import PrelNames
39
import TysPrim          ( funTyConName )
40 41
import Name
import SrcLoc
42
import NameSet
43

44
import Util
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
45 46
import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                          Fixity(..), FixityDirection(..) )
47
import Outputable
48
import FastString
49
import Maybes
50
import Data.List        ( nub )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
51
import Control.Monad    ( unless, when )
52 53 54 55 56 57 58 59

#include "HsVersions.h"
\end{code}

These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

%*********************************************************
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
60
%*                                                      *
61
\subsection{Renaming types}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
62
%*                                                      *
63 64 65
%*********************************************************

\begin{code}
66
rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
67 68
        -- rnHsSigType is used for source-language type signatures,
        -- which use *implicit* universal quantification.
69
rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
70

71
rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
72
-- Rename the type in an instance or standalone deriving decl
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
73
rnLHsInstType doc_str ty
74
  = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
75
       ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
76
       ; return (ty', fvs) }
77 78 79 80 81 82 83
  where
    good_inst_ty
      | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
      , isTcOcc (rdrNameOcc cls) = True
      | otherwise                = False

badInstTy :: LHsType RdrName -> SDoc
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
84
badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
85 86 87 88 89 90
\end{code}

rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

\begin{code}
dreixel's avatar
dreixel committed
91
rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
92 93
           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsTyKi isType doc (L loc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
94
  = setSrcSpan loc $
95 96
    do { (ty', fvs) <- rnHsTyKi isType doc ty
       ; return (L loc ty', fvs) }
dreixel's avatar
dreixel committed
97

98
rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
dreixel's avatar
dreixel committed
99
rnLHsType = rnLHsTyKi True
100 101

rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
dreixel's avatar
dreixel committed
102 103
rnLHsKind = rnLHsTyKi False

104 105
rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
                -> RnM (Maybe (LHsKind Name), FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
106
rnLHsMaybeKind _ Nothing
107
  = return (Nothing, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
108
rnLHsMaybeKind doc (Just kind)
109 110
  = do { (kind', fvs) <- rnLHsKind doc kind
       ; return (Just kind', fvs) }
111 112

rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
dreixel's avatar
dreixel committed
113
rnHsType = rnHsTyKi True
114
rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
dreixel's avatar
dreixel committed
115 116
rnHsKind = rnHsTyKi False

117
rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
dreixel's avatar
dreixel committed
118

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
119
rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
120
  = ASSERT( isType ) do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
121 122 123
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify
        -- over FV(T) \ {in-scope-tyvars}
124
    rdr_env <- getLocalRdrEnv
125
    loc <- getSrcSpanM
126
    let
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
127
        (forall_kvs, forall_tvs) = filterInScope rdr_env $
128
                                   extractHsTysRdrTyVars (ty:ctxt)
129 130 131 132
           -- In for-all types we don't bring in scope
           -- kind variables mentioned in kind signatures
           -- (Well, not yet anyway....)
           --    f :: Int -> T (a::k)    -- Not allowed
133

134
           -- The filterInScope is to ensure that we don't quantify over
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
135 136 137 138
           -- type variables that are in scope; when GlasgowExts is off,
           -- there usually won't be any, except for class signatures:
           --   class C a where { op :: a -> a }
        tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
139

140
    rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
141

142
rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
143
  = ASSERT( isType ) do {      -- Explicit quantification.
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
144 145
         -- Check that the forall'd tyvars are actually
         -- mentioned in the type, and produce a warning if not
146
         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
147
             in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
dreixel's avatar
dreixel committed
148
       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
149

150
       ; rnForAll doc Explicit kvs forall_tyvars lctxt tau }
151

152 153 154
rnHsTyKi isType _ (HsTyVar rdr_name)
  = do { name <- rnTyVar isType rdr_name
       ; return (HsTyVar name, unitFV name) }
155

156 157 158
-- If we see (forall a . ty), without foralls on, the forall will give
-- a sensible error message, but we don't want to complain about the dot too
-- Hence the jiggery pokery with ty1
dreixel's avatar
dreixel committed
159
rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
160
  = ASSERT( isType ) setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
161 162 163 164 165 166 167 168 169 170
    do  { ops_ok <- xoptM Opt_TypeOperators
        ; op' <- if ops_ok
                 then rnTyVar isType op
                 else do { addErr (opTyErr op ty)
                         ; return (mkUnboundName op) }  -- Avoid double complaint
        ; let l_op' = L loc op'
        ; fix <- lookupTyFixityRn l_op'
        ; (ty1', fvs1) <- rnLHsType doc ty1
        ; (ty2', fvs2) <- rnLHsType doc ty2
        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
171 172
                               op' fix ty1' ty2'
        ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
173

174 175 176
rnHsTyKi isType doc (HsParTy ty)
  = do { (ty', fvs) <- rnLHsTyKi isType doc ty
       ; return (HsParTy ty', fvs) }
177

dreixel's avatar
dreixel committed
178
rnHsTyKi isType doc (HsBangTy b ty)
179
  = ASSERT( isType )
180 181
    do { (ty', fvs) <- rnLHsType doc ty
       ; return (HsBangTy b ty', fvs) }
182

183 184 185 186
rnHsTyKi _ doc ty@(HsRecTy flds)
  = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                    2 (ppr ty))
       ; (flds', fvs) <- rnConDeclFields doc flds
187
       ; return (HsRecTy flds', fvs) }
188

189 190
rnHsTyKi isType doc (HsFunTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
191
        -- Might find a for-all as the arg of a function type
192
       ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
193 194
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
195

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
196
        -- Check for fixity rearrangements
197 198 199 200
       ; res_ty <- if isType
                   then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
                   else return (HsFunTy ty1' ty2')
       ; return (res_ty, fvs1 `plusFV` fvs2) }
dreixel's avatar
dreixel committed
201

202 203
rnHsTyKi isType doc listTy@(HsListTy ty)
  = do { data_kinds <- xoptM Opt_DataKinds
204
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy))
205 206
       ; (ty', fvs) <- rnLHsTyKi isType doc ty
       ; return (HsListTy ty', fvs) }
207

dreixel's avatar
dreixel committed
208
rnHsTyKi isType doc (HsKindSig ty k)
209
  = ASSERT( isType )
210 211 212 213 214
    do { kind_sigs_ok <- xoptM Opt_KindSignatures
       ; unless kind_sigs_ok (badSigErr False doc ty)
       ; (ty', fvs1) <- rnLHsType doc ty
       ; (k', fvs2) <- rnLHsKind doc k
       ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
215

216 217 218
rnHsTyKi _ doc (HsRoleAnnot ty _) 
  = illegalRoleAnnotDoc doc ty >> failM

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
219
rnHsTyKi isType doc (HsPArrTy ty)
220
  = ASSERT( isType )
221 222
    do { (ty', fvs) <- rnLHsType doc ty
       ; return (HsPArrTy ty', fvs) }
chak's avatar
chak committed
223

224 225
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
226 227
rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
  = do { data_kinds <- xoptM Opt_DataKinds
228
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy))
229 230 231
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
       ; return (HsTupleTy tup_con tys', fvs) }

232 233
-- 1. Perhaps we should use a separate extension here?
-- 2. Check that the integer is positive?
234 235
rnHsTyKi isType _ tyLit@(HsTyLit t)
  = do { data_kinds <- xoptM Opt_DataKinds
236
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType tyLit))
237 238
       ; return (HsTyLit t, emptyFVs) }

239 240 241 242 243 244 245 246
rnHsTyKi isType doc (HsAppTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
       ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
       ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }

rnHsTyKi isType doc (HsIParamTy n ty)
  = ASSERT( isType )
    do { (ty', fvs) <- rnLHsType doc ty
247
       ; return (HsIParamTy n ty', fvs) }
248

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
249
rnHsTyKi isType doc (HsEqTy ty1 ty2)
250 251 252 253
  = ASSERT( isType )
    do { (ty1', fvs1) <- rnLHsType doc ty1
       ; (ty2', fvs2) <- rnLHsType doc ty2
       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
254

dreixel's avatar
dreixel committed
255
rnHsTyKi isType _ (HsSpliceTy sp _ k)
256
  = ASSERT( isType )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
257
    do { (sp', fvs) <- rnSplice sp      -- ToDo: deal with fvs
258
       ; return (HsSpliceTy sp' fvs k, fvs) }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
259

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
260
rnHsTyKi isType doc (HsDocTy ty haddock_doc)
261
  = ASSERT( isType )
262 263 264
    do { (ty', fvs) <- rnLHsType doc ty
       ; haddock_doc' <- rnLHsDoc haddock_doc
       ; return (HsDocTy ty' haddock_doc', fvs) }
265

266
#ifndef GHCI
dreixel's avatar
dreixel committed
267
rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
268
#else
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
269
rnHsTyKi isType doc (HsQuasiQuoteTy qq)
270
  = ASSERT( isType )
271
    do { ty <- runQuasiQuoteType qq
Edsko de Vries's avatar
Edsko de Vries committed
272 273 274
         -- Wrap the result of the quasi-quoter in parens so that we don't
         -- lose the outermost location set by runQuasiQuote (#7918) 
       ; rnHsType doc (HsParTy ty) }
275
#endif
dreixel's avatar
dreixel committed
276

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
277
rnHsTyKi isType _ (HsCoreTy ty)
278
  = ASSERT( isType )
279
    return (HsCoreTy ty, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
280
    -- The emptyFVs probably isn't quite right
281 282
    -- but I don't think it matters

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
283
rnHsTyKi _ _ (HsWrapTy {})
284
  = panic "rnHsTyKi"
dreixel's avatar
dreixel committed
285

286
rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
287
  = ASSERT( isType )
288 289 290
    do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr isType ty))
       ; (tys', fvs) <- rnLHsTypes doc tys
291 292
       ; return (HsExplicitListTy k tys', fvs) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
293
rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
294
  = ASSERT( isType )
295 296 297
    do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr isType ty))
       ; (tys', fvs) <- rnLHsTypes doc tys
298 299 300 301 302 303 304
       ; return (HsExplicitTupleTy kis tys', fvs) }

--------------
rnTyVar :: Bool -> RdrName -> RnM Name
rnTyVar is_type rdr_name
  | is_type   = lookupTypeOccRn rdr_name
  | otherwise = lookupKindOccRn rdr_name
305

306

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
307
--------------
dreixel's avatar
dreixel committed
308
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
309 310
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
311 312
\end{code}

313

314
\begin{code}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
315
rnForAll :: HsDocContext -> HsExplicitFlag
316 317
         -> [RdrName]                -- Kind variables
         -> LHsTyVarBndrs RdrName   -- Type variables
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
318
         -> LHsContext RdrName -> LHsType RdrName
319
         -> RnM (HsType Name, FreeVars)
320

321 322 323
rnForAll doc exp kvs forall_tyvars ctxt ty
  | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
  = rnHsType doc (unLoc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
324 325 326 327 328 329 330
        -- One reason for this case is that a type like Int#
        -- starts off as (HsForAllTy Nothing [] Int), in case
        -- there is some quantification.  Now that we have quantified
        -- and discovered there are no type variables, it's nicer to turn
        -- it into plain Int.  If it were Int# instead of Int, we'd actually
        -- get an error, because the body of a genuine for-all is
        -- of kind *.
331

332 333
  | otherwise
  = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
334 335 336
    do { (new_ctxt, fvs1) <- rnContext doc ctxt
       ; (new_ty, fvs2) <- rnLHsType doc ty
       ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
337 338
        -- Retain the same implicit/explicit flag as before
        -- so that we can later print it correctly
339

340 341
---------------
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
342 343
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
344 345 346 347
-- Used just before renaming the defn of a function
-- with a separate type signature, to bring its tyvars into scope
-- With no -XScopedTypeVariables, this is a no-op
bindSigTyVarsFV tvs thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
348 349 350 351 352
  = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
353 354

---------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
355
bindHsTyVars :: HsDocContext
356 357 358 359 360
             -> Maybe a                 -- Just _  => an associated type decl
             -> [RdrName]               -- Kind variables from scope
             -> LHsTyVarBndrs RdrName   -- Type variables
             -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
             -> RnM (b, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
361 362
-- (a) Bring kind variables into scope
--     both (i)  passed in (kv_bndrs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
363
--     and  (ii) mentioned in the kinds of tv_bndrs
364 365 366 367
-- (b) Bring type variables into scope
bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
  = do { rdr_env <- getLocalRdrEnv
       ; let tvs = hsQTvBndrs tv_bndrs
368
             kvs_from_tv_bndrs = [ kv | L _ (HsTyVarBndr _ (Just kind) _) <- tvs
369 370 371 372
                                 , let (_, kvs) = extractHsTyRdrTyVars kind
                                 , kv <- kvs ]
             all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
                       nub (kv_bndrs ++ kvs_from_tv_bndrs)
373 374 375 376 377
             overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
                -- These variables appear both as kind and type variables
                -- in the same declaration; eg  type family  T (x :: *) (y :: x)
                -- We disallow this: too confusing!

378
       ; poly_kind <- xoptM Opt_PolyKinds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
379
       ; unless (poly_kind || null all_kvs)
380
                (addErr (badKindBndrs doc all_kvs))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
381
       ; unless (null overlap_kvs)
382 383
                (addErr (overlappingKindVars doc overlap_kvs))

384 385
       ; loc <- getSrcSpanM
       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
386
       ; bindLocalNamesFV kv_names $
387 388
    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
389
             rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
390 391 392 393 394 395 396 397 398 399 400 401 402
             rn_tv_bndr (L loc (HsTyVarBndr name mkind mrole))
               = do { ksig_ok <- xoptM Opt_KindSignatures
                    ; unless ksig_ok $
                      whenIsJust mkind $ \k -> badSigErr False doc k
                    ; rsig_ok <- xoptM Opt_RoleAnnotations
                    ; unless rsig_ok $
                      whenIsJust mrole $ \_ -> badRoleAnnotOpt loc doc
                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc name
                    ; (mkind', fvs) <- case mkind of
                                         Just k  -> do { (kind', fvs) <- rnLHsKind doc k
                                                       ; return (Just kind', fvs) }
                                         Nothing -> return (Nothing, emptyFVs)
                    ; return (L loc (HsTyVarBndr nm mkind' mrole), fvs) }
403 404 405 406 407 408 409 410 411 412 413

       -- Check for duplicate or shadowed tyvar bindrs
       ; checkDupRdrNames tv_names_w_loc
       ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)

       ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
                        do { env <- getLocalRdrEnv
                           ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
       ; return (res, fvs1 `plusFV` fvs2) } }
414

415 416 417 418
newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
newTyVarNameRn mb_assoc rdr_env loc rdr
  | Just _ <- mb_assoc    -- Use the same Name as the parent class decl
  , Just n <- lookupLocalRdrEnv rdr_env rdr
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
419 420
  = return n
  | otherwise
421
  = newLocalBndrRn (L loc rdr)
422 423

--------------------------------
424 425 426
rnHsBndrSig :: HsDocContext
            -> HsWithBndrs (LHsType RdrName)
            -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars))
427
            -> RnM (a, FreeVars)
428 429 430 431
rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
       ; unless sig_ok (badSigErr True doc ty)
       ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
432 433 434 435 436
       ; name_env <- getLocalRdrEnv
       ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
                                               , not (tv `elemLocalRdrEnv` name_env) ]
       ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
                                               , not (kv `elemLocalRdrEnv` name_env) ]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
437 438
       ; bindLocalNamesFV kv_names $
         bindLocalNamesFV tv_names $
439 440
    do { (ty', fvs1) <- rnLHsType doc ty
       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
441 442
       ; return (res, fvs1 `plusFV` fvs2) } }

443 444
overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
overlappingKindVars doc kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
445 446
  = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
           ptext (sLit "also used as type variable") <> plural kvs
447 448 449
           <> colon <+> pprQuotedList kvs
         , docOfHsDocContext doc ]

450 451 452
badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
badKindBndrs doc kvs
  = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
453 454 455 456 457 458 459
                 <+> pprQuotedList kvs)
              2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
         , docOfHsDocContext doc ]

badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
badSigErr is_type doc (L loc ty)
  = setSrcSpan loc $ addErr $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
460
    vcat [ hang (ptext (sLit "Illegal") <+> what
461 462 463 464 465 466
                 <+> ptext (sLit "signature:") <+> quotes (ppr ty))
              2 (ptext (sLit "Perhaps you intended to use") <+> flag)
         , docOfHsDocContext doc ]
  where
    what | is_type   = ptext (sLit "type")
         | otherwise = ptext (sLit "kind")
467
    flag | is_type   = ptext (sLit "-XScopedTypeVariables")
468
         | otherwise = ptext (sLit "-XKindSignatures")
469 470 471 472 473 474 475 476

dataKindsErr :: Bool -> HsType RdrName -> SDoc
dataKindsErr is_type thing
  = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
       2 (ptext (sLit "Perhaps you intended to use -XDataKinds"))
  where
    what | is_type   = ptext (sLit "type")
         | otherwise = ptext (sLit "kind")
477 478 479 480 481 482 483 484 485 486 487 488 489

badRoleAnnotOpt :: SrcSpan -> HsDocContext -> TcM ()
badRoleAnnotOpt loc doc
  = setSrcSpan loc $ addErr $
    vcat [ ptext (sLit "Illegal role annotation")
         , ptext (sLit "Perhaps you intended to use -XRoleAnnotations")
         , docOfHsDocContext doc ]

illegalRoleAnnotDoc :: HsDocContext -> LHsType RdrName -> TcM ()
illegalRoleAnnotDoc doc (L loc ty)
  = setSrcSpan loc $ addErr $
    vcat [ ptext (sLit "Illegal role annotation on") <+> (ppr ty)
         , docOfHsDocContext doc ]
490
\end{code}
dreixel's avatar
dreixel committed
491

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
492
Note [Renaming associated types]
493 494 495 496 497 498
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check that the RHS of the decl mentions only type variables
bound on the LHS.  For example, this is not ok
   class C a b where
      type F a x :: *
   instance C (p,q) r where
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
499
      type F (p,q) x = (x, r)   -- BAD: mentions 'r'
500 501 502 503 504 505 506
c.f. Trac #5515

What makes it tricky is that the *kind* variable from the class *are*
in scope (Trac #5862):
    class Category (x :: k -> k -> *) where
      type Ob x :: k -> Constraint
      id :: Ob x a => x a a
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
507 508
      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
Here 'k' is in scope in the kind signature even though it's not
509 510 511 512 513 514
explicitly mentioned on the LHS of the type Ob declaration.

We could force you to mention k explicitly, thus
    class Category (x :: k -> k -> *) where
      type Ob (x :: k -> k -> *) :: k -> Constraint
but it seems tiresome to do so.
515

516

517
%*********************************************************
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
518
%*                                                      *
519
\subsection{Contexts and predicates}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
520
%*                                                      *
521 522 523
%*********************************************************

\begin{code}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
524
rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
525 526 527 528 529 530 531 532 533
                -> RnM ([ConDeclField Name], FreeVars)
rnConDeclFields doc fields = mapFvRn (rnField doc) fields

rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
rnField doc (ConDeclField name ty haddock_doc)
  = do { new_name <- lookupLocatedTopBndrRn name
       ; (new_ty, fvs) <- rnLHsType doc ty
       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
       ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
534

535
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
536
rnContext doc (L loc cxt)
537 538
  = do { (cxt', fvs) <- rnLHsTypes doc cxt
       ; return (L loc cxt', fvs) }
539 540
\end{code}

541

542
%************************************************************************
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
543 544 545
%*                                                                      *
        Fixities and precedence parsing
%*                                                                      *
546
%************************************************************************
547

548 549 550 551 552 553 554 555 556
@mkOpAppRn@ deals with operator fixities.  The argument expressions
are assumed to be already correctly arranged.  It needs the fixities
recorded in the OpApp nodes, because fixity info applies to the things
the programmer actually wrote, so you can't find it out from the Name.

Furthermore, the second argument is guaranteed not to be another
operator application.  Why? Because the parser parses all
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
557
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
558
        a `op` b `op` c
559
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
560
        a `op` (b `op` c)
561 562 563

mkHsOpTyRn rearranges where necessary.  The two arguments
have already been renamed and rearranged.  It's made rather tiresome
564
by the presence of ->, which is a separate syntactic construct.
565 566

\begin{code}
567 568 569
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
570 571
           -> Name -> Fixity -> LHsType Name -> LHsType Name
           -> RnM (HsType Name)
572

dreixel's avatar
dreixel committed
573
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
574
  = do  { fix2 <- lookupTyFixityRn op2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
575 576 577
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
                      (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
                      (unLoc op2) fix2 ty21 ty22 loc2 }
578

Ian Lynagh's avatar
Ian Lynagh committed
579
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
580 581
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
582

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
583
mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
584 585 586 587
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
588 589 590 591 592 593
            -> Name -> Fixity -> LHsType Name
            -> (LHsType Name -> LHsType Name -> HsType Name)
            -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
            -> RnM (HsType Name)
mk_hs_op_ty mk1 op1 fix1 ty1
            mk2 op2 fix2 ty21 ty22 loc2
594
  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
595
                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
596
  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
597 598 599
  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
600 601 602
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

603

604
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
605 606 607 608 609
mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity             -- Operator and fixity
          -> LHsExpr Name                       -- Right operand (not an OpApp, but might
                                                -- be a NegApp)
          -> RnM (HsExpr Name)
610 611 612

-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
613 614 615
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
616

617 618 619
  | associate_right = do
    new_e <- mkOpAppRn e12 op2 fix2 e2
    return (OpApp e11 op1 fix1 (L loc' new_e))
620 621 622 623 624
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
625
--      (- neg_arg) `op` e2
626
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
627 628 629
  | nofix_error
  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
630

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
631
  | associate_right
632 633
  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
       return (NegApp (L loc' new_e) neg_name)
634 635 636 637 638
  where
    loc' = combineLocs neg_arg e2
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
639 640 641
--      e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
  | not associate_right                 -- We *want* right association
642 643
  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
       return (OpApp e1 op1 fix1 e2)
644 645 646 647
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
648 649
--      Default case
mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
650
  = ASSERT2( right_op_ok fix (unLoc e2),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
651
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
652
    )
653
    return (OpApp e1 op fix e2)
654

655 656 657 658 659
----------------------------
get_op :: LHsExpr Name -> Name
get_op (L _ (HsVar n)) = n
get_op other           = pprPanic "get_op" (ppr other)

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
660
-- Parser left-associates everything, but
661 662
-- derived instances may have correctly-associated things to
-- in the right operarand.  So we just check that the right operand is OK
Ian Lynagh's avatar
Ian Lynagh committed
663
right_op_ok :: Fixity -> HsExpr Name -> Bool
664 665 666 667
right_op_ok fix1 (OpApp _ _ fix2 _)
  = not error_please && associate_right
  where
    (error_please, associate_right) = compareFixity fix1 fix2
Ian Lynagh's avatar
Ian Lynagh committed
668
right_op_ok _ _
669 670 671 672 673 674 675
  = True

-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
mkNegAppRn neg_arg neg_name
  = ASSERT( not_op_app (unLoc neg_arg) )
676
    return (NegApp neg_arg neg_name)
677

Ian Lynagh's avatar
Ian Lynagh committed
678
not_op_app :: HsExpr id -> Bool
679
not_op_app (OpApp _ _ _ _) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
680
not_op_app _               = True
681 682

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
683 684 685 686
mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity     -- Operator and fixity
          -> LHsCmdTop Name             -- Right operand (not an infix)
          -> RnM (HsCmd Name)
687 688

-- (e11 `op1` e12) `op2` e2
689
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
690
        op2 fix2 a2
691 692
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
693
       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
694 695 696

  | associate_right
  = do new_c <- mkOpFormRn a12 op2 fix2 a2
697
       return (HsCmdArrForm op1 (Just fix1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
698 699
                  [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])])
        -- TODO: locs are wrong
700 701 702
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
703 704
--      Default case
mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
705
  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
706 707 708 709


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
710
             -> RnM (Pat Name)
711 712

mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
713 714
  = do  { fix1 <- lookupFixityRn (unLoc op1)
        ; let (nofix_error, associate_right) = compareFixity fix1 fix2
715

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
716 717 718
        ; if nofix_error then do
                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
719

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
720 721 722 723
          else if associate_right then do
                { new_p <- mkConOpPatRn op2 fix2 p12 p2
                ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
          else return (ConPatIn op2 (InfixCon p1 p2)) }
724

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
725
mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
726
  = ASSERT( not_op_pat (unLoc p2) )
727
    return (ConPatIn op (InfixCon p1 p2))
728

Ian Lynagh's avatar
Ian Lynagh committed
729
not_op_pat :: Pat Name -> Bool
730
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
731
not_op_pat _                           = True
732 733

--------------------------------------
734
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
735 736 737
  -- Check precedence of a function binding written infix
  --   eg  a `op` b `C` c = ...
  -- See comments with rnExpr (OpApp ...) about "deriving"
738

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
739 740
checkPrecMatch op (MG { mg_alts = ms })
  = mapM_ check ms
741
  where
742 743 744 745
    check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
      = setSrcSpan (combineSrcSpans l1 l2) $
        do checkPrec op p1 False
           checkPrec op p2 True
746

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
747 748 749 750 751 752 753 754
    check _ = return ()
        -- This can happen.  Consider
        --      a `op` True = ...
        --      op          = ...
        -- The infix flag comes from the first binding of the group
        -- but the second eqn has no args (an error, but not discovered
        -- until the type checker).  So we don't want to crash on the
        -- second eqn.
755

Ian Lynagh's avatar
Ian Lynagh committed
756
checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
757 758 759
checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
    op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
760
    let
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
761 762 763 764 765 766 767 768
        inf_ok = op1_prec > op_prec ||
                 (op1_prec == op_prec &&
                  (op1_dir == InfixR && op_dir == InfixR && right ||
                   op1_dir == InfixL && op_dir == InfixL && not right))

        info  = (op,        op_fix)
        info1 = (unLoc op1, op1_fix)
        (infol, infor) = if right then (info, info1) else (info1, info)
769
    unless inf_ok (precParseErr infol infor)
770

Ian Lynagh's avatar
Ian Lynagh committed
771
checkPrec _ _ _
772
  = return ()
773 774 775 776 777 778

-- Check precedence of (arg op) or (op arg) respectively
-- If arg is itself an operator application, then either
--   (a) its precedence must be higher than that of op
--   (b) its precedency & associativity must be the same as that of op
checkSectionPrec :: FixityDirection -> HsExpr RdrName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
779
        -> LHsExpr Name -> LHsExpr Name -> RnM ()
780 781
checkSectionPrec direction section op arg
  = case unLoc arg of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
782 783 784
        OpApp _ op fix _ -> go_for_it (get_op op) fix
        NegApp _ _       -> go_for_it negateName  negateFixity
        _                -> return ()
785
  where
786 787
    op_name = get_op op
    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
788
          op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
789 790 791 792
          unless (op_prec < arg_prec
                  || (op_prec == arg_prec && direction == assoc))
                 (sectionPrecErr (op_name, op_fix)
                                 (arg_op, arg_fix) section)
793 794 795 796 797
\end{code}

Precedence-related error messages

\begin{code}
798
precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
799
precParseErr op1@(n1,_) op2@(n2,_)
800
  | isUnboundName n1 || isUnboundName n2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
801
  = return ()     -- Avoid error cascade
802 803
  | otherwise
  = addErr $ hang (ptext (sLit "Precedence parsing error"))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
804 805 806
      4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
               ppr_opfix op2,
               ptext (sLit "in the same infix expression")])
807

808 809 810
sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
sectionPrecErr op@(n1,_) arg_op@(n2,_) section
  | isUnboundName n1 || isUnboundName n2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
811
  = return ()     -- Avoid error cascade
812 813
  | otherwise
  = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
814 815 816
         nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
                      nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
         nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
817

818 819 820 821
ppr_opfix :: (Name, Fixity) -> SDoc
ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
   where
     pp_op | op == negateName = ptext (sLit "prefix `-'")
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
822
           | otherwise        = quotes (ppr op)
823 824 825
\end{code}

%*********************************************************
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
826
%*                                                      *
827
\subsection{Errors}
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
828
%*                                                      *
829 830
%*********************************************************

831
\begin{code}
832
warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
833
warnUnusedForAlls in_doc bound mentioned_rdrs
ian@well-typed.com's avatar
ian@well-typed.com committed
834
  = whenWOptM Opt_WarnUnusedMatches $
835 836 837 838 839
    mapM_ add_warn bound_but_not_used
  where
    bound_names        = hsLTyVarLocNames bound
    bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
840
    add_warn (L loc tv)
841 842 843
      = addWarnAt loc $
        vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
             , in_doc ]
844

Ian Lynagh's avatar
Ian Lynagh committed
845 846
opTyErr :: RdrName -> HsType RdrName -> SDoc
opTyErr op ty@(HsOpTy ty1 _ _)
Ian Lynagh's avatar
Ian Lynagh committed
847
  = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
848
         2 extra
849 850
  where
    extra | op == dot_tv_RDR && forall_head ty1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
851 852 853
          = perhapsForallMsg
          | otherwise
          = ptext (sLit "Use -XTypeOperators to allow operators in types")
854 855 856

    forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
    forall_head (L _ (HsAppTy ty _)) = forall_head ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed