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