Several TH/quasiquote changes
[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 module RnTypes ( 
8         -- Type related stuff
9         rnHsType, rnLHsType, rnLHsTypes, rnContext,
10         rnHsSigType, rnHsTypeFVs, rnConDeclFields,
11
12         -- Precence related stuff
13         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
14         checkPrecMatch, checkSectionPrec,
15
16         -- Splice related stuff
17         rnSplice, checkTH
18   ) where
19
20 import {-# SOURCE #-} RnExpr( rnLExpr )
21 #ifdef GHCI
22 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
23 #endif  /* GHCI */
24
25 import DynFlags
26 import HsSyn
27 import RdrHsSyn         ( extractHsRhoRdrTyVars )
28 import RnHsSyn          ( extractHsTyNames )
29 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
30 import RnEnv
31 import TcRnMonad
32 import RdrName
33 import PrelNames
34 import TypeRep          ( funTyConName )
35 import Name
36 import SrcLoc
37 import NameSet
38
39 import BasicTypes       ( compareFixity, funTyFixity, negateFixity, 
40                           Fixity(..), FixityDirection(..) )
41 import Outputable
42 import FastString
43 import Control.Monad    ( unless )
44
45 #include "HsVersions.h"
46 \end{code}
47
48 These type renamers are in a separate module, rather than in (say) RnSource,
49 to break several loop.
50
51 %*********************************************************
52 %*                                                      *
53 \subsection{Renaming types}
54 %*                                                      *
55 %*********************************************************
56
57 \begin{code}
58 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
59 rnHsTypeFVs doc_str ty  = do
60     ty' <- rnLHsType doc_str ty
61     return (ty', extractHsTyNames ty')
62
63 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
64         -- rnHsSigType is used for source-language type signatures,
65         -- which use *implicit* universal quantification.
66 rnHsSigType doc_str ty
67   = rnLHsType (text "In the type signature for" <+> doc_str) ty
68 \end{code}
69
70 rnHsType is here because we call it from loadInstDecl, and I didn't
71 want a gratuitous knot.
72
73 \begin{code}
74 rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
75 rnLHsType doc = wrapLocM (rnHsType doc)
76
77 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
78
79 rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
80         -- Implicit quantifiction in source code (no kinds on tyvars)
81         -- Given the signature  C => T  we universally quantify 
82         -- over FV(T) \ {in-scope-tyvars} 
83     name_env <- getLocalRdrEnv
84     let
85         mentioned = extractHsRhoRdrTyVars ctxt ty
86
87         -- Don't quantify over type variables that are in scope;
88         -- when GlasgowExts is off, there usually won't be any, except for
89         -- class signatures:
90         --      class C a where { op :: a -> a }
91         forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
92         tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
93
94     rnForAll doc Implicit tyvar_bndrs ctxt ty
95
96 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
97         -- Explicit quantification.
98         -- Check that the forall'd tyvars are actually 
99         -- mentioned in the type, and produce a warning if not
100     let
101         mentioned          = map unLoc (extractHsRhoRdrTyVars ctxt tau)
102         forall_tyvar_names = hsLTyVarLocNames forall_tyvars
103
104         -- Explicitly quantified but not mentioned in ctxt or tau
105         warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
106
107     mapM_ (forAllWarn doc tau) warn_guys
108     rnForAll doc Explicit forall_tyvars ctxt tau
109
110 rnHsType _ (HsTyVar tyvar) = do
111     tyvar' <- lookupOccRn tyvar
112     return (HsTyVar tyvar')
113
114 -- If we see (forall a . ty), without foralls on, the forall will give
115 -- a sensible error message, but we don't want to complain about the dot too
116 -- Hence the jiggery pokery with ty1
117 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
118   = setSrcSpan loc $ 
119     do  { ops_ok <- doptM Opt_TypeOperators
120         ; op' <- if ops_ok
121                  then lookupOccRn op 
122                  else do { addErr (opTyErr op ty)
123                          ; return (mkUnboundName op) }  -- Avoid double complaint
124         ; let l_op' = L loc op'
125         ; fix <- lookupTyFixityRn l_op'
126         ; ty1' <- rnLHsType doc ty1
127         ; ty2' <- rnLHsType doc ty2
128         ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
129
130 rnHsType doc (HsParTy ty) = do
131     ty' <- rnLHsType doc ty
132     return (HsParTy ty')
133
134 rnHsType doc (HsBangTy b ty)
135   = do { ty' <- rnLHsType doc ty
136        ; return (HsBangTy b ty') }
137
138 rnHsType doc (HsRecTy flds)
139   = do { flds' <- rnConDeclFields doc flds
140        ; return (HsRecTy flds') }
141
142 rnHsType _ (HsNumTy i)
143   | i == 1    = return (HsNumTy i)
144   | otherwise = addErr err_msg >> return (HsNumTy i)
145   where
146     err_msg = ptext (sLit "Only unit numeric type pattern is valid")
147                            
148
149 rnHsType doc (HsFunTy ty1 ty2) = do
150     ty1' <- rnLHsType doc ty1
151         -- Might find a for-all as the arg of a function type
152     ty2' <- rnLHsType doc ty2
153         -- Or as the result.  This happens when reading Prelude.hi
154         -- when we find return :: forall m. Monad m -> forall a. a -> m a
155
156         -- Check for fixity rearrangements
157     mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
158
159 rnHsType doc (HsListTy ty) = do
160     ty' <- rnLHsType doc ty
161     return (HsListTy ty')
162
163 rnHsType doc (HsKindSig ty k)
164   = do { kind_sigs_ok <- doptM Opt_KindSignatures
165        ; unless kind_sigs_ok (addErr (kindSigErr ty))
166        ; ty' <- rnLHsType doc ty
167        ; return (HsKindSig ty' k) }
168
169 rnHsType doc (HsPArrTy ty) = do
170     ty' <- rnLHsType doc ty
171     return (HsPArrTy ty')
172
173 -- Unboxed tuples are allowed to have poly-typed arguments.  These
174 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
175 rnHsType doc (HsTupleTy tup_con tys) = do
176     tys' <- mapM (rnLHsType doc) tys
177     return (HsTupleTy tup_con tys')
178
179 rnHsType doc (HsAppTy ty1 ty2) = do
180     ty1' <- rnLHsType doc ty1
181     ty2' <- rnLHsType doc ty2
182     return (HsAppTy ty1' ty2')
183
184 rnHsType doc (HsPredTy pred) = do
185     pred' <- rnPred doc pred
186     return (HsPredTy pred')
187
188 rnHsType _ (HsSpliceTy sp)
189   = do { (sp', _fvs) <- rnSplice sp     -- ToDo: deal with fvs
190        ; return (HsSpliceTy sp') }
191
192 rnHsType doc (HsDocTy ty haddock_doc) = do
193     ty' <- rnLHsType doc ty
194     haddock_doc' <- rnLHsDoc haddock_doc
195     return (HsDocTy ty' haddock_doc')
196
197 #ifndef GHCI
198 rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
199 #else
200 rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
201                                       ; rnHsType doc (unLoc ty) }
202 #endif
203 rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType"
204
205 rnLHsTypes :: SDoc -> [LHsType RdrName]
206            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
207 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
208 \end{code}
209
210
211 \begin{code}
212 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
213          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
214
215 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
216         -- One reason for this case is that a type like Int#
217         -- starts off as (HsForAllTy Nothing [] Int), in case
218         -- there is some quantification.  Now that we have quantified
219         -- and discovered there are no type variables, it's nicer to turn
220         -- it into plain Int.  If it were Int# instead of Int, we'd actually
221         -- get an error, because the body of a genuine for-all is
222         -- of kind *.
223
224 rnForAll doc exp forall_tyvars ctxt ty
225   = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
226     new_ctxt <- rnContext doc ctxt
227     new_ty <- rnLHsType doc ty
228     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
229         -- Retain the same implicit/explicit flag as before
230         -- so that we can later print it correctly
231
232 rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
233 rnConDeclFields doc fields = mapM (rnField doc) fields
234
235 rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
236 rnField doc (ConDeclField name ty haddock_doc)
237   = do { new_name <- lookupLocatedTopBndrRn name
238        ; new_ty <- rnLHsType doc ty
239        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
240        ; return (ConDeclField new_name new_ty new_haddock_doc) }
241 \end{code}
242
243 %*********************************************************
244 %*                                                      *
245 \subsection{Contexts and predicates}
246 %*                                                      *
247 %*********************************************************
248
249 \begin{code}
250 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
251 rnContext doc = wrapLocM (rnContext' doc)
252
253 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
254 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
255
256 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
257 rnLPred doc  = wrapLocM (rnPred doc)
258
259 rnPred :: SDoc -> HsPred RdrName
260        -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
261 rnPred doc (HsClassP clas tys)
262   = do { clas_name <- lookupOccRn clas
263        ; tys' <- rnLHsTypes doc tys
264        ; return (HsClassP clas_name tys')
265        }
266 rnPred doc (HsEqualP ty1 ty2)
267   = do { ty1' <- rnLHsType doc ty1
268        ; ty2' <- rnLHsType doc ty2
269        ; return (HsEqualP ty1' ty2')
270        }
271 rnPred doc (HsIParam n ty)
272   = do { name <- newIPNameRn n
273        ; ty' <- rnLHsType doc ty
274        ; return (HsIParam name ty')
275        }
276 \end{code}
277
278
279 %************************************************************************
280 %*                                                                      *
281         Fixities and precedence parsing
282 %*                                                                      *
283 %************************************************************************
284
285 @mkOpAppRn@ deals with operator fixities.  The argument expressions
286 are assumed to be already correctly arranged.  It needs the fixities
287 recorded in the OpApp nodes, because fixity info applies to the things
288 the programmer actually wrote, so you can't find it out from the Name.
289
290 Furthermore, the second argument is guaranteed not to be another
291 operator application.  Why? Because the parser parses all
292 operator appications left-associatively, EXCEPT negation, which
293 we need to handle specially.
294 Infix types are read in a *right-associative* way, so that
295         a `op` b `op` c
296 is always read in as
297         a `op` (b `op` c)
298
299 mkHsOpTyRn rearranges where necessary.  The two arguments
300 have already been renamed and rearranged.  It's made rather tiresome
301 by the presence of ->, which is a separate syntactic construct.
302
303 \begin{code}
304 ---------------
305 -- Building (ty1 `op1` (ty21 `op2` ty22))
306 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
307            -> Name -> Fixity -> LHsType Name -> LHsType Name 
308            -> RnM (HsType Name)
309
310 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
311   = do  { fix2 <- lookupTyFixityRn op2
312         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
313                       (\t1 t2 -> HsOpTy t1 op2 t2)
314                       (unLoc op2) fix2 ty21 ty22 loc2 }
315
316 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
317   = mk_hs_op_ty mk1 pp_op1 fix1 ty1 
318                 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
319
320 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
321   = return (mk1 ty1 ty2)
322
323 ---------------
324 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
325             -> Name -> Fixity -> LHsType Name
326             -> (LHsType Name -> LHsType Name -> HsType Name)
327             -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
328             -> RnM (HsType Name)
329 mk_hs_op_ty mk1 op1 fix1 ty1 
330             mk2 op2 fix2 ty21 ty22 loc2
331   | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
332                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
333   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
334   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
335                            new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
336                          ; return (mk2 (noLoc new_ty) ty22) }
337   where
338     (nofix_error, associate_right) = compareFixity fix1 fix2
339
340
341 ---------------------------
342 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
343           -> LHsExpr Name -> Fixity             -- Operator and fixity
344           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
345                                                 -- be a NegApp)
346           -> RnM (HsExpr Name)
347
348 -- (e11 `op1` e12) `op2` e2
349 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
350   | nofix_error
351   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
352        return (OpApp e1 op2 fix2 e2)
353
354   | associate_right = do
355     new_e <- mkOpAppRn e12 op2 fix2 e2
356     return (OpApp e11 op1 fix1 (L loc' new_e))
357   where
358     loc'= combineLocs e12 e2
359     (nofix_error, associate_right) = compareFixity fix1 fix2
360
361 ---------------------------
362 --      (- neg_arg) `op` e2
363 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
364   | nofix_error
365   = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
366        return (OpApp e1 op2 fix2 e2)
367
368   | associate_right 
369   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
370        return (NegApp (L loc' new_e) neg_name)
371   where
372     loc' = combineLocs neg_arg e2
373     (nofix_error, associate_right) = compareFixity negateFixity fix2
374
375 ---------------------------
376 --      e1 `op` - neg_arg
377 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
378   | not associate_right                 -- We *want* right association
379   = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
380        return (OpApp e1 op1 fix1 e2)
381   where
382     (_, associate_right) = compareFixity fix1 negateFixity
383
384 ---------------------------
385 --      Default case
386 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
387   = ASSERT2( right_op_ok fix (unLoc e2),
388              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
389     )
390     return (OpApp e1 op fix e2)
391
392 ----------------------------
393 get_op :: LHsExpr Name -> Name
394 get_op (L _ (HsVar n)) = n
395 get_op other           = pprPanic "get_op" (ppr other)
396
397 -- Parser left-associates everything, but 
398 -- derived instances may have correctly-associated things to
399 -- in the right operarand.  So we just check that the right operand is OK
400 right_op_ok :: Fixity -> HsExpr Name -> Bool
401 right_op_ok fix1 (OpApp _ _ fix2 _)
402   = not error_please && associate_right
403   where
404     (error_please, associate_right) = compareFixity fix1 fix2
405 right_op_ok _ _
406   = True
407
408 -- Parser initially makes negation bind more tightly than any other operator
409 -- And "deriving" code should respect this (use HsPar if not)
410 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
411 mkNegAppRn neg_arg neg_name
412   = ASSERT( not_op_app (unLoc neg_arg) )
413     return (NegApp neg_arg neg_name)
414
415 not_op_app :: HsExpr id -> Bool
416 not_op_app (OpApp _ _ _ _) = False
417 not_op_app _               = True
418
419 ---------------------------
420 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
421           -> LHsExpr Name -> Fixity     -- Operator and fixity
422           -> LHsCmdTop Name             -- Right operand (not an infix)
423           -> RnM (HsCmd Name)
424
425 -- (e11 `op1` e12) `op2` e2
426 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
427         op2 fix2 a2
428   | nofix_error
429   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
430        return (HsArrForm op2 (Just fix2) [a1, a2])
431
432   | associate_right
433   = do new_c <- mkOpFormRn a12 op2 fix2 a2
434        return (HsArrForm op1 (Just fix1)
435                   [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
436         -- TODO: locs are wrong
437   where
438     (nofix_error, associate_right) = compareFixity fix1 fix2
439
440 --      Default case
441 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
442   = return (HsArrForm op (Just fix) [arg1, arg2])
443
444
445 --------------------------------------
446 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
447              -> RnM (Pat Name)
448
449 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
450   = do  { fix1 <- lookupFixityRn (unLoc op1)
451         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
452
453         ; if nofix_error then do
454                 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
455                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
456
457           else if associate_right then do
458                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
459                 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
460           else return (ConPatIn op2 (InfixCon p1 p2)) }
461
462 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
463   = ASSERT( not_op_pat (unLoc p2) )
464     return (ConPatIn op (InfixCon p1 p2))
465
466 not_op_pat :: Pat Name -> Bool
467 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
468 not_op_pat _                           = True
469
470 --------------------------------------
471 checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
472   -- Check precedence of a function binding written infix
473   --   eg  a `op` b `C` c = ...
474   -- See comments with rnExpr (OpApp ...) about "deriving"
475
476 checkPrecMatch op (MatchGroup ms _)     
477   = mapM_ check ms                              
478   where
479     check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
480       = setSrcSpan (combineSrcSpans l1 l2) $
481         do checkPrec op p1 False
482            checkPrec op p2 True
483
484     check _ = return () 
485         -- This can happen.  Consider
486         --      a `op` True = ...
487         --      op          = ...
488         -- The infix flag comes from the first binding of the group
489         -- but the second eqn has no args (an error, but not discovered
490         -- until the type checker).  So we don't want to crash on the
491         -- second eqn.
492
493 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
494 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
495     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
496     op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
497     let
498         inf_ok = op1_prec > op_prec || 
499                  (op1_prec == op_prec &&
500                   (op1_dir == InfixR && op_dir == InfixR && right ||
501                    op1_dir == InfixL && op_dir == InfixL && not right))
502
503         info  = (op,        op_fix)
504         info1 = (unLoc op1, op1_fix)
505         (infol, infor) = if right then (info, info1) else (info1, info)
506     unless inf_ok (precParseErr infol infor)
507
508 checkPrec _ _ _
509   = return ()
510
511 -- Check precedence of (arg op) or (op arg) respectively
512 -- If arg is itself an operator application, then either
513 --   (a) its precedence must be higher than that of op
514 --   (b) its precedency & associativity must be the same as that of op
515 checkSectionPrec :: FixityDirection -> HsExpr RdrName
516         -> LHsExpr Name -> LHsExpr Name -> RnM ()
517 checkSectionPrec direction section op arg
518   = case unLoc arg of
519         OpApp _ op fix _ -> go_for_it (get_op op) fix
520         NegApp _ _       -> go_for_it negateName  negateFixity
521         _                -> return ()
522   where
523     op_name = get_op op
524     go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
525           op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
526           unless (op_prec < arg_prec
527                   || (op_prec == arg_prec && direction == assoc))
528                  (sectionPrecErr (op_name, op_fix)      
529                                  (arg_op, arg_fix) section)
530 \end{code}
531
532 Precedence-related error messages
533
534 \begin{code}
535 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
536 precParseErr op1@(n1,_) op2@(n2,_) 
537   | isUnboundName n1 || isUnboundName n2
538   = return ()     -- Avoid error cascade
539   | otherwise
540   = addErr $ hang (ptext (sLit "Precedence parsing error"))
541       4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), 
542                ppr_opfix op2,
543                ptext (sLit "in the same infix expression")])
544
545 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
546 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
547   | isUnboundName n1 || isUnboundName n2
548   = return ()     -- Avoid error cascade
549   | otherwise
550   = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
551          nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
552                       nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
553          nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
554
555 ppr_opfix :: (Name, Fixity) -> SDoc
556 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
557    where
558      pp_op | op == negateName = ptext (sLit "prefix `-'")
559            | otherwise        = quotes (ppr op)
560 \end{code}
561
562 %*********************************************************
563 %*                                                      *
564 \subsection{Errors}
565 %*                                                      *
566 %*********************************************************
567
568 \begin{code}
569 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
570            -> TcRnIf TcGblEnv TcLclEnv ()
571 forAllWarn doc ty (L loc tyvar)
572   = ifOptM Opt_WarnUnusedMatches        $
573     addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
574                         nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
575                    $$
576                    doc)
577
578 opTyErr :: RdrName -> HsType RdrName -> SDoc
579 opTyErr op ty@(HsOpTy ty1 _ _)
580   = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
581          2 extra
582   where
583     extra | op == dot_tv_RDR && forall_head ty1
584           = perhapsForallMsg
585           | otherwise 
586           = ptext (sLit "Use -XTypeOperators to allow operators in types")
587
588     forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
589     forall_head (L _ (HsAppTy ty _)) = forall_head ty
590     forall_head _other               = False
591 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
592 \end{code}
593
594 %*********************************************************
595 %*                                                      *
596                 Splices
597 %*                                                      *
598 %*********************************************************
599
600 Note [Splices]
601 ~~~~~~~~~~~~~~
602 Consider
603         f = ...
604         h = ...$(thing "f")...
605
606 The splice can expand into literally anything, so when we do dependency
607 analysis we must assume that it might mention 'f'.  So we simply treat
608 all locally-defined names as mentioned by any splice.  This is terribly
609 brutal, but I don't see what else to do.  For example, it'll mean
610 that every locally-defined thing will appear to be used, so no unused-binding
611 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
612 and that will crash the type checker because 'f' isn't in scope.
613
614 Currently, I'm not treating a splice as also mentioning every import,
615 which is a bit inconsistent -- but there are a lot of them.  We might
616 thereby get some bogus unused-import warnings, but we won't crash the
617 type checker.  Not very satisfactory really.
618
619 \begin{code}
620 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
621 rnSplice (HsSplice n expr)
622   = do  { checkTH expr "splice"
623         ; loc  <- getSrcSpanM
624         ; n' <- newLocalBndrRn (L loc n)
625         ; (expr', fvs) <- rnLExpr expr
626
627         -- Ugh!  See Note [Splices] above
628         ; lcl_rdr <- getLocalRdrEnv
629         ; gbl_rdr <- getGlobalRdrEnv
630         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
631                                                     isLocalGRE gre]
632               lcl_names = mkNameSet (occEnvElts lcl_rdr)
633
634         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
635
636 checkTH :: Outputable a => a -> String -> RnM ()
637 #ifdef GHCI 
638 checkTH _ _ = return () -- OK
639 #else
640 checkTH e what  -- Raise an error in a stage-1 compiler
641   = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>  
642                   ptext (sLit "illegal in a stage-1 compiler"),
643                   nest 2 (ppr e)])
644 #endif   
645 \end{code}