-- 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
#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"
-- 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
(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]
| 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
= 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.
| '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 }
| 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 $
- 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.
mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
+ mkHsDo,
cvBinds,
cvMonoBindsAndSigs,
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}
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
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}
* 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.
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}
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 )
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) ->
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) ->
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,
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 *,
-- 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
-- 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}
%************************************************************************
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,
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
\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}
%************************************************************************
\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,
-- 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}
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(..)
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
++
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))]
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
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 ->
import VarSet
import Var ( Id )
import Bag
-import Util ( isSingleton, lengthExceeds )
+import Util ( isSingleton, lengthExceeds, notNull )
import Outputable
import List ( nub )
\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
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)
projects / ghc-hetmet.git / commitdiff