Commit dbc254c3 authored by simonpj's avatar simonpj

[project @ 2002-09-27 08:20:43 by simonpj]

--------------------------------
        Implement recursive do-notation
	--------------------------------

This commit adds recursive do-notation, which Hugs has had for some time.

	mdo { x <- foo y ;
	      y <- baz x ;
	      return (y,x) }

turns into

	do { (x,y) <- mfix (\~(x,y) -> do { x <- foo y;
					    y <- baz x }) ;
	     return (y,x) }

This is all based on work by Levent Erkok and John Lanuchbury.

The really tricky bit is in the renamer (RnExpr.rnMDoStmts) where
we break things up into minimal segments.  The rest is easy, including
the type checker.

Levent laid the groundwork, and Simon finished it off. Needless to say,
I couldn't resist tidying up other stuff, so there's no guaranteed I
have not broken something.
parent b7cc3d01
......@@ -10,6 +10,7 @@ module NameSet (
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
intersectsNameSet, intersectNameSet,
-- Free variables
FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV,
......@@ -46,6 +47,9 @@ delFromNameSet :: NameSet -> Name -> NameSet
delListFromNameSet :: NameSet -> [Name] -> NameSet
foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
intersectNameSet :: NameSet -> NameSet -> NameSet
intersectsNameSet :: NameSet -> NameSet -> Bool -- True if non-empty intersection
-- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty
isEmptyNameSet = isEmptyUniqSet
emptyNameSet = emptyUniqSet
......@@ -61,8 +65,11 @@ nameSetToList = uniqSetToList
delFromNameSet = delOneFromUniqSet
foldNameSet = foldUniqSet
filterNameSet = filterUniqSet
intersectNameSet = intersectUniqSets
delListFromNameSet set ns = foldl delFromNameSet set ns
intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
\end{code}
......
......@@ -19,7 +19,7 @@ import CoreSyn
import DsMonad
import CoreUtils ( exprType, mkCoerce2 )
import Id ( Id, mkWildId, idType )
import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
......@@ -29,14 +29,12 @@ import ForeignCall ( ForeignCall, CCallTarget(..) )
import TcType ( tcSplitTyConApp_maybe )
import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
tyVarsOfType, mkForAllTys, mkTyConApp,
isPrimitiveType, eqType,
splitTyConApp_maybe, splitNewType_maybe
isPrimitiveType, splitTyConApp_maybe, splitNewType_maybe
)
import PrimOp ( PrimOp(..) )
import TysPrim ( realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
intPrimTy, foreignObjPrimTy
import TysPrim ( realWorldStatePrimTy, intPrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon
)
import TyCon ( TyCon, tyConDataCons )
import TysWiredIn ( unitDataConId,
......
......@@ -25,9 +25,9 @@ import DsMeta ( dsBracket )
import HsSyn ( failureFreePat,
HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
Stmt(..), HsMatchContext(..), HsDoContext(..),
Stmt(..), HsMatchContext(..), HsStmtContext(..),
Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
mkSimpleMatch
mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType )
......@@ -37,7 +37,8 @@ import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatT
-- Sigh. This is a pain.
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs,
tcSplitTyConApp, isUnLiftedType, Type )
tcSplitTyConApp, isUnLiftedType, Type,
mkAppTy )
import Type ( splitFunTys )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
......@@ -49,9 +50,10 @@ import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
import TyCon ( tyConDataCons )
import TysWiredIn ( tupleCon )
import TysWiredIn ( tupleCon, mkTupleTy )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
import PrelNames ( toPName )
import SrcLoc ( noSrcLoc )
import Util ( zipEqual, zipWithEqual )
import Outputable
import FastString
......@@ -274,9 +276,10 @@ dsExpr (HsDo ListComp stmts _ result_ty src_loc)
where
(_, [elt_ty]) = tcSplitTyConApp result_ty
dsExpr (HsDo DoExpr stmts ids result_ty src_loc)
dsExpr (HsDo do_or_lc stmts ids result_ty src_loc)
| isDoExpr do_or_lc
= putSrcLocDs src_loc $
dsDo DoExpr stmts ids result_ty
dsDo do_or_lc stmts ids result_ty
dsExpr (HsDo PArrComp stmts _ result_ty src_loc)
= -- Special case for array comprehensions
......@@ -568,18 +571,17 @@ dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn"
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
dsDo :: HsDoContext
dsDo :: HsStmtContext
-> [TypecheckedStmt]
-> [Id] -- id for: [return,fail,>>=,>>]
-> [Id] -- id for: [return,fail,>>=,>>] and possibly mfixName
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
dsDo do_or_lc stmts ids result_ty
= let
(_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
is_do = case do_or_lc of
DoExpr -> True
_ -> False
(return_id : fail_id : bind_id : then_id : _) = ids
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
is_do = isDoExpr do_or_lc -- True for both MDo and Do
-- For ExprStmt, see the comments near HsExpr.Stmt about
-- exactly what ExprStmts mean!
......@@ -629,12 +631,55 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
, mkSimpleMatch [WildPat a_ty] fail_expr result_ty locn
]
in
matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
matchWrapper (StmtCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
go (RecStmt rec_vars rec_stmts : stmts)
= go (bind_stmt : stmts)
where
bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts
in
go stmts
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
\end{code}
Translation for RecStmt's:
-----------------------------
We turn (RecStmt [v1,..vn] stmts) into:
(v1,..,vn) <- mfix (\~(v1,..vn). do stmts
return (v1,..vn))
\begin{code}
dsRecStmt :: Type -- Monad type constructor :: * -> *
-> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
-> [Id] -> [TypecheckedStmt] -- Guts of the RecStmt
-> TypecheckedStmt
dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts
= BindStmt tup_pat mfix_app noSrcLoc
where
(var1:rest) = vars -- Always at least one
one_var = null rest
mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
tup_expr | one_var = HsVar var1
| otherwise = ExplicitTuple (map HsVar vars) Boxed
tup_ty | one_var = idType var1
| otherwise = mkTupleTy Boxed (length vars) (map idType vars)
tup_pat | one_var = VarPat var1
| otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
body = HsDo DoExpr (stmts ++ [return_stmt])
ids -- Don't need the mfix, but it does no harm
(mkAppTy m_ty tup_ty)
noSrcLoc
return_stmt = ResultStmt return_app noSrcLoc
return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr
\end{code}
......@@ -13,7 +13,7 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import BasicTypes ( Boxity(..) )
import TyCon ( tyConName )
import HsSyn ( Pat(..), HsExpr(..), Stmt(..),
HsMatchContext(..), HsDoContext(..),
HsMatchContext(..), HsStmtContext(..),
collectHsBinders )
import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
hsPatType )
......@@ -202,7 +202,7 @@ deBindComp pat core_list1 quals core_list2
letrec_body = App (Var h) core_list1
in
deListComp quals core_fail `thenDs` \ rest_expr ->
matchSimply (Var u2) (DoCtxt ListComp) pat
matchSimply (Var u2) (StmtCtxt ListComp) pat
rest_expr core_fail `thenDs` \ core_match ->
let
rhs = Lam u1 $
......@@ -315,7 +315,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
dfListComp c_id b quals `thenDs` \ core_rest ->
-- build the pattern match
matchSimply (Var x) (DoCtxt ListComp)
matchSimply (Var x) (StmtCtxt ListComp)
pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
......@@ -395,7 +395,7 @@ dePArrComp (BindStmt p e _ : qs) pa cea =
true = Var trueId
in
newSysLocalDs ty'ce `thenDs` \v ->
matchSimply (Var v) (DoCtxt PArrComp) p true false `thenDs` \pred ->
matchSimply (Var v) (StmtCtxt PArrComp) p true false `thenDs` \pred ->
let cef = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce]
ty'cef = ty'ce -- filterP preserves the type
pa' = TuplePat [pa, p] Boxed
......@@ -421,7 +421,7 @@ dePArrComp (LetStmt ds : qs) pa cea =
errMsg = "DsListComp.dePArrComp: internal error!"
in
mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
matchSimply (Var v) (DoCtxt PArrComp) pa projBody cerr `thenDs` \ccase ->
matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr `thenDs` \ccase ->
let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
proj = mkLams [v] ccase
in
......@@ -459,7 +459,7 @@ deLambda ty p e =
errMsg = "DsListComp.deLambda: internal error!"
in
mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
matchSimply (Var v) (DoCtxt PArrComp) p ce cerr `thenDs` \res ->
matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res ->
returnDs (mkLams [v] res, errTy)
-- obtain the element type of the parallel array produced by the given Core
......
......@@ -20,12 +20,12 @@ import qualified Language.Haskell.THSyntax as M
import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
Match(..), GRHSs(..), GRHS(..), HsBracket(..),
HsDoContext(ListComp,DoExpr), ArithSeqInfo(..),
HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
HsBinds(..), MonoBinds(..), HsConDetails(..),
HsDecl(..), TyClDecl(..), ForeignDecl(..),
PendingSplice,
placeHolderType, tyClDeclNames,
collectHsBinders, collectMonoBinders,
collectHsBinders,
collectPatBinders, collectPatsBinders
)
......
......@@ -14,7 +14,7 @@ import Language.Haskell.THSyntax as Meta
import HsSyn as Hs
( HsExpr(..), HsLit(..), ArithSeqInfo(..),
HsDoContext(..),
HsStmtContext(..),
Match(..), GRHSs(..), GRHS(..), HsPred(..),
HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
......
......@@ -269,18 +269,18 @@ data Sig name
\begin{code}
okBindSig :: NameSet -> Sig Name -> Bool
okBindSig ns (ClassOpSig _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig
okBindSig ns (ClassOpSig _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool
okClsDclSig ns (Sig _ _ _) = False
okClsDclSig ns sig = sigForThisGroup ns sig
okClsDclSig ns (Sig _ _ _) = False
okClsDclSig ns sig = sigForThisGroup ns sig
okInstDclSig :: NameSet -> Sig Name -> Bool
okInstDclSig ns (Sig _ _ _) = False
okInstDclSig ns (FixSig _) = False
okInstDclSig ns (SpecInstSig _ _) = True
okInstDclSig ns sig = sigForThisGroup ns sig
okInstDclSig ns (Sig _ _ _) = False
okInstDclSig ns (FixSig _) = False
okInstDclSig ns (SpecInstSig _ _) = True
okInstDclSig ns sig = sigForThisGroup ns sig
sigForThisGroup ns sig
= case sigName sig of
......
......@@ -88,7 +88,7 @@ data HsExpr id
Bool -- True <=> this was a 'with' binding
-- (tmp, until 'with' is removed)
| HsDo HsDoContext
| HsDo HsStmtContext
[Stmt id] -- "do":one or more stmts
[id] -- Ids for [return,fail,>>=,>>]
-- Brutal but simple
......@@ -572,9 +572,18 @@ data Stmt id
| ResultStmt (HsExpr id) SrcLoc -- See notes that follow
| ExprStmt (HsExpr id) PostTcType SrcLoc -- See notes that follow
-- The type is the *element type* of the expression
| ParStmt [[Stmt id]] -- List comp only: parallel set of quals
| ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
-- bound by the stmts
-- ParStmts only occur in a list comprehension
| ParStmt [[Stmt id]] -- List comp only: parallel set of quals
| ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
-- bound by the stmts
-- mdo-notation (only exists after renamer)
-- The ids are a subset of the variables bound by the stmts that
-- either (a) are used before they are bound in the stmts
-- or (b) are used in stmts that follow the RecStmt
| RecStmt [id]
[Stmt id]
\end{code}
ExprStmts and ResultStmts are a bit tricky, because what they mean
......@@ -632,9 +641,11 @@ pprStmt (ParStmt stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (ParStmtOut stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (RecStmt _ segment) = vcat (map ppr segment)
pprDo :: OutputableBndr id => HsDoContext -> [Stmt id] -> SDoc
pprDo :: OutputableBndr id => HsStmtContext -> [Stmt id] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
pprDo MDoExpr stmts = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts))
pprDo ListComp stmts = pprComp brackets stmts
pprDo PArrComp stmts = pprComp pa_brackets stmts
......@@ -711,7 +722,7 @@ pp_dotdot = ptext SLIT(" .. ")
\begin{code}
data HsMatchContext id -- Context of a Match or Stmt
= DoCtxt HsDoContext -- Do-stmt or list comprehension
= StmtCtxt HsStmtContext -- Do-stmt or list comprehension
| FunRhs id -- Function binding for f
| CaseAlt -- Guard on a case alternative
| LambdaExpr -- Lambda
......@@ -719,14 +730,18 @@ data HsMatchContext id -- Context of a Match or Stmt
| RecUpd -- Record update
deriving ()
data HsDoContext = ListComp
| DoExpr
| PArrComp -- parallel array comprehension
data HsStmtContext
= ListComp
| DoExpr
| MDoExpr -- recursive do-expression
| PArrComp -- parallel array comprehension
| PatGuard -- Never occurs in an HsDo expression, of course
\end{code}
\begin{code}
isDoExpr (DoCtxt DoExpr) = True
isDoExpr other = False
isDoExpr DoExpr = True
isDoExpr MDoExpr = True
isDoExpr other = False
\end{code}
\begin{code}
......@@ -734,7 +749,7 @@ matchSeparator (FunRhs _) = ptext SLIT("=")
matchSeparator CaseAlt = ptext SLIT("->")
matchSeparator LambdaExpr = ptext SLIT("->")
matchSeparator PatBindRhs = ptext SLIT("=")
matchSeparator (DoCtxt _) = ptext SLIT("<-")
matchSeparator (StmtCtxt _) = ptext SLIT("<-")
matchSeparator RecUpd = panic "When is this used?"
\end{code}
......@@ -744,19 +759,23 @@ pprMatchContext CaseAlt = ptext SLIT("In a case alternative")
pprMatchContext RecUpd = ptext SLIT("In a record-update construct")
pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding")
pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction")
pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding")
pprMatchContext (DoCtxt ListComp) =
ptext SLIT("In a 'list comprehension' pattern binding")
pprMatchContext (DoCtxt PArrComp) =
ptext SLIT("In an 'array comprehension' pattern binding")
pprMatchContext (StmtCtxt ctxt) = pprStmtCtxt ctxt
pprStmtCtxt PatGuard = ptext SLIT("In a pattern guard")
pprStmtCtxt DoExpr = ptext SLIT("In a 'do' expression pattern binding")
pprStmtCtxt MDoExpr = ptext SLIT("In an 'mdo' expression pattern binding")
pprStmtCtxt ListComp = ptext SLIT("In a 'list comprehension' pattern binding")
pprStmtCtxt PArrComp = ptext SLIT("In an 'array comprehension' pattern binding")
-- 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 (DoCtxt DoExpr) = "'do' expression"
matchContextErrString (DoCtxt ListComp) = "list comprehension"
matchContextErrString (DoCtxt PArrComp) = "array comprehension"
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"
\end{code}
......@@ -25,7 +25,7 @@ module HsSyn (
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromMonoBinds,
collectSigTysFromHsBinds, collectSigTysFromMonoBinds,
hsModule, hsImports
) where
......@@ -151,15 +151,16 @@ collectMonoBinders binds
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
%************************************************************************
%* *
\subsection{Getting patterns out of bindings}
%* *
%************************************************************************
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
collectSigTysFromHsBinds :: HsBinds name -> [HsType name]
collectSigTysFromHsBinds EmptyBinds = []
collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b
collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++
collectSigTysFromHsBinds b2
collectSigTysFromMonoBinds :: MonoBinds name -> [HsType name]
collectSigTysFromMonoBinds bind
= go bind []
......@@ -177,3 +178,16 @@ collectSigTysFromMonoBinds bind
go_matches (match : matches) acc = go_matches matches acc
\end{code}
\begin{code}
collectStmtsBinders :: [Stmt id] -> [id]
collectStmtsBinders = concatMap collectStmtBinders
collectStmtBinders :: Stmt id -> [id]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt pat _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectHsBinders binds
collectStmtBinders (ExprStmt _ _ _) = []
collectStmtBinders (ResultStmt _ _) = []
collectStmtBinders other = panic "collectStmtBinders"
\end{code}
......@@ -38,7 +38,7 @@ import HscTypes ( VersionInfo(..), ModIface(..), HomeModInfo(..),
import CmdLineOpts
import Id ( idType, idInfo, isImplicitId, idCgInfo )
import DataCon ( dataConWorkId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..), IdCoreRule )
import CoreFVs ( ruleLhsFreeNames )
......
......@@ -123,6 +123,7 @@ data Token
| ITccallconv
| ITdotnet
| ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc)
| ITmdo
| ITspecialise_prag -- Pragmas
| ITsource_prag
......@@ -276,6 +277,7 @@ isSpecial ITunsafe = True
isSpecial ITwith = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
isSpecial _ = False
-- the bitmap provided as the third component indicates whether the
......@@ -296,6 +298,7 @@ ghcExtensionKeywordsFM = listToUFM $
( "threadsafe", ITthreadsafe, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
( "with", ITwith, bit withBit),
( "mdo", ITmdo, bit glaExtsBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
......
......@@ -33,6 +33,7 @@ module ParseUtil (
, checkPattern -- HsExp -> P HsPat
, checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
, checkDo -- [Stmt] -> P [Stmt]
, checkMDo -- [Stmt] -> P [Stmt]
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
) where
......@@ -177,12 +178,16 @@ checkDictTy _ _ = parseError "Malformed context in instance header"
-- as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
-- (b) transforms it to a ResultStmt
-- same comments apply for mdo as well
checkDo [] = parseError "Empty 'do' construct"
checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
returnP (s:ss')
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
returnP (s:ss')
---------------------------------------------------------------------------
-- Checking Patterns.
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.104 2002/09/25 12:47:42 simonmar Exp $
$Id: Parser.y,v 1.105 2002/09/27 08:20:45 simonpj Exp $
Haskell grammar.
......@@ -126,6 +126,7 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
'threadsafe' { ITthreadsafe }
'unsafe' { ITunsafe }
'with' { ITwith }
'mdo' { ITmdo }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'dotnet' { ITdotnet }
......@@ -999,6 +1000,8 @@ exp10 :: { RdrNameHsExpr }
| '-' fexp { mkHsNegApp $2 }
| srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts ->
returnP (mkHsDo DoExpr stmts $1) }
| srcloc 'mdo' stmtlist {% checkMDo $3 `thenP` \ stmts ->
returnP (mkHsDo MDoExpr stmts $1) }
| '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
| '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
......
......@@ -33,7 +33,7 @@ import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
import Name ( nameOccName )
import RdrName ( mkRdrUnqual, getRdrName )
import HsSyn ( HsTyVarBndr(..), TyClDecl(..), HsType(..) )
import HsSyn ( HsTyVarBndr(..) )
import OccName ( mkVarOcc )
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
......
......@@ -203,6 +203,9 @@ knownKeyNames
thenMName, bindMName, returnMName, failMName,
thenIOName, bindIOName, returnIOName, failIOName,
-- MonadRec stuff
mfixName,
-- Ix stuff
ixClassName,
......@@ -335,7 +338,7 @@ lEX_Name = mkModuleName "Text.Read.Lex"
mAIN_Name = mkModuleName "Main"
pREL_INT_Name = mkModuleName "GHC.Int"
pREL_WORD_Name = mkModuleName "GHC.Word"
mONAD_FIX_Name = mkModuleName "Control.Monad.Fix"
aDDR_Name = mkModuleName "Addr"
gLA_EXTS_Name = mkModuleName "GHC.Exts"
......@@ -353,6 +356,7 @@ pREL_REAL = mkPrelModule pREL_REAL_Name
pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
pRELUDE = mkPrelModule pRELUDE_Name
iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive")
-- MetaHaskell Extension text2 from Meta/work/gen.hs
......@@ -806,6 +810,9 @@ runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey
-- The "split" Id for splittable implicit parameters
splitName = varQual gLA_EXTS_Name FSLIT("split") splitIdKey
-- Recursive-do notation
mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey
\end{code}
%************************************************************************
......@@ -1179,6 +1186,9 @@ valIdKey = mkPreludeMiscIdUnique 159
protoIdKey = mkPreludeMiscIdUnique 160
matchIdKey = mkPreludeMiscIdUnique 161
clauseIdKey = mkPreludeMiscIdUnique 162
-- Recursive do notation
mfixIdKey = mkPreludeMiscIdUnique 163
\end{code}
......
......@@ -10,33 +10,31 @@ they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
module RnBinds (
rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
renameSigs, renameSigsFVs, unknownSigErr
rnTopMonoBinds, rnMonoBinds, rnMonoBindsAndThen,
rnMethodBinds, renameSigs, checkSigs, unknownSigErr
) where
#include "HsVersions.h"
import HsSyn
import HsBinds ( eqHsSig, sigName, hsSigDoc )
import HsBinds ( eqHsSig, hsSigDoc )
import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnHsType )
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnTypes ( rnHsSigType, rnHsType, rnPat )
import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
lookupSigOccRn, bindPatSigTyVars, bindLocalFixities,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import CmdLineOpts ( DynFlag(..) )
import Digraph ( stronglyConnComp, SCC(..) )
import Digraph ( SCC(..), stronglyConnComp )
import Name ( Name, nameOccName, nameSrcLoc )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..), FixitySig(..) )
import List ( partition )
import BasicTypes ( RecFlag(..) )
import Outputable
import PrelNames ( isUnboundName )
\end{code}