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