From 203a687fbdb9bf54592f907302d8e47e174bb549 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 23 Oct 2002 14:30:03 +0000 Subject: [PATCH] [project @ 2002-10-23 14:30:00 by simonpj] ------------------------------------------------ Allow implicit-parameter bindings anywhere that a normal binding group is allowed. ------------------------------------------------ That is, you can have implicit parameters * in a let binding * in a where clause (but then you can't have non-implicit ones as well) * in a let group in a list comprehension or monad do-notation The implementation is simple: just add IPBinds to the allowable forms of HsBinds, and remove the HsWith expression form altogether. (It now comes in via the HsLet form.) It'a a nice generalisation really. Needs a bit of documentation, which I'll do next. --- ghc/compiler/deSugar/DsExpr.lhs | 15 +++++---- ghc/compiler/deSugar/DsMeta.hs | 4 ++- ghc/compiler/hsSyn/HsBinds.lhs | 34 +++++++++++++------- ghc/compiler/hsSyn/HsExpr.lhs | 40 +++++++++--------------- ghc/compiler/hsSyn/HsSyn.lhs | 12 ++++--- ghc/compiler/parser/Parser.y | 28 +++++++++-------- ghc/compiler/rename/RnExpr.lhs | 45 ++++++++------------------- ghc/compiler/rename/RnSource.lhs | 44 +++++++++++++++++++++++--- ghc/compiler/typecheck/TcBinds.lhs | 55 +++++++++++++++++++++++++-------- ghc/compiler/typecheck/TcExpr.lhs | 35 ++------------------- ghc/compiler/typecheck/TcGenDeriv.lhs | 2 +- ghc/compiler/typecheck/TcHsSyn.lhs | 28 ++++++++--------- ghc/compiler/typecheck/TcMatches.lhs | 21 ++++++------- 13 files changed, 190 insertions(+), 173 deletions(-) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index a3808de..45cdacd 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -88,6 +88,13 @@ dsLet (ThenBinds b1 b2) body = dsLet b2 body `thenDs` \ body' -> dsLet b1 body' +dsLet (IPBinds binds is_with) body + = foldlDs dsIPBind body binds + where + dsIPBind body (n, e) + = dsExpr e `thenDs` \ e' -> + returnDs (Let (NonRec (ipNameName n) e') body) + -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. @@ -259,14 +266,6 @@ dsExpr (HsLet binds body) = dsExpr body `thenDs` \ body' -> dsLet binds body' -dsExpr (HsWith expr binds is_with) - = dsExpr expr `thenDs` \ expr' -> - foldlDs dsIPBind expr' binds - where - dsIPBind body (n, e) - = dsExpr e `thenDs` \ e' -> - returnDs (Let (NonRec (ipNameName n) e') body) - -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 296766b..d138a62 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -142,6 +142,7 @@ repTopDs group groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) +-- Collect the binders of a Group = collectHsBinders val_decls ++ [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++ [n | ForeignImport n _ _ _ _ <- foreign_decls] @@ -362,7 +363,6 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs } -repE (HsWith _ _ _) = panic "No with for implicit parameters yet" repE (ExplicitPArr ty es) = panic "No parallel arrays yet" repE (RecordConOut _ _ _) = panic "No record construction yet" repE (RecordUpdOut _ _ _ _) = panic "No record update yet" @@ -479,6 +479,8 @@ rep_binds (MonoBind bs sigs _) = do { core1 <- rep_monobind bs ; core2 <- rep_sigs sigs ; return (core1 ++ core2) } +rep_binds (IPBinds _ _) + = panic "DsMeta:repBinds: can't do implicit parameters" rep_monobind :: MonoBinds Name -> DsM [Core M.Decl] rep_monobind EmptyMonoBinds = return [] diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 8f3d81e..efdb9e4 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -25,7 +25,7 @@ import PprCore ( {- instance Outputable (Expr a) -} ) import Name ( Name ) import PrelNames ( isUnboundName ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..) ) +import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..), IPName ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) @@ -49,13 +49,18 @@ Collections of bindings, created by dependency analysis and translation: \begin{code} data HsBinds id -- binders and bindees = EmptyBinds - - | ThenBinds (HsBinds id) - (HsBinds id) - - | MonoBind (MonoBinds id) - [Sig id] -- Empty on typechecker output, Type Signatures - RecFlag + | ThenBinds (HsBinds id) (HsBinds id) + + | MonoBind -- A mutually recursive group + (MonoBinds id) + [Sig id] -- Empty on typechecker output, Type Signatures + RecFlag + + | IPBinds -- Implcit parameters + -- Not allowed at top level + [(IPName id, HsExpr id)] + Bool -- True <=> this was a 'with' binding + -- (tmp, until 'with' is removed) \end{code} \begin{code} @@ -64,10 +69,11 @@ nullBinds :: HsBinds id -> Bool nullBinds EmptyBinds = True nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 nullBinds (MonoBind b _ _) = nullMonoBinds b +nullBinds (IPBinds b _) = null b -mkMonoBind :: MonoBinds id -> [Sig id] -> RecFlag -> HsBinds id -mkMonoBind EmptyMonoBinds _ _ = EmptyBinds -mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec +mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id +mkMonoBind _ EmptyMonoBinds = EmptyBinds +mkMonoBind is_rec mbinds = MonoBind mbinds [] is_rec \end{code} \begin{code} @@ -77,6 +83,12 @@ instance (OutputableBndr id) => Outputable (HsBinds id) where ppr_binds EmptyBinds = empty ppr_binds (ThenBinds binds1 binds2) = ppr_binds binds1 $$ ppr_binds binds2 + +ppr_binds (IPBinds binds is_with) + = sep (punctuate semi (map pp_item binds)) + where + pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs + ppr_binds (MonoBind bind sigs is_rec) = vcat [ppr_isrec, vcat (map ppr sigs), diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index ac9fa7e..64eb26d 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -83,14 +83,9 @@ data HsExpr id | HsLet (HsBinds id) -- let(rec) (HsExpr id) - | HsWith (HsExpr id) -- implicit parameter binding - [(IPName id, HsExpr id)] - Bool -- True <=> this was a 'with' binding - -- (tmp, until 'with' is removed) - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use - -- the FunRhs variant + -- the PatGuard or ParStmt variant [Stmt id] -- "do":one or more stmts [id] -- Ids for [return,fail,>>=,>>] -- Brutal but simple @@ -311,10 +306,6 @@ ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), hang (ptext SLIT("in")) 2 (ppr expr)] -ppr_expr (HsWith expr binds is_with) - = sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds), - hang (ptext SLIT("in")) 2 (ppr expr)] - ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) @@ -445,12 +436,6 @@ pp_rbinds thing rbinds pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e] \end{code} -\begin{code} -pp_ipbinds :: OutputableBndr id => [(IPName id, HsExpr id)] -> SDoc -pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs)) - where - pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> ppr_expr rhs -\end{code} %************************************************************************ @@ -764,6 +749,7 @@ data HsStmtContext id | MDoExpr -- Recursive do-expression | PArrComp -- Parallel array comprehension | PatGuard (HsMatchContext id) -- Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt \end{code} \begin{code} @@ -796,6 +782,7 @@ pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern bin pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda") pprMatchRhsContext RecUpd = panic "pprMatchRhsContext" +pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c] pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt pprStmtContext DoExpr = ptext SLIT("a 'do' expression") pprStmtContext MDoExpr = ptext SLIT("an 'mdo' expression") @@ -810,14 +797,15 @@ pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext -- Used to generate the string for a *runtime* error message -matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) -matchContextErrString CaseAlt = "case" -matchContextErrString PatBindRhs = "pattern binding" -matchContextErrString RecUpd = "record update" -matchContextErrString LambdaExpr = "lambda" -matchContextErrString (StmtCtxt (PatGuard _)) = "pattern gaurd" -matchContextErrString (StmtCtxt DoExpr) = "'do' expression" -matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression" -matchContextErrString (StmtCtxt ListComp) = "list comprehension" -matchContextErrString (StmtCtxt PArrComp) = "array comprehension" +matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) +matchContextErrString CaseAlt = "case" +matchContextErrString PatBindRhs = "pattern binding" +matchContextErrString RecUpd = "record update" +matchContextErrString LambdaExpr = "lambda" +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard" +matchContextErrString (StmtCtxt DoExpr) = "'do' expression" +matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression" +matchContextErrString (StmtCtxt ListComp) = "list comprehension" +matchContextErrString (StmtCtxt PArrComp) = "array comprehension" \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 708a82f..7f5ca52 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -118,6 +118,7 @@ it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)] +-- Used at top level only; so no need for an IPBinds case collectLocatedHsBinders EmptyBinds = [] collectLocatedHsBinders (MonoBind b _ _) = collectLocatedMonoBinders b @@ -125,11 +126,11 @@ collectLocatedHsBinders (ThenBinds b1 b2) = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 collectHsBinders :: HsBinds name -> [name] -collectHsBinders EmptyBinds = [] -collectHsBinders (MonoBind b _ _) - = collectMonoBinders b -collectHsBinders (ThenBinds b1 b2) - = collectHsBinders b1 ++ collectHsBinders b2 +collectHsBinders EmptyBinds = [] +collectHsBinders (IPBinds _ _) = [] -- Implicit parameters don't create + -- ordinary bindings +collectHsBinders (MonoBind b _ _) = collectMonoBinders b +collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2 collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)] collectLocatedMonoBinders binds @@ -162,6 +163,7 @@ Get all the pattern type signatures out of a bunch of bindings \begin{code} collectSigTysFromHsBinds :: HsBinds name -> [HsType name] collectSigTysFromHsBinds EmptyBinds = [] +collectSigTysFromHsBinds (IPBinds _ _) = [] collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++ collectSigTysFromHsBinds b2 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index cbddb21..c5c6173 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.110 2002/10/11 14:46:04 simonpj Exp $ +$Id: Parser.y,v 1.111 2002/10/23 14:30:01 simonpj Exp $ Haskell grammar. @@ -469,21 +469,23 @@ decls :: { [RdrBinding] } -- Reversed | {- empty -} { [] } -wherebinds :: { RdrNameHsBinds } - : where { cvBinds $1 } +decllist :: { [RdrBinding] } -- Reversed + : '{' decls '}' { $2 } + | layout_on decls close { $2 } where :: { [RdrBinding] } -- Reversed + -- No implicit parameters : 'where' decllist { $2 } | {- empty -} { [] } -decllist :: { [RdrBinding] } -- Reversed - : '{' decls '}' { $2 } - | layout_on decls close { $2 } +binds :: { RdrNameHsBinds } -- May have implicit parameters + : decllist { cvBinds $1 } + | '{' dbinds '}' { IPBinds $2 False{-not with-} } + | layout_on dbinds close { IPBinds $2 False{-not with-} } -letbinds :: { RdrNameHsExpr -> RdrNameHsExpr } - : decllist { HsLet (cvBinds $1) } - | '{' dbinds '}' { \e -> HsWith e $2 False{-not with-} } - | layout_on dbinds close { \e -> HsWith e $2 False{-not with-} } +wherebinds :: { RdrNameHsBinds } -- May have implicit parameters + : 'where' binds { $2 } + | {- empty -} { EmptyBinds } @@ -922,7 +924,7 @@ sigdecl :: { RdrBinding } exp :: { RdrNameHsExpr } : infixexp '::' sigtype { ExprWithTySig $1 $3 } - | infixexp 'with' dbinding { HsWith $1 $3 True{-not a let-} } + | infixexp 'with' dbinding { HsLet (IPBinds $3 True{-not a let-}) $1 } | infixexp { $1 } infixexp :: { RdrNameHsExpr } @@ -936,7 +938,7 @@ exp10 :: { RdrNameHsExpr } returnP (HsLam (Match ps $5 (GRHSs (unguardedRHS $8 $7) EmptyBinds placeHolderType))) } - | 'let' letbinds 'in' exp { $2 $4 } + | 'let' binds 'in' exp { HsLet $2 $4 } | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 } | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 } | '-' fexp { mkHsNegApp $2 } @@ -1156,7 +1158,7 @@ stmt :: { RdrNameStmt } : srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p -> returnP (BindStmt p $4 $1) } | srcloc exp { ExprStmt $2 placeHolderType $1 } - | srcloc 'let' decllist { LetStmt (cvBinds $3) } + | srcloc 'let' binds { LetStmt $3 } ----------------------------------------------------------------------------- -- Record Field Update/Construction diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 36bd94b..e67f32e 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -286,12 +286,6 @@ rnExpr (HsLet binds expr) rnExpr expr `thenM` \ (expr',fvExpr) -> returnM (HsLet binds' expr', fvExpr) -rnExpr (HsWith expr binds is_with) - = warnIf is_with withWarning `thenM_` - rnExpr expr `thenM` \ (expr',fvExpr) -> - rnIPBinds binds `thenM` \ (binds',fvBinds) -> - returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) - rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) = addSrcLoc src_loc $ rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) -> @@ -442,22 +436,6 @@ rnRbinds str rbinds %************************************************************************ %* * -\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * -%* * -%************************************************************************ - -\begin{code} -rnIPBinds [] = returnM ([], emptyFVs) -rnIPBinds ((n, expr) : binds) - = newIPName n `thenM` \ name -> - rnExpr expr `thenM` \ (expr',fvExpr) -> - rnIPBinds binds `thenM` \ (binds',fvBinds) -> - returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) - -\end{code} - -%************************************************************************ -%* * Template Haskell brackets %* * %************************************************************************ @@ -526,12 +504,18 @@ rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) -- the rnPatsAndThen, but it does not matter rnNormalStmts ctxt (LetStmt binds : stmts) - = rnBindsAndThen binds $ \ binds' -> - rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - returnM (LetStmt binds' : stmts', fvs) + = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_` + rnBindsAndThen binds ( \ binds' -> + rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> + returnM (LetStmt binds' : stmts', fvs)) + where + -- We do not allow implicit-parameter bindings in a parallel + -- list comprehension. I'm not sure what it might mean. + ok (ParStmtCtxt _) (IPBinds _ _) = False + ok _ _ = True rnNormalStmts ctxt (ParStmt stmtss : stmts) - = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) -> + = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) -> let bndrss = map collectStmtsBinders stmtss' in @@ -934,10 +918,7 @@ thErr what = ptext SLIT("Template Haskell") <+> text what <+> ptext SLIT("illegal in a stage-1 compiler") - -withWarning - = sep [quotes (ptext SLIT("with")), - ptext SLIT("is deprecated, use"), - quotes (ptext SLIT("let")), - ptext SLIT("instead")] +badIpBinds binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4 + (ppr binds) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 401030f..0e53b07 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -33,7 +33,7 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, checkDupOrQualNames, checkDupNames, mapFvRn, lookupTopSrcBndr_maybe, lookupTopSrcBndr, - dataTcOccs, unknownNameErr + dataTcOccs, newIPName, unknownNameErr ) import TcRnMonad @@ -258,18 +258,41 @@ rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars) -- This version assumes that the binders are already in scope +-- It's used only in 'mdo' rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs) rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs - -- The parser doesn't produce other forms +rnBinds b@(IPBinds bind _) = addErr (badIpBinds b) `thenM_` + returnM (EmptyBinds, emptyFVs) rnBindsAndThen :: RdrNameHsBinds -> (RenamedHsBinds -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -- This version (a) assumes that the binding vars are not already in scope -- (b) removes the binders from the free vars of the thing inside -rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds -rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside - -- The parser doesn't produce other forms +-- The parser doesn't produce ThenBinds +rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds +rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside +rnBindsAndThen (IPBinds binds is_with) thing_inside + = warnIf is_with withWarning `thenM_` + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + thing_inside (IPBinds binds' is_with) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * +%* * +%************************************************************************ + +\begin{code} +rnIPBinds [] = returnM ([], emptyFVs) +rnIPBinds ((n, expr) : binds) + = newIPName n `thenM` \ name -> + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + \end{code} @@ -945,4 +968,15 @@ badRuleVar name var emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] + +withWarning + = sep [quotes (ptext SLIT("with")), + ptext SLIT("is deprecated, use"), + quotes (ptext SLIT("let")), + ptext SLIT("instead")] + +badIpBinds binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 + (ppr binds) \end{code} + diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index ae28e06..1dee32a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -10,22 +10,23 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcExpr ) +import {-# SOURCE #-} TcExpr ( tcExpr, tcMonoExpr ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), - Match(..), HsMatchContext(..), + Match(..), HsMatchContext(..), mkMonoBind, collectMonoBinders, andMonoBinds, collectSigTysFromMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet ) +import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) import TcRnMonad -import Inst ( InstOrigin(..), newDicts, instToId ) +import Inst ( InstOrigin(..), newDicts, newIPDict, instToId ) import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, + tcSimplifyToDicts, tcSimplifyIPs ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars ) @@ -93,11 +94,17 @@ tcTopBinds binds getLclEnv `thenM` \ env -> returnM (EmptyMonoBinds, env) where - glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing) + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive MonoBinds + glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env) + flatten EmptyBinds = EmptyMonoBinds + flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2 + flatten (MonoBind b _ _) = b + -- Can't have a IPBinds at top level tcBindsAndThen - :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator + :: (TcHsBinds -> thing -> thing) -- Combinator -> RenamedHsBinds -> TcM thing -> TcM thing @@ -114,6 +121,27 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next tc_binds_and_then top_lvl combiner b2 $ do_next +tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next + = getLIE do_next `thenM` \ (result, expr_lie) -> + mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') -> + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> + + returnM (combiner (IPBinds binds' is_with) $ + combiner (mkMonoBind Recursive dict_binds) result) + where + -- I wonder if we should do these one at at time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind (ip, expr) + = newTyVarTy openTypeKind `thenM` \ ty -> + getSrcLocM `thenM` \ loc -> + newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> + tcMonoExpr expr ty `thenM` \ expr' -> + returnM (ip_inst, (ip', expr')) + tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE -- Notice that they scope over @@ -149,7 +177,8 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- leave them to the tcSimplifyTop, and quite a bit faster too TopLevel -> extendLIEs lie `thenM_` - returnM (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing) + returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds)) + thing) NotTopLevel -> bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> @@ -159,16 +188,16 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- so that we desugar unlifted bindings correctly if isRec is_rec then returnM ( - combiner Recursive ( + combiner (mkMonoBind Recursive ( poly_binds `andMonoBinds` lie_binds `andMonoBinds` - prag_binds) thing + prag_binds)) thing ) else returnM ( - combiner NonRecursive poly_binds $ - combiner NonRecursive prag_binds $ - combiner Recursive lie_binds $ + combiner (mkMonoBind NonRecursive poly_binds) $ + combiner (mkMonoBind NonRecursive prag_binds) $ + combiner (mkMonoBind Recursive lie_binds) $ -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns -- aren't guaranteed in dependency order (though we could change -- that); hence the Recursive marker. diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index e7307f7..676a5d2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -19,9 +19,7 @@ import Name ( isExternalName ) import qualified DsMeta #endif -import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - mkMonoBind, recBindFields - ) +import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet ) import TcRnMonad @@ -236,11 +234,9 @@ tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty \begin{code} tcMonoExpr (HsLet binds expr) res_ty = tcBindsAndThen - combiner + HsLet binds -- Bindings to check (tcMonoExpr expr res_ty) - where - combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty = addSrcLoc src_loc $ @@ -664,33 +660,6 @@ tcMonoExpr (HsReify (Reify flavour name)) res_ty #endif GHCI \end{code} -%************************************************************************ -%* * -\subsection{Implicit Parameter bindings} -%* * -%************************************************************************ - -\begin{code} -tcMonoExpr (HsWith expr binds is_with) res_ty - = getLIE (tcMonoExpr expr res_ty) `thenM` \ (expr', expr_lie) -> - mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') -> - - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> - let - expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr' - in - returnM (HsWith expr'' binds' is_with) - where - tc_ip_bind (ip, expr) - = newTyVarTy openTypeKind `thenM` \ ty -> - getSrcLocM `thenM` \ loc -> - newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> - tcMonoExpr expr ty `thenM` \ expr' -> - returnM (ip_inst, (ip', expr')) -\end{code} - %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index a4b286f..ef9b35e 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -1090,7 +1090,7 @@ mk_easy_FunMonoBind loc fun pats binds expr = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc mk_easy_Match loc pats binds expr - = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive) + = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds)) -- The renamer expects everything in its input to be a -- "recursive" MonoBinds, and it is its job to sort things out -- from there. diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 494b0d6..0ca5d60 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -315,7 +315,20 @@ zonkBinds env (MonoBind bind sigs is_rec) zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) -> returnM (env1, new_bind, new_ids) ) `thenM` \ (env1, new_bind, _) -> - returnM (env1, mkMonoBind new_bind [] is_rec) + returnM (env1, mkMonoBind is_rec new_bind) + +zonkBinds env (IPBinds binds is_with) + = mappM zonk_ip_bind binds `thenM` \ new_binds -> + let + env1 = extendZonkEnv env (map (ipNameName . fst) new_binds) + in + returnM (env1, IPBinds new_binds is_with) + where + zonk_ip_bind (n, e) + = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> + zonkExpr env e `thenM` \ e' -> + returnM (n', e') + --------------------------------------------- zonkMonoBinds :: ZonkEnv -> TcMonoBinds @@ -497,19 +510,6 @@ zonkExpr env (HsLet binds expr) zonkExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsWith expr binds is_with) - = mappM zonk_ip_bind binds `thenM` \ new_binds -> - let - env1 = extendZonkEnv env (map (ipNameName . fst) new_binds) - in - zonkExpr env1 expr `thenM` \ new_expr -> - returnM (HsWith new_expr new_binds is_with) - where - zonk_ip_bind (n, e) - = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> - zonkExpr env e `thenM` \ e' -> - returnM (n', e') - zonkExpr env (HsDo do_or_lc stmts ids ty src_loc) = zonkStmts env stmts `thenM` \ new_stmts -> zonkTcTypeToType env ty `thenM` \ new_ty -> diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 37e33a9..317e335 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -20,7 +20,7 @@ import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..), ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedMatchContext ) -import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, +import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcMonoBinds, TcPat, TcStmt ) import TcRnMonad @@ -151,7 +151,7 @@ tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this; addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) -> - returnM (Match pats' Nothing (glue_on Recursive ex_binds grhss')) + returnM (Match pats' Nothing (glue_on ex_binds grhss')) where tc_grhss rhs_ty @@ -181,9 +181,9 @@ lift_grhss co_fn rhs_ty (GRHSs grhss binds ty) lift_stmt stmt = stmt -- glue_on just avoids stupid dross -glue_on _ EmptyMonoBinds grhss = grhss -- The common case -glue_on is_rec mbinds (GRHSs grhss binds ty) - = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty +glue_on EmptyBinds grhss = grhss -- The common case +glue_on binds1 (GRHSs grhss binds2 ty) + = GRHSs grhss (binds1 `ThenBinds` binds2) ty tcGRHSs :: RenamedMatchContext -> RenamedGRHSs @@ -216,7 +216,7 @@ tcGRHSs ctxt (GRHSs grhss binds _) expected_ty tcMatchPats :: [RenamedPat] -> TcType -> (TcType -> TcM a) - -> TcM ([TcPat], a, TcDictBinds) + -> TcM ([TcPat], a, TcHsBinds) -- Typecheck the patterns, extend the environment to bind the variables, -- do the thing inside, use any existentially-bound dictionaries to -- discharge parts of the returning LIE, and deal with pattern type @@ -246,7 +246,7 @@ tcMatchPats pats expected_ty thing_inside -- f (C g) x = g x -- Here, result_ty will be simply Int, but expected_ty is (a -> Int). - returnM (pats', result, ex_binds) + returnM (pats', result, mkMonoBind Recursive ex_binds) tc_match_pats [] expected_ty thing_inside = thing_inside expected_ty `thenM` \ answer -> @@ -433,7 +433,7 @@ tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) t popErrCtxt thing_inside ) `thenM` \ ([pat'], thing, dict_binds) -> returnM (combine (BindStmt pat' exp' src_loc) - (glue_binds combine Recursive dict_binds thing)) + (glue_binds combine dict_binds thing)) -- ParStmt tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside @@ -515,9 +515,8 @@ tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) t ------------------------------ -glue_binds combine is_rec binds thing - | nullMonoBinds binds = thing - | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing +glue_binds combine EmptyBinds thing = thing +glue_binds combine other_binds thing = combine (LetStmt other_binds) thing \end{code} -- 1.7.10.4