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