path: root/compiler/rename/RnTypes.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnSource]{Main pass of renamer}

\begin{code}
module RnTypes ( 
	-- Type related stuff
	rnHsType, rnLHsType, rnLHsTypes, rnContext,
	rnHsSigType, rnHsTypeFVs,

	-- Patterns and literals
	rnLPat, rnPat, rnPatsAndThen,	-- Here because it's not part 
	rnLit, rnOverLit, 		-- of any mutual recursion	

	-- Precence related stuff
	mkOpAppRn, mkNegAppRn, mkOpFormRn, 
	checkPrecMatch, checkSectionPrec, 
	
	-- Error messages
	dupFieldErr, patSigErr, checkTupSize
  ) where

import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )

import HsSyn
import RdrHsSyn		( extractHsRhoRdrTyVars )
import RnHsSyn		( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
			  listTyCon_name
			)
import RnEnv		( lookupOccRn, lookupBndrRn, lookupSyntaxName,
			  lookupLocatedOccRn, lookupLocatedBndrRn,
			  lookupLocatedGlobalOccRn, bindTyVarsRn, 
			  lookupFixityRn, lookupTyFixityRn,
			  mapFvRn, warnUnusedMatches,
			  newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
import TcRnMonad
import RdrName		( RdrName, elemLocalRdrEnv )
import PrelNames	( eqClassName, integralClassName, geName, eqName,
		  	  negateName, minusName, lengthPName, indexPName,
			  plusIntegerName, fromIntegerName, timesIntegerName,
			  ratioDataConName, fromRationalName )
import TypeRep		( funTyCon )
import Constants	( mAX_TUPLE_SIZE )
import Name		( Name )
import SrcLoc		( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
import NameSet

import Literal		( inIntRange, inCharRange )
import BasicTypes	( compareFixity, funTyFixity, negateFixity, 
			  Fixity(..), FixityDirection(..) )
import ListSetOps	( removeDups )
import Outputable

#include "HsVersions.h"
\end{code}

These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

%*********************************************************
%*							*
\subsection{Renaming types}
%*							*
%*********************************************************

\begin{code}
rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnHsTypeFVs doc_str ty 
  = rnLHsType doc_str ty	`thenM` \ ty' ->
    returnM (ty', extractHsTyNames ty')

rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
	-- rnHsSigType is used for source-language type signatures,
	-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
  = rnLHsType (text "In the type signature for" <+> doc_str) ty
\end{code}

rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

\begin{code}
rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
rnLHsType doc = wrapLocM (rnHsType doc)

rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)

rnHsType doc (HsForAllTy Implicit _ ctxt ty)
	-- 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 ->
    let
	mentioned = extractHsRhoRdrTyVars ctxt ty

	-- Don't quantify over type variables that are in scope;
	-- when GlasgowExts is off, there usually won't be any, except for
	-- class signatures:
	--	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)
	-- Explicit quantification.
	-- Check that the forall'd tyvars are actually 
	-- mentioned in the type, and produce a warning if not
  = 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_`
    rnForAll doc Explicit forall_tyvars ctxt tau

rnHsType doc (HsTyVar tyvar)
  = lookupOccRn tyvar 		`thenM` \ tyvar' ->
    returnM (HsTyVar tyvar')

rnHsType doc (HsOpTy ty1 (L loc op) ty2)
  = setSrcSpan loc (
      lookupOccRn op			`thenM` \ op' ->
      let
	l_op' = L loc op'
      in
      lookupTyFixityRn l_op'		`thenM` \ fix ->
      rnLHsType doc ty1			`thenM` \ ty1' ->
      rnLHsType doc ty2			`thenM` \ ty2' -> 
      mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
   )

rnHsType doc (HsParTy ty)
  = rnLHsType doc ty 	        `thenM` \ ty' ->
    returnM (HsParTy ty')

rnHsType doc (HsBangTy b ty)
  = rnLHsType doc ty 	        `thenM` \ ty' ->
    returnM (HsBangTy b ty')

rnHsType doc (HsNumTy i)
  | i == 1    = returnM (HsNumTy i)
  | otherwise = addErr err_msg	`thenM_`  returnM (HsNumTy i)
  where
    err_msg = ptext SLIT("Only unit numeric type pattern is valid")
			   

rnHsType doc (HsFunTy ty1 ty2)
  = rnLHsType doc ty1	`thenM` \ ty1' ->
	-- Might find a for-all as the arg of a function type
    rnLHsType doc ty2	`thenM` \ 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'

rnHsType doc (HsListTy ty)
  = rnLHsType doc ty				`thenM` \ ty' ->
    returnM (HsListTy ty')

rnHsType doc (HsKindSig ty k)
  = rnLHsType doc ty				`thenM` \ ty' ->
    returnM (HsKindSig ty' k)

rnHsType doc (HsPArrTy ty)
  = rnLHsType doc ty				`thenM` \ ty' ->
    returnM (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 }

rnLHsTypes doc tys = mappM (rnLHsType doc) tys
\end{code}


\begin{code}
rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
	 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)

rnForAll doc exp [] (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
	-- and discovered there are no type variables, it's nicer to turn
	-- it into plain Int.  If it were Int# instead of Int, we'd actually
	-- get an error, because the body of a genuine for-all is
	-- 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)
	-- Retain the same implicit/explicit flag as before
	-- so that we can later print it correctly
\end{code}


%************************************************************************
%*									*
	Fixities and precedence parsing
%*									*
%************************************************************************

@mkOpAppRn@ deals with operator fixities.  The argument expressions
are assumed to be already correctly arranged.  It needs the fixities
recorded in the OpApp nodes, because fixity info applies to the things
the programmer actually wrote, so you can't find it out from the Name.

Furthermore, the second argument is guaranteed not to be another
operator application.  Why? Because the parser parses all
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
Infix types are read in a *right-associative* way, so that
	a `op` b `op` c
is always read in as
	a `op` (b `op` c)

mkHsOpTyRn rearranges where necessary.  The two arguments
have already been renamed and rearranged.  It's made rather tiresome
by the presence of ->, which is a separate syntactic construct.

\begin{code}
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
	   -> SDoc -> 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 }

mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22))
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1 
		HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2

mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2 		-- Default case, no rearrangment
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
	    -> SDoc -> Fixity -> LHsType Name
	    -> (LHsType Name -> LHsType Name -> HsType Name)
	    -> SDoc -> 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))
		         ; 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
			 ; return (mk2 (noLoc new_ty) ty22) }
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2


---------------------------
mkOpAppRn :: LHsExpr Name			-- Left operand; already rearranged
	  -> LHsExpr Name -> Fixity 		-- Operator and fixity
	  -> LHsExpr Name			-- Right operand (not an OpApp, but might
						-- be a NegApp)
	  -> RnM (HsExpr Name)

-- (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)

  | associate_right
  = mkOpAppRn e12 op2 fix2 e2		`thenM` \ new_e ->
    returnM (OpApp e11 op1 fix1 (L loc' new_e))
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
--	(- 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)

  | associate_right
  = mkOpAppRn neg_arg op2 fix2 e2	`thenM` \ new_e ->
    returnM (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)
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
--	Default case
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)

-- 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 fix1 (OpApp _ _ fix2 _)
  = not error_please && associate_right
  where
    (error_please, associate_right) = compareFixity fix1 fix2
right_op_ok fix1 other
  = True

-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
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)

not_op_app (OpApp _ _ _ _) = False
not_op_app other	   = True

---------------------------
mkOpFormRn :: LHsCmdTop Name		-- Left operand; already rearranged
	  -> LHsExpr Name -> Fixity 	-- Operator and fixity
	  -> LHsCmdTop Name		-- Right operand (not an infix)
	  -> RnM (HsCmd Name)

-- (e11 `op1` e12) `op2` e2
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])

  | associate_right
  = mkOpFormRn a12 op2 fix2 a2		`thenM` \ new_c ->
    returnM (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])


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
	     -> RnM (Pat Name)

mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
  = lookupFixityRn (unLoc op1)	`thenM` \ fix1 ->
    let
	(nofix_error, associate_right) = compareFixity fix1 fix2
    in
    if nofix_error then
	addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))	`thenM_`
	returnM (ConPatIn op2 (InfixCon p1 p2))
    else 
    if associate_right then
	mkConOpPatRn op2 fix2 p12 p2		`thenM` \ new_p ->
	returnM (ConPatIn op1 (InfixCon p11 (L loc new_p)))  -- XXX loc right?
    else
    returnM (ConPatIn op2 (InfixCon p1 p2))

mkConOpPatRn op fix p1 p2 			-- Default case, no rearrangment
  = ASSERT( not_op_pat (unLoc p2) )
    returnM (ConPatIn op (InfixCon p1 p2))

not_op_pat (ConPatIn _ (InfixCon _ _)) = False
not_op_pat other   	               = True

--------------------------------------
checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
	-- True indicates an infix lhs
	-- See comments with rnExpr (OpApp ...) about "deriving"

checkPrecMatch False fn match 
  = returnM ()
checkPrecMatch True op (MatchGroup ms _)	
  = mapM_ check ms			 	
  where
    check (L _ (Match (p1:p2:_) _ _))
      = checkPrec op (unLoc p1) False	`thenM_`
        checkPrec op (unLoc p2) True

    check _ = panic "checkPrecMatch"

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) ->
    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)
	(infol, infor) = if right then (info, info1) else (info1, info)
    in
    checkErr inf_ok (precParseErr infol infor)

checkPrec op pat right
  = returnM ()

-- Check precedence of (arg op) or (op arg) respectively
-- If arg is itself an operator application, then either
--   (a) its precedence must be higher than that of op
--   (b) its precedency & associativity must be the same as that of op
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 ()
  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)
\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"), 
	       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)
\end{code}

%*********************************************************
%*							*
\subsection{Contexts and predicates}
%*							*
%*********************************************************

\begin{code}
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

rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
rnLPred doc  = wrapLocM (rnPred doc)

rnPred doc (HsClassP clas tys)
  = lookupOccRn clas		`thenM` \ clas_name ->
    rnLHsTypes doc tys		`thenM` \ tys' ->
    returnM (HsClassP clas_name tys')

rnPred doc (HsIParam n ty)
  = newIPNameRn n		`thenM` \ name ->
    rnLHsType doc ty		`thenM` \ ty' ->
    returnM (HsIParam name ty')
\end{code}


*********************************************************
*							*
\subsection{Patterns}
*							*
*********************************************************

\begin{code}
rnPatsAndThen :: HsMatchContext Name
	      -> [LPat RdrName] 
	      -> ([LPat Name] -> RnM (a, FreeVars))
	      -> RnM (a, FreeVars)
-- Bring into scope all the binders and type variables
-- bound by the patterns; then rename the patterns; then
-- do the thing inside.
--
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
--	f x x = 1

rnPatsAndThen ctxt pats thing_inside
  = bindPatSigTyVarsFV pat_sig_tys 	$
    bindLocatedLocalsFV doc_pat bndrs	$ \ new_bndrs ->
    rnLPats pats			`thenM` \ (pats', pat_fvs) ->
    thing_inside pats'			`thenM` \ (res, res_fvs) ->

    let
	unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
    in
    warnUnusedMatches unused_binders   `thenM_`
    returnM (res, res_fvs `plusFV` pat_fvs)
  where
    pat_sig_tys = collectSigTysFromPats pats
    bndrs 	= collectLocatedPatsBinders pats
    doc_pat     = ptext SLIT("In") <+> pprMatchContext ctxt

rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
rnLPats ps = mapFvRn rnLPat ps

rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
rnLPat = wrapLocFstM rnPat

-- -----------------------------------------------------------------------------
-- rnPat

rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)

rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)

rnPat (VarPat name)
  = lookupBndrRn  name			`thenM` \ vname ->
    returnM (VarPat vname, emptyFVs)

rnPat (SigPatIn pat ty)
  = doptM Opt_GlasgowExts `thenM` \ glaExts ->
    
    if glaExts
    then rnLPat pat		`thenM` \ (pat', fvs1) ->
         rnHsTypeFVs doc ty	`thenM` \ (ty',  fvs2) ->
         returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)

    else addErr (patSigErr ty)	`thenM_`
         rnPat (unLoc pat) -- XXX shouldn't throw away the loc
  where
    doc = text "In a pattern type-signature"
    
rnPat (LitPat lit) 
  = rnLit lit 	`thenM_` 
    returnM (LitPat lit, emptyFVs) 

rnPat (NPat lit mb_neg eq _) 
  = rnOverLit lit			`thenM` \ (lit', fvs1) ->
    (case mb_neg of
	Nothing -> returnM (Nothing, emptyFVs)
	Just _  -> lookupSyntaxName negateName	`thenM` \ (neg, fvs) ->
		   returnM (Just neg, fvs)
    )					`thenM` \ (mb_neg', fvs2) ->
    lookupSyntaxName eqName		`thenM` \ (eq', fvs3) -> 
    returnM (NPat lit' mb_neg' eq' placeHolderType, 
	      fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)	
	-- Needed to find equality on pattern

rnPat (NPlusKPat name lit _ _)
  = rnOverLit lit			`thenM` \ (lit', fvs1) ->
    lookupLocatedBndrRn name		`thenM` \ name' ->
    lookupSyntaxName minusName		`thenM` \ (minus, fvs2) ->
    lookupSyntaxName geName		`thenM` \ (ge, fvs3) ->
    returnM (NPlusKPat name' lit' ge minus,
	     fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
	-- The Report says that n+k patterns must be in Integral

rnPat (LazyPat pat)
  = rnLPat pat		`thenM` \ (pat', fvs) ->
    returnM (LazyPat pat', fvs)

rnPat (BangPat pat)
  = rnLPat pat		`thenM` \ (pat', fvs) ->
    returnM (BangPat pat', fvs)

rnPat (AsPat name pat)
  = rnLPat pat			`thenM` \ (pat', fvs) ->
    lookupLocatedBndrRn name	`thenM` \ vname ->
    returnM (AsPat vname pat', fvs)

rnPat (ConPatIn con stuff) = rnConPat con stuff


rnPat (ParPat pat)
  = rnLPat pat		`thenM` \ (pat', fvs) ->
    returnM (ParPat pat', fvs)

rnPat (ListPat pats _)
  = rnLPats pats			`thenM` \ (patslist, fvs) ->
    returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)

rnPat (PArrPat pats _)
  = rnLPats pats			`thenM` \ (patslist, fvs) ->
    returnM (PArrPat patslist placeHolderType, 
	      fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
  where
    implicit_fvs = mkFVs [lengthPName, indexPName]

rnPat (TuplePat pats boxed _)
  = checkTupSize tup_size	`thenM_`
    rnLPats pats			`thenM` \ (patslist, fvs) ->
    returnM (TuplePat patslist boxed placeHolderType, 
	     fvs `addOneFV` tycon_name)
  where
    tup_size   = length pats
    tycon_name = tupleTyCon_name boxed tup_size

rnPat (TypePat name) =
    rnHsTypeFVs (text "In a type pattern") name	`thenM` \ (name', fvs) ->
    returnM (TypePat name', fvs)

-- -----------------------------------------------------------------------------
-- rnConPat

rnConPat con (PrefixCon pats)
  = lookupLocatedOccRn con 	`thenM` \ con' ->
    rnLPats pats		`thenM` \ (pats', fvs) ->
    returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')

rnConPat con (RecCon rpats)
  = lookupLocatedOccRn con 	`thenM` \ con' ->
    rnRpats rpats		`thenM` \ (rpats', fvs) ->
    returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')

rnConPat con (InfixCon pat1 pat2)
  = lookupLocatedOccRn con			`thenM` \ con' ->
    rnLPat pat1					`thenM` \ (pat1', fvs1) ->
    rnLPat pat2					`thenM` \ (pat2', fvs2) ->
    lookupFixityRn (unLoc con')			`thenM` \ fixity ->
    mkConOpPatRn con' fixity pat1' pat2'	`thenM` \ pat' ->
    returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con')

-- -----------------------------------------------------------------------------
-- rnRpats

rnRpats :: [(Located RdrName, LPat RdrName)]
        -> RnM ([(Located Name, LPat Name)], FreeVars)
rnRpats rpats
  = mappM_ field_dup_err dup_fields 	`thenM_`
    mapFvRn rn_rpat rpats		`thenM` \ (rpats', fvs) ->
    returnM (rpats', fvs)
  where
    (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]

    field_dup_err dups = addErr (dupFieldErr "pattern" dups)

    rn_rpat (field, pat)
      = lookupLocatedGlobalOccRn field	`thenM` \ fieldname ->
	rnLPat pat			`thenM` \ (pat', fvs) ->
	returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)

\end{code}


%************************************************************************
%*									*
\subsubsection{Literals}
%*									*
%************************************************************************

When literals occur we have to make sure
that the types and classes they involve
are made available.

\begin{code}
rnLit :: HsLit -> RnM ()
rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
rnLit other	 = returnM ()

rnOverLit (HsIntegral i _)
  = lookupSyntaxName fromIntegerName	`thenM` \ (from_integer_name, fvs) ->
    if inIntRange i then
	returnM (HsIntegral i from_integer_name, fvs)
    else let
	extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
	-- Big integer literals are built, using + and *, 
	-- out of small integers (DsUtils.mkIntegerLit)
	-- [NB: plusInteger, timesInteger aren't rebindable... 
	--	they are used to construct the argument to fromInteger, 
	--	which is the rebindable one.]
    in
    returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)

rnOverLit (HsFractional i _)
  = lookupSyntaxName fromRationalName		`thenM` \ (from_rat_name, fvs) ->
    let
	extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
	-- We have to make sure that the Ratio type is imported with
	-- its constructor, because literals of type Ratio t are
	-- built with that constructor.
	-- The Rational type is needed too, but that will come in
	-- as part of the type for fromRational.
	-- The plus/times integer operations may be needed to construct the numerator
	-- and denominator (see DsUtils.mkIntegerLit)
    in
    returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
\end{code}



%*********************************************************
%*							*
\subsection{Errors}
%*							*
%*********************************************************

\begin{code}
checkTupSize :: Int -> RnM ()
checkTupSize tup_size
  | tup_size <= mAX_TUPLE_SIZE 
  = returnM ()
  | otherwise		       
  = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
		 nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
		 nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])

forAllWarn doc ty (L loc tyvar)
  = ifOptM Opt_WarnUnusedMatches 	$
    setSrcSpan loc $
    addWarn (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
                )

bogusCharError c
  = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''

patSigErr ty
  =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
	$$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))

dupFieldErr str dup
  = hsep [ptext SLIT("duplicate field name"), 
          quotes (ppr dup),
	  ptext SLIT("in record"), text str]
\end{code}