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 ...@@ -88,6 +88,13 @@ dsLet (ThenBinds b1 b2) body
= dsLet b2 body `thenDs` \ body' -> = dsLet b2 body `thenDs` \ body' ->
dsLet b1 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 -- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building -- We need to do a case right away, rather than building
-- a tuple and doing selections. -- a tuple and doing selections.
...@@ -259,14 +266,6 @@ dsExpr (HsLet binds body) ...@@ -259,14 +266,6 @@ dsExpr (HsLet binds body)
= dsExpr body `thenDs` \ body' -> = dsExpr body `thenDs` \ body' ->
dsLet binds 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) -- 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. -- because the interpretation of `stmts' depends on what sort of thing it is.
-- --
......
...@@ -142,6 +142,7 @@ repTopDs group ...@@ -142,6 +142,7 @@ repTopDs group
groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_fords = foreign_decls }) hs_fords = foreign_decls })
-- Collect the binders of a Group
= collectHsBinders val_decls ++ = collectHsBinders val_decls ++
[n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++ [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
[n | ForeignImport n _ _ _ _ <- foreign_decls] [n | ForeignImport n _ _ _ _ <- foreign_decls]
...@@ -362,7 +363,6 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ...@@ -362,7 +363,6 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup 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 (ExplicitPArr ty es) = panic "No parallel arrays yet"
repE (RecordConOut _ _ _) = panic "No record construction yet" repE (RecordConOut _ _ _) = panic "No record construction yet"
repE (RecordUpdOut _ _ _ _) = panic "No record update yet" repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
...@@ -479,6 +479,8 @@ rep_binds (MonoBind bs sigs _) ...@@ -479,6 +479,8 @@ rep_binds (MonoBind bs sigs _)
= do { core1 <- rep_monobind bs = do { core1 <- rep_monobind bs
; core2 <- rep_sigs sigs ; core2 <- rep_sigs sigs
; return (core1 ++ core2) } ; return (core1 ++ core2) }
rep_binds (IPBinds _ _)
= panic "DsMeta:repBinds: can't do implicit parameters"
rep_monobind :: MonoBinds Name -> DsM [Core M.Decl] rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
rep_monobind EmptyMonoBinds = return [] rep_monobind EmptyMonoBinds = return []
......
...@@ -25,7 +25,7 @@ import PprCore ( {- instance Outputable (Expr a) -} ) ...@@ -25,7 +25,7 @@ import PprCore ( {- instance Outputable (Expr a) -} )
import Name ( Name ) import Name ( Name )
import PrelNames ( isUnboundName ) import PrelNames ( isUnboundName )
import NameSet ( NameSet, elemNameSet, nameSetToList ) import NameSet ( NameSet, elemNameSet, nameSetToList )
import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..) ) import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..), IPName )
import Outputable import Outputable
import SrcLoc ( SrcLoc ) import SrcLoc ( SrcLoc )
import Var ( TyVar ) import Var ( TyVar )
...@@ -49,13 +49,18 @@ Collections of bindings, created by dependency analysis and translation: ...@@ -49,13 +49,18 @@ Collections of bindings, created by dependency analysis and translation:
\begin{code} \begin{code}
data HsBinds id -- binders and bindees data HsBinds id -- binders and bindees
= EmptyBinds = EmptyBinds
| ThenBinds (HsBinds id) (HsBinds id)
| ThenBinds (HsBinds id)
(HsBinds id) | MonoBind -- A mutually recursive group
(MonoBinds id)
| MonoBind (MonoBinds id) [Sig id] -- Empty on typechecker output, Type Signatures
[Sig id] -- Empty on typechecker output, Type Signatures RecFlag
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} \end{code}
\begin{code} \begin{code}
...@@ -64,10 +69,11 @@ nullBinds :: HsBinds id -> Bool ...@@ -64,10 +69,11 @@ nullBinds :: HsBinds id -> Bool
nullBinds EmptyBinds = True nullBinds EmptyBinds = True
nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
nullBinds (MonoBind b _ _) = nullMonoBinds b nullBinds (MonoBind b _ _) = nullMonoBinds b
nullBinds (IPBinds b _) = null b
mkMonoBind :: MonoBinds id -> [Sig id] -> RecFlag -> HsBinds id mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
mkMonoBind EmptyMonoBinds _ _ = EmptyBinds mkMonoBind _ EmptyMonoBinds = EmptyBinds
mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec mkMonoBind is_rec mbinds = MonoBind mbinds [] is_rec
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -77,6 +83,12 @@ instance (OutputableBndr id) => Outputable (HsBinds id) where ...@@ -77,6 +83,12 @@ instance (OutputableBndr id) => Outputable (HsBinds id) where
ppr_binds EmptyBinds = empty ppr_binds EmptyBinds = empty
ppr_binds (ThenBinds binds1 binds2) ppr_binds (ThenBinds binds1 binds2)
= ppr_binds binds1 $$ ppr_binds 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) ppr_binds (MonoBind bind sigs is_rec)
= vcat [ppr_isrec, = vcat [ppr_isrec,
vcat (map ppr sigs), vcat (map ppr sigs),
......
...@@ -83,14 +83,9 @@ data HsExpr id ...@@ -83,14 +83,9 @@ data HsExpr id
| HsLet (HsBinds id) -- let(rec) | HsLet (HsBinds id) -- let(rec)
(HsExpr id) (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 | HsDo (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use -- because in this context we never use
-- the FunRhs variant -- the PatGuard or ParStmt variant
[Stmt id] -- "do":one or more stmts [Stmt id] -- "do":one or more stmts
[id] -- Ids for [return,fail,>>=,>>] [id] -- Ids for [return,fail,>>=,>>]
-- Brutal but simple -- Brutal but simple
...@@ -311,10 +306,6 @@ ppr_expr (HsLet binds expr) ...@@ -311,10 +306,6 @@ ppr_expr (HsLet binds expr)
= sep [hang (ptext SLIT("let")) 2 (pprBinds binds), = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)] 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 (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs) ppr_expr (ExplicitList _ exprs)
...@@ -445,12 +436,6 @@ pp_rbinds thing rbinds ...@@ -445,12 +436,6 @@ pp_rbinds thing rbinds
pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e] pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e]
\end{code} \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 ...@@ -764,6 +749,7 @@ data HsStmtContext id
| MDoExpr -- Recursive do-expression | MDoExpr -- Recursive do-expression
| PArrComp -- Parallel array comprehension | PArrComp -- Parallel array comprehension
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing | PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -796,6 +782,7 @@ pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern bin ...@@ -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 LambdaExpr = ptext SLIT("the body of a lambda")
pprMatchRhsContext RecUpd = panic "pprMatchRhsContext" 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 (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr = ptext SLIT("a 'do' expression") pprStmtContext DoExpr = ptext SLIT("a 'do' expression")
pprStmtContext MDoExpr = ptext SLIT("an 'mdo' expression") pprStmtContext MDoExpr = ptext SLIT("an 'mdo' expression")
...@@ -810,14 +797,15 @@ pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext ...@@ -810,14 +797,15 @@ pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext
-- Used to generate the string for a *runtime* error message -- Used to generate the string for a *runtime* error message
matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt = "case" matchContextErrString CaseAlt = "case"
matchContextErrString PatBindRhs = "pattern binding" matchContextErrString PatBindRhs = "pattern binding"
matchContextErrString RecUpd = "record update" matchContextErrString RecUpd = "record update"
matchContextErrString LambdaExpr = "lambda" matchContextErrString LambdaExpr = "lambda"
matchContextErrString (StmtCtxt (PatGuard _)) = "pattern gaurd" matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt DoExpr) = "'do' expression" matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard"
matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression" matchContextErrString (StmtCtxt DoExpr) = "'do' expression"
matchContextErrString (StmtCtxt ListComp) = "list comprehension" matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression"
matchContextErrString (StmtCtxt PArrComp) = "array comprehension" matchContextErrString (StmtCtxt ListComp) = "list comprehension"
matchContextErrString (StmtCtxt PArrComp) = "array comprehension"
\end{code} \end{code}
...@@ -118,6 +118,7 @@ it should return @[x, y, f, a, b]@ (remember, order important). ...@@ -118,6 +118,7 @@ it should return @[x, y, f, a, b]@ (remember, order important).
\begin{code} \begin{code}
collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)] collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)]
-- Used at top level only; so no need for an IPBinds case
collectLocatedHsBinders EmptyBinds = [] collectLocatedHsBinders EmptyBinds = []
collectLocatedHsBinders (MonoBind b _ _) collectLocatedHsBinders (MonoBind b _ _)
= collectLocatedMonoBinders b = collectLocatedMonoBinders b
...@@ -125,11 +126,11 @@ collectLocatedHsBinders (ThenBinds b1 b2) ...@@ -125,11 +126,11 @@ collectLocatedHsBinders (ThenBinds b1 b2)
= collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2
collectHsBinders :: HsBinds name -> [name] collectHsBinders :: HsBinds name -> [name]
collectHsBinders EmptyBinds = [] collectHsBinders EmptyBinds = []
collectHsBinders (MonoBind b _ _) collectHsBinders (IPBinds _ _) = [] -- Implicit parameters don't create
= collectMonoBinders b -- ordinary bindings
collectHsBinders (ThenBinds b1 b2) collectHsBinders (MonoBind b _ _) = collectMonoBinders b
= collectHsBinders b1 ++ collectHsBinders b2 collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2
collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)] collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)]
collectLocatedMonoBinders binds collectLocatedMonoBinders binds
...@@ -162,6 +163,7 @@ Get all the pattern type signatures out of a bunch of bindings ...@@ -162,6 +163,7 @@ Get all the pattern type signatures out of a bunch of bindings
\begin{code} \begin{code}
collectSigTysFromHsBinds :: HsBinds name -> [HsType name] collectSigTysFromHsBinds :: HsBinds name -> [HsType name]
collectSigTysFromHsBinds EmptyBinds = [] collectSigTysFromHsBinds EmptyBinds = []
collectSigTysFromHsBinds (IPBinds _ _) = []
collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b
collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++ collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++
collectSigTysFromHsBinds b2 collectSigTysFromHsBinds b2
......
{- -*-haskell-*- {- -*-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. Haskell grammar.
...@@ -469,21 +469,23 @@ decls :: { [RdrBinding] } -- Reversed ...@@ -469,21 +469,23 @@ decls :: { [RdrBinding] } -- Reversed
| {- empty -} { [] } | {- empty -} { [] }
wherebinds :: { RdrNameHsBinds } decllist :: { [RdrBinding] } -- Reversed
: where { cvBinds $1 } : '{' decls '}' { $2 }
| layout_on decls close { $2 }
where :: { [RdrBinding] } -- Reversed where :: { [RdrBinding] } -- Reversed
-- No implicit parameters
: 'where' decllist { $2 } : 'where' decllist { $2 }
| {- empty -} { [] } | {- empty -} { [] }
decllist :: { [RdrBinding] } -- Reversed binds :: { RdrNameHsBinds } -- May have implicit parameters
: '{' decls '}' { $2 } : decllist { cvBinds $1 }
| layout_on decls close { $2 } | '{' dbinds '}' { IPBinds $2 False{-not with-} }
| layout_on dbinds close { IPBinds $2 False{-not with-} }
letbinds :: { RdrNameHsExpr -> RdrNameHsExpr } wherebinds :: { RdrNameHsBinds } -- May have implicit parameters
: decllist { HsLet (cvBinds $1) } : 'where' binds { $2 }
| '{' dbinds '}' { \e -> HsWith e $2 False{-not with-} } | {- empty -} { EmptyBinds }
| layout_on dbinds close { \e -> HsWith e $2 False{-not with-} }
...@@ -922,7 +924,7 @@ sigdecl :: { RdrBinding } ...@@ -922,7 +924,7 @@ sigdecl :: { RdrBinding }
exp :: { RdrNameHsExpr } exp :: { RdrNameHsExpr }
: infixexp '::' sigtype { ExprWithTySig $1 $3 } : 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 { $1 }
infixexp :: { RdrNameHsExpr } infixexp :: { RdrNameHsExpr }
...@@ -936,7 +938,7 @@ exp10 :: { RdrNameHsExpr } ...@@ -936,7 +938,7 @@ exp10 :: { RdrNameHsExpr }
returnP (HsLam (Match ps $5 returnP (HsLam (Match ps $5
(GRHSs (unguardedRHS $8 $7) (GRHSs (unguardedRHS $8 $7)
EmptyBinds placeHolderType))) } 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 } | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 }
| 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 } | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 }
| '-' fexp { mkHsNegApp $2 } | '-' fexp { mkHsNegApp $2 }
...@@ -1156,7 +1158,7 @@ stmt :: { RdrNameStmt } ...@@ -1156,7 +1158,7 @@ stmt :: { RdrNameStmt }
: srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p -> : srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p ->
returnP (BindStmt p $4 $1) } returnP (BindStmt p $4 $1) }
| srcloc exp { ExprStmt $2 placeHolderType $1 } | srcloc exp { ExprStmt $2 placeHolderType $1 }
| srcloc 'let' decllist { LetStmt (cvBinds $3) } | srcloc 'let' binds { LetStmt $3 }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Record Field Update/Construction -- Record Field Update/Construction
......
...@@ -286,12 +286,6 @@ rnExpr (HsLet binds expr) ...@@ -286,12 +286,6 @@ rnExpr (HsLet binds expr)
rnExpr expr `thenM` \ (expr',fvExpr) -> rnExpr expr `thenM` \ (expr',fvExpr) ->
returnM (HsLet binds' 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) rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
= addSrcLoc src_loc $ = addSrcLoc src_loc $
rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) -> rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
...@@ -440,22 +434,6 @@ rnRbinds str rbinds ...@@ -440,22 +434,6 @@ rnRbinds str rbinds
returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname) returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
\end{code} \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 Template Haskell brackets
...@@ -526,12 +504,18 @@ rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) ...@@ -526,12 +504,18 @@ rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
-- the rnPatsAndThen, but it does not matter -- the rnPatsAndThen, but it does not matter
rnNormalStmts ctxt (LetStmt binds : stmts) rnNormalStmts ctxt (LetStmt binds : stmts)
= rnBindsAndThen binds $ \ binds' -> = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> rnBindsAndThen binds ( \ binds' ->
returnM (LetStmt binds' : stmts', fvs) 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) rnNormalStmts ctxt (ParStmt stmtss : stmts)
= mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) -> = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
let let
bndrss = map collectStmtsBinders stmtss' bndrss = map collectStmtsBinders stmtss'
in in
...@@ -934,10 +918,7 @@ thErr what ...@@ -934,10 +918,7 @@ thErr what
= ptext SLIT("Template Haskell") <+> text what <+> = ptext SLIT("Template Haskell") <+> text what <+>
ptext SLIT("illegal in a stage-1 compiler") ptext SLIT("illegal in a stage-1 compiler")
badIpBinds binds
withWarning = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
= sep [quotes (ptext SLIT("with")), (ppr binds)
ptext SLIT("is deprecated, use"),
quotes (ptext SLIT("let")),
ptext SLIT("instead")]
\end{code} \end{code}
...@@ -33,7 +33,7 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, ...@@ -33,7 +33,7 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn, checkDupOrQualNames, checkDupNames, mapFvRn,
lookupTopSrcBndr_maybe, lookupTopSrcBndr, lookupTopSrcBndr_maybe, lookupTopSrcBndr,
dataTcOccs, unknownNameErr dataTcOccs, newIPName, unknownNameErr
) )
import TcRnMonad import TcRnMonad
...@@ -258,18 +258,41 @@ rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs ...@@ -258,18 +258,41 @@ rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars) rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
-- This version assumes that the binders are already in scope -- This version assumes that the binders are already in scope
-- It's used only in 'mdo'
rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs) rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs 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 rnBindsAndThen :: RdrNameHsBinds
-> (RenamedHsBinds -> RnM (result, FreeVars)) -> (RenamedHsBinds -> RnM (result, FreeVars))
-> RnM (result, FreeVars) -> RnM (result, FreeVars)
-- This version (a) assumes that the binding vars are not already in scope -- 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 -- (b) removes the binders from the free vars of the thing inside
rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds -- The parser doesn't produce ThenBinds
rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds
-- The parser doesn't produce other forms 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} \end{code}
...@@ -945,4 +968,15 @@ badRuleVar name var ...@@ -945,4 +968,15 @@ badRuleVar name var
emptyConDeclsErr tycon emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] 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} \end{code}
...@@ -10,22 +10,23 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, ...@@ -10,22 +10,23 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr ) import {-# SOURCE #-} TcExpr ( tcExpr, tcMonoExpr )
import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
Match(..), HsMatchContext(..), Match(..), HsMatchContext(..), mkMonoBind,
collectMonoBinders, andMonoBinds, collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds collectSigTysFromMonoBinds
) )
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet ) import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
import TcRnMonad import TcRnMonad
import Inst ( InstOrigin(..), newDicts, instToId ) import Inst ( InstOrigin(..), newDicts, newIPDict, instToId )
import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars
) )
...@@ -93,11 +94,17 @@ tcTopBinds binds ...@@ -93,11 +94,17 @@ tcTopBinds binds
getLclEnv `thenM` \ env -> getLclEnv `thenM` \ env ->
returnM (EmptyMonoBinds, env) returnM (EmptyMonoBinds, env)
where 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 tcBindsAndThen
:: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator :: (TcHsBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds -> RenamedHsBinds
-> TcM thing -> TcM thing
-> TcM thing -> TcM thing
...@@ -114,6 +121,27 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next ...@@ -114,6 +121,27 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
tc_binds_and_then top_lvl combiner b2 $ tc_binds_and_then top_lvl combiner b2 $
do_next 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) $