X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=b275d2df40350ae71e563080d718855d527978f2;hp=aad8de83b3632c8ed5413b7b68622c5e008c4d99;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index aad8de8..b275d2d 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -4,53 +4,43 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module RnTypes ( 
 	-- Type related stuff
 	rnHsType, rnLHsType, rnLHsTypes, rnContext,
-	rnHsSigType, rnHsTypeFVs,
+	rnHsSigType, rnHsTypeFVs, rnConDeclFields,
 
 	-- Precence related stuff
 	mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
-	checkPrecMatch, checkSectionPrec
+	checkPrecMatch, checkSectionPrec,
+
+	-- Splice related stuff
+	rnSplice, checkTH
   ) where
 
+import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
+#endif 	/* GHCI */
+
 import DynFlags
 import HsSyn
 import RdrHsSyn		( extractHsRhoRdrTyVars )
-import RnHsSyn		( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
-			  listTyCon_name
-			)
-import RnHsDoc          ( rnLHsDoc )
-import RnEnv		( lookupOccRn, lookupBndrRn, lookupSyntaxName,
-			  lookupLocatedOccRn, lookupLocatedBndrRn,
-			  lookupLocatedGlobalOccRn, bindTyVarsRn, 
-			  lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
-			  lookupRecordBndr, mapFvRn, warnUnusedMatches,
-			  newIPNameRn, bindPatSigTyVarsFV)
+import RnHsSyn		( extractHsTyNames )
+import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
+import RnEnv
 import TcRnMonad
 import RdrName
-import PrelNames	( eqClassName, integralClassName, geName, eqName,
-		  	  negateName, minusName, lengthPName, indexPName,
-			  plusIntegerName, fromIntegerName, timesIntegerName,
-			  ratioDataConName, fromRationalName, fromStringName )
-import TypeRep		( funTyCon )
-import Constants	( mAX_TUPLE_SIZE )
+import PrelNames
+import TypeRep		( funTyConName )
 import Name
 import SrcLoc
 import NameSet
 
-import Literal		( inIntRange, inCharRange )
 import BasicTypes	( compareFixity, funTyFixity, negateFixity, 
 			  Fixity(..), FixityDirection(..) )
-import ListSetOps	( removeDups, minusList )
 import Outputable
+import FastString
+import Control.Monad	( unless )
 
 #include "HsVersions.h"
 \end{code}
@@ -66,9 +56,9 @@ to break several loop.
 
 \begin{code}
 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnHsTypeFVs doc_str ty 
-  = rnLHsType doc_str ty	`thenM` \ ty' ->
-    returnM (ty', extractHsTyNames ty')
+rnHsTypeFVs doc_str ty  = do
+    ty' <- rnLHsType doc_str ty
+    return (ty', extractHsTyNames ty')
 
 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
 	-- rnHsSigType is used for source-language type signatures,
@@ -86,11 +76,11 @@ rnLHsType doc = wrapLocM (rnHsType doc)
 
 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
 
-rnHsType doc (HsForAllTy Implicit _ ctxt ty)
+rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
 	-- Implicit quantifiction in source code (no kinds on tyvars)
 	-- Given the signature  C => T  we universally quantify 
 	-- over FV(T) \ {in-scope-tyvars} 
-  = getLocalRdrEnv		`thenM` \ name_env ->
+    name_env <- getLocalRdrEnv
     let
 	mentioned = extractHsRhoRdrTyVars ctxt ty
 
@@ -100,108 +90,130 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty)
 	--	class C a where { op :: a -> a }
 	forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
 	tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
-    in
+
     rnForAll doc Implicit tyvar_bndrs ctxt ty
 
-rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
+rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
 	-- Explicit quantification.
 	-- Check that the forall'd tyvars are actually 
 	-- mentioned in the type, and produce a warning if not
-  = let
+    let
 	mentioned	   = map unLoc (extractHsRhoRdrTyVars ctxt tau)
 	forall_tyvar_names = hsLTyVarLocNames forall_tyvars
 
 	-- Explicitly quantified but not mentioned in ctxt or tau
 	warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
-    in
-    mappM_ (forAllWarn doc tau) warn_guys	`thenM_`
+
+    mapM_ (forAllWarn doc tau) warn_guys
     rnForAll doc Explicit forall_tyvars ctxt tau
 
-rnHsType doc (HsTyVar tyvar)
-  = lookupOccRn tyvar 		`thenM` \ tyvar' ->
-    returnM (HsTyVar tyvar')
+rnHsType _ (HsTyVar tyvar) = do
+    tyvar' <- lookupOccRn tyvar
+    return (HsTyVar tyvar')
 
+-- If we see (forall a . ty), without foralls on, the forall will give
+-- a sensible error message, but we don't want to complain about the dot too
+-- Hence the jiggery pokery with ty1
 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
   = setSrcSpan loc $ 
-    do	{ ty_ops_ok <- doptM Opt_TypeOperators
-	; checkErr ty_ops_ok (opTyErr op ty)
-	; op' <- lookupOccRn op
+    do	{ ops_ok <- doptM Opt_TypeOperators
+	; op' <- if ops_ok
+		 then lookupOccRn op 
+		 else do { addErr (opTyErr op ty)
+			 ; return (mkUnboundName op) }	-- Avoid double complaint
 	; let l_op' = L loc op'
 	; fix <- lookupTyFixityRn l_op'
 	; ty1' <- rnLHsType doc ty1
 	; ty2' <- rnLHsType doc ty2
-	; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' }
+	; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
 
-rnHsType doc (HsParTy ty)
-  = rnLHsType doc ty 	        `thenM` \ ty' ->
-    returnM (HsParTy ty')
+rnHsType doc (HsParTy ty) = do
+    ty' <- rnLHsType doc ty
+    return (HsParTy ty')
 
 rnHsType doc (HsBangTy b ty)
-  = rnLHsType doc ty 	        `thenM` \ ty' ->
-    returnM (HsBangTy b ty')
+  = do { ty' <- rnLHsType doc ty
+       ; return (HsBangTy b ty') }
 
-rnHsType doc (HsNumTy i)
-  | i == 1    = returnM (HsNumTy i)
-  | otherwise = addErr err_msg	`thenM_`  returnM (HsNumTy i)
+rnHsType doc (HsRecTy flds)
+  = do { flds' <- rnConDeclFields doc flds
+       ; return (HsRecTy flds') }
+
+rnHsType _ (HsNumTy i)
+  | i == 1    = return (HsNumTy i)
+  | otherwise = addErr err_msg >> return (HsNumTy i)
   where
-    err_msg = ptext SLIT("Only unit numeric type pattern is valid")
+    err_msg = ptext (sLit "Only unit numeric type pattern is valid")
 			   
 
-rnHsType doc (HsFunTy ty1 ty2)
-  = rnLHsType doc ty1	`thenM` \ ty1' ->
+rnHsType doc (HsFunTy ty1 ty2) = do
+    ty1' <- rnLHsType doc ty1
 	-- Might find a for-all as the arg of a function type
-    rnLHsType doc ty2	`thenM` \ ty2' ->
+    ty2' <- rnLHsType doc ty2
 	-- Or as the result.  This happens when reading Prelude.hi
 	-- when we find return :: forall m. Monad m -> forall a. a -> m a
 
 	-- Check for fixity rearrangements
-    mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2'
+    mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
 
-rnHsType doc (HsListTy ty)
-  = rnLHsType doc ty				`thenM` \ ty' ->
-    returnM (HsListTy ty')
+rnHsType doc (HsListTy ty) = do
+    ty' <- rnLHsType doc ty
+    return (HsListTy ty')
 
 rnHsType doc (HsKindSig ty k)
-  = rnLHsType doc ty				`thenM` \ ty' ->
-    returnM (HsKindSig ty' k)
+  = do { kind_sigs_ok <- doptM Opt_KindSignatures
+       ; unless kind_sigs_ok (addErr (kindSigErr ty))
+       ; ty' <- rnLHsType doc ty
+       ; return (HsKindSig ty' k) }
 
-rnHsType doc (HsPArrTy ty)
-  = rnLHsType doc ty				`thenM` \ ty' ->
-    returnM (HsPArrTy ty')
+rnHsType doc (HsPArrTy ty) = do
+    ty' <- rnLHsType doc ty
+    return (HsPArrTy ty')
 
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy tup_con tys)
-  = mappM (rnLHsType doc) tys	  	`thenM` \ tys' ->
-    returnM (HsTupleTy tup_con tys')
-
-rnHsType doc (HsAppTy ty1 ty2)
-  = rnLHsType doc ty1		`thenM` \ ty1' ->
-    rnLHsType doc ty2		`thenM` \ ty2' ->
-    returnM (HsAppTy ty1' ty2')
-
-rnHsType doc (HsPredTy pred)
-  = rnPred doc pred	`thenM` \ pred' ->
-    returnM (HsPredTy pred')
-
-rnHsType doc (HsSpliceTy _)
-  = do	{ addErr (ptext SLIT("Type splices are not yet implemented"))
- 	; failM }
-
-rnHsType doc (HsDocTy ty haddock_doc)
-  = rnLHsType doc ty 	        `thenM` \ ty' ->
-    rnLHsDoc haddock_doc	`thenM` \ haddock_doc' ->
-    returnM (HsDocTy ty' haddock_doc')
-
-rnLHsTypes doc tys = mappM (rnLHsType doc) tys
+rnHsType doc (HsTupleTy tup_con tys) = do
+    tys' <- mapM (rnLHsType doc) tys
+    return (HsTupleTy tup_con tys')
+
+rnHsType doc (HsAppTy ty1 ty2) = do
+    ty1' <- rnLHsType doc ty1
+    ty2' <- rnLHsType doc ty2
+    return (HsAppTy ty1' ty2')
+
+rnHsType doc (HsPredTy pred) = do
+    pred' <- rnPred doc pred
+    return (HsPredTy pred')
+
+rnHsType _ (HsSpliceTy sp _ k)
+  = do { (sp', fvs) <- rnSplice sp	-- ToDo: deal with fvs
+       ; return (HsSpliceTy sp' fvs k) }
+
+rnHsType doc (HsDocTy ty haddock_doc) = do
+    ty' <- rnLHsType doc ty
+    haddock_doc' <- rnLHsDoc haddock_doc
+    return (HsDocTy ty' haddock_doc')
+
+#ifndef GHCI
+rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
+#else
+rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
+                                      ; rnHsType doc (unLoc ty) }
+#endif
+rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty)
+
+--------------
+rnLHsTypes :: SDoc -> [LHsType RdrName]
+           -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
+rnLHsTypes doc tys = mapM (rnLHsType doc) tys
 \end{code}
 
 
 \begin{code}
-rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
+rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
 	 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
-rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
+rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
 	-- One reason for this case is that a type like Int#
 	-- starts off as (HsForAllTy Nothing [] Int), in case
 	-- there is some quantification.  Now that we have quantified
@@ -211,12 +223,22 @@ rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
 	-- of kind *.
 
 rnForAll doc exp forall_tyvars ctxt ty
-  = bindTyVarsRn doc forall_tyvars	$ \ new_tyvars ->
-    rnContext doc ctxt			`thenM` \ new_ctxt ->
-    rnLHsType doc ty			`thenM` \ new_ty ->
-    returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
+  = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
+    new_ctxt <- rnContext doc ctxt
+    new_ty <- rnLHsType doc ty
+    return (HsForAllTy exp new_tyvars new_ctxt new_ty)
 	-- Retain the same implicit/explicit flag as before
 	-- so that we can later print it correctly
+
+rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
+rnConDeclFields doc fields = mapM (rnField doc) fields
+
+rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
+rnField doc (ConDeclField name ty haddock_doc)
+  = do { new_name <- lookupLocatedTopBndrRn name
+       ; new_ty <- rnLHsType doc ty
+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
+       ; return (ConDeclField new_name new_ty new_haddock_doc) }
 \end{code}
 
 %*********************************************************
@@ -230,25 +252,27 @@ rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
 rnContext doc = wrapLocM (rnContext' doc)
 
 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
-rnContext' doc ctxt = mappM (rnLPred doc) ctxt
+rnContext' doc ctxt = mapM (rnLPred doc) ctxt
 
 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 rnLPred doc  = wrapLocM (rnPred doc)
 
+rnPred :: SDoc -> HsPred RdrName
+       -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
 rnPred doc (HsClassP clas tys)
   = do { clas_name <- lookupOccRn clas
        ; tys' <- rnLHsTypes doc tys
-       ; returnM (HsClassP clas_name tys')
+       ; return (HsClassP clas_name tys')
        }
 rnPred doc (HsEqualP ty1 ty2)
   = do { ty1' <- rnLHsType doc ty1
        ; ty2' <- rnLHsType doc ty2
-       ; returnM (HsEqualP ty1' ty2')
+       ; return (HsEqualP ty1' ty2')
        }
 rnPred doc (HsIParam n ty)
   = do { name <- newIPNameRn n
        ; ty' <- rnLHsType doc ty
-       ; returnM (HsIParam name ty')
+       ; return (HsIParam name ty')
        }
 \end{code}
 
@@ -281,36 +305,35 @@ by the presence of ->, which is a separate syntactic construct.
 ---------------
 -- Building (ty1 `op1` (ty21 `op2` ty22))
 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
-	   -> SDoc -> Fixity -> LHsType Name -> LHsType Name 
+	   -> Name -> Fixity -> LHsType Name -> LHsType Name 
 	   -> RnM (HsType Name)
 
 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
   = do  { fix2 <- lookupTyFixityRn op2
 	; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
 		      (\t1 t2 -> HsOpTy t1 op2 t2)
-		      (ppr op2) fix2 ty21 ty22 loc2 }
+		      (unLoc op2) fix2 ty21 ty22 loc2 }
 
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
   = mk_hs_op_ty mk1 pp_op1 fix1 ty1 
-		HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2
+		HsFunTy funTyConName funTyFixity ty21 ty22 loc2
 
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2 		-- Default case, no rearrangment
+mkHsOpTyRn mk1 _ _ ty1 ty2 		-- Default case, no rearrangment
   = return (mk1 ty1 ty2)
 
 ---------------
 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
-	    -> SDoc -> Fixity -> LHsType Name
+	    -> Name -> Fixity -> LHsType Name
 	    -> (LHsType Name -> LHsType Name -> HsType Name)
-	    -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
+	    -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
 	    -> RnM (HsType Name)
-mk_hs_op_ty mk1 pp_op1 fix1 ty1 
-	    mk2 pp_op2 fix2 ty21 ty22 loc2
-  | nofix_error     = do { addErr (precParseErr (quotes pp_op1,fix1) 
-			 		        (quotes pp_op2,fix2))
+mk_hs_op_ty mk1 op1 fix1 ty1 
+	    mk2 op2 fix2 ty21 ty22 loc2
+  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
 		         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
   | otherwise	    = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
-			   new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21
+			   new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
 			 ; return (mk2 (noLoc new_ty) ty22) }
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
@@ -326,12 +349,12 @@ mkOpAppRn :: LHsExpr Name			-- Left operand; already rearranged
 -- (e11 `op1` e12) `op2` e2
 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
   | nofix_error
-  = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenM_`
-    returnM (OpApp e1 op2 fix2 e2)
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (OpApp e1 op2 fix2 e2)
 
-  | associate_right
-  = mkOpAppRn e12 op2 fix2 e2		`thenM` \ new_e ->
-    returnM (OpApp e11 op1 fix1 (L loc' new_e))
+  | associate_right = do
+    new_e <- mkOpAppRn e12 op2 fix2 e2
+    return (OpApp e11 op1 fix1 (L loc' new_e))
   where
     loc'= combineLocs e12 e2
     (nofix_error, associate_right) = compareFixity fix1 fix2
@@ -340,22 +363,22 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
 --	(- neg_arg) `op` e2
 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
   | nofix_error
-  = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))	`thenM_`
-    returnM (OpApp e1 op2 fix2 e2)
+  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
+       return (OpApp e1 op2 fix2 e2)
 
-  | associate_right
-  = mkOpAppRn neg_arg op2 fix2 e2	`thenM` \ new_e ->
-    returnM (NegApp (L loc' new_e) neg_name)
+  | associate_right 
+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
+       return (NegApp (L loc' new_e) neg_name)
   where
     loc' = combineLocs neg_arg e2
     (nofix_error, associate_right) = compareFixity negateFixity fix2
 
 ---------------------------
 --	e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _))	-- NegApp can occur on the right
-  | not associate_right				-- We *want* right association
-  = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))	`thenM_`
-    returnM (OpApp e1 op1 fix1 e2)
+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))	-- NegApp can occur on the right
+  | not associate_right			-- We *want* right association
+  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
+       return (OpApp e1 op1 fix1 e2)
   where
     (_, associate_right) = compareFixity fix1 negateFixity
 
@@ -365,16 +388,22 @@ mkOpAppRn e1 op fix e2 			-- Default case, no rearrangment
   = ASSERT2( right_op_ok fix (unLoc e2),
 	     ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
     )
-    returnM (OpApp e1 op fix e2)
+    return (OpApp e1 op fix e2)
+
+----------------------------
+get_op :: LHsExpr Name -> Name
+get_op (L _ (HsVar n)) = n
+get_op other           = pprPanic "get_op" (ppr other)
 
 -- Parser left-associates everything, but 
 -- derived instances may have correctly-associated things to
 -- in the right operarand.  So we just check that the right operand is OK
+right_op_ok :: Fixity -> HsExpr Name -> Bool
 right_op_ok fix1 (OpApp _ _ fix2 _)
   = not error_please && associate_right
   where
     (error_please, associate_right) = compareFixity fix1 fix2
-right_op_ok fix1 other
+right_op_ok _ _
   = True
 
 -- Parser initially makes negation bind more tightly than any other operator
@@ -382,10 +411,11 @@ right_op_ok fix1 other
 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
 mkNegAppRn neg_arg neg_name
   = ASSERT( not_op_app (unLoc neg_arg) )
-    returnM (NegApp neg_arg neg_name)
+    return (NegApp neg_arg neg_name)
 
+not_op_app :: HsExpr id -> Bool
 not_op_app (OpApp _ _ _ _) = False
-not_op_app other	   = True
+not_op_app _    	   = True
 
 ---------------------------
 mkOpFormRn :: LHsCmdTop Name		-- Left operand; already rearranged
@@ -397,20 +427,20 @@ mkOpFormRn :: LHsCmdTop Name		-- Left operand; already rearranged
 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
 	op2 fix2 a2
   | nofix_error
-  = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenM_`
-    returnM (HsArrForm op2 (Just fix2) [a1, a2])
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (HsArrForm op2 (Just fix2) [a1, a2])
 
   | associate_right
-  = mkOpFormRn a12 op2 fix2 a2		`thenM` \ new_c ->
-    returnM (HsArrForm op1 (Just fix1)
-	[a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
+  = do new_c <- mkOpFormRn a12 op2 fix2 a2
+       return (HsArrForm op1 (Just fix1)
+	          [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
 	-- TODO: locs are wrong
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
 
 --	Default case
 mkOpFormRn arg1 op fix arg2 			-- Default case, no rearrangment
-  = returnM (HsArrForm op (Just fix) [arg1, arg2])
+  = return (HsArrForm op (Just fix) [arg1, arg2])
 
 
 --------------------------------------
@@ -422,7 +452,7 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 	; let (nofix_error, associate_right) = compareFixity fix1 fix2
 
 	; if nofix_error then do
-		{ addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
+		{ precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
 		; return (ConPatIn op2 (InfixCon p1 p2)) }
 
 	  else if associate_right then do
@@ -430,26 +460,27 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
 		; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
 	  else return (ConPatIn op2 (InfixCon p1 p2)) }
 
-mkConOpPatRn op fix p1 p2 			-- Default case, no rearrangment
+mkConOpPatRn op _ p1 p2 			-- Default case, no rearrangment
   = ASSERT( not_op_pat (unLoc p2) )
-    returnM (ConPatIn op (InfixCon p1 p2))
+    return (ConPatIn op (InfixCon p1 p2))
 
+not_op_pat :: Pat Name -> Bool
 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
-not_op_pat other   	               = True
+not_op_pat _        	               = True
 
 --------------------------------------
-checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
-	-- True indicates an infix lhs
-	-- See comments with rnExpr (OpApp ...) about "deriving"
+checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
+  -- Check precedence of a function binding written infix
+  --   eg  a `op` b `C` c = ...
+  -- See comments with rnExpr (OpApp ...) about "deriving"
 
-checkPrecMatch False fn match 
-  = returnM ()
-checkPrecMatch True op (MatchGroup ms _)	
+checkPrecMatch op (MatchGroup ms _)	
   = mapM_ check ms			 	
   where
-    check (L _ (Match (p1:p2:_) _ _))
-      = checkPrec op (unLoc p1) False	`thenM_`
-        checkPrec op (unLoc p2) True
+    check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
+      = setSrcSpan (combineSrcSpans l1 l2) $
+        do checkPrec op p1 False
+           checkPrec op p2 True
 
     check _ = return ()	
 	-- This can happen.  Consider
@@ -460,23 +491,23 @@ checkPrecMatch True op (MatchGroup ms _)
 	-- until the type checker).  So we don't want to crash on the
 	-- second eqn.
 
-checkPrec op (ConPatIn op1 (InfixCon _ _)) right
-  = lookupFixityRn op		`thenM` \  op_fix@(Fixity op_prec  op_dir) ->
-    lookupFixityRn (unLoc op1)	`thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
+checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
+checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
+    op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
+    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
     let
 	inf_ok = op1_prec > op_prec || 
 	         (op1_prec == op_prec &&
 		  (op1_dir == InfixR && op_dir == InfixR && right ||
 		   op1_dir == InfixL && op_dir == InfixL && not right))
 
-	info  = (ppr_op op,  op_fix)
-	info1 = (ppr_op op1, op1_fix)
+	info  = (op,        op_fix)
+	info1 = (unLoc op1, op1_fix)
 	(infol, infor) = if right then (info, info1) else (info1, info)
-    in
-    checkErr inf_ok (precParseErr infol infor)
+    unless inf_ok (precParseErr infol infor)
 
-checkPrec op pat right
-  = returnM ()
+checkPrec _ _ _
+  = return ()
 
 -- Check precedence of (arg op) or (op arg) respectively
 -- If arg is itself an operator application, then either
@@ -486,36 +517,47 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName
 	-> LHsExpr Name -> LHsExpr Name -> RnM ()
 checkSectionPrec direction section op arg
   = case unLoc arg of
-	OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
-	NegApp _ _	 -> go_for_it pp_prefix_minus negateFixity
-	other		 -> returnM ()
+	OpApp _ op fix _ -> go_for_it (get_op op) fix
+	NegApp _ _	 -> go_for_it negateName  negateFixity
+	_    		 -> return ()
   where
-    L _ (HsVar op_name) = op
-    go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
-	= lookupFixityRn op_name	`thenM` \ op_fix@(Fixity op_prec _) ->
-	  checkErr (op_prec < arg_prec
-		     || op_prec == arg_prec && direction == assoc)
-		  (sectionPrecErr (ppr_op op_name, op_fix) 	
-		  (pp_arg_op, arg_fix) section)
+    op_name = get_op op
+    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
+          op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
+	  unless (op_prec < arg_prec
+	          || (op_prec == arg_prec && direction == assoc))
+		 (sectionPrecErr (op_name, op_fix) 	
+				 (arg_op, arg_fix) section)
 \end{code}
 
 Precedence-related error messages
 
 \begin{code}
-precParseErr op1 op2 
-  = hang (ptext SLIT("precedence parsing error"))
-      4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
+precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
+precParseErr op1@(n1,_) op2@(n2,_) 
+  | isUnboundName n1 || isUnboundName n2
+  = return ()	  -- Avoid error cascade
+  | otherwise
+  = addErr $ hang (ptext (sLit "Precedence parsing error"))
+      4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), 
 	       ppr_opfix op2,
-	       ptext SLIT("in the same infix expression")])
-
-sectionPrecErr op arg_op section
- = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
-	 nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
-	 nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
-
-pp_prefix_minus = ptext SLIT("prefix `-'")
-ppr_op op = quotes (ppr op)	-- Here, op can be a Name or a (Var n), where n is a Name
-ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
+	       ptext (sLit "in the same infix expression")])
+
+sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
+sectionPrecErr op@(n1,_) arg_op@(n2,_) section
+  | isUnboundName n1 || isUnboundName n2
+  = return ()	  -- Avoid error cascade
+  | otherwise
+  = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
+	 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
+	      	      nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
+	 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
+
+ppr_opfix :: (Name, Fixity) -> SDoc
+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
+   where
+     pp_op | op == negateName = ptext (sLit "prefix `-'")
+     	   | otherwise        = quotes (ppr op)
 \end{code}
 
 %*********************************************************
@@ -525,14 +567,80 @@ ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 %*********************************************************
 
 \begin{code}
+forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
+           -> TcRnIf TcGblEnv TcLclEnv ()
 forAllWarn doc ty (L loc tyvar)
   = ifOptM Opt_WarnUnusedMatches 	$
-    addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
-		 	nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+    addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
+		 	nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
 		   $$
 		   doc)
 
-opTyErr op ty 
-  = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty))
-	 2 (parens (ptext SLIT("Use -XTypeOperators to allow operators in types")))
+opTyErr :: RdrName -> HsType RdrName -> SDoc
+opTyErr op ty@(HsOpTy ty1 _ _)
+  = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
+	 2 extra
+  where
+    extra | op == dot_tv_RDR && forall_head ty1
+	  = perhapsForallMsg
+	  | otherwise 
+	  = ptext (sLit "Use -XTypeOperators to allow operators in types")
+
+    forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
+    forall_head (L _ (HsAppTy ty _)) = forall_head ty
+    forall_head _other		     = False
+opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
+\end{code}
+
+%*********************************************************
+%*							*
+		Splices
+%*							*
+%*********************************************************
+
+Note [Splices]
+~~~~~~~~~~~~~~
+Consider
+	f = ...
+	h = ...$(thing "f")...
+
+The splice can expand into literally anything, so when we do dependency
+analysis we must assume that it might mention 'f'.  So we simply treat
+all locally-defined names as mentioned by any splice.  This is terribly
+brutal, but I don't see what else to do.  For example, it'll mean
+that every locally-defined thing will appear to be used, so no unused-binding
+warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
+and that will crash the type checker because 'f' isn't in scope.
+
+Currently, I'm not treating a splice as also mentioning every import,
+which is a bit inconsistent -- but there are a lot of them.  We might
+thereby get some bogus unused-import warnings, but we won't crash the
+type checker.  Not very satisfactory really.
+
+\begin{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+  = do	{ checkTH expr "splice"
+	; loc  <- getSrcSpanM
+	; n' <- newLocalBndrRn (L loc n)
+	; (expr', fvs) <- rnLExpr expr
+
+	-- Ugh!  See Note [Splices] above
+	; lcl_rdr <- getLocalRdrEnv
+	; gbl_rdr <- getGlobalRdrEnv
+	; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
+						    isLocalGRE gre]
+	      lcl_names = mkNameSet (occEnvElts lcl_rdr)
+
+	; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+
+checkTH :: Outputable a => a -> String -> RnM ()
+#ifdef GHCI 
+checkTH _ _ = return ()	-- OK
+#else
+checkTH e what 	-- Raise an error in a stage-1 compiler
+  = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>  
+	          ptext (sLit "illegal in a stage-1 compiler"),
+	          nest 2 (ppr e)])
+#endif   
 \end{code}