Fix typo in error message (Trac #6076)
[ghc.git] / compiler / rename / RnTypes.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnSource]{Main pass of renamer}
5
6 \begin{code}
7 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module RnTypes ( 
15         -- Type related stuff
16         rnHsType, rnLHsType, rnLHsTypes, rnContext,
17         rnHsKind, rnLHsKind, rnLHsMaybeKind,
18         rnHsSigType, rnLHsInstType, rnConDeclFields,
19         rnIPName,
20
21         -- Precence related stuff
22         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
23         checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
24
25         -- Splice related stuff
26         rnSplice, checkTH,
27
28         -- Binding related stuff
29         bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig,
30         extractHsTyRdrTyVars, extractHsTysRdrTyVars
31
32   ) where
33
34 import {-# SOURCE #-} RnExpr( rnLExpr )
35 #ifdef GHCI
36 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
37 #endif  /* GHCI */
38
39 import DynFlags
40 import HsSyn
41 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
42 import RnEnv
43 import TcRnMonad
44 import IfaceEnv         ( newIPName )
45 import RdrName
46 import PrelNames
47 import TysPrim          ( funTyConName )
48 import Name
49 import SrcLoc
50 import NameSet
51
52 import Util             ( filterOut )
53 import BasicTypes       ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity, 
54                           Fixity(..), FixityDirection(..) )
55 import Outputable
56 import FastString
57 import Data.List        ( nub )
58 import Control.Monad    ( unless )
59
60 #include "HsVersions.h"
61 \end{code}
62
63 These type renamers are in a separate module, rather than in (say) RnSource,
64 to break several loop.
65
66 %*********************************************************
67 %*                                                      *
68 \subsection{Renaming types}
69 %*                                                      *
70 %*********************************************************
71
72 \begin{code}
73 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
74         -- rnHsSigType is used for source-language type signatures,
75         -- which use *implicit* universal quantification.
76 rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
77
78 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
79 -- Rename the type in an instance or standalone deriving decl
80 rnLHsInstType doc_str ty 
81   = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty
82        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
83        ; return (ty', fvs) }
84   where
85     good_inst_ty
86       | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
87       , isTcOcc (rdrNameOcc cls) = True
88       | otherwise                = False
89
90 badInstTy :: LHsType RdrName -> SDoc
91 badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty 
92 \end{code}
93
94 rnHsType is here because we call it from loadInstDecl, and I didn't
95 want a gratuitous knot.
96
97 \begin{code}
98 rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
99            -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
100 rnLHsTyKi isType doc (L loc ty)
101   = setSrcSpan loc $ 
102     do { (ty', fvs) <- rnHsTyKi isType doc ty
103        ; return (L loc ty', fvs) }
104
105 rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
106 rnLHsType = rnLHsTyKi True
107
108 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
109 rnLHsKind = rnLHsTyKi False
110
111 rnLHsMaybeKind  :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
112                 -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
113 rnLHsMaybeKind _ Nothing 
114   = return (Nothing, emptyFVs)
115 rnLHsMaybeKind doc (Just bsig) 
116   = rnHsBndrSig False doc bsig $ \ bsig' -> 
117     return (Just bsig', emptyFVs)
118
119 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
120 rnHsType = rnHsTyKi True
121 rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
122 rnHsKind = rnHsTyKi False
123
124 rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
125
126 rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) 
127   = ASSERT ( isType ) do
128         -- Implicit quantifiction in source code (no kinds on tyvars)
129         -- Given the signature  C => T  we universally quantify 
130         -- over FV(T) \ {in-scope-tyvars} 
131     name_env <- getLocalRdrEnv
132     loc <- getSrcSpanM
133     let
134         (_kvs, mentioned) = extractHsTysRdrTyVars (ty:ctxt)
135            -- In for-all types we don't bring in scope
136            -- kind variables mentioned in kind signatures
137            -- (Well, not yet anyway....)
138            --    f :: Int -> T (a::k)    -- Not allowed
139
140         -- Don't quantify over type variables that are in scope;
141         -- when GlasgowExts is off, there usually won't be any, except for
142         -- class signatures:
143         --      class C a where { op :: a -> a }
144         forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
145         tyvar_bndrs   = userHsTyVarBndrs loc forall_tyvars
146
147     rnForAll doc Implicit tyvar_bndrs lctxt ty
148
149 rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
150   = ASSERT ( isType ) do {      -- Explicit quantification.
151          -- Check that the forall'd tyvars are actually 
152          -- mentioned in the type, and produce a warning if not
153          let (_kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
154              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
155        ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
156
157        ; rnForAll doc Explicit forall_tyvars lctxt tau }
158
159 rnHsTyKi isType _ (HsTyVar rdr_name)
160   = do { name <- rnTyVar isType rdr_name
161        ; return (HsTyVar name, unitFV name) }
162
163 -- If we see (forall a . ty), without foralls on, the forall will give
164 -- a sensible error message, but we don't want to complain about the dot too
165 -- Hence the jiggery pokery with ty1
166 rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
167   = ASSERT ( isType ) setSrcSpan loc $ 
168     do  { ops_ok <- xoptM Opt_TypeOperators
169         ; op' <- if ops_ok
170                  then rnTyVar isType op
171                  else do { addErr (opTyErr op ty)
172                          ; return (mkUnboundName op) }  -- Avoid double complaint
173         ; let l_op' = L loc op'
174         ; fix <- lookupTyFixityRn l_op'
175         ; (ty1', fvs1) <- rnLHsType doc ty1
176         ; (ty2', fvs2) <- rnLHsType doc ty2
177         ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) 
178                                op' fix ty1' ty2'
179         ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
180
181 rnHsTyKi isType doc (HsParTy ty)
182   = do { (ty', fvs) <- rnLHsTyKi isType doc ty
183        ; return (HsParTy ty', fvs) }
184
185 rnHsTyKi isType doc (HsBangTy b ty)
186   = ASSERT ( isType ) 
187     do { (ty', fvs) <- rnLHsType doc ty
188        ; return (HsBangTy b ty', fvs) }
189
190 rnHsTyKi isType doc (HsRecTy flds)
191   = ASSERT ( isType ) 
192     do { (flds', fvs) <- rnConDeclFields doc flds
193        ; return (HsRecTy flds', fvs) }
194
195 rnHsTyKi isType doc (HsFunTy ty1 ty2)
196   = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
197         -- Might find a for-all as the arg of a function type
198        ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
199         -- Or as the result.  This happens when reading Prelude.hi
200         -- when we find return :: forall m. Monad m -> forall a. a -> m a
201
202         -- Check for fixity rearrangements
203        ; res_ty <- if isType
204                    then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
205                    else return (HsFunTy ty1' ty2')
206        ; return (res_ty, fvs1 `plusFV` fvs2) }
207
208 rnHsTyKi isType doc listTy@(HsListTy ty)
209   = do { data_kinds <- xoptM Opt_DataKinds
210        ; unless (data_kinds || isType) (addErr (dataKindsErr listTy))
211        ; (ty', fvs) <- rnLHsTyKi isType doc ty
212        ; return (HsListTy ty', fvs) }
213
214 rnHsTyKi isType doc (HsKindSig ty k)
215   = ASSERT ( isType ) 
216     do { kind_sigs_ok <- xoptM Opt_KindSignatures
217        ; unless kind_sigs_ok (badSigErr False doc ty)
218        ; (ty', fvs1) <- rnLHsType doc ty
219        ; (k', fvs2) <- rnLHsKind doc k
220        ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
221
222 rnHsTyKi isType doc (HsPArrTy ty) 
223   = ASSERT ( isType )
224     do { (ty', fvs) <- rnLHsType doc ty
225        ; return (HsPArrTy ty', fvs) }
226
227 -- Unboxed tuples are allowed to have poly-typed arguments.  These
228 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
229 rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
230   = do { data_kinds <- xoptM Opt_DataKinds
231        ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
232        ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
233        ; return (HsTupleTy tup_con tys', fvs) }
234
235 -- 1. Perhaps we should use a separate extension here?
236 -- 2. Check that the integer is positive?
237 rnHsTyKi isType _ tyLit@(HsTyLit t)
238   = do { data_kinds <- xoptM Opt_DataKinds
239        ; unless (data_kinds || isType) (addErr (dataKindsErr tyLit))
240        ; return (HsTyLit t, emptyFVs) }
241
242 rnHsTyKi isType doc (HsAppTy ty1 ty2)
243   = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
244        ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
245        ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
246
247 rnHsTyKi isType doc (HsIParamTy n ty)
248   = ASSERT( isType )
249     do { (ty', fvs) <- rnLHsType doc ty
250        ; n' <- rnIPName n
251        ; return (HsIParamTy n' ty', fvs) }
252
253 rnHsTyKi isType doc (HsEqTy ty1 ty2) 
254   = ASSERT( isType )
255     do { (ty1', fvs1) <- rnLHsType doc ty1
256        ; (ty2', fvs2) <- rnLHsType doc ty2
257        ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
258
259 rnHsTyKi isType _ (HsSpliceTy sp _ k)
260   = ASSERT ( isType ) 
261     do { (sp', fvs) <- rnSplice sp      -- ToDo: deal with fvs
262        ; return (HsSpliceTy sp' fvs k, fvs) }
263
264 rnHsTyKi isType doc (HsDocTy ty haddock_doc) 
265   = ASSERT ( isType )
266     do { (ty', fvs) <- rnLHsType doc ty
267        ; haddock_doc' <- rnLHsDoc haddock_doc
268        ; return (HsDocTy ty' haddock_doc', fvs) }
269
270 #ifndef GHCI
271 rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
272 #else
273 rnHsTyKi isType doc (HsQuasiQuoteTy qq) 
274   = ASSERT ( isType ) 
275     do { ty <- runQuasiQuoteType qq
276        ; rnHsType doc (unLoc ty) }
277 #endif
278
279 rnHsTyKi isType _ (HsCoreTy ty) 
280   = ASSERT ( isType ) 
281     return (HsCoreTy ty, emptyFVs)
282     -- The emptyFVs probably isn't quite right 
283     -- but I don't think it matters
284
285 rnHsTyKi _ _ (HsWrapTy {}) 
286   = panic "rnHsTyKi"
287
288 rnHsTyKi isType doc (HsExplicitListTy k tys)
289   = ASSERT( isType )
290     do { (tys', fvs) <- rnLHsTypes doc tys
291        ; return (HsExplicitListTy k tys', fvs) }
292
293 rnHsTyKi isType doc (HsExplicitTupleTy kis tys) 
294   = ASSERT( isType )
295     do { (tys', fvs) <- rnLHsTypes doc tys
296        ; return (HsExplicitTupleTy kis tys', fvs) }
297
298 --------------
299 rnTyVar :: Bool -> RdrName -> RnM Name
300 rnTyVar is_type rdr_name
301   | is_type   = lookupTypeOccRn rdr_name
302   | otherwise = lookupKindOccRn rdr_name
303
304
305 --------------
306 rnLHsTypes :: HsDocContext -> [LHsType RdrName]
307            -> RnM ([LHsType Name], FreeVars)
308 rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
309 \end{code}
310
311
312 \begin{code}
313 rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
314          -> LHsContext RdrName -> LHsType RdrName 
315          -> RnM (HsType Name, FreeVars)
316
317 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
318         -- One reason for this case is that a type like Int#
319         -- starts off as (HsForAllTy Nothing [] Int), in case
320         -- there is some quantification.  Now that we have quantified
321         -- and discovered there are no type variables, it's nicer to turn
322         -- it into plain Int.  If it were Int# instead of Int, we'd actually
323         -- get an error, because the body of a genuine for-all is
324         -- of kind *.
325
326 rnForAll doc exp forall_tyvars ctxt ty
327   = bindHsTyVars doc forall_tyvars $ \ new_tyvars ->
328     do { (new_ctxt, fvs1) <- rnContext doc ctxt
329        ; (new_ty, fvs2) <- rnLHsType doc ty
330        ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
331         -- Retain the same implicit/explicit flag as before
332         -- so that we can later print it correctly
333
334 ---------------
335 bindSigTyVarsFV :: [Name]
336                 -> RnM (a, FreeVars)
337                 -> RnM (a, FreeVars)
338 -- Used just before renaming the defn of a function
339 -- with a separate type signature, to bring its tyvars into scope
340 -- With no -XScopedTypeVariables, this is a no-op
341 bindSigTyVarsFV tvs thing_inside
342   = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
343         ; if not scoped_tyvars then 
344                 thing_inside 
345           else
346                 bindLocalNamesFV tvs thing_inside }
347
348 ---------------
349 bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
350               -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
351               -> RnM (a, FreeVars)
352 bindHsTyVars doc tv_bndrs thing_inside
353   = do { checkDupAndShadowedRdrNames rdr_names_w_loc
354        ; names <- newLocalBndrsRn rdr_names_w_loc
355        ; bindTyVarsRn doc tv_bndrs names thing_inside }
356   where
357     rdr_names_w_loc = hsLTyVarLocNames tv_bndrs
358
359 ---------------
360 bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name]
361              -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
362              -> RnM (a, FreeVars)
363 -- Rename the HsTyVarBndrs, giving them the specified names
364 -- *and* bringing into scope the kind variables bound in 
365 -- any kind signatures
366
367 bindTyVarsRn doc tv_bndrs names thing_inside
368   = go tv_bndrs names $ \ tv_bndrs' -> 
369     bindLocalNamesFV names (thing_inside tv_bndrs')
370   where
371     go [] [] thing_inside = thing_inside []
372
373     go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside
374       = go tvs ns $ \ tvs' ->
375         thing_inside (L loc (UserTyVar n) : tvs')
376
377     go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside
378       = rnHsBndrSig False doc bsig $ \ bsig' ->
379         go tvs ns $ \ tvs' ->
380         thing_inside (L loc (KindedTyVar n bsig') : tvs')
381
382     -- Lists of unequal length
383     go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
384
385 --------------------------------
386 rnHsBndrSig :: Bool    -- True <=> type sig, False <=> kind sig
387             -> HsDocContext
388             -> HsBndrSig (LHsType RdrName)
389             -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
390             -> RnM (a, FreeVars)
391 rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
392   = do { let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
393        ; checkHsBndrFlags is_type doc ty tv_bndrs 
394        ; name_env <- getLocalRdrEnv
395        ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
396                                                , not (tv `elemLocalRdrEnv` name_env) ]
397        ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
398                                                , not (kv `elemLocalRdrEnv` name_env) ]
399        ; bindLocalNamesFV kv_names $ 
400          bindLocalNamesFV tv_names $ 
401     do { (ty', fvs1) <- rnLHsTyKi is_type doc ty
402        ; (res, fvs2) <- thing_inside (HsBSig ty' (kv_names, tv_names))
403        ; return (res, fvs1 `plusFV` fvs2) } }
404
405 checkHsBndrFlags :: Bool -> HsDocContext 
406                  -> LHsType RdrName -> [RdrName] -> RnM ()
407 checkHsBndrFlags is_type doc ty tv_bndrs
408   | is_type     -- Type
409   = do { sig_ok <- xoptM Opt_ScopedTypeVariables
410        ; unless sig_ok (badSigErr True doc ty) }
411   | otherwise   -- Kind
412   = do { sig_ok <- xoptM Opt_KindSignatures
413        ; unless sig_ok (badSigErr False doc ty)
414        ; poly_kind <- xoptM Opt_PolyKinds
415        ; unless (poly_kind || null tv_bndrs) 
416                 (addErr (badKindBndrs doc ty tv_bndrs)) }
417
418 badKindBndrs :: HsDocContext -> LHsKind RdrName -> [RdrName] -> SDoc
419 badKindBndrs doc _kind kvs
420   = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
421                  <+> pprQuotedList kvs)
422               2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
423          , docOfHsDocContext doc ]
424
425 badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
426 badSigErr is_type doc (L loc ty)
427   = setSrcSpan loc $ addErr $
428     vcat [ hang (ptext (sLit "Illegal") <+> what 
429                  <+> ptext (sLit "signature:") <+> quotes (ppr ty))
430               2 (ptext (sLit "Perhaps you intended to use") <+> flag)
431          , docOfHsDocContext doc ]
432   where
433     what | is_type   = ptext (sLit "type")
434          | otherwise = ptext (sLit "kind")
435     flag | is_type   = ptext (sLit "-XScopedTypeVariables")
436          | otherwise = ptext (sLit "-XKindSignatures")
437 \end{code}
438
439 Note [Renaming associated types] 
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
441 Check that the RHS of the decl mentions only type variables
442 bound on the LHS.  For example, this is not ok
443    class C a b where
444       type F a x :: *
445    instance C (p,q) r where
446       type F (p,q) x = (x, r)   -- BAD: mentions 'r'
447 c.f. Trac #5515
448
449 What makes it tricky is that the *kind* variable from the class *are*
450 in scope (Trac #5862):
451     class Category (x :: k -> k -> *) where
452       type Ob x :: k -> Constraint
453       id :: Ob x a => x a a
454       (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c 
455 Here 'k' is in scope in the kind signature even though it's not 
456 explicitly mentioned on the LHS of the type Ob declaration.
457
458 We could force you to mention k explicitly, thus
459     class Category (x :: k -> k -> *) where
460       type Ob (x :: k -> k -> *) :: k -> Constraint
461 but it seems tiresome to do so.
462
463
464 %*********************************************************
465 %*                                                      *
466 \subsection{Contexts and predicates}
467 %*                                                      *
468 %*********************************************************
469
470 \begin{code}
471 rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] 
472                 -> RnM ([ConDeclField Name], FreeVars)
473 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
474
475 rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
476 rnField doc (ConDeclField name ty haddock_doc)
477   = do { new_name <- lookupLocatedTopBndrRn name
478        ; (new_ty, fvs) <- rnLHsType doc ty
479        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
480        ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
481
482 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
483 rnContext doc (L loc cxt) 
484   = do { (cxt', fvs) <- rnLHsTypes doc cxt
485        ; return (L loc cxt', fvs) }
486
487 rnIPName :: IPName RdrName -> RnM (IPName Name)
488 rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
489 \end{code}
490
491
492 %************************************************************************
493 %*                                                                      *
494         Fixities and precedence parsing
495 %*                                                                      *
496 %************************************************************************
497
498 @mkOpAppRn@ deals with operator fixities.  The argument expressions
499 are assumed to be already correctly arranged.  It needs the fixities
500 recorded in the OpApp nodes, because fixity info applies to the things
501 the programmer actually wrote, so you can't find it out from the Name.
502
503 Furthermore, the second argument is guaranteed not to be another
504 operator application.  Why? Because the parser parses all
505 operator appications left-associatively, EXCEPT negation, which
506 we need to handle specially.
507 Infix types are read in a *right-associative* way, so that
508         a `op` b `op` c
509 is always read in as
510         a `op` (b `op` c)
511
512 mkHsOpTyRn rearranges where necessary.  The two arguments
513 have already been renamed and rearranged.  It's made rather tiresome
514 by the presence of ->, which is a separate syntactic construct.
515
516 \begin{code}
517 ---------------
518 -- Building (ty1 `op1` (ty21 `op2` ty22))
519 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
520            -> Name -> Fixity -> LHsType Name -> LHsType Name 
521            -> RnM (HsType Name)
522
523 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
524   = do  { fix2 <- lookupTyFixityRn op2
525         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
526                       (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
527                       (unLoc op2) fix2 ty21 ty22 loc2 }
528
529 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
530   = mk_hs_op_ty mk1 pp_op1 fix1 ty1 
531                 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
532
533 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
534   = return (mk1 ty1 ty2)
535
536 ---------------
537 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
538             -> Name -> Fixity -> LHsType Name
539             -> (LHsType Name -> LHsType Name -> HsType Name)
540             -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
541             -> RnM (HsType Name)
542 mk_hs_op_ty mk1 op1 fix1 ty1 
543             mk2 op2 fix2 ty21 ty22 loc2
544   | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
545                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
546   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
547   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
548                            new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
549                          ; return (mk2 (noLoc new_ty) ty22) }
550   where
551     (nofix_error, associate_right) = compareFixity fix1 fix2
552
553
554 ---------------------------
555 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
556           -> LHsExpr Name -> Fixity             -- Operator and fixity
557           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
558                                                 -- be a NegApp)
559           -> RnM (HsExpr Name)
560
561 -- (e11 `op1` e12) `op2` e2
562 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
563   | nofix_error
564   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
565        return (OpApp e1 op2 fix2 e2)
566
567   | associate_right = do
568     new_e <- mkOpAppRn e12 op2 fix2 e2
569     return (OpApp e11 op1 fix1 (L loc' new_e))
570   where
571     loc'= combineLocs e12 e2
572     (nofix_error, associate_right) = compareFixity fix1 fix2
573
574 ---------------------------
575 --      (- neg_arg) `op` e2
576 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
577   | nofix_error
578   = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
579        return (OpApp e1 op2 fix2 e2)
580
581   | associate_right 
582   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
583        return (NegApp (L loc' new_e) neg_name)
584   where
585     loc' = combineLocs neg_arg e2
586     (nofix_error, associate_right) = compareFixity negateFixity fix2
587
588 ---------------------------
589 --      e1 `op` - neg_arg
590 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
591   | not associate_right                 -- We *want* right association
592   = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
593        return (OpApp e1 op1 fix1 e2)
594   where
595     (_, associate_right) = compareFixity fix1 negateFixity
596
597 ---------------------------
598 --      Default case
599 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
600   = ASSERT2( right_op_ok fix (unLoc e2),
601              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
602     )
603     return (OpApp e1 op fix e2)
604
605 ----------------------------
606 get_op :: LHsExpr Name -> Name
607 get_op (L _ (HsVar n)) = n
608 get_op other           = pprPanic "get_op" (ppr other)
609
610 -- Parser left-associates everything, but 
611 -- derived instances may have correctly-associated things to
612 -- in the right operarand.  So we just check that the right operand is OK
613 right_op_ok :: Fixity -> HsExpr Name -> Bool
614 right_op_ok fix1 (OpApp _ _ fix2 _)
615   = not error_please && associate_right
616   where
617     (error_please, associate_right) = compareFixity fix1 fix2
618 right_op_ok _ _
619   = True
620
621 -- Parser initially makes negation bind more tightly than any other operator
622 -- And "deriving" code should respect this (use HsPar if not)
623 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
624 mkNegAppRn neg_arg neg_name
625   = ASSERT( not_op_app (unLoc neg_arg) )
626     return (NegApp neg_arg neg_name)
627
628 not_op_app :: HsExpr id -> Bool
629 not_op_app (OpApp _ _ _ _) = False
630 not_op_app _               = True
631
632 ---------------------------
633 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
634           -> LHsExpr Name -> Fixity     -- Operator and fixity
635           -> LHsCmdTop Name             -- Right operand (not an infix)
636           -> RnM (HsCmd Name)
637
638 -- (e11 `op1` e12) `op2` e2
639 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
640         op2 fix2 a2
641   | nofix_error
642   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
643        return (HsArrForm op2 (Just fix2) [a1, a2])
644
645   | associate_right
646   = do new_c <- mkOpFormRn a12 op2 fix2 a2
647        return (HsArrForm op1 (Just fix1)
648                   [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
649         -- TODO: locs are wrong
650   where
651     (nofix_error, associate_right) = compareFixity fix1 fix2
652
653 --      Default case
654 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
655   = return (HsArrForm op (Just fix) [arg1, arg2])
656
657
658 --------------------------------------
659 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
660              -> RnM (Pat Name)
661
662 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
663   = do  { fix1 <- lookupFixityRn (unLoc op1)
664         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
665
666         ; if nofix_error then do
667                 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
668                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
669
670           else if associate_right then do
671                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
672                 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
673           else return (ConPatIn op2 (InfixCon p1 p2)) }
674
675 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
676   = ASSERT( not_op_pat (unLoc p2) )
677     return (ConPatIn op (InfixCon p1 p2))
678
679 not_op_pat :: Pat Name -> Bool
680 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
681 not_op_pat _                           = True
682
683 --------------------------------------
684 checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
685   -- Check precedence of a function binding written infix
686   --   eg  a `op` b `C` c = ...
687   -- See comments with rnExpr (OpApp ...) about "deriving"
688
689 checkPrecMatch op (MatchGroup ms _)     
690   = mapM_ check ms                              
691   where
692     check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
693       = setSrcSpan (combineSrcSpans l1 l2) $
694         do checkPrec op p1 False
695            checkPrec op p2 True
696
697     check _ = return () 
698         -- This can happen.  Consider
699         --      a `op` True = ...
700         --      op          = ...
701         -- The infix flag comes from the first binding of the group
702         -- but the second eqn has no args (an error, but not discovered
703         -- until the type checker).  So we don't want to crash on the
704         -- second eqn.
705
706 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
707 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
708     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
709     op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
710     let
711         inf_ok = op1_prec > op_prec || 
712                  (op1_prec == op_prec &&
713                   (op1_dir == InfixR && op_dir == InfixR && right ||
714                    op1_dir == InfixL && op_dir == InfixL && not right))
715
716         info  = (op,        op_fix)
717         info1 = (unLoc op1, op1_fix)
718         (infol, infor) = if right then (info, info1) else (info1, info)
719     unless inf_ok (precParseErr infol infor)
720
721 checkPrec _ _ _
722   = return ()
723
724 -- Check precedence of (arg op) or (op arg) respectively
725 -- If arg is itself an operator application, then either
726 --   (a) its precedence must be higher than that of op
727 --   (b) its precedency & associativity must be the same as that of op
728 checkSectionPrec :: FixityDirection -> HsExpr RdrName
729         -> LHsExpr Name -> LHsExpr Name -> RnM ()
730 checkSectionPrec direction section op arg
731   = case unLoc arg of
732         OpApp _ op fix _ -> go_for_it (get_op op) fix
733         NegApp _ _       -> go_for_it negateName  negateFixity
734         _                -> return ()
735   where
736     op_name = get_op op
737     go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
738           op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
739           unless (op_prec < arg_prec
740                   || (op_prec == arg_prec && direction == assoc))
741                  (sectionPrecErr (op_name, op_fix)      
742                                  (arg_op, arg_fix) section)
743 \end{code}
744
745 Precedence-related error messages
746
747 \begin{code}
748 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
749 precParseErr op1@(n1,_) op2@(n2,_) 
750   | isUnboundName n1 || isUnboundName n2
751   = return ()     -- Avoid error cascade
752   | otherwise
753   = addErr $ hang (ptext (sLit "Precedence parsing error"))
754       4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), 
755                ppr_opfix op2,
756                ptext (sLit "in the same infix expression")])
757
758 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
759 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
760   | isUnboundName n1 || isUnboundName n2
761   = return ()     -- Avoid error cascade
762   | otherwise
763   = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
764          nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
765                       nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
766          nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
767
768 ppr_opfix :: (Name, Fixity) -> SDoc
769 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
770    where
771      pp_op | op == negateName = ptext (sLit "prefix `-'")
772            | otherwise        = quotes (ppr op)
773 \end{code}
774
775 %*********************************************************
776 %*                                                      *
777 \subsection{Errors}
778 %*                                                      *
779 %*********************************************************
780
781 \begin{code}
782 warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM ()
783 warnUnusedForAlls in_doc bound mentioned_rdrs
784   = ifWOptM Opt_WarnUnusedMatches $
785     mapM_ add_warn bound_but_not_used
786   where
787     bound_names        = hsLTyVarLocNames bound
788     bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
789
790     add_warn (L loc tv) 
791       = addWarnAt loc $
792         vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
793              , in_doc ]
794
795 opTyErr :: RdrName -> HsType RdrName -> SDoc
796 opTyErr op ty@(HsOpTy ty1 _ _)
797   = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
798          2 extra
799   where
800     extra | op == dot_tv_RDR && forall_head ty1
801           = perhapsForallMsg
802           | otherwise 
803           = ptext (sLit "Use -XTypeOperators to allow operators in types")
804
805     forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
806     forall_head (L _ (HsAppTy ty _)) = forall_head ty
807     forall_head _other               = False
808 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
809 \end{code}
810
811 %*********************************************************
812 %*                                                      *
813                 Splices
814 %*                                                      *
815 %*********************************************************
816
817 Note [Splices]
818 ~~~~~~~~~~~~~~
819 Consider
820         f = ...
821         h = ...$(thing "f")...
822
823 The splice can expand into literally anything, so when we do dependency
824 analysis we must assume that it might mention 'f'.  So we simply treat
825 all locally-defined names as mentioned by any splice.  This is terribly
826 brutal, but I don't see what else to do.  For example, it'll mean
827 that every locally-defined thing will appear to be used, so no unused-binding
828 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
829 and that will crash the type checker because 'f' isn't in scope.
830
831 Currently, I'm not treating a splice as also mentioning every import,
832 which is a bit inconsistent -- but there are a lot of them.  We might
833 thereby get some bogus unused-import warnings, but we won't crash the
834 type checker.  Not very satisfactory really.
835
836 \begin{code}
837 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
838 rnSplice (HsSplice n expr)
839   = do  { checkTH expr "splice"
840         ; loc  <- getSrcSpanM
841         ; n' <- newLocalBndrRn (L loc n)
842         ; (expr', fvs) <- rnLExpr expr
843
844         -- Ugh!  See Note [Splices] above
845         ; lcl_rdr <- getLocalRdrEnv
846         ; gbl_rdr <- getGlobalRdrEnv
847         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
848                                                     isLocalGRE gre]
849               lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
850
851         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
852
853 checkTH :: Outputable a => a -> String -> RnM ()
854 #ifdef GHCI 
855 checkTH _ _ = return () -- OK
856 #else
857 checkTH e what  -- Raise an error in a stage-1 compiler
858   = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>  
859                   ptext (sLit "requires GHC with interpreter support"),
860                   ptext (sLit "Perhaps you are using a stage-1 compiler?"),
861                   nest 2 (ppr e)])
862 #endif   
863 \end{code}
864
865 %************************************************************************
866 %*                                                                      *
867       Finding the free type variables of a (HsType RdrName)
868 %*                                                                    *
869 %************************************************************************
870
871 extractHsTyRdrNames finds the free variables of a HsType
872 It's used when making the for-alls explicit.
873
874 Note [Kind and type-variable binders]
875 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
876 In a type signature we may implicitly bind type varaible and, more
877 recently, kind variables.  For example:
878   *   f :: a -> a
879       f = ...
880     Here we need to find the free type variables of (a -> a),
881     so that we know what to quantify
882
883   *   class C (a :: k) where ...
884     This binds 'k' in ..., as well as 'a'
885
886   *   f (x :: a -> [a]) = ....
887     Here we bind 'a' in ....
888
889   *   f (x :: T a -> T (b :: k)) = ...
890     Here we bind both 'a' and the kind variable 'k'
891
892   *   type instance F (T (a :: Maybe k)) = ...a...k...
893     Here we want to constrain the kind of 'a', and bind 'k'.
894
895 In general we want to walk over a type, and find 
896   * Its free type variables
897   * The free kind variables of any kind signatures in the type
898
899 Hence we returns a pair (kind-vars, type vars)
900 See also Note [HsBSig binder lists] in HsTypes
901
902 \begin{code}
903 type FreeKiTyVars = ([RdrName], [RdrName])
904
905 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
906 -- See Note [Kind and type-variable binders]
907 extractHsTyRdrTyVars ty 
908   = case extract_lty ty ([],[]) of
909      (kvs, tvs) -> (nub kvs, nub tvs)
910
911 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
912 -- See Note [Kind and type-variable binders]
913 extractHsTysRdrTyVars ty 
914   = case extract_ltys ty ([],[]) of
915      (kvs, tvs) -> (nub kvs, nub tvs)
916
917 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
918 extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
919
920 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
921 extract_ltys tys acc = foldr extract_lty acc tys
922
923 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
924 extract_lty (L _ ty) acc
925   = case ty of
926       HsTyVar tv                -> extract_tv tv acc
927       HsBangTy _ ty             -> extract_lty ty acc
928       HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
929       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
930       HsListTy ty               -> extract_lty ty acc
931       HsPArrTy ty               -> extract_lty ty acc
932       HsTupleTy _ tys           -> extract_ltys tys acc
933       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
934       HsIParamTy _ ty           -> extract_lty ty acc
935       HsEqTy ty1 ty2            -> extract_lty ty1 (extract_lty ty2 acc)
936       HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
937       HsParTy ty                -> extract_lty ty acc
938       HsCoreTy {}               -> acc  -- The type is closed
939       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
940       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
941       HsDocTy ty _              -> extract_lty ty acc
942       HsExplicitListTy _ tys    -> extract_ltys tys acc
943       HsExplicitTupleTy _ tys   -> extract_ltys tys acc
944       HsTyLit _                 -> acc
945       HsWrapTy _ _              -> panic "extract_lty"
946       HsKindSig ty ki           -> case extract_lty ty acc of { (kvs1, tvs) ->
947                                    case extract_lty ki ([],kvs1) of { (_, kvs2) -> 
948                                         -- Kinds shouldn't have sort signatures!
949                                    (kvs2, tvs) }}
950       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
951       HsForAllTy _ tvs cx ty    -> (acc_kvs ++ body_kvs, 
952                                     acc_tvs ++ filterOut (`elem` locals_tvs) body_tvs)
953                                 where
954                                    (body_kvs, body_tvs) = extract_lctxt cx (extract_lty ty ([],[]))
955                                    (acc_kvs, acc_tvs) = acc
956                                    locals_tvs = hsLTyVarNames tvs
957                                         -- Currently we don't have a syntax to explicity bind 
958                                         -- kind variables, so these are all type variables
959
960 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
961 extract_tv tv acc
962   | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
963   | otherwise     = acc
964 \end{code}