Commit aadb64aa authored by simonpj's avatar simonpj

[project @ 2002-10-09 16:53:10 by simonpj]

Fix to mdo, plus SrcLocs on splices and brackets
parent 316f8291
......@@ -550,7 +550,7 @@ Here is where we desugar the Template Haskell brackets and escapes
#ifdef GHCI /* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
dsExpr (HsSplice n e) = pprPanic "dsExpr:splice" (ppr e)
dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
#endif
\end{code}
......@@ -636,10 +636,10 @@ dsDo do_or_lc stmts ids result_ty
returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
go (RecStmt rec_vars rec_stmts : stmts)
go (RecStmt rec_vars rec_stmts rec_rets : stmts)
= go (bind_stmt : stmts)
where
bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts
bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
in
go stmts
......@@ -658,19 +658,21 @@ We turn (RecStmt [v1,..vn] stmts) into:
\begin{code}
dsRecStmt :: Type -- Monad type constructor :: * -> *
-> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
-> [Id] -> [TypecheckedStmt] -- Guts of the RecStmt
-> [Id] -> [TypecheckedStmt] -> [TypecheckedHsExpr] -- Guts of the RecStmt
-> TypecheckedStmt
dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts
= BindStmt tup_pat mfix_app noSrcLoc
dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
= ASSERT( length vars == length rets )
BindStmt tup_pat mfix_app noSrcLoc
where
(var1:rest) = vars -- Always at least one
(ret1:_) = rets
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_expr | one_var = ret1
| otherwise = ExplicitTuple rets Boxed
tup_ty | one_var = idType var1
| otherwise = mkTupleTy Boxed (length vars) (map idType vars)
tup_pat | one_var = VarPat var1
......
......@@ -284,7 +284,7 @@ repE (HsIPVar x) = panic "Can't represent implicit parameters"
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsSplice n e)
repE (HsSplice n e loc)
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
......
......@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..), HsGroup(..),
DefaultDecl(..), HsGroup(..), SpliceDecl(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), CoreDecl(..),
......@@ -74,7 +74,7 @@ data HsDecl id
| DeprecD (DeprecDecl id)
| RuleD (RuleDecl id)
| CoreD (CoreDecl id)
| SpliceD (HsExpr id) -- Top level splice
| SpliceD (SpliceDecl id)
-- NB: all top-level fixity decls are contained EITHER
-- EITHER SigDs
......@@ -125,7 +125,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
ppr (CoreD dd) = ppr dd
ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e)
ppr (SpliceD dd) = ppr dd
instance OutputableBndr name => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls,
......@@ -145,6 +145,11 @@ instance OutputableBndr name => Outputable (HsGroup name) where
where
ppr_ds [] = empty
ppr_ds ds = text "" $$ vcat (map ppr ds)
data SpliceDecl id = SpliceDecl (HsExpr id) SrcLoc -- Top level splice
instance OutputableBndr name => Outputable (SpliceDecl name) where
ppr (SpliceDecl e _) = ptext SLIT("$") <> parens (pprExpr e)
\end{code}
......
......@@ -164,13 +164,13 @@ data HsExpr id
(HsExpr id) -- expr whose cost is to be measured
-- MetaHaskell Extensions
| HsBracket (HsBracket id)
| HsBracket (HsBracket id) SrcLoc
| HsBracketOut (HsBracket Name) -- Output of the type checker is the *original*
[PendingSplice] -- renamed expression, plus *typechecked* splices
-- to be pasted back in by the desugarer
| HsSplice id (HsExpr id ) -- $z or $(f 4)
| HsSplice id (HsExpr id) SrcLoc -- $z or $(f 4)
-- The id is just a unique name to
-- identify this splice point
\end{code}
......@@ -389,8 +389,8 @@ ppr_expr (DictApp expr dnames)
ppr_expr (HsType id) = ppr id
ppr_expr (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsSplice n e _) = char '$' <> brackets (ppr n) <> pprParendExpr e
ppr_expr (HsBracket b _) = pprHsBracket b
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
-- add parallel array brackets around a document
......@@ -585,8 +585,13 @@ data Stmt id
-- 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]
| RecStmt [id]
[Stmt id]
[HsExpr id] -- Post type-checking only; these expressions correspond
-- 1-to-1 with the [id], and are the expresions that should
-- be returned by the recursion. They may not quite be the
-- Ids themselves, because the Id may be polymorphic, but
-- the returned thing has to be monomorphic.
\end{code}
ExprStmts and ResultStmts are a bit tricky, because what they mean
......@@ -644,7 +649,7 @@ 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)
pprStmt (RecStmt _ segment _) = vcat (map ppr segment)
pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.106 2002/10/09 15:03:53 simonpj Exp $
$Id: Parser.y,v 1.107 2002/10/09 16:53:11 simonpj Exp $
Haskell grammar.
......@@ -415,7 +415,7 @@ topdecl :: { RdrBinding }
| 'foreign' fdecl { RdrHsDecl $2 }
| '{-# DEPRECATED' deprecations '#-}' { RdrBindings $2 }
| '{-# RULES' rules '#-}' { RdrBindings $2 }
| '$(' exp ')' { RdrHsDecl (SpliceD $2) }
| srcloc '$(' exp ')' { RdrHsDecl (SpliceD (SpliceDecl $3 $1)) }
| decl { $1 }
tycl_decl :: { RdrNameTyClDecl }
......@@ -1000,13 +1000,13 @@ aexp2 :: { RdrNameHsExpr }
| '_' { EWildPat }
-- MetaHaskell Extension
| ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $1))} -- $x
| '$(' exp ')' { mkHsSplice $2 } -- $( exp )
| '[|' exp '|]' { HsBracket (ExpBr $2) }
| '[t|' ctype '|]' { HsBracket (TypBr $2) }
| '[p|' srcloc infixexp '|]' {% checkPattern $2 $3 `thenP` \p ->
returnP (HsBracket (PatBr p)) }
| '[d|' cvtopdecls '|]' { HsBracket (DecBr (mkGroup $2)) }
| srcloc ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x
| srcloc '$(' exp ')' { mkHsSplice $3 $1 } -- $( exp )
| srcloc '[|' exp '|]' { HsBracket (ExpBr $3) $1 }
| srcloc '[t|' ctype '|]' { HsBracket (TypBr $3) $1 }
| srcloc '[p|' infixexp '|]' {% checkPattern $1 $3 `thenP` \p ->
returnP (HsBracket (PatBr p) $1) }
| srcloc '[d|' cvtopdecls '|]' { HsBracket (DecBr (mkGroup $3)) $1 }
texps :: { [RdrNameHsExpr] }
......
......@@ -281,7 +281,7 @@ mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
\end{code}
\begin{code}
mkHsSplice e = HsSplice unqualSplice e
mkHsSplice e loc = HsSplice unqualSplice e loc
unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
-- A name (uniquified later) to
......@@ -418,7 +418,7 @@ emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
hs_fixds = [], hs_defds = [], hs_fords = [],
hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
findSplice :: [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
findSplice ds = add emptyGroup ds
mkGroup :: [HsDecl a] -> HsGroup a
......@@ -430,7 +430,7 @@ addImpDecls group decls = case add group decls of
(group', Nothing) -> group'
other -> panic "addImpDecls"
add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
-- This stuff reverses the declarations (again) but it doesn't matter
-- Base cases
......
......@@ -228,20 +228,21 @@ rnExpr (HsPar e)
-- Template Haskell extensions
#ifdef GHCI
rnExpr (HsBracket br_body)
= checkGHCI (thErr "bracket") `thenM_`
rnExpr (HsBracket br_body loc)
= addSrcLoc loc $
checkGHCI (thErr "bracket") `thenM_`
rnBracket br_body `thenM` \ (body', fvs_e) ->
returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
-- We use the Q tycon as a proxy to haul in all the smart
-- constructors; see the hack in RnIfaces
#endif
rnExpr (HsSplice n e)
= checkGHCI (thErr "splice") `thenM_`
getSrcLocM `thenM` \ loc ->
rnExpr (HsSplice n e loc)
= addSrcLoc loc $
checkGHCI (thErr "splice") `thenM_`
newLocalsRn [(n,loc)] `thenM` \ [n'] ->
rnExpr e `thenM` \ (e', fvs_e) ->
returnM (HsSplice n' e', fvs_e)
returnM (HsSplice n' e' loc, fvs_e)
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
......@@ -724,7 +725,7 @@ segsToStmts ((defs, uses, fwds, ss) : segs)
where
(later_stmts, later_uses) = segsToStmts segs
new_stmt | non_rec = head ss
| otherwise = RecStmt rec_names ss
| otherwise = RecStmt rec_names ss []
where
non_rec = isSingleton ss && isEmptyNameSet fwds
rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
......
......@@ -621,10 +621,11 @@ tcMonoExpr (PArrSeqIn _) _
#ifdef GHCI /* Only if bootstrapped */
-- Rename excludes these cases otherwise
tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
tcMonoExpr (HsBracket brack) res_ty
= getStage `thenM` \ level ->
tcMonoExpr (HsBracket brack loc) res_ty
= addSrcLoc loc $
getStage `thenM` \ level ->
case bracketOK level of {
Nothing -> failWithTc (illegalBracket level) ;
Just next_level ->
......
......@@ -413,7 +413,11 @@ zonkGRHSs env (GRHSs grhss binds ty)
%************************************************************************
\begin{code}
zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
zonkExprs env exprs = mappM (zonkExpr env) exprs
zonkExpr env (HsVar id)
= returnM (HsVar (zonkIdOcc env id))
......@@ -450,8 +454,8 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
returnM (n,e')
zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
returnM (HsSplice n e)
zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
returnM (HsSplice n e loc)
zonkExpr env (OpApp e1 op fixity e2)
= zonkExpr env e1 `thenM` \ new_e1 ->
......@@ -513,16 +517,16 @@ zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitList new_ty new_exprs)
zonkExpr env (ExplicitPArr ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
zonkExpr env (ExplicitTuple exprs boxed)
= mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
= zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitTuple new_exprs boxed)
zonkExpr env (RecordConOut data_con con_expr rbinds)
......@@ -554,7 +558,7 @@ zonkExpr env (PArrSeqOut expr info)
returnM (PArrSeqOut new_expr new_info)
zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
= mappM (zonkExpr env) args `thenM` \ new_args ->
= zonkExprs env args `thenM` \ new_args ->
zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
......@@ -629,14 +633,15 @@ zonkStmts env (ParStmtOut bndrstmtss : stmts)
where
(bndrss, stmtss) = unzip bndrstmtss
zonkStmts env (RecStmt vs segStmts : stmts)
zonkStmts env (RecStmt vs segStmts rets : stmts)
= mappM zonkId vs `thenM` \ new_vs ->
let
env1 = extendZonkEnv env new_vs
in
zonkStmts env1 segStmts `thenM` \ new_segStmts ->
zonkExprs env1 rets `thenM` \ new_rets ->
zonkStmts env1 stmts `thenM` \ new_stmts ->
returnM (RecStmt new_vs new_segStmts : new_stmts)
returnM (RecStmt new_vs new_segStmts new_rets : new_stmts)
zonkStmts env (ResultStmt expr locn : stmts)
= zonkExpr env expr `thenM` \ new_expr ->
......
......@@ -458,23 +458,28 @@ tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
combine_par stmt (stmts, thing) = (stmt:stmts, thing)
-- RecStmt
tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts) thing_inside
tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
= newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
tcExtendLocalValEnv (zipWith mkLocalId recNames recTys) $
tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
tcLookupLocalIds recNames `thenM` \ rn ->
returnM ([], rn)
) `thenM` \ (stmts', recNames') ->
) `thenM` \ (stmts', recIds) ->
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
unifyTauTyLists recTys (map idType recNames') `thenM_`
mappM tc_ret (recIds `zip` recTys) `thenM` \ rets' ->
thing_inside `thenM` \ thing ->
returnM (combine (RecStmt recNames' stmts') thing)
returnM (combine (RecStmt recIds stmts' rets') thing)
where
combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
tc_ret (rec_id, rec_ty)
= tcSubExp rec_ty (idType rec_id) `thenM` \ co_fn ->
returnM (co_fn <$> HsVar rec_id)
-- ExprStmt
tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
= addErrCtxt (stmtCtxt do_or_lc stmt) (
......
......@@ -22,7 +22,7 @@ import {-# SOURCE #-} TcSplice( tcSpliceDecls )
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
HsGroup(..),
HsGroup(..), SpliceDecl(..),
mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
isSrcRule, collectStmtsBinders
)
......@@ -597,7 +597,7 @@ tcRnSrcDecls ds
-- If there is no splice, we're done
case group_tail of
Nothing -> return (tcg_env, src_fvs1)
Just (splice_expr, rest_ds) -> do {
Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
setGblEnv tcg_env $ do {
......@@ -605,7 +605,9 @@ tcRnSrcDecls ds
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
(rn_splice_expr, fvs) <- initRn SourceMode $
addSrcLoc splice_loc $
rnExpr splice_expr ;
tcg_env <- importSupportingDecls fvs ;
setGblEnv tcg_env $ do {
......
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