Basically dependency analysis.
-Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In
+Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes. In
general, all of these functions return a renamed thing, and a set of
free variables.
module RnExpr (
rnMatch, rnGRHSsAndBinds, rnPat,
- checkPrecInfixBind
+ checkPrecMatch
) where
-import Ubiq
-import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
-import ErrUtils ( addErrLoc )
-import Name ( isLocallyDefinedName, pprOp, Name, RdrName )
+import ErrUtils ( addErrLoc, addShortErrLocLine )
+import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
import Pretty
-import UniqFM ( lookupUFM )
+import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
- UniqSet(..) )
-import Util ( Ord3(..), panic )
+ SYN_IE(UniqSet)
+ )
+import Util ( Ord3(..), removeDups, panic )
\end{code}
returnRn (LazyPatIn pat')
rnPat (AsPatIn name pat)
- = rnPat pat `thenRn` \ pat' ->
+ = rnPat pat `thenRn` \ pat' ->
lookupValue name `thenRn` \ vname ->
returnRn (AsPatIn vname pat')
-rnPat (ConPatIn name pats)
- = lookupValue name `thenRn` \ name' ->
+rnPat (ConPatIn con pats)
+ = lookupConstr con `thenRn` \ con' ->
mapRn rnPat pats `thenRn` \ patslist ->
- returnRn (ConPatIn name' patslist)
+ returnRn (ConPatIn con' patslist)
-rnPat (ConOpPatIn pat1 name pat2)
- = lookupValue name `thenRn` \ name' ->
+rnPat (ConOpPatIn pat1 con pat2)
+ = lookupConstr con `thenRn` \ con' ->
rnPat pat1 `thenRn` \ pat1' ->
rnPat pat2 `thenRn` \ pat2' ->
- precParsePat (ConOpPatIn pat1' name' pat2')
+ precParsePat (ConOpPatIn pat1' con' pat2')
rnPat neg@(NegPatIn pat)
= getSrcLocRn `thenRn` \ src_loc ->
returnRn (TuplePatIn patslist)
rnPat (RecPatIn con rpats)
- = panic "rnPat:RecPatIn"
-
+ = lookupConstr con `thenRn` \ con' ->
+ rnRpats rpats `thenRn` \ rpats' ->
+ returnRn (RecPatIn con' rpats')
\end{code}
************************************************************************
\end{itemize}
\begin{code}
+fv_set vname@(RnName n) | isLocallyDefinedName n
+ = unitUniqSet vname
+fv_set _ = emptyUniqSet
+
+
rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
rnExpr (HsVar v)
= lookupValue v `thenRn` \ vname ->
returnRn (HsVar vname, fv_set vname)
- where
- fv_set vname@(RnName n)
- | isLocallyDefinedName n = unitUniqSet vname
- fv_set _ = emptyUniqSet
rnExpr (HsLit lit)
= returnRn (HsLit lit, emptyUniqSet)
precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
-rnExpr (NegApp e)
+rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fvs_e) ->
- returnRn (NegApp e', fvs_e)
+ rnExpr n `thenRn` \ (n', fvs_n) ->
+ returnRn (NegApp e' n', fvs_e `unionUniqSets` fvs_n)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
= rnExprs exps `thenRn` \ (exps', fvExps) ->
returnRn (ExplicitTuple exps', fvExps)
-rnExpr (RecordCon con rbinds)
- = panic "rnExpr:RecordCon"
-rnExpr (RecordUpd exp rbinds)
- = panic "rnExpr:RecordUpd"
+rnExpr (RecordCon (HsVar con) rbinds)
+ = lookupConstr con `thenRn` \ conname ->
+ rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
+ returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
+
+rnExpr (RecordUpd expr rbinds)
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
+ returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds)
rnExpr (ExprWithTySig expr pty)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
returnRn (FromThenTo expr1' expr2' expr3',
unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+rnRbinds str rbinds
+ = mapRn field_dup_err dup_fields `thenRn_`
+ mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
+ returnRn (rbinds', unionManyUniqSets fvRbind_s)
+ where
+ (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
+
+ field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
+ addErrRn (dupFieldErr str src_loc dups)
+
+ rn_rbind (field, expr, pun)
+ = lookupField field `thenRn` \ fieldname ->
+ rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ returnRn ((fieldname, expr', pun), fvExpr)
+rnRpats rpats
+ = mapRn field_dup_err dup_fields `thenRn_`
+ mapRn rn_rpat rpats
+ where
+ (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
+
+ field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
+ addErrRn (dupFieldErr "pattern" src_loc dups)
+
+ rn_rpat (field, pat, pun)
+ = lookupField field `thenRn` \ fieldname ->
+ rnPat pat `thenRn` \ pat' ->
+ returnRn (fieldname, pat', pun)
\end{code}
%************************************************************************
%* *
-\subsubsection{@Qual@s: in list comprehensions}
+\subsubsection{@Qualifier@s: in list comprehensions}
%* *
%************************************************************************
= rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) ->
extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) ->
returnRn
- ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
+ ((qual' : quals', bs1 ++ bs2), -- The ones on the right (bs2) shadow the
-- ones on the left (bs1)
fvQuals1 `unionUniqSets` fvQuals2)
precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat
-precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2)
+precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
if 6 < op_prec then
-- negate precedence 6 wired in
-- (-x)*y ==> -(x*y)
precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
- returnRn (NegApp op_app)
+ returnRn (NegApp op_app n)
else
returnRn exp
precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
- case cmp op1_prec op_prec of
+ -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
+ case (op1_prec `cmp` op_prec) of
LT_ -> rearrange
EQ_ -> case (op1_fix, op_fix) of
(INFIXR, INFIXR) -> rearrange
precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
- case cmp op1_prec op_prec of
+ case (op1_prec `cmp` op_prec) of
LT_ -> rearrange
EQ_ -> case (op1_fix, op_fix) of
(INFIXR, INFIXR) -> rearrange
lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
lookupFixity op
= getExtraRn `thenRn` \ fixity_fm ->
+ -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $
case lookupUFM fixity_fm op of
Nothing -> returnRn (INFIXL, 9)
Just (InfixL _ n) -> returnRn (INFIXL, n)
\end{code}
\begin{code}
-checkPrecInfixBind :: Bool -> RnName -> [RenamedPat] -> RnM_Fixes s ()
+checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
-checkPrecInfixBind False fn pats
+checkPrecMatch False fn match
= returnRn ()
-checkPrecInfixBind True op [p1,p2]
+checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
= checkPrec op p1 False `thenRn_`
checkPrec op p2 True
+checkPrecMatch True op _
+ = panic "checkPrecMatch"
checkPrec op (ConOpPatIn _ op1 _) right
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
getSrcLocRn `thenRn` \ src_loc ->
let
inf_ok = op1_prec > op_prec ||
- op1_prec == op_prec &&
- (op1_fix == INFIXR && op_fix == INFIXR && right ||
- op1_fix == INFIXL && op_fix == INFIXL && not right)
+ (op1_prec == op_prec &&
+ (op1_fix == INFIXR && op_fix == INFIXR && right ||
+ op1_fix == INFIXL && op_fix == INFIXL && not right))
info = (op,op_fix,op_prec)
info1 = (op1,op1_fix,op1_prec)
(infol, infor) = if right then (info, info1) else (info1, info)
-
- inf_err = precParseErr infol infor src_loc
in
- addErrIfRn (not inf_ok) inf_err
+ addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
checkPrec op (NegPatIn _) right
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
\end{code}
\begin{code}
+dupFieldErr str src_loc (dup:rest)
+ = addShortErrLocLine src_loc (\ sty ->
+ ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str])
+
negPatErr pat src_loc
- = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
- ppr sty pat)
+ = addShortErrLocLine src_loc (\ sty ->
+ ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat])
precParseNegPatErr op src_loc
= addErrLoc src_loc "precedence parsing error" (\ sty ->
ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
ppStr " in the same infix expression"])
-pp_op sty (op, fix, prec) = ppBesides [pprOp sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
+pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
pp_fix INFIXL = ppStr "infixl"
pp_fix INFIXR = ppStr "infixr"
pp_fix INFIXN = ppStr "infix"
projects / ghc-hetmet.git / blobdiff