\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,
- -- 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
+ mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+ checkPrecMatch, checkSectionPrec
) where
-import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
-
+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,
- mapFvRn, warnUnusedMatches,
- newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
+ lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
+ lookupRecordBndr, mapFvRn, warnUnusedMatches,
+ newIPNameRn, bindPatSigTyVarsFV)
import TcRnMonad
-import RdrName ( RdrName, elemLocalRdrEnv )
+import RdrName
import PrelNames ( eqClassName, integralClassName, geName, eqName,
negateName, minusName, lengthPName, indexPName,
plusIntegerName, fromIntegerName, timesIntegerName,
- ratioDataConName, fromRationalName )
+ ratioDataConName, fromRationalName, fromStringName )
import TypeRep ( funTyCon )
import Constants ( mAX_TUPLE_SIZE )
-import Name ( Name )
-import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
+import Name
+import SrcLoc
import NameSet
import Literal ( inIntRange, inCharRange )
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
-import ListSetOps ( removeDups )
+import ListSetOps ( removeDups, minusList )
import Outputable
#include "HsVersions.h"
= 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 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
+ ; 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' }
rnHsType doc (HsParTy ty)
= rnLHsType doc ty `thenM` \ ty' ->
= 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
\end{code}
-- so that we can later print it correctly
\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)
+ = do { clas_name <- lookupOccRn clas
+ ; tys' <- rnLHsTypes doc tys
+ ; returnM (HsClassP clas_name tys')
+ }
+rnPred doc (HsEqualP ty1 ty2)
+ = do { ty1' <- rnLHsType doc ty1
+ ; ty2' <- rnLHsType doc ty2
+ ; returnM (HsEqualP ty1' ty2')
+ }
+rnPred doc (HsIParam n ty)
+ = do { name <- newIPNameRn n
+ ; ty' <- rnLHsType doc ty
+ ; returnM (HsIParam name ty')
+ }
+\end{code}
+
%************************************************************************
%* *
-> 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))
+ = do { fix1 <- lookupFixityRn (unLoc op1)
+ ; let (nofix_error, associate_right) = compareFixity fix1 fix2
+
+ ; if nofix_error then do
+ { addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
+ ; return (ConPatIn op2 (InfixCon p1 p2)) }
+
+ else if associate_right then do
+ { new_p <- mkConOpPatRn op2 fix2 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
= ASSERT( not_op_pat (unLoc p2) )
= checkPrec op (unLoc p1) False `thenM_`
checkPrec op (unLoc p2) True
- check _ = panic "checkPrecMatch"
+ check _ = return ()
+ -- This can happen. Consider
+ -- a `op` True = ...
+ -- op = ...
+ -- The infix flag comes from the first binding of the group
+ -- but the second eqn has no args (an error, but not discovered
+ -- 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) ->
%*********************************************************
%* *
-\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))]
+ 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
- )
-
-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"))
+ doc)
-dupFieldErr str dup
- = hsep [ptext SLIT("duplicate field name"),
- quotes (ppr dup),
- ptext SLIT("in record"), text str]
+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")))
\end{code}