Commit b2f644fa authored by simonpj's avatar simonpj
Browse files

[project @ 2002-06-05 14:39:27 by simonpj]

---------------------------------------
	Add rebindable syntax for do-notation
		(this time, on the HEAD)
	---------------------------------------

Make do-notation use rebindable syntax, so that -fno-implicit-prelude
makes do-notation use whatever (>>=), (>>), return, fail are in scope,
rather than the Prelude versions.

On the way, combine HsDo and HsDoOut into one constructor in HsSyn,
and tidy up type checking of HsDo.
parent 2145e55a
......@@ -266,18 +266,18 @@ dsExpr (HsWith expr binds is_with)
-- 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.
--
dsExpr (HsDoOut ListComp stmts _ result_ty src_loc)
dsExpr (HsDo ListComp stmts _ result_ty src_loc)
= -- Special case for list comprehensions
putSrcLocDs src_loc $
dsListComp stmts elt_ty
where
(_, [elt_ty]) = tcSplitTyConApp result_ty
dsExpr (HsDoOut DoExpr stmts ids result_ty src_loc)
dsExpr (HsDo DoExpr stmts ids result_ty src_loc)
= putSrcLocDs src_loc $
dsDo DoExpr stmts ids result_ty
dsExpr (HsDoOut PArrComp stmts _ result_ty src_loc)
dsExpr (HsDo PArrComp stmts _ result_ty src_loc)
= -- Special case for array comprehensions
putSrcLocDs src_loc $
dsPArrComp stmts elt_ty
......@@ -542,7 +542,6 @@ dsExpr (DictApp expr dicts) -- becomes a curried application
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo"
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn"
......@@ -571,7 +570,7 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
-- For ExprStmt, see the comments near HsExpr.Stmt about
-- exactly what ExprStmts mean!
--
-- In dsDo we can only see DoStmt and ListComp (no gaurds)
-- In dsDo we can only see DoStmt and ListComp (no guards)
go [ResultStmt expr locn]
| is_do = do_expr expr locn
......@@ -607,7 +606,7 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
(HsLit (HsString (mkFastString msg)))
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts ids result_ty locn)
(HsDo do_or_lc stmts ids result_ty locn)
result_ty locn
the_matches
| failureFreePat pat = [main_match]
......
......@@ -90,13 +90,10 @@ data HsExpr id pat
| HsDo HsDoContext
[Stmt id pat] -- "do":one or more stmts
SrcLoc
| HsDoOut HsDoContext
[Stmt id pat] -- "do":one or more stmts
[id] -- ids for [return,fail,>>=,>>]
[id] -- Ids for [return,fail,>>=,>>]
-- Brutal but simple
Type -- Type of the whole expression
-- Before type checking, used for rebindable syntax
PostTcType -- Type of the whole expression
SrcLoc
| ExplicitList -- syntactic list
......@@ -310,8 +307,7 @@ 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 (HsDoOut 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)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.98 2002/05/27 15:28:08 simonpj Exp $
$Id: Parser.y,v 1.99 2002/06/05 14:39:28 simonpj Exp $
Haskell grammar.
......@@ -987,7 +987,7 @@ exp10 :: { RdrNameHsExpr }
| 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 }
| '-' fexp { mkHsNegApp $2 }
| srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts ->
returnP (HsDo DoExpr stmts $1) }
returnP (mkHsDo DoExpr stmts $1) }
| '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
| '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
......@@ -1071,9 +1071,9 @@ list :: { RdrNameHsExpr }
| exp srcloc pquals {% let { body [qs] = qs;
body qss = [ParStmt (map reverse qss)] }
in
returnP ( HsDo ListComp
(reverse (ResultStmt $1 $2 : body $3))
$2
returnP ( mkHsDo ListComp
(reverse (ResultStmt $1 $2 : body $3))
$2
)
}
......@@ -1113,10 +1113,10 @@ parr :: { RdrNameHsExpr }
(map reverse qss)]}
in
returnP $
HsDo PArrComp
(reverse (ResultStmt $1 $2
: body $3))
$2
mkHsDo PArrComp
(reverse (ResultStmt $1 $2
: body $3))
$2
}
-- We are reusing `lexps' and `pquals' from the list case.
......
......@@ -48,6 +48,7 @@ module RdrHsSyn (
mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
mkHsDo,
cvBinds,
cvMonoBindsAndSigs,
......@@ -61,12 +62,14 @@ module RdrHsSyn (
import HsSyn -- Lots of it
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
mkGenOcc2,
mkGenOcc2, mkVarOcc
)
import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName )
import PrelNames ( unboundKey )
import Name ( mkInternalName )
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
import List ( nub )
import BasicTypes ( RecFlag(..) )
import SrcLoc ( builtinSrcLoc )
import Class ( DefMeth (..) )
\end{code}
......@@ -241,7 +244,7 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
mkHsNegApp expr = NegApp expr negateName
mkHsNegApp expr = NegApp expr placeHolderName
\end{code}
A useful function for building @OpApps@. The operator is always a
......@@ -255,9 +258,14 @@ These are the bits of syntax that contain rebindable names
See RnEnv.lookupSyntaxName
\begin{code}
mkHsIntegral i = HsIntegral i fromIntegerName
mkHsFractional f = HsFractional f fromRationalName
mkNPlusKPat n k = NPlusKPatIn n k minusName
mkHsIntegral i = HsIntegral i placeHolderName
mkHsFractional f = HsFractional f placeHolderName
mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
placeHolderName = mkInternalName unboundKey
(mkVarOcc FSLIT("syntaxPlaceHolder"))
builtinSrcLoc
\end{code}
......
......@@ -608,11 +608,13 @@ At the moment this just happens for
* fromInteger, fromRational on literals (in expressions and patterns)
* negate (in expressions)
* minus (arising from n+k patterns)
* "do" notation
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
* NPlusKPatIn
* HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does.
......@@ -621,15 +623,18 @@ name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does.
lookupSyntaxName :: Name -- The standard name
-> RnMS Name -- Possibly a non-standard name
lookupSyntaxName std_name
= doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
= getModeRn `thenRn` \ mode ->
case mode of {
InterfaceMode -> returnRn std_name ; -- Happens for 'derived' code
-- where we don't want to rebind
other ->
doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
if not no_prelude then
returnRn std_name -- Normal case
else
let
rdr_name = mkRdrUnqual (nameOccName std_name)
-- Get the similarly named thing from the local environment
in
lookupOccRn rdr_name
lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
\end{code}
......
......@@ -39,7 +39,9 @@ import PrelNames ( hasKey, assertIdKey,
replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
zipPName, lengthPName, indexPName, toPName,
enumFromToPName, enumFromThenToPName )
enumFromToPName, enumFromThenToPName,
fromIntegerName, fromRationalName, minusName, negateName,
failMName, bindMName, thenMName, returnMName )
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon )
import TysWiredIn ( intTyCon )
......@@ -101,12 +103,12 @@ rnPat (NPatIn lit mb_neg)
fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
-- Needed to find equality on pattern
rnPat (NPlusKPatIn name lit minus)
rnPat (NPlusKPatIn name lit _)
= rnOverLit lit `thenRn` \ (lit', fvs) ->
lookupBndrRn name `thenRn` \ name' ->
lookupSyntaxName minus `thenRn` \ minus' ->
returnRn (NPlusKPatIn name' lit' minus',
fvs `addOneFV` ordClassName `addOneFV` minus')
lookupSyntaxName minusName `thenRn` \ minus ->
returnRn (NPlusKPatIn name' lit' minus,
fvs `addOneFV` ordClassName `addOneFV` minus)
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
......@@ -339,11 +341,11 @@ rnExpr (OpApp e1 op _ e2)
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
rnExpr (NegApp e neg_name)
rnExpr (NegApp e _)
= rnExpr e `thenRn` \ (e', fv_e) ->
lookupSyntaxName neg_name `thenRn` \ neg_name' ->
mkNegAppRn e' neg_name' `thenRn` \ final_e ->
returnRn (final_e, fv_e `addOneFV` neg_name')
lookupSyntaxName negateName `thenRn` \ neg_name ->
mkNegAppRn e' neg_name `thenRn` \ final_e ->
returnRn (final_e, fv_e `addOneFV` neg_name)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
......@@ -391,16 +393,27 @@ rnExpr (HsWith expr binds is_with)
rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
rnExpr e@(HsDo do_or_lc stmts src_loc)
rnExpr e@(HsDo do_or_lc stmts _ ty src_loc)
= pushSrcLocRn src_loc $
rnStmts stmts `thenRn` \ ((_, stmts'), fvs) ->
-- check the statement list ends in an expression
-- Check the statement list ends in an expression
case last stmts' of {
ResultStmt _ _ -> returnRn () ;
_ -> addErrRn (doStmtListErr e)
} `thenRn_`
returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
-- Generate the rebindable syntax for the monad
(case do_or_lc of
DoExpr -> mapRn lookupSyntaxName monad_names
other -> returnRn []
) `thenRn` \ monad_names' ->
returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
fvs `plusFV` implicit_fvs)
where
monad_names = [returnMName, failMName, bindMName, thenMName]
implicit_fvs = case do_or_lc of
PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
......@@ -845,10 +858,10 @@ litFVs (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName)
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
-- in post-typechecker translations
rnOverLit (HsIntegral i from_integer_name)
= lookupSyntaxName from_integer_name `thenRn` \ from_integer_name' ->
rnOverLit (HsIntegral i _)
= lookupSyntaxName fromIntegerName `thenRn` \ from_integer_name ->
if inIntRange i then
returnRn (HsIntegral i from_integer_name', unitFV from_integer_name')
returnRn (HsIntegral i from_integer_name, unitFV from_integer_name)
else let
fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
......@@ -857,10 +870,10 @@ rnOverLit (HsIntegral i from_integer_name)
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
in
returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name')
returnRn (HsIntegral i from_integer_name, fvs `addOneFV` from_integer_name)
rnOverLit (HsFractional i from_rat_name)
= lookupSyntaxName from_rat_name `thenRn` \ from_rat_name' ->
rnOverLit (HsFractional i _)
= lookupSyntaxName fromRationalName `thenRn` \ from_rat_name ->
let
fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
......@@ -871,7 +884,7 @@ rnOverLit (HsFractional i from_rat_name)
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
in
returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name')
returnRn (HsFractional i from_rat_name, fvs `addOneFV` from_rat_name)
\end{code}
%************************************************************************
......
......@@ -38,7 +38,7 @@ import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, mkFunTys,
isSigmaTy, mkFunTy, mkAppTy, mkFunTys,
mkTyConApp, mkClassPred, tcFunArgTy,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind, mkArrowKind,
......@@ -54,13 +54,13 @@ import Name ( Name )
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
import PrelNames ( cCallableClassName,
cReturnableClassName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
thenMName, bindMName, failMName, returnMName, ioTyConName
ioTyConName
)
import ListSetOps ( minusList )
import CmdLineOpts
......@@ -336,8 +336,8 @@ tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
\end{code}
\begin{code}
tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
= tcDoStmts do_or_lc stmts src_loc res_ty
tcMonoExpr expr@(HsDo do_or_lc stmts method_names _ src_loc) res_ty
= tcAddSrcLoc src_loc (tcDoStmts do_or_lc stmts method_names src_loc res_ty)
\end{code}
\begin{code}
......@@ -820,51 +820,30 @@ tcExpr_id expr = newHoleTyVarTy `thenNF_Tc` \ id_ty ->
%************************************************************************
\begin{code}
-- I don't like this lumping together of do expression and list/array
-- comprehensions; creating the monad instances is entirely pointless in the
-- latter case; I'll leave the list case as it is for the moment, but handle
-- arrays extra (would be better to handle arrays and lists together, though)
-- -=chak
--
tcDoStmts PArrComp stmts src_loc res_ty
=
ASSERT( notNull stmts )
tcAddSrcLoc src_loc $
unifyPArrTy res_ty `thenTc` \elt_ty ->
let tc_ty = mkTyConTy parrTyCon
m_ty = (mkPArrTy, elt_ty)
in
tcStmts (DoCtxt PArrComp) m_ty stmts `thenTc` \(stmts', stmts_lie) ->
returnTc (HsDoOut PArrComp stmts'
undefined -- don't touch!
res_ty src_loc,
tcDoStmts PArrComp stmts method_names src_loc res_ty
= unifyPArrTy res_ty `thenTc` \elt_ty ->
tcStmts (DoCtxt PArrComp)
(mkPArrTy, elt_ty) stmts `thenTc` \(stmts', stmts_lie) ->
returnTc (HsDo PArrComp stmts'
[] -- Unused
res_ty src_loc,
stmts_lie)
tcDoStmts do_or_lc stmts src_loc res_ty
= -- get the Monad and MonadZero classes
-- create type consisting of a fresh monad tyvar
ASSERT( notNull stmts )
tcAddSrcLoc src_loc $
-- If it's a comprehension we're dealing with,
-- force it to be a list comprehension.
-- (as of Haskell 98, monad comprehensions are no more.)
-- Similarily, array comprehensions must involve parallel arrays types
-- -=chak
(case do_or_lc of
ListComp -> unifyListTy res_ty `thenTc` \ elt_ty ->
returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
PArrComp -> panic "TcExpr.tcDoStmts: How did we get here?!?"
tcDoStmts ListComp stmts method_names src_loc res_ty
= unifyListTy res_ty `thenTc` \ elt_ty ->
tcStmts (DoCtxt ListComp)
(mkListTy, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
returnTc (HsDo ListComp stmts'
[] -- Unused
res_ty src_loc,
stmts_lie)
_ -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
) `thenNF_Tc` \ (tc_ty, m_ty) ->
tcDoStmts DoExpr stmts method_names src_loc res_ty
= newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ tc_ty ->
newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy tc_ty elt_ty) `thenTc_`
tcStmts (DoCtxt do_or_lc) m_ty stmts `thenTc` \ (stmts', stmts_lie) ->
tcStmts (DoCtxt DoExpr) (mkAppTy tc_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
......@@ -874,12 +853,11 @@ tcDoStmts do_or_lc stmts src_loc res_ty
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
--
mapNF_Tc (newMethodFromName DoOrigin tc_ty)
[returnMName, failMName, bindMName, thenMName] `thenNF_Tc` \ insts ->
mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names `thenNF_Tc` \ insts ->
returnTc (HsDoOut do_or_lc stmts'
(map instToId insts)
res_ty src_loc,
returnTc (HsDo DoExpr stmts'
(map instToId insts)
res_ty src_loc,
stmts_lie `plusLIE` mkLIE insts)
\end{code}
......
......@@ -31,8 +31,8 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
HsBinds(..), HsType(..), HsDoContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
import RdrName ( RdrName, mkUnqual )
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence
, Boxity(..)
......@@ -685,7 +685,7 @@ gen_Ix_binds tycon
single_con_range
= mk_easy_FunMonoBind tycon_loc range_RDR
[TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
HsDo ListComp stmts tycon_loc
mkHsDo ListComp stmts tycon_loc
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
++
......@@ -802,8 +802,8 @@ gen_Read_binds get_fixity tycon
read_nullary_cons
= case nullary_cons of
[] -> []
[con] -> [HsDo DoExpr [bindLex (ident_pat (data_con_str con)),
result_stmt con []] loc]
[con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
result_stmt con []] loc]
_ -> [HsApp (HsVar choose_RDR)
(ExplicitList placeHolderType (map mk_pair nullary_cons))]
......@@ -812,7 +812,7 @@ gen_Read_binds get_fixity tycon
Boxed
read_non_nullary_con data_con
= mkHsApps prec_RDR [mkHsIntLit prec, HsDo DoExpr stmts loc]
= mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
where
stmts | is_infix = infix_stmts
| length labels > 0 = lbl_stmts
......
......@@ -482,13 +482,11 @@ zonkExpr (HsWith expr binds is_with)
zonkExpr e `thenNF_Tc` \ e' ->
returnNF_Tc (n', e')
zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
zonkExpr (HsDoOut do_or_lc stmts ids ty src_loc)
zonkExpr (HsDo do_or_lc stmts ids ty src_loc)
= zonkStmts stmts `thenNF_Tc` \ new_stmts ->
zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkIdOcc ids `thenNF_Tc` \ new_ids ->
returnNF_Tc (HsDoOut do_or_lc new_stmts new_ids new_ty src_loc)
returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
zonkExpr (ExplicitList ty exprs)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
......
......@@ -39,7 +39,7 @@ import BasicTypes ( RecFlag(..) )
import VarSet
import Var ( Id )
import Bag
import Util ( isSingleton, lengthExceeds )
import Util ( isSingleton, lengthExceeds, notNull )
import Outputable
import List ( nub )
......@@ -338,7 +338,8 @@ group. But that's fine; there's no shadowing to worry about.
\begin{code}
tcStmts do_or_lc m_ty stmts
= tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
= ASSERT( notNull stmts )
tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
tcStmtsAndThen
:: (TcStmt -> thing -> thing) -- Combiner
......
......@@ -213,8 +213,8 @@ tc_stmts names stmts
traceTc (text "tcs 4") `thenNF_Tc_`
returnTc (mkHsLet const_binds $
HsDoOut DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
HsDo DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
ids)
where
combine stmt (ids, stmts) = (ids, stmt:stmts)
......
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