#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}
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
\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
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
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
- DefaultDecl(..), HsGroup(..),
+ DefaultDecl(..), HsGroup(..), SpliceDecl(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), CoreDecl(..),
| 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
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,
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}
(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}
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
-- 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
= 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.
| '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 }
| '_' { 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] }
\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
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
(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
-- 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) ->
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))
#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 ->
%************************************************************************
\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))
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 ->
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)
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)
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 ->
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) (
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
)
-- 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 {
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 {
projects / ghc-hetmet.git / commitdiff