#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
-import RnIfaces ( lookupFixity )
+import RnIfaces ( lookupFixityRn )
import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
-import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence )
-import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
+import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
+import PrelInfo ( eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR
+ ioDataCon_RDR,
+ foldr_RDR, build_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
)
-import Name ( nameUnique, isLocallyDefined, NamedThing(..)
- , mkSysLocalName, nameSrcLoc
- )
+import TysWiredIn ( intTyCon, integerTyCon )
+import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
import NameSet
import UniqFM ( isNullUFM )
import FiniteMap ( elemFM )
-import UniqSet ( emptyUniqSet, UniqSet )
-import Unique ( assertIdKey )
+import UniqSet ( emptyUniqSet )
+import Unique ( hasKey, assertIdKey )
import Util ( removeDups )
import ListSetOps ( unionLists )
import Maybes ( maybeToBool )
rnPat (SigPatIn pat ty)
| opt_GlasgowExts
= rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsPolyType doc ty `thenRn` \ (ty', fvs2) ->
+ rnHsType doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
| otherwise
doc = text "a pattern type-signature"
rnPat (LitPatIn lit)
- = litOccurrence lit `thenRn` \ fvs1 ->
- lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
- returnRn (LitPatIn lit, fvs1 `addOneFV` eq)
+ = litFVs lit `thenRn` \ fvs ->
+ returnRn (LitPatIn lit, fvs)
+
+rnPat (NPatIn lit)
+ = rnOverLit lit `thenRn` \ (lit', fvs1) ->
+ lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
+ returnRn (NPatIn lit', fvs1 `addOneFV` eq)
+
+rnPat (NPlusKPatIn name lit minus)
+ = rnOverLit lit `thenRn` \ (lit', fvs) ->
+ lookupOrigName ordClass_RDR `thenRn` \ ord ->
+ lookupBndrRn name `thenRn` \ name' ->
+ lookupOccRn minus `thenRn` \ minus' ->
+ returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus')
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
-- See comments with rnExpr (OpApp ...)
(case mode of
InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
- SourceMode -> lookupFixity con' `thenRn` \ fixity ->
+ SourceMode -> lookupFixityRn con' `thenRn` \ fixity ->
mkConOpPatRn pat1' con' fixity pat2'
) `thenRn` \ pat' ->
returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
--- Negated patters can only be literals, and they are dealt with
--- by negating the literal at compile time, not by using the negation
--- operation in Num. So we don't need to make an implicit reference
--- to negate_RDR.
-rnPat neg@(NegPatIn pat)
- = checkRn (valid_neg_pat pat) (negPatErr neg)
- `thenRn_`
- rnPat pat `thenRn` \ (pat', fvs) ->
- returnRn (NegPatIn pat', fvs)
- where
- valid_neg_pat (LitPatIn (HsInt _)) = True
- valid_neg_pat (LitPatIn (HsIntPrim _)) = True
- valid_neg_pat (LitPatIn (HsFrac _)) = True
- valid_neg_pat (LitPatIn (HsFloatPrim _)) = True
- valid_neg_pat (LitPatIn (HsDoublePrim _)) = True
- valid_neg_pat _ = False
-
rnPat (ParPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (ParPatIn pat', fvs)
-rnPat (NPlusKPatIn name lit)
- = litOccurrence lit `thenRn` \ fvs ->
- lookupImplicitOccRn ordClass_RDR `thenRn` \ ord ->
- lookupBndrRn name `thenRn` \ name' ->
- returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord)
-
rnPat (ListPatIn pats)
= mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
rhs_sig_tyvars = case maybe_rhs_sig of
Nothing -> []
- Just ty -> extractHsTyRdrNames ty
+ Just ty -> extractHsTyRdrTyVars ty
tyvars_in_pats = extractPatsTyVars pats
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
- doc = text "a pattern type-signature"
+ doc_sig = text "a pattern type-signature"
+ doc_pats = text "in a pattern match"
in
- bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
+ bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
-- f x x = 1
- bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders ->
+ bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
rnExpr (HsVar v)
= lookupOccRn v `thenRn` \ name ->
- if nameUnique name == assertIdKey then
+ if name `hasKey` assertIdKey then
-- We expand it to (GHCerr.assert__ location)
mkAssertExpr
else
-- The normal case
returnRn (HsVar name, unitFV name)
+rnExpr (HsIPVar v)
+ = newIPName v `thenRn` \ name ->
+ returnRn (HsIPVar name, emptyFVs)
+
rnExpr (HsLit lit)
- = litOccurrence lit `thenRn` \ fvs ->
+ = litFVs lit `thenRn` \ fvs ->
returnRn (HsLit lit, fvs)
+rnExpr (HsOverLit lit)
+ = rnOverLit lit `thenRn` \ (lit', fvs) ->
+ returnRn (HsOverLit lit', fvs)
+
rnExpr (HsLam match)
= rnMatch match `thenRn` \ (match', fvMatch) ->
returnRn (HsLam match', fvMatch)
-- Don't even look up the fixity when in interface mode
getModeRn `thenRn` \ mode ->
(case mode of
- SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
+ SourceMode -> lookupFixityRn op_name `thenRn` \ fixity ->
mkOpAppRn e1' op' fixity e2'
InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
) `thenRn` \ final_e ->
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
--- constant-fold some negate applications on unboxed literals. Since
--- negate is a polymorphic function, we have to do these here.
-rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
-rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
-rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
-
rnExpr (NegApp e n)
- = rnExpr e `thenRn` \ (e', fv_e) ->
- lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
- mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
+ = rnExpr e `thenRn` \ (e', fv_e) ->
+ lookupOrigName negate_RDR `thenRn` \ neg ->
+ mkNegAppRn e' neg `thenRn` \ final_e ->
returnRn (final_e, fv_e `addOneFV` neg)
rnExpr (HsPar e)
checkSectionPrec "right" section op' expr' `thenRn_`
returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
-rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
- lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
- lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
+ = lookupOrigNames [ccallableClass_RDR,
+ creturnableClass_RDR,
+ ioDataCon_RDR] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
- returnRn (CCall fun args' may_gc is_casm fake_result_ty,
- fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
+ returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
+ fvs_args `plusFV` implicit_fvs)
rnExpr (HsSCC lbl expr)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
+rnExpr (HsWith expr binds)
+ = rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
+ returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
+
rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
- lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
+ lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
-- check the statement list ends in an expression
case last stmts' of {
ReturnStmt _ -> returnRn () ; -- for list comprehensions
_ -> addErrRn (doStmtListErr e)
} `thenRn_`
- returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
+ returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
+ where
+ implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
+ -- Monad stuff should not be necessary for a list comprehension
+ -- but the typechecker looks up the bind and return Ids anyway
+ -- Oh well.
+
rnExpr (ExplicitList exps)
= rnExprs exps `thenRn` \ (exps', fvs) ->
returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
-rnExpr (ExplicitTuple exps boxed)
+rnExpr (ExplicitTuple exps boxity)
= rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
+ returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
where
- tycon_name = tupleTyCon_name boxed (length exps)
+ tycon_name = tupleTyCon_name boxity (length exps)
rnExpr (RecordCon con_id rbinds)
= lookupOccRn con_id `thenRn` \ conname ->
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
rnExpr (ArithSeqIn seq)
- = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
+ = lookupOrigName enumClass_RDR `thenRn` \ enum ->
rn_seq seq `thenRn` \ (new_seq, fvs) ->
returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
where
returnRn (EWildPat, emptyFVs)
\end{code}
+
+
%************************************************************************
%* *
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
%************************************************************************
%* *
+\subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
+%* *
+%************************************************************************
+
+\begin{code}
+rnIPBinds [] = returnRn ([], emptyFVs)
+rnIPBinds ((n, expr) : binds)
+ = newIPName n `thenRn` \ name ->
+ rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
+ returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+
+\end{code}
+
+%************************************************************************
+%* *
\subsubsection{@Stmt@s: in @do@ expressions}
%* *
%************************************************************************
= addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
returnRn (OpApp e1 op1 fix1 e2)
where
- (nofix_err, associate_right) = compareFixity fix1 negateFixity
+ (_, associate_right) = compareFixity fix1 negateFixity
---------------------------
-- Default case
where
(nofix_error, associate_right) = compareFixity fix1 fix2
-mkConOpPatRn p1@(NegPatIn neg_arg)
- op2
- fix2@(Fixity prec2 dir2)
- p2
- | prec2 > negatePrecedence -- Precedence of unary - is wired in
- = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_`
- returnRn (ConOpPatIn p1 op2 fix2 p2)
-
mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
= ASSERT( not_op_pat p2 )
returnRn (ConOpPatIn p1 op fix p2)
checkPrecMatch False fn match
= returnRn ()
-checkPrecMatch True op (Match _ [p1,p2] _ _)
+checkPrecMatch True op (Match _ (p1:p2:_) _ _)
+ -- True indicates an infix lhs
= getModeRn `thenRn` \ mode ->
-- See comments with rnExpr (OpApp ...)
case mode of
checkPrecMatch True op _ = panic "checkPrecMatch"
checkPrec op (ConOpPatIn _ op1 _ _) right
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
+ = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
in
checkRn inf_ok (precParseErr infol infor)
-checkPrec op (NegPatIn _) right
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
-
checkPrec op pat right
= returnRn ()
checkSectionPrec left_or_right section op arg
= case arg of
OpApp _ op fix _ -> go_for_it (ppr_op op) fix
- NegApp _ op -> go_for_it pp_prefix_minus negateFixity
+ NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
other -> returnRn ()
where
HsVar op_name = op
go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
- = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
+ = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
checkRn (op_prec < arg_prec)
(sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
\end{code}
are made available.
\begin{code}
-litOccurrence (HsChar _)
- = returnRn (unitFV charTyCon_name)
-
-litOccurrence (HsCharPrim _)
- = returnRn (unitFV (getName charPrimTyCon))
-
-litOccurrence (HsString _)
- = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name)
-
-litOccurrence (HsStringPrim _)
- = returnRn (unitFV (getName addrPrimTyCon))
+litFVs (HsChar c) = returnRn (unitFV charTyCon_name)
+litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon))
+litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name])
+litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon))
+litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
+litFVs (HsInteger i) = returnRn (unitFV (getName integerTyCon))
+litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
+litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
+litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
+litFVs (HsLitLit l bogus_ty)
+ = lookupOrigName ccallableClass_RDR `thenRn` \ cc ->
+ returnRn (unitFV cc)
-litOccurrence (HsInt _)
- = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
- returnRn (unitFV num) -- Int and Integer are forced in by Num
+rnOverLit (HsIntegral i n)
+ = lookupOccRn n `thenRn` \ n' ->
+ returnRn (HsIntegral i n', unitFV n')
-litOccurrence (HsFrac _)
- = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
- lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
- returnRn (unitFV frac `plusFV` unitFV ratio)
+rnOverLit (HsFractional i n)
+ = lookupOccRn n `thenRn` \ n' ->
+ lookupOrigNames [ratioDataCon_RDR] `thenRn` \ ns' ->
-- 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
-- when fractionalClass does.
-
-litOccurrence (HsIntPrim _)
- = returnRn (unitFV (getName intPrimTyCon))
-
-litOccurrence (HsFloatPrim _)
- = returnRn (unitFV (getName floatPrimTyCon))
-
-litOccurrence (HsDoublePrim _)
- = returnRn (unitFV (getName doublePrimTyCon))
-
-litOccurrence (HsLitLit _)
- = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
- returnRn (unitFV cc)
+ returnRn (HsFractional i n', ns' `addOneFV` n')
\end{code}
%************************************************************************
\begin{code}
mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
mkAssertExpr =
- mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
- getSrcLocRn `thenRn` \ sloc ->
+ lookupOrigName assertErr_RDR `thenRn` \ name ->
+ getSrcLocRn `thenRn` \ sloc ->
-- if we're ignoring asserts, return (\ _ e -> e)
-- if not, return (assertError "src-loc")
quotes (ppr dup),
ptext SLIT("in record"), text str]
-negPatErr pat
- = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"),
- quotes (ppr pat)]
-
-precParseNegPatErr op
- = hang (ptext SLIT("precedence parsing error"))
- 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"),
- ppr_opfix op,
- ptext SLIT("in pattern")])
-
precParseErr op1 op2
= hang (ptext SLIT("precedence parsing error"))
4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
projects / ghc-hetmet.git / blobdiff