compiler/rename/RnTypes.lhs

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