%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnSource]{Main pass of renamer}
\begin{code}
module RnTypes (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
checkPrecMatch, checkSectionPrec,
rnSplice, checkTH
) where
import RnExpr( rnLExpr )
#ifdef GHCI
import TcSplice( runQuasiQuoteType )
#endif /* GHCI */
import DynFlags
import HsSyn
import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn ( extractHsTyNames )
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
import RdrName
import PrelNames
import TypeRep ( funTyConName )
import Name
import SrcLoc
import NameSet
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
import Outputable
import FastString
import Control.Monad ( unless )
#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 = do
ty' <- rnLHsType doc_str ty
return (ty', extractHsTyNames ty')
rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
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) = do
name_env <- getLocalRdrEnv
let
mentioned = extractHsRhoRdrTyVars ctxt ty
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
tyvar_bndrs = userHsTyVarBndrs forall_tyvars
rnForAll doc Implicit tyvar_bndrs ctxt ty
rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
let
mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau)
forall_tyvar_names = hsLTyVarLocNames forall_tyvars
warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
mapM_ (forAllWarn doc tau) warn_guys
rnForAll doc Explicit forall_tyvars ctxt tau
rnHsType _ (HsTyVar tyvar) = do
tyvar' <- lookupOccRn tyvar
return (HsTyVar tyvar')
rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
= setSrcSpan loc $
do { ops_ok <- xoptM Opt_TypeOperators
; op' <- if ops_ok
then lookupOccRn op
else do { addErr (opTyErr op ty)
; return (mkUnboundName 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) op' fix ty1' ty2' }
rnHsType doc (HsParTy ty) = do
ty' <- rnLHsType doc ty
return (HsParTy ty')
rnHsType doc (HsBangTy b ty)
= do { ty' <- rnLHsType doc ty
; return (HsBangTy b ty') }
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")
rnHsType doc (HsFunTy ty1 ty2) = do
ty1' <- rnLHsType doc ty1
ty2' <- rnLHsType doc ty2
mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
rnHsType doc (HsListTy ty) = do
ty' <- rnLHsType doc ty
return (HsListTy ty')
rnHsType doc (HsKindSig ty k)
= do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless kind_sigs_ok (addErr (kindSigErr ty))
; ty' <- rnLHsType doc ty
; return (HsKindSig ty' k) }
rnHsType doc (HsPArrTy ty) = do
ty' <- rnLHsType doc ty
return (HsPArrTy ty')
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
; 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 -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
-> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
rnForAll doc exp forall_tyvars ctxt 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)
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}
%*********************************************************
%* *
\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 = 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
; return (HsClassP clas_name tys')
}
rnPred doc (HsEqualP ty1 ty2)
= do { ty1' <- rnLHsType doc ty1
; ty2' <- rnLHsType doc ty2
; return (HsEqualP ty1' ty2')
}
rnPred doc (HsIParam n ty)
= do { name <- newIPNameRn n
; ty' <- rnLHsType doc ty
; return (HsIParam name ty')
}
\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}
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType 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)
(unLoc op2) fix2 ty21 ty22 loc2 }
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
= mk_hs_op_ty mk1 pp_op1 fix1 ty1
HsFunTy funTyConName funTyFixity ty21 ty22 loc2
mkHsOpTyRn mk1 _ _ ty1 ty2
= return (mk1 ty1 ty2)
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
-> Name -> Fixity -> LHsType Name
-> (LHsType Name -> LHsType Name -> HsType Name)
-> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
-> RnM (HsType Name)
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 {
new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
; return (mk2 (noLoc new_ty) ty22) }
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpAppRn :: LHsExpr Name
-> LHsExpr Name -> Fixity
-> LHsExpr Name
-> RnM (HsExpr Name)
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2)
| 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
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
| nofix_error
= do precParseErr (negateName,negateFixity) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2)
| 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
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))
| not associate_right
= do precParseErr (get_op op1, fix1) (negateName, negateFixity)
return (OpApp e1 op1 fix1 e2)
where
(_, associate_right) = compareFixity fix1 negateFixity
mkOpAppRn e1 op fix e2
= ASSERT2( right_op_ok fix (unLoc e2),
ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr 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)
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 _ _
= True
mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
mkNegAppRn neg_arg neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
return (NegApp neg_arg neg_name)
not_op_app :: HsExpr id -> Bool
not_op_app (OpApp _ _ _ _) = False
not_op_app _ = True
mkOpFormRn :: LHsCmdTop Name
-> LHsExpr Name -> Fixity
-> LHsCmdTop Name
-> RnM (HsCmd Name)
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
op2 fix2 a2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (HsArrForm op2 (Just fix2) [a1, a2])
| associate_right
= do new_c <- mkOpFormRn a12 op2 fix2 a2
return (HsArrForm op1 (Just fix1)
[a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
where
(nofix_error, associate_right) = compareFixity fix1 fix2
mkOpFormRn arg1 op fix arg2
= return (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
= do { fix1 <- lookupFixityRn (unLoc op1)
; let (nofix_error, associate_right) = compareFixity fix1 fix2
; if nofix_error then do
{ precParseErr (unLoc op1,fix1) (unLoc 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))) }
else return (ConPatIn op2 (InfixCon p1 p2)) }
mkConOpPatRn op _ p1 p2
= ASSERT( not_op_pat (unLoc p2) )
return (ConPatIn op (InfixCon p1 p2))
not_op_pat :: Pat Name -> Bool
not_op_pat (ConPatIn _ (InfixCon _ _)) = False
not_op_pat _ = True
checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
checkPrecMatch op (MatchGroup ms _)
= mapM_ check ms
where
check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
check _ = return ()
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 = (op, op_fix)
info1 = (unLoc op1, op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info)
unless inf_ok (precParseErr infol infor)
checkPrec _ _ _
= return ()
checkSectionPrec :: FixityDirection -> HsExpr RdrName
-> LHsExpr Name -> LHsExpr Name -> RnM ()
checkSectionPrec direction section op arg
= case unLoc arg of
OpApp _ op fix _ -> go_for_it (get_op op) fix
NegApp _ _ -> go_for_it negateName negateFixity
_ -> return ()
where
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 :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
precParseErr op1@(n1,_) op2@(n2,_)
| isUnboundName n1 || isUnboundName n2
= return ()
| 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 :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
sectionPrecErr op@(n1,_) arg_op@(n2,_) section
| isUnboundName n1 || isUnboundName n2
= return ()
| 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}
%*********************************************************
%* *
\subsection{Errors}
%* *
%*********************************************************
\begin{code}
forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
-> TcRnIf TcGblEnv TcLclEnv ()
forAllWarn doc ty (L loc tyvar)
= ifDOptM 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))]
$$
doc)
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
; 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 ()
#else
checkTH e what
= addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
ptext (sLit "illegal in a stage-1 compiler"),
nest 2 (ppr e)])
#endif
\end{code}