= 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.
= 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.
--
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]
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"
= 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 []
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 )
\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}
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}
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),
| 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
= 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)
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}
%************************************************************************
| 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}
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")
-- 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}
\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
= 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
\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.
| {- 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 }
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 }
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 }
: 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
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) ->
%************************************************************************
%* *
-\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
%* *
%************************************************************************
-- 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
= 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}
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn,
lookupTopSrcBndr_maybe, lookupTopSrcBndr,
- dataTcOccs, unknownNameErr
+ dataTcOccs, newIPName, unknownNameErr
)
import TcRnMonad
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}
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}
+
#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
)
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
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
-- 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 ->
-- 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.
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
\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 $
#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}
-
%************************************************************************
%* *
= 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.
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
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 ->
)
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
= 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
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
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
-- 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 ->
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
------------------------------
-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}
projects / ghc-hetmet.git / commitdiff