RnTypes.hs 50.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,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
14
        rnHsSigType, rnLHsInstType, rnConDeclFields,
thomasw's avatar
thomasw committed
15
        newTyVarNameRn, rnLHsTypeWithWildCards,
Jan Stolarek's avatar
Jan Stolarek committed
16
        rnHsSigTypeWithWildCards, rnLTyVar, collectWildCards,
17

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

dreixel's avatar
dreixel committed
22
        -- Binding related stuff
23
        warnContextQuantification, warnUnusedForAlls,
Jan Stolarek's avatar
Jan Stolarek committed
24
        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, rnLHsTyVarBndr,
25
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
thomasw's avatar
thomasw committed
26
        extractRdrKindSigVars, extractDataDefnKindVars,
thomasw's avatar
thomasw committed
27
        filterInScope
28
  ) where
29

gmainland's avatar
gmainland committed
30
import {-# SOURCE #-} RnSplice( rnSpliceType )
31

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

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

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

58
59
#include "HsVersions.h"

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

Austin Seipp's avatar
Austin Seipp committed
64
65
*********************************************************
*                                                      *
66
\subsection{Renaming types}
Austin Seipp's avatar
Austin Seipp committed
67
68
69
*                                                      *
*********************************************************
-}
70

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

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

badInstTy :: LHsType RdrName -> SDoc
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
90
badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
91

Austin Seipp's avatar
Austin Seipp committed
92
{-
93
94
95
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
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
114
-}
115

dreixel's avatar
dreixel committed
116
rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
117
118
           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsTyKi isType doc (L loc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
119
  = setSrcSpan loc $
120
121
    do { (ty', fvs) <- rnHsTyKi isType doc ty
       ; return (L loc ty', fvs) }
dreixel's avatar
dreixel committed
122

123
rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
dreixel's avatar
dreixel committed
124
rnLHsType = rnLHsTyKi True
125
126

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

129
130
rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
                -> RnM (Maybe (LHsKind Name), FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
131
rnLHsMaybeKind _ Nothing
132
  = return (Nothing, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
133
rnLHsMaybeKind doc (Just kind)
134
135
  = do { (kind', fvs) <- rnLHsKind doc kind
       ; return (Just kind', fvs) }
136
137

rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
dreixel's avatar
dreixel committed
138
rnHsType = rnHsTyKi True
139
rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
dreixel's avatar
dreixel committed
140
141
rnHsKind = rnHsTyKi False

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

144
145
rnHsTyKi isType doc ty@HsForAllTy{}
  = rnHsTyKiForAll isType doc (flattenTopLevelHsForAllTy ty)
146

147
148
149
rnHsTyKi isType _ (HsTyVar rdr_name)
  = do { name <- rnTyVar isType rdr_name
       ; return (HsTyVar name, unitFV name) }
150

151
152
153
-- 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
154
rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
155
  = ASSERT( isType ) setSrcSpan loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
156
157
158
159
160
161
162
163
164
165
    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)
166
167
                               op' fix ty1' ty2'
        ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
168

169
170
171
rnHsTyKi isType doc (HsParTy ty)
  = do { (ty', fvs) <- rnLHsTyKi isType doc ty
       ; return (HsParTy ty', fvs) }
172

dreixel's avatar
dreixel committed
173
rnHsTyKi isType doc (HsBangTy b ty)
174
  = ASSERT( isType )
175
176
    do { (ty', fvs) <- rnLHsType doc ty
       ; return (HsBangTy b ty', fvs) }
177

178
179
180
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
181
       ; (flds', fvs) <- rnConDeclFields [] doc flds
182
       ; return (HsRecTy flds', fvs) }
183

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
191
        -- Check for fixity rearrangements
192
193
194
195
       ; 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
196

197
198
rnHsTyKi isType doc listTy@(HsListTy ty)
  = do { data_kinds <- xoptM Opt_DataKinds
199
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy))
200
201
       ; (ty', fvs) <- rnLHsTyKi isType doc ty
       ; return (HsListTy ty', fvs) }
202

dreixel's avatar
dreixel committed
203
rnHsTyKi isType doc (HsKindSig ty k)
204
  = ASSERT( isType )
205
206
207
208
209
    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) }
210

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
211
rnHsTyKi isType doc (HsPArrTy ty)
212
  = ASSERT( isType )
213
214
    do { (ty', fvs) <- rnLHsType doc ty
       ; return (HsPArrTy ty', fvs) }
chak's avatar
chak committed
215

216
217
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
218
219
rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
  = do { data_kinds <- xoptM Opt_DataKinds
220
       ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy))
221
222
223
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
       ; return (HsTupleTy tup_con tys', fvs) }

224
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
225
226
rnHsTyKi isType _ tyLit@(HsTyLit t)
  = do { data_kinds <- xoptM Opt_DataKinds
227
       ; unless data_kinds (addErr (dataKindsErr isType tyLit))
228
       ; when (negLit t) (addErr negLitErr)
229
       ; return (HsTyLit t, emptyFVs) }
230
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
231
232
    negLit (HsStrTy _ _) = False
    negLit (HsNumTy _ i) = i < 0
233
    negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
234

235
236
237
238
239
240
241
242
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
243
       ; return (HsIParamTy n ty', fvs) }
244

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

251
rnHsTyKi isType _ (HsSpliceTy sp k)
252
  = ASSERT( isType )
gmainland's avatar
gmainland committed
253
    rnSpliceType sp k
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
254

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
255
rnHsTyKi isType doc (HsDocTy ty haddock_doc)
256
  = ASSERT( isType )
257
258
259
    do { (ty', fvs) <- rnLHsType doc ty
       ; haddock_doc' <- rnLHsDoc haddock_doc
       ; return (HsDocTy ty' haddock_doc', fvs) }
260

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
261
rnHsTyKi isType _ (HsCoreTy ty)
262
  = ASSERT( isType )
263
    return (HsCoreTy ty, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
264
    -- The emptyFVs probably isn't quite right
265
266
    -- but I don't think it matters

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
267
rnHsTyKi _ _ (HsWrapTy {})
268
  = panic "rnHsTyKi"
dreixel's avatar
dreixel committed
269

270
rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
271
  = ASSERT( isType )
272
273
274
    do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr isType ty))
       ; (tys', fvs) <- rnLHsTypes doc tys
275
276
       ; return (HsExplicitListTy k tys', fvs) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
277
rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
278
  = ASSERT( isType )
279
280
281
    do { data_kinds <- xoptM Opt_DataKinds
       ; unless data_kinds (addErr (dataKindsErr isType ty))
       ; (tys', fvs) <- rnLHsTypes doc tys
282
283
       ; return (HsExplicitTupleTy kis tys', fvs) }

thomasw's avatar
thomasw committed
284
285
286
287
288
rnHsTyKi isType _doc (HsWildCardTy (AnonWildCard PlaceHolder))
  = ASSERT( isType )
    do { loc <- getSrcSpanM
       ; uniq <- newUnique
       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
289
290
291
       ; return (HsWildCardTy (AnonWildCard name), emptyFVs) }
         -- emptyFVs: this occurrence does not refer to a
         --           binding, so don't treat it as a free variable
thomasw's avatar
thomasw committed
292

thomasw's avatar
thomasw committed
293
rnHsTyKi isType doc (HsWildCardTy (NamedWildCard rdr_name))
thomasw's avatar
thomasw committed
294
  = ASSERT( isType )
thomasw's avatar
thomasw committed
295
296
297
298
299
300
301
302
    do { not_in_scope <- isNothing `fmap` lookupOccRn_maybe rdr_name
       ; when not_in_scope $
         -- When the named wild card is not in scope, it means it shouldn't be
         -- there in the first place, i.e. rnHsSigTypeWithWildCards wasn't
         -- used, so fail.
         failWith $ text "Unexpected wild card:" <+> quotes (ppr rdr_name) $$
                    docOfHsDocContext doc
       ; name <- rnTyVar isType rdr_name
303
304
305
       ; return (HsWildCardTy (NamedWildCard name), emptyFVs) }
         -- emptyFVs: this occurrence does not refer to a
         --           binding, so don't treat it as a free variable
thomasw's avatar
thomasw committed
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
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
--------------
rnHsTyKiForAll :: Bool -> HsDocContext -> HsType RdrName
               -> RnM (HsType Name, FreeVars)
rnHsTyKiForAll isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty)
  = ASSERT( isType ) do
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify
        -- over FV(T) \ {in-scope-tyvars}
    rdr_env <- getLocalRdrEnv
    loc <- getSrcSpanM
    let
        (forall_kvs, forall_tvs) = filterInScope rdr_env $
                                   extractHsTysRdrTyVars (ty:ctxt)
           -- 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

           -- The filterInScope is to ensure that we don't quantify over
           -- 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

    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty

rnHsTyKiForAll isType doc
               fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty)
  = 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
    rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty

rnHsTyKiForAll isType doc
               ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau)
  = ASSERT( isType ) do {      -- Explicit quantification.
         -- Check that the forall'd tyvars are actually
         -- mentioned in the type, and produce a warning if not
         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
             in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
       ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc)
                           forall_tyvars mentioned
       ; traceRn (text "rnHsTyKiForAll:Exlicit" <+> vcat
            [ppr forall_tyvars, ppr lctxt,ppr tau ])
       ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau }

-- The following should never happen but keeps the completeness checker happy
rnHsTyKiForAll isType doc ty = rnHsTyKi isType doc ty
363
364
365
366
367
--------------
rnTyVar :: Bool -> RdrName -> RnM Name
rnTyVar is_type rdr_name
  | is_type   = lookupTypeOccRn rdr_name
  | otherwise = lookupKindOccRn rdr_name
368

Jan Stolarek's avatar
Jan Stolarek committed
369
370
371
372
rnLTyVar :: Bool -> Located RdrName -> RnM (Located Name)
rnLTyVar is_type (L loc rdr_name) = do
  tyvar' <- rnTyVar is_type rdr_name
  return (L loc tyvar')
373

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
374
--------------
dreixel's avatar
dreixel committed
375
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
376
377
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
378

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
379
rnForAll :: HsDocContext -> HsExplicitFlag
thomasw's avatar
thomasw committed
380
381
         -> Maybe SrcSpan           -- Location of an extra-constraints wildcard
         -> [RdrName]               -- Kind variables
382
         -> LHsTyVarBndrs RdrName   -- Type variables
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
383
         -> LHsContext RdrName -> LHsType RdrName
384
         -> RnM (HsType Name, FreeVars)
385

thomasw's avatar
thomasw committed
386
387
rnForAll doc exp extra kvs forall_tyvars ctxt ty
  | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra
388
  = rnHsType doc (unLoc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
389
        -- One reason for this case is that a type like Int#
thomasw's avatar
thomasw committed
390
        -- starts off as (HsForAllTy Implicit Nothing [] Int), in case
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
391
392
393
394
395
        -- 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 *.
396

397
398
  | otherwise
  = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
399
400
    do { (new_ctxt, fvs1) <- rnContext doc ctxt
       ; (new_ty, fvs2) <- rnLHsType doc ty
thomasw's avatar
thomasw committed
401
       ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
402
403
        -- Retain the same implicit/explicit flag as before
        -- so that we can later print it correctly
404

405
406
---------------
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
407
408
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
409
410
411
412
-- 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
413
414
415
416
417
  = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
418
419

---------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
420
bindHsTyVars :: HsDocContext
421
422
423
424
425
             -> 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
426
427
-- (a) Bring kind variables into scope
--     both (i)  passed in (kv_bndrs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
428
--     and  (ii) mentioned in the kinds of tv_bndrs
429
430
431
432
-- (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
433
             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
434
435
                                 , let (_, kvs) = extractHsTyRdrTyVars kind
                                 , kv <- kvs ]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
436
437
438
             all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
             all_kvs  = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'

439
440
441
442
443
             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!

444
       ; poly_kind <- xoptM Opt_PolyKinds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
445
       ; unless (poly_kind || null all_kvs)
446
                (addErr (badKindBndrs doc all_kvs))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
447
       ; unless (null overlap_kvs)
448
449
                (addErr (overlappingKindVars doc overlap_kvs))

450
451
       ; loc <- getSrcSpanM
       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
452
       ; bindLocalNamesFV kv_names $
453
454
455
456
457
458
    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs

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

Jan Stolarek's avatar
Jan Stolarek committed
459
       ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tvs
460
       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
461
462
463
464
465
466
                        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 ])
467
468
                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
       ; return (res, fvs1 `plusFV` fvs2) } }
469

Jan Stolarek's avatar
Jan Stolarek committed
470
471
472
473
474
475
476
477
478
479
480
481
rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv
               -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar rdr))
  = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
       ; return (L loc (UserTyVar nm), emptyFVs) }
rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind))
  = 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
       ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) }

482
483
484
485
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
486
487
  = return n
  | otherwise
488
  = newLocalBndrRn (L loc rdr)
489
490

--------------------------------
491
rnHsBndrSig :: HsDocContext
492
493
            -> HsWithBndrs RdrName (LHsType RdrName)
            -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
494
            -> RnM (a, FreeVars)
495
496
497
rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
       ; unless sig_ok (badSigErr True doc ty)
498
499
500
501
502
       ; rdr_env <- getLocalRdrEnv
       ; let (kv_bndrs, tv_bndrs) = filterInScope rdr_env $
                                    extractHsTyRdrTyVars ty
       ; kv_names <- newLocalBndrsRn (map (L loc) kv_bndrs)
       ; tv_names <- newLocalBndrsRn (map (L loc) tv_bndrs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
503
504
       ; bindLocalNamesFV kv_names $
         bindLocalNamesFV tv_names $
thomasw's avatar
thomasw committed
505
    do { (ty', fvs1, wcs) <- rnLHsTypeWithWildCards doc ty
506
507
508
509
       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty'
                                           , hswb_kvs = kv_names
                                           , hswb_tvs = tv_names
                                           , hswb_wcs = wcs })
510
511
       ; return (res, fvs1 `plusFV` fvs2) } }

512
513
overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
overlappingKindVars doc kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
514
515
  = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
           ptext (sLit "also used as type variable") <> plural kvs
516
517
518
           <> colon <+> pprQuotedList kvs
         , docOfHsDocContext doc ]

519
520
521
badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
badKindBndrs doc kvs
  = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
522
                 <+> pprQuotedList kvs)
523
              2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
524
525
526
527
528
         , 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
529
    vcat [ hang (ptext (sLit "Illegal") <+> what
530
531
532
533
534
535
                 <+> 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")
536
537
    flag | is_type   = ptext (sLit "ScopedTypeVariables")
         | otherwise = ptext (sLit "KindSignatures")
538
539
540
541

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

thomasw's avatar
thomasw committed
547
548
549
550
551
--------------------------------
-- | Variant of @rnHsSigType@ that supports wild cards. Also returns the wild
-- cards to bind.
rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName
                         -> RnM (LHsType Name, FreeVars, [Name])
thomasw's avatar
thomasw committed
552
553
554
555
556
557
558
559
560
561
562
rnHsSigTypeWithWildCards doc_str ty
  = rnLHsTypeWithWildCards (TypeSigCtx doc_str) ty'
  where
    ty' = extractExtraCtsWc `fmap` flattenTopLevelLHsForAllTy ty
    -- When there is a wild card at the end of the context, remove it and add
    -- its location as the extra-constraints wild card in the HsForAllTy.
    extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty)
      | Just (ctxt', ct) <- snocView ctxt
      , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct
      = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty
    extractExtraCtsWc ty = ty
thomasw's avatar
thomasw committed
563
564
565
566
567
568
569
570

-- | Variant of @rnLHsType@ that supports wild cards. The third element of the
-- tuple consists of the freshly generated names of the anonymous wild cards
-- occurring in the type, as well as the names of the named wild cards in the
-- type that are not yet in scope.
rnLHsTypeWithWildCards  :: HsDocContext -> LHsType RdrName
                        -> RnM (LHsType Name, FreeVars, [Name])
rnLHsTypeWithWildCards doc ty
thomasw's avatar
thomasw committed
571
  = do { checkValidPartialType doc ty
thomasw's avatar
thomasw committed
572
573
       ; rdr_env <- getLocalRdrEnv
       -- Filter out named wildcards that are already in scope
thomasw's avatar
thomasw committed
574
       ; let (_, wcs) = collectWildCards ty
thomasw's avatar
thomasw committed
575
576
577
             nwcs = [L loc n | L loc (NamedWildCard n) <- wcs
                             , not (elemLocalRdrEnv n rdr_env) ]
       ; bindLocatedLocalsRn nwcs $ \nwcs' -> do {
thomasw's avatar
thomasw committed
578
         (ty', fvs) <- rnLHsType doc ty
thomasw's avatar
thomasw committed
579
580
       -- Add the anonymous wildcards that have been given names during
       -- renaming
thomasw's avatar
thomasw committed
581
       ; let (_, wcs') = collectWildCards ty'
thomasw's avatar
thomasw committed
582
             awcs      = filter (isAnonWildCard . unLoc) wcs'
thomasw's avatar
thomasw committed
583
       ; return (ty', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } }
thomasw's avatar
thomasw committed
584
585
586
587
588
589
590
591

-- | Extract all wild cards from a type. The named and anonymous
-- extra-constraints wild cards are returned separately to be able to give
-- more accurate error messages.
collectWildCards
  :: Eq name => LHsType name
  -> ([Located (HsWildCardInfo name)],  -- extra-constraints wild cards
      [Located (HsWildCardInfo name)])  -- wild cards
thomasw's avatar
thomasw committed
592
collectWildCards lty = (extra, nubBy sameNamedWildCard wcs)
thomasw's avatar
thomasw committed
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
  where
    (extra, wcs) = go lty
    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
      HsWildCardTy wc         -> ([], [L loc wc])
      HsForAllTy _ _ _ (L _ ctxt) ty -> ctxtWcs `mappend` go ty
        where
          ctxt' = map ignoreParens ctxt
          extraWcs  = [L l wc | L l (HsWildCardTy wc) <- ctxt']
          (_, wcs) = gos ctxt'
          -- Remove extra-constraints wild cards from wcs
          ctxtWcs = (extraWcs, deleteFirstsBy sameWildCard
                               (nubBy sameWildCard wcs) extraWcs)
      -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
      _ -> mempty
    gos = mconcat . map go

-- | Check the validity of a partial type signature. The following things are
-- checked:
--
-- * Named extra-constraints wild cards aren't allowed,
-- e.g. invalid: @(Show a, _x) => a -> String@.
--
-- * There is only one extra-constraints wild card in the context and it must
-- come last, e.g. invalid: @(_, Show a) => a -> String@
-- or @(_, Show a, _) => a -> String@.
--
-- * There should be no unnamed wild cards in the context.
--
-- * An extra-constraints wild card can only occur in the top-level context.
-- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@.
--
-- * Named wild cards occurring in the context must also occur in the monotype.
--
-- When an invalid wild card is found, we fail with an error.
checkValidPartialType :: HsDocContext -> LHsType RdrName -> RnM ()
checkValidPartialType doc lty
  = do { whenNonEmpty isNamedWildCard inExtra $ \(L loc _) ->
           failAt loc $ typeDoc $$
           text "An extra-constraints wild card cannot be named" $$
           docOfHsDocContext doc

       ; whenNonEmpty isAnonWildCard extraTopLevel $ \(L loc _) ->
           failAt loc $ typeDoc $$
           -- If there was a valid extra-constraints wild card, it should have
           -- already been removed and its location should be stored in the
           -- HsForAllTy
thomasw's avatar
thomasw committed
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
           (case extra of
             Just _ ->
               -- We're in a top-level context with an extracted
               -- extra-constraints wild card.
               text "Only a single extra-constraints wild card is allowed"
             _ | TypeSigCtx _ <- doc ->
               -- We're in a top-level context, but the extra-constraints wild
               -- card didn't occur at the end.
               fcat [ text "An extra-constraints wild card must occur"
                    , text "at the end of the constraints" ]
             _ ->
               -- We're not in a top-level context, so no extra-constraints
               -- wild cards are supported.
               fcat [ text "An extra-constraints wild card is only allowed"
                    , text "in the top-level context" ]) $$
thomasw's avatar
thomasw committed
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
           docOfHsDocContext doc

       ; whenNonEmpty isAnonWildCard inCtxt $ \(L loc _) ->
           failAt loc $ typeDoc $$
           text "Anonymous wild cards are not allowed in constraints" $$
           docOfHsDocContext doc

       ; whenNonEmpty isAnonWildCard nestedExtra $ \(L loc _) ->
           failAt loc $ typeDoc $$
           fcat [ text "An extra-constraints wild card is only allowed"
                , text "in the top-level context" ] $$
           docOfHsDocContext doc

       ; whenNonEmpty isNamedWildCard inCtxtNotInTau $ \(L loc name) ->
           failAt loc $ typeDoc $$
           fcat [ text "The named wild card" <+> quotes (ppr name) <> space
                , text "is only allowed in the constraints"
                , text "when it also occurs in the rest of the type" ] $$
           docOfHsDocContext doc }
  where
    typeDoc               = hang (text "Invalid partial type:") 2 (ppr lty)
    (extra, ctxt, tau)    = splitPartialType lty
    (inExtra,     _)      = collectWildCards lty
    (nestedExtra, inTau)  = collectWildCards tau
    (_,           inCtxt) = mconcat $ map collectWildCards ctxt
    inCtxtNotInTau        = deleteFirstsBy sameWildCard inCtxt inTau
    extraTopLevel         = deleteFirstsBy sameWildCard inExtra nestedExtra

    splitPartialType (L _ (HsForAllTy _ extra _ (L _ ctxt) ty))
      = (extra, map ignoreParens ctxt, ty)
    splitPartialType ty = (Nothing, [], ty)

    whenNonEmpty test wcs f
      = whenIsJust (listToMaybe $ filter (test . unLoc) wcs) f


Austin Seipp's avatar
Austin Seipp committed
707
708
{-
*********************************************************
Adam Gundry's avatar
Adam Gundry committed
709
710
711
*                                                       *
        ConDeclField
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
712
*********************************************************
Adam Gundry's avatar
Adam Gundry committed
713
714
715
716
717
718

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
719
-}
720

Adam Gundry's avatar
Adam Gundry committed
721
rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
722
                -> RnM ([LConDeclField Name], FreeVars)
Adam Gundry's avatar
Adam Gundry committed
723
724
725
rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
  where
    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
726

Adam Gundry's avatar
Adam Gundry committed
727
rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
728
        -> RnM (LConDeclField Name, FreeVars)
Adam Gundry's avatar
Adam Gundry committed
729
730
rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
  = do { let new_names = map (fmap lookupField) names
731
732
       ; (new_ty, fvs) <- rnLHsType doc ty
       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
733
       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
Adam Gundry's avatar
Adam Gundry committed
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
  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
*                                                       *
*********************************************************
-}
749

750
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
751
rnContext doc (L loc cxt)
752
753
  = do { (cxt', fvs) <- rnLHsTypes doc cxt
       ; return (L loc cxt', fvs) }
754

Austin Seipp's avatar
Austin Seipp committed
755
756
757
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
758
        Fixities and precedence parsing
Austin Seipp's avatar
Austin Seipp committed
759
760
*                                                                      *
************************************************************************
761

762
763
764
765
766
767
768
769
770
@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.
771
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
772
        a `op` b `op` c
773
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
774
        a `op` (b `op` c)
775
776
777

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

781
782
783
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
784
785
           -> Name -> Fixity -> LHsType Name -> LHsType Name
           -> RnM (HsType Name)
786

dreixel's avatar
dreixel committed
787
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
788
  = do  { fix2 <- lookupTyFixityRn op2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
789
790
791
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
                      (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
                      (unLoc op2) fix2 ty21 ty22 loc2 }
792

Ian Lynagh's avatar
Ian Lynagh committed
793
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
794
795
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
796

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
797
mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
798
799
800
801
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
802
803
804
805
806
807
            -> 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
808
  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
809
                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
810
  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
811
812
813
  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
814
815
816
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

817

818
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
819
820
821
822
823
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)
824
825
826

-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
827
828
829
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
830

831
832
833
  | associate_right = do
    new_e <- mkOpAppRn e12 op2 fix2 e2
    return (OpApp e11 op1 fix1 (L loc' new_e))
834
835
836
837
838
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
839
--      (- neg_arg) `op` e2
840
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
841
842
843
  | nofix_error
  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
844

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
845
  | associate_right
846
847
  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
       return (NegApp (L loc' new_e) neg_name)
848
849
850
851
852
  where
    loc' = combineLocs neg_arg e2
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
853
854
855
--      e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
  | not associate_right                 -- We *want* right association
856
857
  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
       return (OpApp e1 op1 fix1 e2)
858
859
860
861
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
862
863
--      Default case
mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
864
  = ASSERT2( right_op_ok fix (unLoc e2),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
865
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
866
    )
867
    return (OpApp e1 op fix e2)
868

869
870
----------------------------
get_op :: LHsExpr Name -> Name
871
-- An unbound name could be either HsVar or HsUnboundVar
872
873
874
875
-- See RnExpr.rnUnboundVar
get_op (L _ (HsVar n))          = n
get_op (L _ (HsUnboundVar occ)) = mkUnboundName (mkRdrUnqual occ)
get_op other                    = pprPanic "get_op" (ppr other)
876

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
877
-- Parser left-associates everything, but
878
879
-- 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
880
right_op_ok :: Fixity -> HsExpr Name -> Bool
881
882
883
884
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
885
right_op_ok _ _
886
887
888
889
890
891
892
  = 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) )
893
    return (NegApp neg_arg neg_name)
894

Ian Lynagh's avatar
Ian Lynagh committed
895
not_op_app :: HsExpr id -> Bool
896
not_op_app (OpApp _ _ _ _) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
897
not_op_app _               = True
898
899

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
900
901
902
903
mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity     -- Operator and fixity
          -> LHsCmdTop Name             -- Right operand (not an infix)
          -> RnM (HsCmd Name)
904
905

-- (e11 `op1` e12) `op2` e2
906
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
907
        op2 fix2 a2
908
909
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
910
       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
911
912
913

  | associate_right
  = do new_c <- mkOpFormRn a12 op2 fix2 a2
914
       return (HsCmdArrForm op1 (Just fix1)
915
916
               [a11, L loc (HsCmdTop (L loc new_c)
               placeHolderType placeHolderType [])])
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
917
        -- TODO: locs are wrong
918
919
920
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
921
922
--      Default case
mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
923
  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
924
925
926
927


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
928
             -> RnM (Pat Name)
929
930

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
934
935
936
        ; if nofix_error then do
                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
937

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
938
939
940
941
          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)) }
942

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
943
mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
944
  = ASSERT( not_op_pat (unLoc p2) )
945
    return (ConPatIn op (InfixCon p1 p2))
946

Ian Lynagh's avatar
Ian Lynagh committed
947
not_op_pat :: Pat Name -> Bool
948
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
949
not_op_pat _                           = True
950
951

--------------------------------------
952
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
953
954
955
  -- Check precedence of a function binding written infix
  --   eg  a `op` b `C` c = ...
  -- See comments with rnExpr (OpApp ...) about "deriving"
956

957
checkPrecMatch op (MG { mg_alts = ms })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
958
  = mapM_ check ms
959
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
960
    check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
961
962
963
      = setSrcSpan (combineSrcSpans l1 l2) $
        do checkPrec op p1 False
           checkPrec op p2 True
964

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
965
966
967
968
969
970
971
972
    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.
973

Ian Lynagh's avatar
Ian Lynagh committed
974
checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
975
976
977
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)
978
    let
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
979
980
981
982
983
984
985
986
        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)
987
    unless inf_ok (precParseErr infol infor)
988

Ian Lynagh's avatar
Ian Lynagh committed
989
checkPrec _ _ _
990
  = return ()
991
992
993
994
995
996

-- 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
997
        -> LHsExpr Name -> LHsExpr Name -> RnM ()
998
999
checkSectionPrec direction section op arg
  = case unLoc arg of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1000
1001
1002
        OpApp _ op fix _ -> go_for_it (get_op op) fix
        NegApp _ _       -> go_for_it negateName  negateFixity
        _                -> return ()
1003
  where