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