Add separate functions for querying DynFlag and ExtensionFlag options
[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, rnLPred,
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 <- xoptM 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 <- xoptM 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 _ k)
189   = do { (sp', fvs) <- rnSplice sp      -- ToDo: deal with fvs
190        ; return (HsSpliceTy sp' fvs k) }
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 _ (HsCoreTy ty) = return (HsCoreTy ty)
204
205 --------------
206 rnLHsTypes :: SDoc -> [LHsType RdrName]
207            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
208 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
209 \end{code}
210
211
212 \begin{code}
213 rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
214          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
215
216 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
217         -- One reason for this case is that a type like Int#
218         -- starts off as (HsForAllTy Nothing [] Int), in case
219         -- there is some quantification.  Now that we have quantified
220         -- and discovered there are no type variables, it's nicer to turn
221         -- it into plain Int.  If it were Int# instead of Int, we'd actually
222         -- get an error, because the body of a genuine for-all is
223         -- of kind *.
224
225 rnForAll doc exp forall_tyvars ctxt ty
226   = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
227     new_ctxt <- rnContext doc ctxt
228     new_ty <- rnLHsType doc ty
229     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
230         -- Retain the same implicit/explicit flag as before
231         -- so that we can later print it correctly
232
233 rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
234 rnConDeclFields doc fields = mapM (rnField doc) fields
235
236 rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
237 rnField doc (ConDeclField name ty haddock_doc)
238   = do { new_name <- lookupLocatedTopBndrRn name
239        ; new_ty <- rnLHsType doc ty
240        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
241        ; return (ConDeclField new_name new_ty new_haddock_doc) }
242 \end{code}
243
244 %*********************************************************
245 %*                                                      *
246 \subsection{Contexts and predicates}
247 %*                                                      *
248 %*********************************************************
249
250 \begin{code}
251 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
252 rnContext doc = wrapLocM (rnContext' doc)
253
254 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
255 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
256
257 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
258 rnLPred doc  = wrapLocM (rnPred doc)
259
260 rnPred :: SDoc -> HsPred RdrName
261        -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
262 rnPred doc (HsClassP clas tys)
263   = do { clas_name <- lookupOccRn clas
264        ; tys' <- rnLHsTypes doc tys
265        ; return (HsClassP clas_name tys')
266        }
267 rnPred doc (HsEqualP ty1 ty2)
268   = do { ty1' <- rnLHsType doc ty1
269        ; ty2' <- rnLHsType doc ty2
270        ; return (HsEqualP ty1' ty2')
271        }
272 rnPred doc (HsIParam n ty)
273   = do { name <- newIPNameRn n
274        ; ty' <- rnLHsType doc ty
275        ; return (HsIParam name ty')
276        }
277 \end{code}
278
279
280 %************************************************************************
281 %*                                                                      *
282         Fixities and precedence parsing
283 %*                                                                      *
284 %************************************************************************
285
286 @mkOpAppRn@ deals with operator fixities.  The argument expressions
287 are assumed to be already correctly arranged.  It needs the fixities
288 recorded in the OpApp nodes, because fixity info applies to the things
289 the programmer actually wrote, so you can't find it out from the Name.
290
291 Furthermore, the second argument is guaranteed not to be another
292 operator application.  Why? Because the parser parses all
293 operator appications left-associatively, EXCEPT negation, which
294 we need to handle specially.
295 Infix types are read in a *right-associative* way, so that
296         a `op` b `op` c
297 is always read in as
298         a `op` (b `op` c)
299
300 mkHsOpTyRn rearranges where necessary.  The two arguments
301 have already been renamed and rearranged.  It's made rather tiresome
302 by the presence of ->, which is a separate syntactic construct.
303
304 \begin{code}
305 ---------------
306 -- Building (ty1 `op1` (ty21 `op2` ty22))
307 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
308            -> Name -> Fixity -> LHsType Name -> LHsType Name 
309            -> RnM (HsType Name)
310
311 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
312   = do  { fix2 <- lookupTyFixityRn op2
313         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
314                       (\t1 t2 -> HsOpTy t1 op2 t2)
315                       (unLoc op2) fix2 ty21 ty22 loc2 }
316
317 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
318   = mk_hs_op_ty mk1 pp_op1 fix1 ty1 
319                 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
320
321 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
322   = return (mk1 ty1 ty2)
323
324 ---------------
325 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
326             -> Name -> Fixity -> LHsType Name
327             -> (LHsType Name -> LHsType Name -> HsType Name)
328             -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
329             -> RnM (HsType Name)
330 mk_hs_op_ty mk1 op1 fix1 ty1 
331             mk2 op2 fix2 ty21 ty22 loc2
332   | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
333                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
334   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
335   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
336                            new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
337                          ; return (mk2 (noLoc new_ty) ty22) }
338   where
339     (nofix_error, associate_right) = compareFixity fix1 fix2
340
341
342 ---------------------------
343 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
344           -> LHsExpr Name -> Fixity             -- Operator and fixity
345           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
346                                                 -- be a NegApp)
347           -> RnM (HsExpr Name)
348
349 -- (e11 `op1` e12) `op2` e2
350 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
351   | nofix_error
352   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
353        return (OpApp e1 op2 fix2 e2)
354
355   | associate_right = do
356     new_e <- mkOpAppRn e12 op2 fix2 e2
357     return (OpApp e11 op1 fix1 (L loc' new_e))
358   where
359     loc'= combineLocs e12 e2
360     (nofix_error, associate_right) = compareFixity fix1 fix2
361
362 ---------------------------
363 --      (- neg_arg) `op` e2
364 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
365   | nofix_error
366   = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
367        return (OpApp e1 op2 fix2 e2)
368
369   | associate_right 
370   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
371        return (NegApp (L loc' new_e) neg_name)
372   where
373     loc' = combineLocs neg_arg e2
374     (nofix_error, associate_right) = compareFixity negateFixity fix2
375
376 ---------------------------
377 --      e1 `op` - neg_arg
378 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
379   | not associate_right                 -- We *want* right association
380   = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
381        return (OpApp e1 op1 fix1 e2)
382   where
383     (_, associate_right) = compareFixity fix1 negateFixity
384
385 ---------------------------
386 --      Default case
387 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
388   = ASSERT2( right_op_ok fix (unLoc e2),
389              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
390     )
391     return (OpApp e1 op fix e2)
392
393 ----------------------------
394 get_op :: LHsExpr Name -> Name
395 get_op (L _ (HsVar n)) = n
396 get_op other           = pprPanic "get_op" (ppr other)
397
398 -- Parser left-associates everything, but 
399 -- derived instances may have correctly-associated things to
400 -- in the right operarand.  So we just check that the right operand is OK
401 right_op_ok :: Fixity -> HsExpr Name -> Bool
402 right_op_ok fix1 (OpApp _ _ fix2 _)
403   = not error_please && associate_right
404   where
405     (error_please, associate_right) = compareFixity fix1 fix2
406 right_op_ok _ _
407   = True
408
409 -- Parser initially makes negation bind more tightly than any other operator
410 -- And "deriving" code should respect this (use HsPar if not)
411 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
412 mkNegAppRn neg_arg neg_name
413   = ASSERT( not_op_app (unLoc neg_arg) )
414     return (NegApp neg_arg neg_name)
415
416 not_op_app :: HsExpr id -> Bool
417 not_op_app (OpApp _ _ _ _) = False
418 not_op_app _               = True
419
420 ---------------------------
421 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
422           -> LHsExpr Name -> Fixity     -- Operator and fixity
423           -> LHsCmdTop Name             -- Right operand (not an infix)
424           -> RnM (HsCmd Name)
425
426 -- (e11 `op1` e12) `op2` e2
427 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
428         op2 fix2 a2
429   | nofix_error
430   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
431        return (HsArrForm op2 (Just fix2) [a1, a2])
432
433   | associate_right
434   = do new_c <- mkOpFormRn a12 op2 fix2 a2
435        return (HsArrForm op1 (Just fix1)
436                   [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
437         -- TODO: locs are wrong
438   where
439     (nofix_error, associate_right) = compareFixity fix1 fix2
440
441 --      Default case
442 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
443   = return (HsArrForm op (Just fix) [arg1, arg2])
444
445
446 --------------------------------------
447 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
448              -> RnM (Pat Name)
449
450 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
451   = do  { fix1 <- lookupFixityRn (unLoc op1)
452         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
453
454         ; if nofix_error then do
455                 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
456                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
457
458           else if associate_right then do
459                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
460                 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
461           else return (ConPatIn op2 (InfixCon p1 p2)) }
462
463 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
464   = ASSERT( not_op_pat (unLoc p2) )
465     return (ConPatIn op (InfixCon p1 p2))
466
467 not_op_pat :: Pat Name -> Bool
468 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
469 not_op_pat _                           = True
470
471 --------------------------------------
472 checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
473   -- Check precedence of a function binding written infix
474   --   eg  a `op` b `C` c = ...
475   -- See comments with rnExpr (OpApp ...) about "deriving"
476
477 checkPrecMatch op (MatchGroup ms _)     
478   = mapM_ check ms                              
479   where
480     check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
481       = setSrcSpan (combineSrcSpans l1 l2) $
482         do checkPrec op p1 False
483            checkPrec op p2 True
484
485     check _ = return () 
486         -- This can happen.  Consider
487         --      a `op` True = ...
488         --      op          = ...
489         -- The infix flag comes from the first binding of the group
490         -- but the second eqn has no args (an error, but not discovered
491         -- until the type checker).  So we don't want to crash on the
492         -- second eqn.
493
494 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
495 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
496     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
497     op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
498     let
499         inf_ok = op1_prec > op_prec || 
500                  (op1_prec == op_prec &&
501                   (op1_dir == InfixR && op_dir == InfixR && right ||
502                    op1_dir == InfixL && op_dir == InfixL && not right))
503
504         info  = (op,        op_fix)
505         info1 = (unLoc op1, op1_fix)
506         (infol, infor) = if right then (info, info1) else (info1, info)
507     unless inf_ok (precParseErr infol infor)
508
509 checkPrec _ _ _
510   = return ()
511
512 -- Check precedence of (arg op) or (op arg) respectively
513 -- If arg is itself an operator application, then either
514 --   (a) its precedence must be higher than that of op
515 --   (b) its precedency & associativity must be the same as that of op
516 checkSectionPrec :: FixityDirection -> HsExpr RdrName
517         -> LHsExpr Name -> LHsExpr Name -> RnM ()
518 checkSectionPrec direction section op arg
519   = case unLoc arg of
520         OpApp _ op fix _ -> go_for_it (get_op op) fix
521         NegApp _ _       -> go_for_it negateName  negateFixity
522         _                -> return ()
523   where
524     op_name = get_op op
525     go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
526           op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
527           unless (op_prec < arg_prec
528                   || (op_prec == arg_prec && direction == assoc))
529                  (sectionPrecErr (op_name, op_fix)      
530                                  (arg_op, arg_fix) section)
531 \end{code}
532
533 Precedence-related error messages
534
535 \begin{code}
536 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
537 precParseErr op1@(n1,_) op2@(n2,_) 
538   | isUnboundName n1 || isUnboundName n2
539   = return ()     -- Avoid error cascade
540   | otherwise
541   = addErr $ hang (ptext (sLit "Precedence parsing error"))
542       4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), 
543                ppr_opfix op2,
544                ptext (sLit "in the same infix expression")])
545
546 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
547 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
548   | isUnboundName n1 || isUnboundName n2
549   = return ()     -- Avoid error cascade
550   | otherwise
551   = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
552          nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
553                       nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
554          nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
555
556 ppr_opfix :: (Name, Fixity) -> SDoc
557 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
558    where
559      pp_op | op == negateName = ptext (sLit "prefix `-'")
560            | otherwise        = quotes (ppr op)
561 \end{code}
562
563 %*********************************************************
564 %*                                                      *
565 \subsection{Errors}
566 %*                                                      *
567 %*********************************************************
568
569 \begin{code}
570 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
571            -> TcRnIf TcGblEnv TcLclEnv ()
572 forAllWarn doc ty (L loc tyvar)
573   = ifDOptM Opt_WarnUnusedMatches       $
574     addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
575                         nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
576                    $$
577                    doc)
578
579 opTyErr :: RdrName -> HsType RdrName -> SDoc
580 opTyErr op ty@(HsOpTy ty1 _ _)
581   = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
582          2 extra
583   where
584     extra | op == dot_tv_RDR && forall_head ty1
585           = perhapsForallMsg
586           | otherwise 
587           = ptext (sLit "Use -XTypeOperators to allow operators in types")
588
589     forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
590     forall_head (L _ (HsAppTy ty _)) = forall_head ty
591     forall_head _other               = False
592 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
593 \end{code}
594
595 %*********************************************************
596 %*                                                      *
597                 Splices
598 %*                                                      *
599 %*********************************************************
600
601 Note [Splices]
602 ~~~~~~~~~~~~~~
603 Consider
604         f = ...
605         h = ...$(thing "f")...
606
607 The splice can expand into literally anything, so when we do dependency
608 analysis we must assume that it might mention 'f'.  So we simply treat
609 all locally-defined names as mentioned by any splice.  This is terribly
610 brutal, but I don't see what else to do.  For example, it'll mean
611 that every locally-defined thing will appear to be used, so no unused-binding
612 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
613 and that will crash the type checker because 'f' isn't in scope.
614
615 Currently, I'm not treating a splice as also mentioning every import,
616 which is a bit inconsistent -- but there are a lot of them.  We might
617 thereby get some bogus unused-import warnings, but we won't crash the
618 type checker.  Not very satisfactory really.
619
620 \begin{code}
621 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
622 rnSplice (HsSplice n expr)
623   = do  { checkTH expr "splice"
624         ; loc  <- getSrcSpanM
625         ; n' <- newLocalBndrRn (L loc n)
626         ; (expr', fvs) <- rnLExpr expr
627
628         -- Ugh!  See Note [Splices] above
629         ; lcl_rdr <- getLocalRdrEnv
630         ; gbl_rdr <- getGlobalRdrEnv
631         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
632                                                     isLocalGRE gre]
633               lcl_names = mkNameSet (occEnvElts lcl_rdr)
634
635         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
636
637 checkTH :: Outputable a => a -> String -> RnM ()
638 #ifdef GHCI 
639 checkTH _ _ = return () -- OK
640 #else
641 checkTH e what  -- Raise an error in a stage-1 compiler
642   = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>  
643                   ptext (sLit "illegal in a stage-1 compiler"),
644                   nest 2 (ppr e)])
645 #endif   
646 \end{code}