From aadb64aa5644f2a3ad8a645e2c7a1e72c2f61e53 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 9 Oct 2002 16:53:13 +0000 Subject: [PATCH] [project @ 2002-10-09 16:53:10 by simonpj] Fix to mdo, plus SrcLocs on splices and brackets --- ghc/compiler/deSugar/DsExpr.lhs | 18 ++++++++++-------- ghc/compiler/deSugar/DsMeta.hs | 2 +- ghc/compiler/hsSyn/HsDecls.lhs | 11 ++++++++--- ghc/compiler/hsSyn/HsExpr.lhs | 17 +++++++++++------ ghc/compiler/parser/Parser.y | 18 +++++++++--------- ghc/compiler/parser/RdrHsSyn.lhs | 6 +++--- ghc/compiler/rename/RnExpr.lhs | 17 +++++++++-------- ghc/compiler/typecheck/TcExpr.lhs | 7 ++++--- ghc/compiler/typecheck/TcHsSyn.lhs | 23 ++++++++++++++--------- ghc/compiler/typecheck/TcMatches.lhs | 13 +++++++++---- ghc/compiler/typecheck/TcRnDriver.lhs | 8 +++++--- 11 files changed, 83 insertions(+), 57 deletions(-) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 8818229..c17a292 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 1899ff3..8571e1e 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 4bda850..5c806a6 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -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} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index e295905..0ff1823 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -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)) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index f90e595..ea68bb3 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-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] } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 51bf7dd..756dfc1 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 2b9ba9d..798c568 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -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)) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index c3dde2f..b38d28b 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -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 -> diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 251c7ad..386f4eb 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -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 -> diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 91d5aef..a1a5758 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -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) ( diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index ae5a12e..6e146f4 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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 { -- 1.7.10.4