From: simonpj Date: Wed, 5 Jun 2002 14:39:31 +0000 (+0000) Subject: [project @ 2002-06-05 14:39:27 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1986 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b2f644fa8edcf8697640c9228089b39030b8b362;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index e379d26..a207c4d 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -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] diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index fa81775..703a0ac 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -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))) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 6c0fccb..c98b2dd 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-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. diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 6b0e63c..6f8bd63 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -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} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 3f4ca43..ae63657 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -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} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 40ed626..fd08c0f 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -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} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index e6a3d85..c5e33f3 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 50adfd6..4636cde 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index b6d31e5..3fda515 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -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 -> diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index f8f2f4b..abf79d0 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 6b76101..6f31598 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -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)