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