---------------------------------------
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.
-- 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.
--
-- 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
= -- 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
= 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
= -- Special case for array comprehensions
putSrcLocDs src_loc $
dsPArrComp stmts elt_ty
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
#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"
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn"
-- For ExprStmt, see the comments near HsExpr.Stmt about
-- exactly what ExprStmts mean!
--
-- 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
go [ResultStmt expr locn]
| is_do = do_expr expr locn
(HsLit (HsString (mkFastString msg)))
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(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]
result_ty locn
the_matches
| failureFreePat pat = [main_match]
| HsDo HsDoContext
[Stmt id pat] -- "do":one or more stmts
| 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,>>=,>>]
- Type -- Type of the whole expression
+ -- Before type checking, used for rebindable syntax
+ PostTcType -- Type of the whole expression
SrcLoc
| ExplicitList -- syntactic list
SrcLoc
| ExplicitList -- syntactic list
= sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)]
= 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)))
ppr_expr (ExplicitList _ exprs)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
{- -*-haskell-*-
-----------------------------------------------------------------------------
{- -*-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 $
| 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 }
| '-' fexp { mkHsNegApp $2 }
| srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts ->
| '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 }
| '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
| '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
| exp srcloc pquals {% let { body [qs] = qs;
body qss = [ParStmt (map reverse qss)] }
in
| 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
(map reverse qss)]}
in
returnP $
(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.
}
-- We are reusing `lexps' and `pquals' from the list case.
mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
cvBinds,
cvMonoBindsAndSigs,
cvBinds,
cvMonoBindsAndSigs,
import HsSyn -- Lots of it
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
import HsSyn -- Lots of it
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
-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 RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
import List ( nub )
import BasicTypes ( RecFlag(..) )
+import SrcLoc ( builtinSrcLoc )
import Class ( DefMeth (..) )
\end{code}
import Class ( DefMeth (..) )
\end{code}
mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
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
\end{code}
A useful function for building @OpApps@. The operator is always a
See RnEnv.lookupSyntaxName
\begin{code}
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
* fromInteger, fromRational on literals (in expressions and patterns)
* negate (in expressions)
* minus (arising from n+k patterns)
* fromInteger, fromRational on literals (in expressions and patterns)
* negate (in expressions)
* minus (arising from n+k patterns)
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
* NPlusKPatIn
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
* NPlusKPatIn
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.
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.
lookupSyntaxName :: Name -- The standard name
-> RnMS Name -- Possibly a non-standard name
lookupSyntaxName std_name
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
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
-- Get the similarly named thing from the local environment
- in
- lookupOccRn rdr_name
+ lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
zipPName, lengthPName, indexPName, toPName,
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 )
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon )
import TysWiredIn ( intTyCon )
fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
-- Needed to find equality on pattern
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' ->
= 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) ->
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
-rnExpr (NegApp e neg_name)
= rnExpr e `thenRn` \ (e', fv_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) ->
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
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) ->
= 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_`
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)
+ monad_names = [returnMName, failMName, bindMName, thenMName]
+
implicit_fvs = case do_or_lc of
PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
implicit_fvs = case do_or_lc of
PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
-- in post-typechecker translations
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 ->
- 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 *,
else let
fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
in
-- 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
let
fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
in
-- 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}
%************************************************************************
\end{code}
%************************************************************************
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
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,
mkTyConApp, mkClassPred, tcFunArgTy,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind, mkArrowKind,
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
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,
import PrelNames ( cCallableClassName,
cReturnableClassName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- thenMName, bindMName, failMName, returnMName, ioTyConName
)
import ListSetOps ( minusList )
import CmdLineOpts
)
import ListSetOps ( minusList )
import CmdLineOpts
-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)
%************************************************************************
\begin{code}
%************************************************************************
\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,
-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,
-- 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,
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
--
-- 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}
stmts_lie `plusLIE` mkLIE insts)
\end{code}
HsBinds(..), HsType(..), HsDoContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
HsBinds(..), HsType(..), HsDoContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
-import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
import RdrName ( RdrName, mkUnqual )
import RdrName ( RdrName, mkUnqual )
+import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence
, Boxity(..)
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence
, Boxity(..)
single_con_range
= mk_easy_FunMonoBind tycon_loc range_RDR
[TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
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
++
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
++
read_nullary_cons
= case nullary_cons of
[] -> []
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))]
_ -> [HsApp (HsVar choose_RDR)
(ExplicitList placeHolderType (map mk_pair nullary_cons))]
Boxed
read_non_nullary_con data_con
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
where
stmts | is_infix = infix_stmts
| length labels > 0 = lbl_stmts
zonkExpr e `thenNF_Tc` \ e' ->
returnNF_Tc (n', e')
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 ->
= 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 ->
zonkExpr (ExplicitList ty exprs)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
import VarSet
import Var ( Id )
import Bag
import VarSet
import Var ( Id )
import Bag
-import Util ( isSingleton, lengthExceeds )
+import Util ( isSingleton, lengthExceeds, notNull )
import Outputable
import List ( nub )
import Outputable
import List ( nub )
\begin{code}
tcStmts do_or_lc m_ty stmts
\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
tcStmtsAndThen
:: (TcStmt -> thing -> thing) -- Combiner
traceTc (text "tcs 4") `thenNF_Tc_`
returnTc (mkHsLet const_binds $
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)
ids)
where
combine stmt (ids, stmts) = (ids, stmt:stmts)
projects / ghc-hetmet.git / commitdiff