#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
-import RnIfaces ( lookupFixityRn )
-import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
+import RnHiFiles ( lookupFixityRn )
+import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
+import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
-import PrelInfo ( eqClass_RDR,
- ccallableClass_RDR, creturnableClass_RDR,
+import PrelNames ( hasKey, assertIdKey,
+ eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
+ cCallableClass_RDR, cReturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR,
- foldr_RDR, build_RDR
+ ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
)
-import TysWiredIn ( intTyCon, integerTyCon )
+import TysWiredIn ( intTyCon )
import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
import NameSet
import UniqFM ( isNullUFM )
import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet )
-import Unique ( hasKey, assertIdKey )
-import Util ( removeDups )
-import ListSetOps ( unionLists )
+import List ( intersectBy )
+import ListSetOps ( unionLists, removeDups )
import Maybes ( maybeToBool )
import Outputable
\end{code}
returnRn (VarPatIn vname, emptyFVs)
rnPat (SigPatIn pat ty)
- | opt_GlasgowExts
- = rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsType doc ty `thenRn` \ (ty', fvs2) ->
- returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
-
- | otherwise
- = addErrRn (patSigErr ty) `thenRn_`
- rnPat pat
+ = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
+
+ if glaExts
+ then rnPat pat `thenRn` \ (pat', fvs1) ->
+ rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) ->
+ returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+
+ else addErrRn (patSigErr ty) `thenRn_`
+ rnPat pat
where
doc = text "a pattern type-signature"
+rnPat (LitPatIn s@(HsString _))
+ = lookupOrigName eqString_RDR `thenRn` \ eq ->
+ returnRn (LitPatIn s, unitFV eq)
+
rnPat (LitPatIn lit)
= litFVs lit `thenRn` \ fvs ->
returnRn (LitPatIn lit, fvs)
= lookupOccRn con `thenRn` \ con' ->
rnRpats rpats `thenRn` \ (rpats', fvs) ->
returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
+rnPat (TypePatIn name) =
+ (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) ->
+ returnRn (TypePatIn name', fvs)
\end{code}
************************************************************************
doc_sig = text "a pattern type-signature"
doc_pats = text "in a pattern match"
in
- bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
+ bindNakedTyVarsFVRn doc_sig forall_tyvars $ \ sig_tyvars ->
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
+ doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
rnGRHS (GRHS guarded locn)
- = pushSrcLocRn locn $
+ = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+ pushSrcLocRn locn $
(if not (opt_GlasgowExts || is_standard_guard guarded) then
addWarnRn (nonStdGuardErr guarded)
else
returnRn ()
) `thenRn_`
- rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
+ rnStmts rnExpr guarded `thenRn` \ ((_, guarded'), fvs) ->
returnRn (GRHS guarded' locn, fvs)
where
-- Standard Haskell 1.4 guards are just a single boolean
rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = lookupOrigNames [ccallableClass_RDR,
- creturnableClass_RDR,
+ = lookupOrigNames [cCallableClass_RDR,
+ cReturnableClass_RDR,
ioDataCon_RDR] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
- rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
+ rnStmts rnExpr stmts `thenRn` \ ((_, stmts'), fvs) ->
-- check the statement list ends in an expression
case last stmts' of {
ExprStmt _ _ -> returnRn () ;
ReturnStmt _ -> returnRn () ; -- for list comprehensions
_ -> addErrRn (doStmtListErr e)
- } `thenRn_`
+ } `thenRn_`
returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
where
implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
rnExpr (HsIf p b1 b2 src_loc)
rnExpr b2 `thenRn` \ (b2', fvB2) ->
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
+rnExpr (HsType a)
+ = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
+ returnRn (HsType t, fvT)
+ where
+ doc = text "renaming a type pattern"
+
rnExpr (ArithSeqIn seq)
= lookupOrigName enumClass_RDR `thenRn` \ enum ->
rn_seq seq `thenRn` \ (new_seq, fvs) ->
type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
rnStmts :: RnExprTy
- -> [RdrNameStmt]
- -> RnMS ([RenamedStmt], FreeVars)
+ -> [RdrNameStmt]
+ -> RnMS (([Name], [RenamedStmt]), FreeVars)
rnStmts rn_expr []
- = returnRn ([], emptyFVs)
+ = returnRn (([], []), emptyFVs)
rnStmts rn_expr (stmt:stmts)
- = rnStmt rn_expr stmt $ \ stmt' ->
- rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) ->
- returnRn (stmt' : stmts', fvs)
+ = getLocalNameEnv `thenRn` \ name_env ->
+ rnStmt rn_expr stmt $ \ stmt' ->
+ rnStmts rn_expr stmts `thenRn` \ ((binders, stmts'), fvs) ->
+ returnRn ((binders, stmt' : stmts'), fvs)
rnStmt :: RnExprTy -> RdrNameStmt
- -> (RenamedStmt -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
+ -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
+ -> RnMS (([Name], a), FreeVars)
-- Because of mutual recursion we have to pass in rnExpr.
+rnStmt rn_expr (ParStmt stmtss) thing_inside
+ = mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) ->
+ let (binderss, stmtss') = unzip bndrstmtss
+ checkBndrs all_bndrs bndrs
+ = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
+ returnRn (bndrs ++ all_bndrs)
+ eqOcc n1 n2 = nameOccName n1 == nameOccName n2
+ err = text "duplicate binding in parallel list comprehension"
+ in
+ foldlRn checkBndrs [] binderss `thenRn` \ binders ->
+ bindLocalNamesFV binders $
+ thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
+ returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest)
+
rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
= pushSrcLocRn src_loc $
- rn_expr expr `thenRn` \ (expr', fv_expr) ->
- bindLocalsFVRn doc binders $ \ new_binders ->
- rnPat pat `thenRn` \ (pat', fv_pat) ->
- thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
+ rn_expr expr `thenRn` \ (expr', fv_expr) ->
+ bindLocalsFVRn doc binders $ \ new_binders ->
+ rnPat pat `thenRn` \ (pat', fv_pat) ->
+ thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) ->
+ -- ZZ is shadowing handled correctly?
+ returnRn ((rest_binders ++ new_binders, result),
+ fv_expr `plusFV` fvs `plusFV` fv_pat)
where
binders = collectPatBinders pat
doc = text "a pattern in do binding"
returnRn (result, fv_expr `plusFV` fvs)
rnStmt rn_expr (LetStmt binds) thing_inside
- = rnBinds binds $ \ binds' ->
+ = rnBinds binds $ \ binds' ->
thing_inside (LetStmt binds')
+
\end{code}
%************************************************************************
are made available.
\begin{code}
-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)
-
-rnOverLit (HsIntegral i n)
- = lookupOccRn n `thenRn` \ n' ->
- returnRn (HsIntegral i n', unitFV n')
+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 (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)
+litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
+ -- in post-typechecker translations
+
+rnOverLit (HsIntegral i from_integer)
+ = lookupOccRn from_integer `thenRn` \ from_integer' ->
+ (if inIntRange i then
+ returnRn emptyFVs
+ else
+ lookupOrigNames [plusInteger_RDR, timesInteger_RDR]
+ ) `thenRn` \ ns ->
+ returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer')
rnOverLit (HsFractional i n)
- = lookupOccRn n `thenRn` \ n' ->
- lookupOrigNames [ratioDataCon_RDR] `thenRn` \ ns' ->
+ = lookupOccRn n `thenRn` \ n' ->
+ lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_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.
+ -- The plus/times integer operations may be needed to construct the numerator
+ -- and denominator (see DsUtils.mkIntegerLit)
returnRn (HsFractional i n', ns' `addOneFV` n')
\end{code}
projects / ghc-hetmet.git / blobdiff