RnTypes.hs 51.3 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
{-# LANGUAGE CPP #-}
thomasw's avatar
thomasw committed
8
{-# LANGUAGE ScopedTypeVariables #-}
9

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
10
11
12
module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
dreixel's avatar
dreixel committed
13
        rnHsKind, rnLHsKind, rnLHsMaybeKind,
14
15
16
17
18
19
        rnHsSigType, rnHsWcType,
        rnHsSigWcType, rnHsSigWcTypeScoped,
        rnLHsInstType,
        newTyVarNameRn, collectAnonWildCards,
        rnConDeclFields,
        rnLTyVar, rnLHsTyVarBndr,
20

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
21
22
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
23
        checkPrecMatch, checkSectionPrec,
24

dreixel's avatar
dreixel committed
25
        -- Binding related stuff
26
27
        warnUnusedForAlls,
        bindSigTyVarsFV, bindHsQTyVars,
28
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
29
        extractRdrKindSigVars, extractDataDefnKindVars
30
  ) where
31

gmainland's avatar
gmainland committed
32
import {-# SOURCE #-} RnSplice( rnSpliceType )
33

34
import DynFlags
35
import HsSyn
36
import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
37
import RnEnv
38
import TcRnMonad
39
import RdrName
40
import PrelNames        ( negateName, dot_tv_RDR, forall_tv_RDR )
41
import TysPrim          ( funTyConName )
42
43
import Name
import SrcLoc
44
import NameSet
Adam Gundry's avatar
Adam Gundry committed
45
import FieldLabel
46

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

thomasw's avatar
thomasw committed
56
57
58
59
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid      ( mappend, mempty, mconcat )
#endif

60
61
#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
62
{-
63
64
65
These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

Austin Seipp's avatar
Austin Seipp committed
66
*********************************************************
67
68
69
*                                                       *
           HsSigWcType (i.e with wildcards)
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
70
71
*********************************************************
-}
72

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName
            -> RnM (LHsSigWcType Name, FreeVars)
rnHsSigWcType doc sig_ty
  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
    return (sig_ty', emptyFVs)

rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName
                    -> (LHsSigWcType Name -> RnM (a, FreeVars))
                    -> RnM (a, FreeVars)
-- Used for
--   - Signatures on binders in a RULE
--   - Pattern type signatures
-- Wildcards are allowed
rnHsSigWcTypeScoped ctx sig_ty thing_inside
  = rn_hs_sig_wc_type False ctx sig_ty thing_inside
    -- False: for pattern type sigs and rules we /do/ want
    --        to bring those type varibles into scope
    -- e.g  \ (x :: forall a. a-> b) -> e
    -- Here we do bring 'b' into scope

rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
                  -> HsDocContext
                  -> LHsSigWcType RdrName
                  -> (LHsSigWcType Name -> RnM (a, FreeVars))
                  -> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
rn_hs_sig_wc_type no_implicit_if_forall ctxt
                  (HsIB { hsib_body = wc_ty }) thing_inside
  = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ kvs tvs ->
    rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
    thing_inside (HsIB { hsib_kvs  = kvs
                       , hsib_tvs  = tvs
                       , hsib_body = wc_ty' })

rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
rnHsWcType ctxt wc_ty
  = rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
    return (wc_ty', emptyFVs)

rn_hs_wc_type :: HsDocContext -> LHsWcType RdrName
              -> (LHsWcType Name -> RnM (a, FreeVars))
              -> RnM (a, FreeVars)
rn_hs_wc_type ctxt (HsWC { hswc_body = hs_ty }) thing_inside
  = do { let nwc_rdrs = collectNamedWildCards hs_ty
       ; rdr_env <- getLocalRdrEnv
       ; nwcs <- sequence [ newLocalBndrRn lrdr
                          | lrdr@(L _ rdr) <- nwc_rdrs
                          , not (inScope rdr_env rdr) ]
                 -- nwcs :: [Name]   Named wildcards
       ; bindLocalNamesFV nwcs $
    do { (wc_ty, fvs1) <- rnWcSigTy ctxt hs_ty
       ; let wc_ty' :: HsWildCardBndrs Name (LHsType Name)
             wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty }
       ; (res, fvs2) <- thing_inside wc_ty'
       ; return (res, fvs1 `plusFV` fvs2) } }
128

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
rnWcSigTy :: HsDocContext -> LHsType RdrName
          -> RnM (LHsWcType Name, FreeVars)
-- Renames just the top level of a type signature
-- It's exactly like rnHsTyKi, except that it uses rnWcSigContext
-- on a qualified type, and return info on any extra-constraints
-- wildcard.  Some code duplication, but no big deal.
rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
  = bindLHsTyVarBndrs ctxt Nothing tvs $ \ tvs' ->
    do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau
       ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs
       ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
       ; return ( hs_tau' { hswc_body = L loc hs_ty' }, fvs) }

rnWcSigTy ctxt (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau }))
  = do { (hs_ctxt', fvs1) <- rnWcSigContext ctxt hs_ctxt
       ; (tau',     fvs2) <- rnLHsType ctxt tau
       ; let awcs_tau = collectAnonWildCards tau'
             hs_ty'   = HsQualTy { hst_ctxt = hswc_body hs_ctxt'
                                 , hst_body = tau' }
       ; return ( HsWC { hswc_wcs = hswc_wcs hs_ctxt' ++ awcs_tau
                       , hswc_ctx = hswc_ctx hs_ctxt'
                       , hswc_body = L loc hs_ty' }
                , fvs1 `plusFV` fvs2) }

rnWcSigTy ctxt hs_ty
  = do { (hs_ty', fvs) <- rnLHsType ctxt hs_ty
       ; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty'
                      , hswc_ctx = Nothing
                      , hswc_body = hs_ty' }
                , fvs) }

rnWcSigContext :: HsDocContext -> LHsContext RdrName
               -> RnM (HsWildCardBndrs Name (LHsContext Name), FreeVars)
rnWcSigContext ctxt (L loc hs_ctxt)
  | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
  , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
  = do { (hs_ctxt1', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt1
       ; wc'              <- setSrcSpan lx $
                             rnExtraConstraintWildCard ctxt wc
       ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
             awcs     = concatMap collectAnonWildCards hs_ctxt1'
             -- NB: *not* including the extra-constraint wildcard
       ; return ( HsWC { hswc_wcs = awcs
                       , hswc_ctx = Just lx
                       , hswc_body = L loc hs_ctxt' }
                , fvs ) }
  | otherwise
  = do { (hs_ctxt', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt
       ; return (HsWC { hswc_wcs = concatMap collectAnonWildCards hs_ctxt'
                      , hswc_ctx = Nothing
                      , hswc_body = L loc hs_ctxt' }, fvs) }
180

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

{- ******************************************************
*                                                       *
           HsSigtype (i.e. no wildcards)
*                                                       *
****************************************************** -}

rnHsSigType :: HsDocContext -> LHsSigType RdrName
            -> RnM (LHsSigType Name, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType ctx (HsIB { hsib_body = hs_ty })
  = rnImplicitBndrs True hs_ty $ \ kvs tvs ->
    do { (body', fvs) <- rnLHsType ctx hs_ty
       ; return (HsIB { hsib_kvs  = kvs
                      , hsib_tvs  = tvs
                      , hsib_body = body' }, fvs) }

rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
                           --          if type is headed by a forall
                           -- E.g.  f :: forall a. a->b
                           -- Do not quantify over 'b' too.
                -> LHsType RdrName
                -> ([Name] -> [Name] -> RnM (a, FreeVars))
                -> RnM (a, FreeVars)
rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside
  = do { rdr_env <- getLocalRdrEnv
       ; let (kv_rdrs, tv_rdrs) = filterInScope rdr_env $
                                  extractHsTyRdrTyVars hs_ty
             real_tv_rdrs  -- Implicit quantification only if
                           -- there is no explicit forall
               | no_implicit_if_forall
               , L _ (HsForAllTy {}) <- hs_ty = []
               | otherwise                    = tv_rdrs
       ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr kv_rdrs $$ ppr tv_rdrs))
       ; kvs <- mapM (newLocalBndrRn . L loc) kv_rdrs
       ; tvs <- mapM (newLocalBndrRn . L loc) real_tv_rdrs
       ; bindLocalNamesFV (kvs ++ tvs) $
         thing_inside kvs tvs }

rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars)
-- Rename the type in an instance or standalone deriving decl
-- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
rnLHsInstType doc_str inst_ty
  | Just cls <- getLHsInstDeclClass_maybe inst_ty
  , isTcOcc (rdrNameOcc (unLoc cls))
         -- The guards check that the instance type looks like
         --   blah => C ty1 .. tyn
  = do { let full_doc = doc_str <+> ptext (sLit "for") <+> quotes (ppr cls)
       ; rnHsSigType (GenericCtx full_doc) inst_ty }

  | otherwise  -- The instance is malformed, but we'd still like
               -- to make progress rather than failing outright, so
               -- we report more errors.  So we rename it anyway.
  = do { addErrAt (getLoc (hsSigType inst_ty)) $
         ptext (sLit "Malformed instance:") <+> ppr inst_ty
       ; rnHsSigType (GenericCtx doc_str) inst_ty }


{- ******************************************************
*                                                       *
           LHsType and HsType
*                                                       *
****************************************************** -}
245

Austin Seipp's avatar
Austin Seipp committed
246
{-
247
248
249
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
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
268
-}
269

270
rnLHsTyKi  :: RnTyKiWhat
271
           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
272
rnLHsTyKi what doc (L loc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
273
  = setSrcSpan loc $
274
    do { (ty', fvs) <- rnHsTyKi what doc ty
275
       ; return (L loc ty', fvs) }
dreixel's avatar
dreixel committed
276

277
rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
278
279
280
281
282
rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $
                   rnLHsTyKi RnType cxt ty

rnLHsPred  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsPred = rnLHsTyKi RnConstraint
283
284

rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
285
rnLHsKind = rnLHsTyKi RnKind
dreixel's avatar
dreixel committed
286

287
288
rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
                -> RnM (Maybe (LHsKind Name), FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
289
rnLHsMaybeKind _ Nothing
290
  = return (Nothing, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
291
rnLHsMaybeKind doc (Just kind)
292
293
  = do { (kind', fvs) <- rnLHsKind doc kind
       ; return (Just kind', fvs) }
294
295

rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
296
rnHsType cxt ty = rnHsTyKi RnType cxt ty
297

298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
rnHsKind = rnHsTyKi RnKind

data RnTyKiWhat = RnType
                | RnKind
                | RnTopConstraint  -- Top-level context of HsSigWcTypes
                | RnConstraint     -- All other constraints

instance Outputable RnTyKiWhat where
  ppr RnType          = ptext (sLit "RnType")
  ppr RnKind          = ptext (sLit "RnKind")
  ppr RnTopConstraint = ptext (sLit "RnTopConstraint")
  ppr RnConstraint    = ptext (sLit "RnConstraint")

isRnType :: RnTyKiWhat -> Bool
isRnType RnType = True
isRnType _      = False

isRnKind :: RnTyKiWhat -> Bool
isRnKind RnKind = True
isRnKind _      = False

rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)

rnHsTyKi _ doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
  = bindLHsTyVarBndrs doc Nothing tyvars $ \ tyvars' ->
    do { (tau',  fvs) <- rnLHsType doc tau
       ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs
       ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
                , fvs) }

rnHsTyKi _ doc (HsQualTy { hst_ctxt = lctxt
                              , hst_body = tau })
  = do { (ctxt', fvs1) <- rnContext doc lctxt
       ; (tau',  fvs2) <- rnLHsType doc tau
       ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
                , fvs1 `plusFV` fvs2) }

rnHsTyKi what _ (HsTyVar (L loc rdr_name))
  = do { name <- rnTyVar what rdr_name
       ; return (HsTyVar (L loc name), unitFV name) }
339

340
341
342
-- 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
343
344
rnHsTyKi what doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
  = setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
345
346
    do  { ops_ok <- xoptM Opt_TypeOperators
        ; op' <- if ops_ok
347
                 then rnTyVar what op
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
348
                 else do { addErr (opTyErr op ty)
349
                         ; return (mkUnboundNameRdr op) }  -- Avoid double complaint
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
350
351
        ; let l_op' = L loc op'
        ; fix <- lookupTyFixityRn l_op'
352
353
        ; (ty1', fvs1) <- rnLHsTyKi what doc ty1
        ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
354
        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
355
356
                               op' fix ty1' ty2'
        ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
357

358
359
rnHsTyKi what doc (HsParTy ty)
  = do { (ty', fvs) <- rnLHsTyKi what doc ty
360
       ; return (HsParTy ty', fvs) }
361

362
363
rnHsTyKi _ doc (HsBangTy b ty)
  = do { (ty', fvs) <- rnLHsType doc ty
364
       ; return (HsBangTy b ty', fvs) }
365

Alan Zimmerman's avatar
Alan Zimmerman committed
366
367
368
369
370
371
372
373
rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
  = do {
       -- AZ:reviewers: is there a monadic version of concatMap?
         flss <- mapM (lookupConstructorFields . unLoc) names
       ; let fls = concat flss
       ; (flds', fvs) <- rnConDeclFields fls doc flds
       ; return (HsRecTy flds', fvs) }

374
375
376
rnHsTyKi _ doc ty@(HsRecTy flds)
  = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                    2 (ppr ty))
Adam Gundry's avatar
Adam Gundry committed
377
       ; (flds', fvs) <- rnConDeclFields [] doc flds
378
       ; return (HsRecTy flds', fvs) }
379

380
381
rnHsTyKi what doc (HsFunTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
382
        -- Might find a for-all as the arg of a function type
383
       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
384
385
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
386

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
387
        -- Check for fixity rearrangements
388
       ; res_ty <- if isRnType what
389
390
                   then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
                   else return (HsFunTy ty1' ty2')
391

392
       ; return (res_ty, fvs1 `plusFV` fvs2) }
dreixel's avatar
dreixel committed
393

394
rnHsTyKi what doc listTy@(HsListTy ty)
395
  = do { data_kinds <- xoptM Opt_DataKinds
396
397
398
       ; when (not data_kinds && isRnKind what)
              (addErr (dataKindsErr what listTy))
       ; (ty', fvs) <- rnLHsTyKi what doc ty
399
       ; return (HsListTy ty', fvs) }
400

401
402
403
rnHsTyKi _ doc (HsKindSig ty k)
  = do { kind_sigs_ok <- xoptM Opt_KindSignatures
       ; unless kind_sigs_ok (badKindSigErr doc ty)
404
405
406
       ; (ty', fvs1) <- rnLHsType doc ty
       ; (k', fvs2) <- rnLHsKind doc k
       ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
407

408
409
rnHsTyKi _ doc (HsPArrTy ty)
  = do { (ty', fvs) <- rnLHsType doc ty
410
       ; return (HsPArrTy ty', fvs) }
chak's avatar
chak committed
411

412
413
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
414
rnHsTyKi what doc tupleTy@(HsTupleTy tup_con tys)
415
  = do { data_kinds <- xoptM Opt_DataKinds
416
417
418
       ; when (not data_kinds && isRnKind what)
              (addErr (dataKindsErr what tupleTy))
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
419
420
       ; return (HsTupleTy tup_con tys', fvs) }

421
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
422
rnHsTyKi what _ tyLit@(HsTyLit t)
423
  = do { data_kinds <- xoptM Opt_DataKinds
424
       ; unless data_kinds (addErr (dataKindsErr what tyLit))
425
       ; when (negLit t) (addErr negLitErr)
426
       ; return (HsTyLit t, emptyFVs) }
427
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
428
429
    negLit (HsStrTy _ _) = False
    negLit (HsNumTy _ i) = i < 0
430
    negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
431

432
433
434
rnHsTyKi what doc (HsAppTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1
       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
435
436
       ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }

437
438
rnHsTyKi _ doc (HsIParamTy n ty)
  = do { (ty', fvs) <- rnLHsType doc ty
439
       ; return (HsIParamTy n ty', fvs) }
440

441
442
rnHsTyKi _ doc (HsEqTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsType doc ty1
443
444
       ; (ty2', fvs2) <- rnLHsType doc ty2
       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
445

446
447
rnHsTyKi _ _ (HsSpliceTy sp k)
  = rnSpliceType sp k
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
448

449
450
rnHsTyKi _ doc (HsDocTy ty haddock_doc)
  = do { (ty', fvs) <- rnLHsType doc ty
451
452
       ; haddock_doc' <- rnLHsDoc haddock_doc
       ; return (HsDocTy ty' haddock_doc', fvs) }
453

454
455
rnHsTyKi _ _ (HsCoreTy ty)
  = return (HsCoreTy ty, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
456
    -- The emptyFVs probably isn't quite right
457
458
    -- but I don't think it matters

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
459
rnHsTyKi _ _ (HsWrapTy {})
460
  = panic "rnHsTyKi"
dreixel's avatar
dreixel committed
461

462
463
464
rnHsTyKi what doc ty@(HsExplicitListTy k tys)
  = do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr what ty))
465
       ; (tys', fvs) <- rnLHsTypes doc tys
466
467
       ; return (HsExplicitListTy k tys', fvs) }

468
469
470
rnHsTyKi what doc ty@(HsExplicitTupleTy kis tys)
  = do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr what ty))
471
       ; (tys', fvs) <- rnLHsTypes doc tys
472
473
       ; return (HsExplicitTupleTy kis tys', fvs) }

474
475
476
477
478
479
480
481
482
483
rnHsTyKi what ctxt (HsWildCardTy wc)
  = do { wc' <- case mb_bad of
           Just msg -> do { addErr (wildCardMsg ctxt msg)
                          ; discardErrs (rnWildCard ctxt wc) }
                          -- discardErrs: avoid reporting
                          -- a second error
           Nothing  -> rnWildCard ctxt wc

       ; traceRn (text "rnHsTyKi wild" <+> ppr wc <+> ppr (isJust mb_bad))
       ; return (HsWildCardTy wc', emptyFVs) }
484
         -- emptyFVs: this occurrence does not refer to a
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
         --           user-written binding site, so don't treat
         --           it as a free variable
  where
    mb_bad :: Maybe SDoc
    mb_bad | not (wildCardsAllowed ctxt)
           = Just (notAllowed wc)
           | otherwise
           = case what of
               RnType          -> Nothing
               RnKind          -> Just (notAllowed wc <+> ptext (sLit "in a kind"))
               RnConstraint    -> Just constraint_msg
               RnTopConstraint -> case wc of
                     AnonWildCard {}  -> Just constraint_msg
                     NamedWildCard {} -> Nothing

    constraint_msg = hang (notAllowed wc <+> ptext (sLit "in a constraint"))
                        2 hint_msg

    hint_msg = case wc of
       NamedWildCard {} -> empty
       AnonWildCard {}  -> vcat [ ptext (sLit "except as the last top-level constraint of a type signature")
                                , nest 2 (ptext (sLit "e.g  f :: (Eq a, _) => blah")) ]

notAllowed :: HsWildCardInfo RdrName -> SDoc
notAllowed wc =  ptext (sLit "Wildcard") <+> quotes (ppr wc)
                 <+> ptext (sLit "not allowed")

wildCardMsg :: HsDocContext -> SDoc -> SDoc
wildCardMsg ctxt doc
  = vcat [doc, nest 2 (ptext (sLit "in") <+> pprHsDocContext ctxt)]
thomasw's avatar
thomasw committed
515

516
--------------
517
518
519
520
rnTyVar :: RnTyKiWhat -> RdrName -> RnM Name
rnTyVar what rdr_name
  | isRnKind what = lookupKindOccRn rdr_name
  | otherwise     = lookupTypeOccRn rdr_name
521

522
523
524
525
rnLTyVar :: Located RdrName -> RnM (Located Name)
rnLTyVar (L loc rdr_name)
  = do { tyvar <- lookupTypeOccRn rdr_name
       ; return (L loc tyvar) }
526

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
527
--------------
dreixel's avatar
dreixel committed
528
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
529
530
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
531

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
--------------
extraConstraintWildCardsAllowed :: HsDocContext -> Bool
extraConstraintWildCardsAllowed ctxt
  = case ctxt of
      TypeSigCtx {}       -> True
      _                   -> False

wildCardsAllowed :: HsDocContext -> Bool
-- ^ In what contexts are wildcards permitted
wildCardsAllowed ctxt
   = case ctxt of
       TypeSigCtx {}       -> True
       TypBrCtx {}         -> True   -- Template Haskell quoted type
       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice
       ExprWithTySigCtx {} -> True
       PatCtx {}           -> True
       RuleCtx {}          -> True
       FamPatCtx {}        -> True   -- Not named wildcards though
       GHCiCtx {}          -> True
       _                   -> False

rnExtraConstraintWildCard :: HsDocContext -> HsWildCardInfo RdrName
                          -> RnM (HsWildCardInfo Name)
-- Rename the extra-constraint spot in a type signature
--    (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
rnExtraConstraintWildCard ctxt wc
  = case mb_bad of
      Nothing  -> rnWildCard ctxt wc
      Just msg -> do { addErr (wildCardMsg ctxt msg)
                     ; discardErrs (rnWildCard ctxt wc) }
  where
    mb_bad | not (extraConstraintWildCardsAllowed ctxt)
           = Just (ptext (sLit "Extra-contraint wildcard") <+> quotes (ppr wc)
                   <+> ptext (sLit "not allowed"))
           | isNamedWildCard wc
           = Just (hang (ptext (sLit "Named wildcard") <+> quotes (ppr wc)
                         <+> ptext (sLit "not allowed as an extra-contraint"))
                      2 (ptext (sLit "Use an anonymous wildcard instead")))
           | otherwise
           = Nothing

rnWildCard :: HsDocContext -> HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)
rnWildCard _ (AnonWildCard _)
  = do { loc <- getSrcSpanM
       ; uniq <- newUnique
       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
       ; return (AnonWildCard (L loc name)) }

rnWildCard ctxt wc@(NamedWildCard (L loc rdr_name))
  -- NB: The parser only generates NamedWildCard if -XNamedWildCards
  --     is on, so we don't need to check for that here
  = do { mb_name <- lookupOccRn_maybe rdr_name
       ; traceRn (text "rnWildCard named" <+> (ppr rdr_name $$ ppr mb_name))
       ; case mb_name of
           Just n  -> return (NamedWildCard (L loc n))
           Nothing -> do { addErr msg  -- I'm not sure how this can happen
                         ; return (NamedWildCard (L loc (mkUnboundNameRdr rdr_name))) } }
  where
    msg = wildCardMsg ctxt (notAllowed wc)
593

594

595
596
597
598
599
600
{- *****************************************************
*                                                      *
          Binding type variables
*                                                      *
***************************************************** -}

601
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
602
603
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
604
605
606
607
-- 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
608
609
610
611
612
  = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
613
614

---------------
615
616
617
618
619
620
bindHsQTyVars :: HsDocContext
              -> Maybe a              -- Just _  => an associated type decl
              -> [RdrName]            -- Kind variables from scope
              -> LHsQTyVars RdrName   -- Type variables
              -> (LHsQTyVars Name -> RnM (b, FreeVars))
              -> RnM (b, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
621
622
-- (a) Bring kind variables into scope
--     both (i)  passed in (kv_bndrs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
623
--     and  (ii) mentioned in the kinds of tv_bndrs
624
-- (b) Bring type variables into scope
625
bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
626
627
  = do { rdr_env <- getLocalRdrEnv
       ; let tvs = hsQTvBndrs tv_bndrs
628
             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
629
630
                                 , let (_, kvs) = extractHsTyRdrTyVars kind
                                 , kv <- kvs ]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
631
             all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
632
             all_kvs  = filterOut (inScope rdr_env) all_kvs'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
633

634
635
636
637
638
             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!

639
       ; poly_kind <- xoptM Opt_PolyKinds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
640
       ; unless (poly_kind || null all_kvs)
641
                (addErr (badKindBndrs doc all_kvs))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
642
       ; unless (null overlap_kvs)
643
644
                (addErr (overlappingKindVars doc overlap_kvs))

645
646
       ; loc <- getSrcSpanM
       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
647
       ; bindLocalNamesFV kv_names $
648
649
650
651
652
653
654
655
656
657
         bindLHsTyVarBndrs doc mb_assoc tvs $ \ tv_bndrs' ->
         thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }

bindLHsTyVarBndrs :: HsDocContext
                  -> Maybe a                 -- Just _  => an associated type decl
                  -> [LHsTyVarBndr RdrName]
                  -> ([LHsTyVarBndr Name] -> RnM (b, FreeVars))
                  -> RnM (b, FreeVars)
bindLHsTyVarBndrs doc mb_assoc tv_bndrs thing_inside
  = do { let tv_names_w_loc = map hsLTyVarLocName tv_bndrs
658
659
660
661
662

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

663
664
       ; rdr_env <- getLocalRdrEnv
       ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tv_bndrs
665
       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
666
667
                        thing_inside tv_bndrs'
       ; return (res, fvs1 `plusFV` fvs2) }
668

Jan Stolarek's avatar
Jan Stolarek committed
669
670
rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv
               -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
671
rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar (L l rdr)))
Jan Stolarek's avatar
Jan Stolarek committed
672
  = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
673
       ; return (L loc (UserTyVar (L l nm)), emptyFVs) }
Jan Stolarek's avatar
Jan Stolarek committed
674
675
rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind))
  = do { sig_ok <- xoptM Opt_KindSignatures
676
       ; unless sig_ok (badKindSigErr doc kind)
Jan Stolarek's avatar
Jan Stolarek committed
677
678
679
680
       ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
       ; (kind', fvs) <- rnLHsKind doc kind
       ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) }

681
682
683
684
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
685
686
  = return n
  | otherwise
687
  = newLocalBndrRn (L loc rdr)
688

689
690
691
692
693
---------------------
collectNamedWildCards :: LHsType RdrName -> [Located RdrName]
collectNamedWildCards hs_ty
  = nubBy eqLocated $
    [n | L _ (NamedWildCard n) <- collectWildCards hs_ty ]
694

695
696
697
collectAnonWildCards :: LHsType Name -> [Name]
collectAnonWildCards hs_ty
  = [n | L _ (AnonWildCard (L _ n)) <- collectWildCards hs_ty ]
698

699
700
701
collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)]
-- | Extract all wild cards from a type.
collectWildCards lty = go lty
702
  where
thomasw's avatar
thomasw committed
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
    go (L loc ty) = case ty of
      HsAppTy ty1 ty2         -> go ty1 `mappend` go ty2
      HsFunTy ty1 ty2         -> go ty1 `mappend` go ty2
      HsListTy ty             -> go ty
      HsPArrTy ty             -> go ty
      HsTupleTy _ tys         -> gos tys
      HsOpTy ty1 _ ty2        -> go ty1 `mappend` go ty2
      HsParTy ty              -> go ty
      HsIParamTy _ ty         -> go ty
      HsEqTy ty1 ty2          -> go ty1 `mappend` go ty2
      HsKindSig ty kind       -> go ty `mappend` go kind
      HsDocTy ty _            -> go ty
      HsBangTy _ ty           -> go ty
      HsRecTy flds            -> gos $ map (cd_fld_type . unLoc) flds
      HsExplicitListTy _ tys  -> gos tys
      HsExplicitTupleTy _ tys -> gos tys
      HsWrapTy _ ty           -> go (L loc ty)
      -- Interesting cases
721
722
723
724
      HsWildCardTy wc         -> [L loc wc]
      HsForAllTy { hst_body = ty } -> go ty
      HsQualTy { hst_ctxt = L _ ctxt
               , hst_body = ty }  -> gos ctxt `mappend` go ty
thomasw's avatar
thomasw committed
725
726
727
      -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
      _ -> mempty

728
    gos = mconcat . map go
thomasw's avatar
thomasw committed
729
730


Austin Seipp's avatar
Austin Seipp committed
731
732
{-
*********************************************************
Adam Gundry's avatar
Adam Gundry committed
733
734
735
*                                                       *
        ConDeclField
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
736
*********************************************************
Adam Gundry's avatar
Adam Gundry committed
737
738
739
740
741
742

When renaming a ConDeclField, we have to find the FieldLabel
associated with each field.  But we already have all the FieldLabels
available (since they were brought into scope by
RnNames.getLocalNonValBinders), so we just take the list as an
argument, build a map and look them up.
Austin Seipp's avatar
Austin Seipp committed
743
-}
744

Adam Gundry's avatar
Adam Gundry committed
745
rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
746
                -> RnM ([LConDeclField Name], FreeVars)
Adam Gundry's avatar
Adam Gundry committed
747
748
749
rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
  where
    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
750

Adam Gundry's avatar
Adam Gundry committed
751
rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
752
        -> RnM (LConDeclField Name, FreeVars)
Adam Gundry's avatar
Adam Gundry committed
753
754
rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
  = do { let new_names = map (fmap lookupField) names
755
756
       ; (new_ty, fvs) <- rnLHsType doc ty
       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
757
       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
Adam Gundry's avatar
Adam Gundry committed
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
  where
    lookupField :: FieldOcc RdrName -> FieldOcc Name
    lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
      where
        lbl = occNameFS $ rdrNameOcc rdr
        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl


{-
*********************************************************
*                                                       *
        Contexts
*                                                       *
*********************************************************
-}
773

774
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
775
rnContext doc (L loc cxt)
776
777
  = do { traceRn (text "rncontext" <+> ppr cxt)
       ; (cxt', fvs) <- mapFvRn (rnLHsPred doc) cxt
778
       ; return (L loc cxt', fvs) }
779

Austin Seipp's avatar
Austin Seipp committed
780
781
782
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
783
        Fixities and precedence parsing
Austin Seipp's avatar
Austin Seipp committed
784
785
*                                                                      *
************************************************************************
786

787
788
789
790
791
792
793
794
795
@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.
796
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
797
        a `op` b `op` c
798
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
799
        a `op` (b `op` c)
800
801
802

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

806
807
808
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
809
810
           -> Name -> Fixity -> LHsType Name -> LHsType Name
           -> RnM (HsType Name)
811

dreixel's avatar
dreixel committed
812
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
813
  = do  { fix2 <- lookupTyFixityRn op2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
814
815
816
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
                      (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
                      (unLoc op2) fix2 ty21 ty22 loc2 }
817

Ian Lynagh's avatar
Ian Lynagh committed
818
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
819
820
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
821

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
822
mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
823
824
825
826
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
827
828
829
830
831
832
            -> 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
833
  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
834
                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
835
  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
836
837
838
  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
839
840
841
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

842

843
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
844
845
846
847
848
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)
849
850
851

-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
852
853
854
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
855

856
857
858
  | associate_right = do
    new_e <- mkOpAppRn e12 op2 fix2 e2
    return (OpApp e11 op1 fix1 (L loc' new_e))
859
860
861
862
863
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
864
--      (- neg_arg) `op` e2
865
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
866
867
868
  | nofix_error
  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
869

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
870
  | associate_right
871
872
  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
       return (NegApp (L loc' new_e) neg_name)
873
874
875
876
877
  where
    loc' = combineLocs neg_arg e2
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
878
879
880
--      e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
  | not associate_right                 -- We *want* right association
881
882
  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
       return (OpApp e1 op1 fix1 e2)
883
884
885
886
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
887
888
--      Default case
mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
889
  = ASSERT2( right_op_ok fix (unLoc e2),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
890
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
891
    )
892
    return (OpApp e1 op fix e2)
893

894
895
----------------------------
get_op :: LHsExpr Name -> Name
896
-- An unbound name could be either HsVar or HsUnboundVar
897
-- See RnExpr.rnUnboundVar
898
get_op (L _ (HsVar (L _ n)))    = n
899
get_op (L _ (HsUnboundVar occ)) = mkUnboundName occ
900
get_op other                    = pprPanic "get_op" (ppr other)
901

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
902
-- Parser left-associates everything, but
903
904
-- 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
905
right_op_ok :: Fixity -> HsExpr Name -> Bool
906
907
908
909
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
910
right_op_ok _ _
911
912
913
914
915
916
917
  = 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) )
918
    return (NegApp neg_arg neg_name)
919

Ian Lynagh's avatar
Ian Lynagh committed
920
not_op_app :: HsExpr id -> Bool
921
not_op_app (OpApp _ _ _ _) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
922
not_op_app _               = True
923
924

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
925
926
927
928
mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity     -- Operator and fixity
          -> LHsCmdTop Name             -- Right operand (not an infix)
          -> RnM (HsCmd Name)
929
930

-- (e11 `op1` e12) `op2` e2
931
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
932
        op2 fix2 a2
933
934
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
935
       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
936
937
938

  | associate_right
  = do new_c <- mkOpFormRn a12 op2 fix2 a2
939
       return (HsCmdArrForm op1 (Just fix1)
940
941
               [a11, L loc (HsCmdTop (L loc new_c)
               placeHolderType placeHolderType [])])
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
942
        -- TODO: locs are wrong
943
944
945
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
946
947
--      Default case
mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
948
  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
949
950
951
952


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
953
             -> RnM (Pat Name)
954
955

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
959
960
961
        ; if nofix_error then do
                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
962

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
963
964
965
966
          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)) }
967

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
968
mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
969
  = ASSERT( not_op_pat (unLoc p2) )
970
    return (ConPatIn op (InfixCon p1 p2))
971

Ian Lynagh's avatar
Ian Lynagh committed
972
not_op_pat :: Pat Name -> Bool
973
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
974
not_op_pat _                           = True
975
976

--------------------------------------
977
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
978
979
980
  -- Check precedence of a function binding written infix
  --   eg  a `op` b `C` c = ...
  -- See comments with rnExpr (OpApp ...) about "deriving"
981

982
checkPrecMatch op (MG { mg_alts = L _ ms })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
983
  = mapM_ check ms
984
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
985
    check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
986
987
988
      = setSrcSpan (combineSrcSpans l1 l2) $
        do checkPrec op p1 False
           checkPrec op p2 True
989

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
990
991
992
993
994
995
996
997
    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.
998

Ian Lynagh's avatar
Ian Lynagh committed
999
checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
1000
1001
1002
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)
1003
    let
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1004
1005
1006
1007
1008
1009
1010
1011
        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)
1012
    unless inf_ok (precParseErr infol infor)
1013

Ian Lynagh's avatar
Ian Lynagh committed
1014
checkPrec _ _ _
1015
  = return ()
1016
1017
1018
1019
1020
1021

-- 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
1022
        -> LHsExpr Name -> LHsExpr Name -> RnM ()
1023
1024
checkSectionPrec direction section op arg
  = case unLoc arg of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1025
1026
1027
        OpApp _ op fix _ -> go_for_it (get_op op) fix
        NegApp _ _       -> go_for_it negateName  negateFixity
        _                -> return ()
1028
  where
1029
1030
    op_name = get_op op
    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
1031
          op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1032
1033
1034
1035
          unless (op_prec < arg_prec
                  || (op_prec == arg_prec && direction == assoc))
                 (sectionPrecErr (op_name, op_fix)
                                 (arg_op, arg_fix) section)
1036

Austin Seipp's avatar
Austin Seipp committed
1037
-- Precedence-related error messages
1038

1039
precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1040
precParseErr op1@(n1,_) op2@(n2,_)
1041
  | isUnboundName n1 || isUnboundName n2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1042
  = return ()     -- Avoid error cascade
1043
1044
  | otherwise
  = addErr $ hang (ptext (sLit "Precedence parsing error"))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1045
1046
1047
      4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
               ppr_opfix op2,
               ptext (sLit "in the same infix expression")])
1048

1049
1050
1051
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
1052
  = return ()     -- Avoid error cascade
1053
1054
  | otherwise
  = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1055
1056
1057
         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))]
1058

1059
1060
1061
1062
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
1063
           | otherwise        = quotes (ppr op)
1064

1065
{- *****************************************************
Austin Seipp's avatar
Austin Seipp committed
1066
*                                                      *
1067
                 Errors
Austin Seipp's avatar
Austin Seipp committed
1068
*                                                      *