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