RnTypes.hs 48.2 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 16
        newTyVarNameRn, rnLHsTypeWithWildCards,
        rnHsSigTypeWithWildCards,
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,
24 25
        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
        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
43

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

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

57 58
#include "HsVersions.h"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

177 178 179 180
rnHsTyKi _ doc ty@(HsRecTy flds)
  = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                    2 (ppr ty))
       ; (flds', fvs) <- rnConDeclFields doc flds
181
       ; return (HsRecTy flds', fvs) }
182

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

thomasw's avatar
thomasw committed
283 284 285 286 287
rnHsTyKi isType _doc (HsWildCardTy (AnonWildCard PlaceHolder))
  = ASSERT( isType )
    do { loc <- getSrcSpanM
       ; uniq <- newUnique
       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
288 289 290
       ; 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
291

thomasw's avatar
thomasw committed
292
rnHsTyKi isType doc (HsWildCardTy (NamedWildCard rdr_name))
thomasw's avatar
thomasw committed
293
  = ASSERT( isType )
thomasw's avatar
thomasw committed
294 295 296 297 298 299 300 301
    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
302 303 304
       ; 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
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 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361
--------------
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
362 363 364 365 366
--------------
rnTyVar :: Bool -> RdrName -> RnM Name
rnTyVar is_type rdr_name
  | is_type   = lookupTypeOccRn rdr_name
  | otherwise = lookupKindOccRn rdr_name
367

368

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
369
--------------
dreixel's avatar
dreixel committed
370
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
371 372
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
373

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

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

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

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

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

434 435 436 437 438
             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!

439
       ; poly_kind <- xoptM Opt_PolyKinds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
440
       ; unless (poly_kind || null all_kvs)
441
                (addErr (badKindBndrs doc all_kvs))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
442
       ; unless (null overlap_kvs)
443 444
                (addErr (overlappingKindVars doc overlap_kvs))

445 446
       ; loc <- getSrcSpanM
       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
447
       ; bindLocalNamesFV kv_names $
448 449
    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
450
             rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
451 452 453
             rn_tv_bndr (L loc (UserTyVar rdr))
               = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
                    ; return (L loc (UserTyVar nm), emptyFVs) }
Alan Zimmerman's avatar
Alan Zimmerman committed
454
             rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind))
455 456 457 458
               = do { sig_ok <- xoptM Opt_KindSignatures
                    ; unless sig_ok (badSigErr False doc kind)
                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
                    ; (kind', fvs) <- rnLHsKind doc kind
Alan Zimmerman's avatar
Alan Zimmerman committed
459
                    ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) }
460 461 462 463 464 465 466

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

       ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
467 468 469 470 471 472
                        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 ])
473 474
                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
       ; return (res, fvs1 `plusFV` fvs2) } }
475

476 477 478 479
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
480 481
  = return n
  | otherwise
482
  = newLocalBndrRn (L loc rdr)
483 484

--------------------------------
485
rnHsBndrSig :: HsDocContext
486 487
            -> HsWithBndrs RdrName (LHsType RdrName)
            -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
488
            -> RnM (a, FreeVars)
489 490 491 492
rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
       ; unless sig_ok (badSigErr True doc ty)
       ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
493 494 495 496 497
       ; name_env <- getLocalRdrEnv
       ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
                                               , not (tv `elemLocalRdrEnv` name_env) ]
       ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
                                               , not (kv `elemLocalRdrEnv` name_env) ]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
498 499
       ; bindLocalNamesFV kv_names $
         bindLocalNamesFV tv_names $
thomasw's avatar
thomasw committed
500 501 502
    do { (ty', fvs1, wcs) <- rnLHsTypeWithWildCards doc ty
       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names,
                                             hswb_tvs = tv_names, hswb_wcs = wcs })
503 504
       ; return (res, fvs1 `plusFV` fvs2) } }

505 506
overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
overlappingKindVars doc kvs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
507 508
  = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
           ptext (sLit "also used as type variable") <> plural kvs
509 510 511
           <> colon <+> pprQuotedList kvs
         , docOfHsDocContext doc ]

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

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

thomasw's avatar
thomasw committed
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556
--------------------------------
-- | Variant of @rnHsSigType@ that supports wild cards. Also returns the wild
-- cards to bind.
rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName
                         -> RnM (LHsType Name, FreeVars, [Name])
rnHsSigTypeWithWildCards doc_str = rnLHsTypeWithWildCards (TypeSigCtx doc_str)

-- | 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
  = do { -- 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.
thomasw's avatar
thomasw committed
557
         let ty' = extractExtraCtsWc `fmap` flattenTopLevelLHsForAllTy ty
thomasw's avatar
thomasw committed
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 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 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690

       ; checkValidPartialType doc ty'

       ; rdr_env <- getLocalRdrEnv
       -- Filter out named wildcards that are already in scope
       ; let (_, wcs) = collectWildCards ty'
             nwcs = [L loc n | L loc (NamedWildCard n) <- wcs
                             , not (elemLocalRdrEnv n rdr_env) ]
       ; bindLocatedLocalsRn nwcs $ \nwcs' -> do {
         (ty'', fvs) <- rnLHsType doc ty'
       -- Add the anonymous wildcards that have been given names during
       -- renaming
       ; let (_, wcs') = collectWildCards ty''
             awcs      = filter (isAnonWildCard . unLoc) wcs'
       ; return (ty'', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } }
  where
    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

-- | 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
collectWildCards lty = (nubBy sameWildCard extra, nubBy sameWildCard wcs)
  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
           (if isJust extra
            then text "Only a single extra-constraints wild card is allowed"
            else fcat [ text "An extra-constraints wild card must occur"
                      , text "at the end of the constraints" ]) $$
           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
691 692 693
{-
*********************************************************
*                                                      *
694
\subsection{Contexts and predicates}
Austin Seipp's avatar
Austin Seipp committed
695 696 697
*                                                      *
*********************************************************
-}
698

699 700
rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
                -> RnM ([LConDeclField Name], FreeVars)
701 702
rnConDeclFields doc fields = mapFvRn (rnField doc) fields

703 704 705 706
rnField :: HsDocContext -> LConDeclField RdrName
        -> RnM (LConDeclField Name, FreeVars)
rnField doc (L l (ConDeclField names ty haddock_doc))
  = do { new_names <- mapM lookupLocatedTopBndrRn names
707 708
       ; (new_ty, fvs) <- rnLHsType doc ty
       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
709
       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
710

711
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
712
rnContext doc (L loc cxt)
713 714
  = do { (cxt', fvs) <- rnLHsTypes doc cxt
       ; return (L loc cxt', fvs) }
715

Austin Seipp's avatar
Austin Seipp committed
716 717 718
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
719
        Fixities and precedence parsing
Austin Seipp's avatar
Austin Seipp committed
720 721
*                                                                      *
************************************************************************
722

723 724 725 726 727 728 729 730 731
@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.
732
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
733
        a `op` b `op` c
734
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
735
        a `op` (b `op` c)
736 737 738

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

742 743 744
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
745 746
           -> Name -> Fixity -> LHsType Name -> LHsType Name
           -> RnM (HsType Name)
747

dreixel's avatar
dreixel committed
748
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
749
  = do  { fix2 <- lookupTyFixityRn op2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
750 751 752
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
                      (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
                      (unLoc op2) fix2 ty21 ty22 loc2 }
753

Ian Lynagh's avatar
Ian Lynagh committed
754
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
755 756
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
757

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
758
mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
759 760 761 762
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
763 764 765 766 767 768
            -> 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
769
  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
770
                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
771
  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
772 773 774
  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
775 776 777
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

778

779
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
780 781 782 783 784
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)
785 786 787

-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
788 789 790
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
791

792 793 794
  | associate_right = do
    new_e <- mkOpAppRn e12 op2 fix2 e2
    return (OpApp e11 op1 fix1 (L loc' new_e))
795 796 797 798 799
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
800
--      (- neg_arg) `op` e2
801
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
802 803 804
  | nofix_error
  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
805

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
806
  | associate_right
807 808
  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
       return (NegApp (L loc' new_e) neg_name)
809 810 811 812 813
  where
    loc' = combineLocs neg_arg e2
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
814 815 816
--      e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
  | not associate_right                 -- We *want* right association
817 818
  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
       return (OpApp e1 op1 fix1 e2)
819 820 821 822
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
823 824
--      Default case
mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
825
  = ASSERT2( right_op_ok fix (unLoc e2),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
826
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
827
    )
828
    return (OpApp e1 op fix e2)
829

830 831 832 833 834
----------------------------
get_op :: LHsExpr Name -> Name
get_op (L _ (HsVar n)) = n
get_op other           = pprPanic "get_op" (ppr other)

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
835
-- Parser left-associates everything, but
836 837
-- 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
838
right_op_ok :: Fixity -> HsExpr Name -> Bool
839 840 841 842
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
843
right_op_ok _ _
844 845 846 847 848 849 850
  = 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) )
851
    return (NegApp neg_arg neg_name)
852

Ian Lynagh's avatar
Ian Lynagh committed
853
not_op_app :: HsExpr id -> Bool
854
not_op_app (OpApp _ _ _ _) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
855
not_op_app _               = True
856 857

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
858 859 860 861
mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity     -- Operator and fixity
          -> LHsCmdTop Name             -- Right operand (not an infix)
          -> RnM (HsCmd Name)
862 863

-- (e11 `op1` e12) `op2` e2
864
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
865
        op2 fix2 a2
866 867
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
868
       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
869 870 871

  | associate_right
  = do new_c <- mkOpFormRn a12 op2 fix2 a2
872
       return (HsCmdArrForm op1 (Just fix1)
873 874
               [a11, L loc (HsCmdTop (L loc new_c)
               placeHolderType placeHolderType [])])
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
875
        -- TODO: locs are wrong
876 877 878
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
879 880
--      Default case
mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
881
  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
882 883 884 885


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
886
             -> RnM (Pat Name)
887 888

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
892 893 894
        ; if nofix_error then do
                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
895

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
896 897 898 899
          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)) }
900

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
901
mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
902
  = ASSERT( not_op_pat (unLoc p2) )
903
    return (ConPatIn op (InfixCon p1 p2))
904

Ian Lynagh's avatar
Ian Lynagh committed
905
not_op_pat :: Pat Name -> Bool
906
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
907
not_op_pat _                           = True
908 909

--------------------------------------
910
checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
911 912 913