Commit 203a687f authored by simonpj's avatar simonpj

[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.
parent 9704f544
......@@ -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.
--
......
......@@ -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 []
......
......@@ -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),
......
......@@ -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}
......@@ -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
......
{- -*-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
......
......@@ -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) ->
......@@ -440,22 +434,6 @@ rnRbinds str rbinds
returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
\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}
%************************************************************************
%* *
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}
......@@ -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}
......@@ -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.
......
......@@ -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}
%************************************************************************
%* *
......
......@@ -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.
......
......@@ -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 ->
......
......@@ -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}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment