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}