RnTypes.hs 43.1 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[RnSource]{Main pass of renamer}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
9 10 11
module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
dreixel's avatar
dreixel committed
12
        rnHsKind, rnLHsKind, rnLHsMaybeKind,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
13
        rnHsSigType, rnLHsInstType, rnConDeclFields,
14
        newTyVarNameRn,
15

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

dreixel's avatar
dreixel committed
20
        -- Binding related stuff
21
        warnContextQuantification, warnUnusedForAlls,
22 23
        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
thomasw's avatar
thomasw committed
24 25
        extractRdrKindSigVars, extractDataDefnKindVars,
        extractWildcards, filterInScope
26
  ) where
27

gmainland's avatar
gmainland committed
28
import {-# SOURCE #-} RnSplice( rnSpliceType )
29

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

42
import Util
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
43 44
import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                          Fixity(..), FixityDirection(..) )
45
import Outputable
46
import FastString
47
import Maybes
thomasw's avatar
thomasw committed
48
import Data.List        ( nub, nubBy )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
49
import Control.Monad    ( unless, when )
50 51 52

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
53
{-
54 55 56
These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

Austin Seipp's avatar
Austin Seipp committed
57 58
*********************************************************
*                                                      *
59
\subsection{Renaming types}
Austin Seipp's avatar
Austin Seipp committed
60 61 62
*                                                      *
*********************************************************
-}
63

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

69
rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
70
-- Rename the type in an instance or standalone deriving decl
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
71
rnLHsInstType doc_str ty
72
  = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
73
       ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
74
       ; return (ty', fvs) }
75 76 77 78 79 80 81
  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
82
badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
83

Austin Seipp's avatar
Austin Seipp committed
84
{-
85 86 87
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
Note [Context quantification]
-----------------------------
Variables in type signatures are implicitly quantified
when (1) they are in a type signature not beginning
with "forall" or (2) in any qualified type T => R.
We are phasing out (2) since it leads to inconsistencies
(Trac #4426):

data A = A (a -> a)           is an error
data A = A (Eq a => a -> a)   binds "a"
data A = A (Eq a => a -> b)   binds "a" and "b"
data A = A (() => a -> b)     binds "a" and "b"
f :: forall a. a -> b         is an error
f :: forall a. () => a -> b   is an error
f :: forall a. a -> (() => b) binds "a" and "b"

The -fwarn-context-quantification flag warns about
this situation. See rnHsTyKi for case HsForAllTy Qualified.
Austin Seipp's avatar
Austin Seipp committed
106
-}
107

dreixel's avatar
dreixel committed
108
rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
109 110
           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsTyKi isType doc (L loc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
111
  = setSrcSpan loc $
112 113
    do { (ty', fvs) <- rnHsTyKi isType doc ty
       ; return (L loc ty', fvs) }
dreixel's avatar
dreixel committed
114

115
rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
dreixel's avatar
dreixel committed
116
rnLHsType = rnLHsTyKi True
117 118

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

121 122
rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
                -> RnM (Maybe (LHsKind Name), FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
123
rnLHsMaybeKind _ Nothing
124
  = return (Nothing, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
125
rnLHsMaybeKind doc (Just kind)
126 127
  = do { (kind', fvs) <- rnLHsKind doc kind
       ; return (Just kind', fvs) }
128 129

rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
dreixel's avatar
dreixel committed
130
rnHsType = rnHsTyKi True
131
rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
dreixel's avatar
dreixel committed
132 133
rnHsKind = rnHsTyKi False

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

thomasw's avatar
thomasw committed
136
rnHsTyKi isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty)
137
  = ASSERT( isType ) do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
138 139 140
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify
        -- over FV(T) \ {in-scope-tyvars}
141
    rdr_env <- getLocalRdrEnv
142
    loc <- getSrcSpanM
143
    let
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
144
        (forall_kvs, forall_tvs) = filterInScope rdr_env $
145
                                   extractHsTysRdrTyVars (ty:ctxt)
146 147 148 149
           -- 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
150

151
           -- The filterInScope is to ensure that we don't quantify over
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
152 153 154 155
           -- 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
156

thomasw's avatar
thomasw committed
157
    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
158

thomasw's avatar
thomasw committed
159
rnHsTyKi isType doc fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty)
160 161 162 163 164 165 166 167 168 169 170
  = ASSERT( isType ) do
    rdr_env <- getLocalRdrEnv
    loc <- getSrcSpanM
    let
        (forall_kvs, forall_tvs) = filterInScope rdr_env $
                                   extractHsTysRdrTyVars (ty:ctxt)
        tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
        in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype)

    -- See Note [Context quantification]
    warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs
thomasw's avatar
thomasw committed
171
    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
172

thomasw's avatar
thomasw committed
173
rnHsTyKi isType doc ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau)
174
  = ASSERT( isType ) do {      -- Explicit quantification.
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
175 176
         -- Check that the forall'd tyvars are actually
         -- mentioned in the type, and produce a warning if not
177
         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
178
             in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
dreixel's avatar
dreixel committed
179
       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
180

thomasw's avatar
thomasw committed
181
       ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau }
182

183 184 185
rnHsTyKi isType _ (HsTyVar rdr_name)
  = do { name <- rnTyVar isType rdr_name
       ; return (HsTyVar name, unitFV name) }
186

187 188 189
-- 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
190
rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
191
  = ASSERT( isType ) setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
192 193 194 195 196 197 198 199 200 201
    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)
202 203
                               op' fix ty1' ty2'
        ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
204

205 206 207
rnHsTyKi isType doc (HsParTy ty)
  = do { (ty', fvs) <- rnLHsTyKi isType doc ty
       ; return (HsParTy ty', fvs) }
208

dreixel's avatar
dreixel committed
209
rnHsTyKi isType doc (HsBangTy b ty)
210
  = ASSERT( isType )
211 212
    do { (ty', fvs) <- rnLHsType doc ty
       ; return (HsBangTy b ty', fvs) }
213

214 215 216 217
rnHsTyKi _ doc ty@(HsRecTy flds)
  = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                    2 (ppr ty))
       ; (flds', fvs) <- rnConDeclFields doc flds
218
       ; return (HsRecTy flds', fvs) }
219

220 221
rnHsTyKi isType doc (HsFunTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
222
        -- Might find a for-all as the arg of a function type
223
       ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
224 225
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
226

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
227
        -- Check for fixity rearrangements
228 229 230 231
       ; 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
232

233 234
rnHsTyKi isType doc listTy@(HsListTy ty)
  = do { data_kinds <- xoptM Opt_DataKinds
235
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy))
236 237
       ; (ty', fvs) <- rnLHsTyKi isType doc ty
       ; return (HsListTy ty', fvs) }
238

dreixel's avatar
dreixel committed
239
rnHsTyKi isType doc (HsKindSig ty k)
240
  = ASSERT( isType )
241 242 243 244 245
    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) }
246

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
247
rnHsTyKi isType doc (HsPArrTy ty)
248
  = ASSERT( isType )
249 250
    do { (ty', fvs) <- rnLHsType doc ty
       ; return (HsPArrTy ty', fvs) }
chak's avatar
chak committed
251

252 253
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
254 255
rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
  = do { data_kinds <- xoptM Opt_DataKinds
256
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy))
257 258 259
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
       ; return (HsTupleTy tup_con tys', fvs) }

260
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
261 262
rnHsTyKi isType _ tyLit@(HsTyLit t)
  = do { data_kinds <- xoptM Opt_DataKinds
263
       ; unless data_kinds (addErr (dataKindsErr isType tyLit))
264
       ; when (negLit t) (addErr negLitErr)
265
       ; return (HsTyLit t, emptyFVs) }
266
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
267 268
    negLit (HsStrTy _ _) = False
    negLit (HsNumTy _ i) = i < 0
269
    negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
270

271 272 273 274 275 276 277 278
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
279
       ; return (HsIParamTy n ty', fvs) }
280

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
281
rnHsTyKi isType doc (HsEqTy ty1 ty2)
282 283 284 285
  = ASSERT( isType )
    do { (ty1', fvs1) <- rnLHsType doc ty1
       ; (ty2', fvs2) <- rnLHsType doc ty2
       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
286

287
rnHsTyKi isType _ (HsSpliceTy sp k)
288
  = ASSERT( isType )
gmainland's avatar
gmainland committed
289
    rnSpliceType sp k
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
290

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
291
rnHsTyKi isType doc (HsDocTy ty haddock_doc)
292
  = ASSERT( isType )
293 294 295
    do { (ty', fvs) <- rnLHsType doc ty
       ; haddock_doc' <- rnLHsDoc haddock_doc
       ; return (HsDocTy ty' haddock_doc', fvs) }
296

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
297
rnHsTyKi isType _ (HsCoreTy ty)
298
  = ASSERT( isType )
299
    return (HsCoreTy ty, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
300
    -- The emptyFVs probably isn't quite right
301 302
    -- but I don't think it matters

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
303
rnHsTyKi _ _ (HsWrapTy {})
304
  = panic "rnHsTyKi"
dreixel's avatar
dreixel committed
305

306
rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
307
  = ASSERT( isType )
308 309 310
    do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr isType ty))
       ; (tys', fvs) <- rnLHsTypes doc tys
311 312
       ; return (HsExplicitListTy k tys', fvs) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
313
rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
314
  = ASSERT( isType )
315 316 317
    do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr isType ty))
       ; (tys', fvs) <- rnLHsTypes doc tys
318 319
       ; return (HsExplicitTupleTy kis tys', fvs) }

thomasw's avatar
thomasw committed
320 321 322 323 324 325 326 327
rnHsTyKi _ _ HsWildcardTy = panic "rnHsTyKi HsWildcardTy"
                            -- Should be replaced by a HsNamedWildcardTy

rnHsTyKi isType _doc (HsNamedWildcardTy rdr_name)
  = ASSERT( isType )
    do { name <- rnTyVar isType rdr_name
       ; return (HsNamedWildcardTy name, unitFV name) }

328 329 330 331 332
--------------
rnTyVar :: Bool -> RdrName -> RnM Name
rnTyVar is_type rdr_name
  | is_type   = lookupTypeOccRn rdr_name
  | otherwise = lookupKindOccRn rdr_name
333

334

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
335
--------------
dreixel's avatar
dreixel committed
336
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
337 338
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
339

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
340
rnForAll :: HsDocContext -> HsExplicitFlag
thomasw's avatar
thomasw committed
341 342
         -> Maybe SrcSpan           -- Location of an extra-constraints wildcard
         -> [RdrName]               -- Kind variables
343
         -> LHsTyVarBndrs RdrName   -- Type variables
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
344
         -> LHsContext RdrName -> LHsType RdrName
345
         -> RnM (HsType Name, FreeVars)
346

thomasw's avatar
thomasw committed
347 348
rnForAll doc exp extra kvs forall_tyvars ctxt ty
  | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra
349
  = rnHsType doc (unLoc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
350
        -- One reason for this case is that a type like Int#
thomasw's avatar
thomasw committed
351
        -- starts off as (HsForAllTy Implicit Nothing [] Int), in case
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
352 353 354 355 356
        -- 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 *.
357

358 359
  | otherwise
  = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
360 361
    do { (new_ctxt, fvs1) <- rnContext doc ctxt
       ; (new_ty, fvs2) <- rnLHsType doc ty
thomasw's avatar
thomasw committed
362
       ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
363 364
        -- Retain the same implicit/explicit flag as before
        -- so that we can later print it correctly
365

366 367
---------------
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
368 369
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
370 371 372 373
-- 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
374 375 376 377 378
  = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
379 380

---------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
381
bindHsTyVars :: HsDocContext
382 383 384 385 386
             -> 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
387 388
-- (a) Bring kind variables into scope
--     both (i)  passed in (kv_bndrs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
389
--     and  (ii) mentioned in the kinds of tv_bndrs
390 391 392 393
-- (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
394
             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
395 396
                                 , let (_, kvs) = extractHsTyRdrTyVars kind
                                 , kv <- kvs ]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
397 398 399
             all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
             all_kvs  = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'

400 401 402 403 404
             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!

405
       ; poly_kind <- xoptM Opt_PolyKinds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
406
       ; unless (poly_kind || null all_kvs)
407
                (addErr (badKindBndrs doc all_kvs))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
408
       ; unless (null overlap_kvs)
409 410
                (addErr (overlappingKindVars doc overlap_kvs))

411 412
       ; loc <- getSrcSpanM
       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
413
       ; bindLocalNamesFV kv_names $
414 415
    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
416
             rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
417 418 419
             rn_tv_bndr (L loc (UserTyVar rdr))
               = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
                    ; return (L loc (UserTyVar nm), emptyFVs) }
Alan Zimmerman's avatar
Alan Zimmerman committed
420
             rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind))
421 422 423 424
               = do { sig_ok <- xoptM Opt_KindSignatures
                    ; unless sig_ok (badSigErr False doc kind)
                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
                    ; (kind', fvs) <- rnLHsKind doc kind
Alan Zimmerman's avatar
Alan Zimmerman committed
425
                    ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) }
426 427 428 429 430 431 432

       -- 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') $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
433 434 435 436 437 438
                        do { inner_rdr_env <- getLocalRdrEnv
                           ; traceRn (text "bhtv" <+> vcat
                                 [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs
                                 , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs'
                                 , ppr $ map (getUnique . rdrNameOcc) all_kvs'
                                 , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ])
439 440
                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
       ; return (res, fvs1 `plusFV` fvs2) } }
441

442 443 444 445
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
446 447
  = return n
  | otherwise
448
  = newLocalBndrRn (L loc rdr)
449 450

--------------------------------
451
rnHsBndrSig :: HsDocContext
452 453
            -> HsWithBndrs RdrName (LHsType RdrName)
            -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
454
            -> RnM (a, FreeVars)
455 456 457 458
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
459 460 461 462 463
       ; 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) ]
thomasw's avatar
thomasw committed
464
       ; (wcs, ty') <- extractWildcards ty
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
465 466
       ; bindLocalNamesFV kv_names $
         bindLocalNamesFV tv_names $
thomasw's avatar
thomasw committed
467 468 469 470
         bindLocatedLocalsFV wcs $ \wcs_new ->
    do { (ty'', fvs1) <- rnLHsType doc ty'
       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty'', hswb_kvs = kv_names,
                                             hswb_tvs = tv_names, hswb_wcs = wcs_new })
471 472
       ; return (res, fvs1 `plusFV` fvs2) } }

473 474
overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
overlappingKindVars doc kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
475 476
  = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
           ptext (sLit "also used as type variable") <> plural kvs
477 478 479
           <> colon <+> pprQuotedList kvs
         , docOfHsDocContext doc ]

480 481 482
badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
badKindBndrs doc kvs
  = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
483
                 <+> pprQuotedList kvs)
484
              2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
485 486 487 488 489
         , 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
490
    vcat [ hang (ptext (sLit "Illegal") <+> what
491 492 493 494 495 496
                 <+> 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")
497 498
    flag | is_type   = ptext (sLit "ScopedTypeVariables")
         | otherwise = ptext (sLit "KindSignatures")
499 500 501 502

dataKindsErr :: Bool -> HsType RdrName -> SDoc
dataKindsErr is_type thing
  = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
503
       2 (ptext (sLit "Perhaps you intended to use DataKinds"))
504 505 506
  where
    what | is_type   = ptext (sLit "type")
         | otherwise = ptext (sLit "kind")
dreixel's avatar
dreixel committed
507

Austin Seipp's avatar
Austin Seipp committed
508 509 510
{-
*********************************************************
*                                                      *
511
\subsection{Contexts and predicates}
Austin Seipp's avatar
Austin Seipp committed
512 513 514
*                                                      *
*********************************************************
-}
515

516 517
rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
                -> RnM ([LConDeclField Name], FreeVars)
518 519
rnConDeclFields doc fields = mapFvRn (rnField doc) fields

520 521 522 523
rnField :: HsDocContext -> LConDeclField RdrName
        -> RnM (LConDeclField Name, FreeVars)
rnField doc (L l (ConDeclField names ty haddock_doc))
  = do { new_names <- mapM lookupLocatedTopBndrRn names
524 525
       ; (new_ty, fvs) <- rnLHsType doc ty
       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
526
       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
527

528
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
529
rnContext doc (L loc cxt)
530 531
  = do { (cxt', fvs) <- rnLHsTypes doc cxt
       ; return (L loc cxt', fvs) }
532

Austin Seipp's avatar
Austin Seipp committed
533 534 535
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
536
        Fixities and precedence parsing
Austin Seipp's avatar
Austin Seipp committed
537 538
*                                                                      *
************************************************************************
539

540 541 542 543 544 545 546 547 548
@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.
549
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
550
        a `op` b `op` c
551
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
552
        a `op` (b `op` c)
553 554 555

mkHsOpTyRn rearranges where necessary.  The two arguments
have already been renamed and rearranged.  It's made rather tiresome
556
by the presence of ->, which is a separate syntactic construct.
Austin Seipp's avatar
Austin Seipp committed
557
-}
558

559 560 561
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
562 563
           -> Name -> Fixity -> LHsType Name -> LHsType Name
           -> RnM (HsType Name)
564

dreixel's avatar
dreixel committed
565
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
566
  = do  { fix2 <- lookupTyFixityRn op2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
567 568 569
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
                      (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
                      (unLoc op2) fix2 ty21 ty22 loc2 }
570

Ian Lynagh's avatar
Ian Lynagh committed
571
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
572 573
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
574

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
575
mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
576 577 578 579
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
580 581 582 583 584 585
            -> 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
586
  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
587
                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
588
  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
589 590 591
  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
592 593 594
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

595

596
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
597 598 599 600 601
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)
602 603 604

-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
605 606 607
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
608

609 610 611
  | associate_right = do
    new_e <- mkOpAppRn e12 op2 fix2 e2
    return (OpApp e11 op1 fix1 (L loc' new_e))
612 613 614 615 616
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
617
--      (- neg_arg) `op` e2
618
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
619 620 621
  | nofix_error
  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
622

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
623
  | associate_right
624 625
  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
       return (NegApp (L loc' new_e) neg_name)
626 627 628 629 630
  where
    loc' = combineLocs neg_arg e2
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
631 632 633
--      e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
  | not associate_right                 -- We *want* right association
634 635
  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
       return (OpApp e1 op1 fix1 e2)
636 637 638 639
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
640 641
--      Default case
mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
642
  = ASSERT2( right_op_ok fix (unLoc e2),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
643
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
644
    )
645
    return (OpApp e1 op fix e2)
646

647 648 649 650 651
----------------------------
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
652
-- Parser left-associates everything, but
653 654
-- 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
655
right_op_ok :: Fixity -> HsExpr Name -> Bool
656 657 658 659
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
660
right_op_ok _ _
661 662 663 664 665 666 667
  = 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) )
668
    return (NegApp neg_arg neg_name)
669

Ian Lynagh's avatar
Ian Lynagh committed
670
not_op_app :: HsExpr id -> Bool
671
not_op_app (OpApp _ _ _ _) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
672
not_op_app _               = True
673 674

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
675 676 677 678
mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity     -- Operator and fixity
          -> LHsCmdTop Name             -- Right operand (not an infix)
          -> RnM (HsCmd Name)
679 680

-- (e11 `op1` e12) `op2` e2
681
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
682
        op2 fix2 a2
683 684
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
685
       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
686 687 688

  | associate_right
  = do new_c <- mkOpFormRn a12 op2 fix2 a2
689
       return (HsCmdArrForm op1 (Just fix1)
690 691
               [a11, L loc (HsCmdTop (L loc new_c)
               placeHolderType placeHolderType [])])
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
692
        -- TODO: locs are wrong
693 694 695
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
696 697
--      Default case
mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
698
  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
699 700 701 702


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
703
             -> RnM (Pat Name)
704 705

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
709 710 711
        ; if nofix_error then do
                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
712

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
713 714 715 716
          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)) }
717

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
718
mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
719
  = ASSERT( not_op_pat (unLoc p2) )
720
    return (ConPatIn op (InfixCon p1 p2))
721

Ian Lynagh's avatar
Ian Lynagh committed
722
not_op_pat :: Pat Name -> Bool
723
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
724
not_op_pat _                           = True
725 726

--------------------------------------
727
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
728 729 730
  -- Check precedence of a function binding written infix
  --   eg  a `op` b `C` c = ...
  -- See comments with rnExpr (OpApp ...) about "deriving"
731

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
732 733
checkPrecMatch op (MG { mg_alts = ms })
  = mapM_ check ms
734
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
735
    check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
736 737 738
      = setSrcSpan (combineSrcSpans l1 l2) $
        do checkPrec op p1 False
           checkPrec op p2 True
739

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
740 741 742 743 744 745 746 747
    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.
748

Ian Lynagh's avatar
Ian Lynagh committed
749
checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
750 751 752
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)
753
    let
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
754 755 756 757 758 759 760 761
        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)
762
    unless inf_ok (precParseErr infol infor)
763

Ian Lynagh's avatar
Ian Lynagh committed
764
checkPrec _ _ _
765
  = return ()
766 767 768 769 770 771

-- 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
772
        -> LHsExpr Name -> LHsExpr Name -> RnM ()
773 774
checkSectionPrec direction section op arg
  = case unLoc arg of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
775 776 777
        OpApp _ op fix _ -> go_for_it (get_op op) fix
        NegApp _ _       -> go_for_it negateName  negateFixity
        _                -> return ()
778
  where
779 780
    op_name = get_op op
    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
781
          op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
782 783 784 785
          unless (op_prec < arg_prec
                  || (op_prec == arg_prec && direction == assoc))
                 (sectionPrecErr (op_name, op_fix)
                                 (arg_op, arg_fix) section)
786

Austin Seipp's avatar
Austin Seipp committed
787
-- Precedence-related error messages
788

789
precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
790
precParseErr op1@(n1,_) op2@(n2,_)
791
  | isUnboundName n1 || isUnboundName n2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
792
  = return ()     -- Avoid error cascade
793 794
  | otherwise
  = addErr $ hang (ptext (sLit "Precedence parsing error"))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
795 796 797
      4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
               ppr_opfix op2,
               ptext (sLit "in the same infix expression")])
798

799 800 801
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
802
  = return ()     -- Avoid error cascade
803 804
  | otherwise
  = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
805 806 807
         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))]
808

809 810 811 812
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
813
           | otherwise        = quotes (ppr op)
814

Austin Seipp's avatar
Austin Seipp committed
815 816 817
{-
*********************************************************
*                                                      *
simonpj's avatar