Commit 8ecf6d8f authored by Simon Marlow's avatar Simon Marlow

ApplicativeDo transformation

Summary:
This is an implementation of the ApplicativeDo proposal.  See the Note
[ApplicativeDo] in RnExpr for details on the current implementation,
and the wiki page https://ghc.haskell.org/trac/ghc/wiki/ApplicativeDo
for design notes.

Test Plan: validate

Reviewers: simonpj, goldfire, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D729
parent 43eb1dc5
......@@ -22,10 +22,6 @@ module MkCore (
-- * Constructing equality evidence boxes
mkEqBox,
-- * Constructing general big tuples
-- $big_tuples
mkChunkified,
-- * Constructing small tuples
mkCoreVarTup, mkCoreVarTupTy, mkCoreTup,
......@@ -67,6 +63,7 @@ import HscTypes
import TysWiredIn
import PrelNames
import HsUtils ( mkChunkified, chunkify )
import TcType ( mkSigmaTy )
import Type
import Coercion
......@@ -82,7 +79,6 @@ import UniqSupply
import BasicTypes
import Util
import Pair
import Constants
import DynFlags
import Data.Char ( ord )
......@@ -319,47 +315,6 @@ mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ p
************************************************************************
-}
-- $big_tuples
-- #big_tuples#
--
-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
-- we might concievably want to build such a massive tuple as part of the
-- output of a desugaring stage (notably that for list comprehensions).
--
-- We call tuples above this size \"big tuples\", and emulate them by
-- creating and pattern matching on >nested< tuples that are expressible
-- by GHC.
--
-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
-- construction to be big.
--
-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
-- and 'mkTupleCase' functions to do all your work with tuples you should be
-- fine, and not have to worry about the arity limitation at all.
-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
-> [a] -- ^ Possible \"big\" list of things to construct from
-> a -- ^ Constructed thing made possible by recursive decomposition
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
where
-- Each sub-list is short enough to fit in a tuple
mk_big_tuple [as] = small_tuple as
mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
chunkify :: [a] -> [[a]]
-- ^ Split a list into lists that are small enough to have a corresponding
-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
chunkify xs
| n_xs <= mAX_TUPLE_SIZE = [xs]
| otherwise = split xs
where
n_xs = length xs
split [] = []
split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
{-
Creating tuples and their types for Core expressions
......
......@@ -3,7 +3,7 @@
(c) University of Glasgow, 2007
-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP, NondecreasingIndentation #-}
module Coverage (addTicksToBinds, hpcInitCode) where
......@@ -660,9 +660,10 @@ addTickLStmts' isGuard lstmts res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt
addTickStmt _isGuard (LastStmt e noret ret) = do
liftM3 LastStmt
(addTickLHsExpr e)
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
......@@ -684,6 +685,9 @@ addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
(mapM (addTickStmtAndBinders isGuard) pairs)
(addTickSyntaxExpr hpcSrcSpan mzipExpr)
(addTickSyntaxExpr hpcSrcSpan bindExpr)
addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
args' <- mapM (addTickApplicativeArg isGuard) args
return (ApplicativeStmt args' mb_join body_ty)
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
, trS_by = by, trS_using = using
......@@ -710,6 +714,20 @@ addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickApplicativeArg
:: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)
-> TM (SyntaxExpr Id, ApplicativeArg Id Id)
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
addTickArg (ApplicativeArgOne pat expr) =
ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr
addTickArg (ApplicativeArgMany stmts ret pat) =
ApplicativeArgMany
<$> addTickLStmts isGuard stmts
<*> addTickSyntaxExpr hpcSrcSpan ret
<*> addTickLPat pat
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
-> TM (ParStmtBlock Id Id)
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
......@@ -872,9 +890,10 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
(addTickLHsCmd c)
(return bind)
(return fail)
addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt
addTickCmdStmt (LastStmt c noret ret) = do
liftM3 LastStmt
(addTickLHsCmd c)
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (BodyStmt c bind' guard' ty) = do
liftM4 BodyStmt
......@@ -892,6 +911,8 @@ addTickCmdStmt stmt@(RecStmt {})
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickCmdStmt ApplicativeStmt{} =
panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-- Others should never happen in a command context.
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
......
......@@ -18,6 +18,7 @@ import DsMonad
import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
import TcHsSyn
import qualified HsUtils
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
......@@ -694,7 +695,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
--
-- ---> premap (\ (xs) -> ((xs), ())) c
dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do
dsCmdDo ids local_vars res_ty [L _ (LastStmt body _ _)] env_ids = do
(core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
let env_ty = mkBigCoreVarTupTy env_ids
env_var <- newSysLocalDs env_ty
......@@ -1167,11 +1168,5 @@ collectLStmtBinders :: LStmt Id body -> [Id]
collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: Stmt Id body -> [Id]
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
$ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
......@@ -33,6 +33,7 @@ import TcType
import Coercion ( Role(..) )
import TcEvidence
import TcRnMonad
import TcHsSyn
import Type
import CoreSyn
import CoreUtils
......@@ -819,7 +820,7 @@ dsDo stmts
goL [] = panic "dsDo"
goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
go _ (LastStmt body _) stmts
go _ (LastStmt body _ _) stmts
= ASSERT( null stmts ) dsLExpr body
-- The 'return' op isn't used for 'do' expressions
......@@ -846,13 +847,45 @@ dsDo stmts
; match_code <- handle_failure pat match fail_op
; return (mkApps bind_op' [rhs', Lam var match_code]) }
go _ (ApplicativeStmt args mb_join body_ty) stmts
= do {
let
(pats, rhss) = unzip (map (do_arg . snd) args)
do_arg (ApplicativeArgOne pat expr) =
(pat, dsLExpr expr)
do_arg (ApplicativeArgMany stmts ret pat) =
(pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
arg_tys = map hsLPatType pats
; rhss' <- sequence rhss
; ops' <- mapM dsExpr (map fst args)
; let body' = noLoc $ HsDo DoExpr stmts body_ty
; let fun = L noSrcSpan $ HsLam $
MG { mg_alts = [mkSimpleMatch pats body']
, mg_arg_tys = arg_tys
, mg_res_ty = body_ty
, mg_origin = Generated }
; fun' <- dsLExpr fun
; let mk_ap_call l (op,r) = mkApps op [l,r]
expr = foldl mk_ap_call fun' (zip ops' rhss')
; case mb_join of
Nothing -> return expr
Just join_op ->
do { join_op' <- dsExpr join_op
; return (App join_op' expr) } }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
, recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
= goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
where
new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
......@@ -865,9 +898,9 @@ dsDo stmts
mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTupId rets)
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
-- which ignores the return_op in the LastStmt,
......
......@@ -123,6 +123,8 @@ matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)
......
......@@ -81,7 +81,7 @@ dsListComp lquals res_ty = do
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)
dsInnerListComp (ParStmtBlock stmts bndrs _)
= do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
= do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)])
(mkListTy bndrs_tuple_type)
; return (expr, bndrs_tuple_type) }
where
......@@ -133,7 +133,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
-- Build a pattern that ensures the consumer binds into the NEW binders,
-- which hold lists rather than single values
let pat = mkBigLHsVarPatTup to_bndrs
let pat = mkBigLHsVarPatTupId to_bndrs
return (bound_unzipped_inner_list_expr, pat)
dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
......@@ -208,7 +208,7 @@ deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
deListComp [] _ = panic "deListComp"
deListComp (LastStmt body _ : quals) list
deListComp (LastStmt body _ _ : quals) list
= -- Figure 7.4, SLPJ, p 135, rule C above
ASSERT( null quals )
do { core_body <- dsLExpr body
......@@ -246,11 +246,14 @@ deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list
bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTup pats
pats = map mkBigLHsVarPatTup bndrs_s
pat = mkBigLHsPatTupId pats
pats = map mkBigLHsVarPatTupId bndrs_s
deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
deListComp (ApplicativeStmt {} : _) _ =
panic "deListComp ApplicativeStmt"
deBindComp :: OutPat Id
-> CoreExpr
-> [ExprStmt Id]
......@@ -312,7 +315,7 @@ dfListComp :: Id -> Id -- 'c' and 'n'
dfListComp _ _ [] = panic "dfListComp"
dfListComp c_id n_id (LastStmt body _ : quals)
dfListComp c_id n_id (LastStmt body _ _ : quals)
= ASSERT( null quals )
do { core_body <- dsLExpr body
; return (mkApps (Var c_id) [core_body, Var n_id]) }
......@@ -342,6 +345,8 @@ dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfListComp _ _ (ApplicativeStmt {} : _) =
panic "dfListComp ApplicativeStmt"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
......@@ -510,7 +515,7 @@ dePArrComp [] _ _ = panic "dePArrComp"
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
dePArrComp (LastStmt e' _ : quals) pa cea
dePArrComp (LastStmt e' _ _ : quals) pa cea
= ASSERT( null quals )
do { mapP <- dsDPHBuiltin mapPVar
; let ty = parrElemType cea
......@@ -589,6 +594,8 @@ dePArrComp (ParStmt {} : _) _ _ =
panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
dePArrComp (ApplicativeStmt {} : _) _ _ =
panic "DsListComp.dePArrComp: ApplicativeStmt"
-- <<[:e' | qs | qss:]>> pa ea =
-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
......@@ -666,7 +673,7 @@ dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
dsMcStmt (LastStmt body ret_op) stmts
dsMcStmt (LastStmt body _ ret_op) stmts
= ASSERT( null stmts )
do { body' <- dsLExpr body
; ret_op' <- dsExpr ret_op
......@@ -761,7 +768,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest
; mzip_op' <- dsExpr mzip_op
; let -- The pattern variables
pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks]
pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
-- Pattern with tuples of variables
-- [v1,v2,v3] => (v1, (v2, v3))
pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
......@@ -834,7 +841,7 @@ dsInnerMonadComp :: [ExprLStmt Id]
-> HsExpr Id -- The monomorphic "return" operator
-> DsM CoreExpr
dsInnerMonadComp stmts bndrs ret_op
= dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])
= dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
-- The `unzip` function for `GroupStmt` in a monad comprehensions
--
......
......@@ -1279,7 +1279,7 @@ repSts (ParStmt stmt_blocks _ _ : ss) =
do { (ss1, zs) <- repSts (map unLoc stmts)
; zs1 <- coreList stmtQTyConName zs
; return (ss1, zs1) }
repSts [LastStmt e _]
repSts [LastStmt e _ _]
= do { e2 <- repLE e
; z <- repNoBindSt e2
; return ([], [z]) }
......
......@@ -30,7 +30,7 @@ module DsUtils (
-- LHs tuples
mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
mkSelectorBinds,
......@@ -717,18 +717,18 @@ mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsVarTupId :: [Id] -> LHsExpr Id
mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
mkBigLHsTup = mkChunkified mkLHsTupleExpr
mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id
mkBigLHsTupId = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [Id] -> LPat Id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsVarPatTupId :: [Id] -> LPat Id
mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
mkBigLHsPatTup :: [LPat Id] -> LPat Id
mkBigLHsPatTup = mkChunkified mkLHsPatTup
mkBigLHsPatTupId :: [LPat Id] -> LPat Id
mkBigLHsPatTupId = mkChunkified mkLHsPatTup
{-
************************************************************************
......
......@@ -39,6 +39,7 @@ import Type
-- libraries:
import Data.Data hiding (Fixity)
import Data.Maybe (isNothing)
{-
************************************************************************
......@@ -1266,12 +1267,15 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
= LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp,
-- and (after the renamer) DoExpr, MDoExpr
-- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff
body
(SyntaxExpr idR) -- The return operator, used only for MonadComp
-- For ListComp, PArrComp, we use the baked-in 'return'
-- For DoExpr, MDoExpr, we don't apply a 'return' at all
-- See Note [Monad Comprehensions]
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
body
Bool -- True <=> return was stripped by ApplicativeDo
(SyntaxExpr idR) -- The return operator, used only for
-- MonadComp For ListComp, PArrComp, we
-- use the baked-in 'return' For DoExpr,
-- MDoExpr, we don't apply a 'return' at
-- all See Note [Monad Comprehensions] |
-- - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnLarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| BindStmt (LPat idL)
......@@ -1281,6 +1285,20 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
-- | 'ApplicativeStmt' represents an applicative expression built with
-- <$> and <*>. It is generated by the renamer, and is desugared into the
-- appropriate applicative expression by the desugarer, but it is intended
-- to be invisible in error messages.
--
-- For full details, see Note [ApplicativeDo] in RnExpr
--
| ApplicativeStmt
[ ( SyntaxExpr idR
, ApplicativeArg idL idR) ]
-- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
(Maybe (SyntaxExpr idR)) -- 'join', if necessary
(PostTc idR Type) -- Type of the body
| BodyStmt body -- See Note [BodyStmt]
(SyntaxExpr idR) -- The (>>) operator
(SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
......@@ -1375,6 +1393,17 @@ data ParStmtBlock idL idR
deriving( Typeable )
deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
data ApplicativeArg idL idR
= ApplicativeArgOne -- pat <- expr (pat must be irrefutable)
(LPat idL)
(LHsExpr idL)
| ApplicativeArgMany -- do { stmts; return vars }
[ExprLStmt idL] -- stmts
(SyntaxExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
(LPat idL) -- (v1,...,vn)
deriving( Typeable )
deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
{-
Note [The type of bind in Stmts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1520,9 +1549,12 @@ instance (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> Outputable (StmtLR idL idR body) where
ppr stmt = pprStmt stmt
pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
pprStmt :: forall idL idR body . (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> (StmtLR idL idR body) -> SDoc
pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
pprStmt (LastStmt expr ret_stripped _)
= ifPprDebug (ptext (sLit "[last]")) <+>
(if ret_stripped then ptext (sLit "return") else empty) <+>
ppr expr
pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
pprStmt (BodyStmt expr _ _ _) = ppr expr
......@@ -1538,6 +1570,45 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
, ptext (sLit "later_ids=") <> ppr later_ids])]
pprStmt (ApplicativeStmt args mb_join _)
= getPprStyle $ \style ->
if userStyle style
then pp_for_user
else pp_debug
where
-- make all the Applicative stuff invisible in error messages by
-- flattening the whole ApplicativeStmt nest back to a sequence
-- of statements.
pp_for_user = vcat $ punctuate semi $ concatMap flattenArg args
-- ppr directly rather than transforming here, becuase we need to
-- inject a "return" which is hard when we're polymorphic in the id
-- type.
flattenStmt :: ExprLStmt idL -> [SDoc]
flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
flattenArg (_, ApplicativeArgOne pat expr) =
[ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL)]
flattenArg (_, ApplicativeArgMany stmts _ _) =
concatMap flattenStmt stmts
pp_debug =
let
ap_expr = sep (punctuate (ptext (sLit " |")) (map pp_arg args))
in
if isNothing mb_join
then ap_expr
else ptext (sLit "join") <+> parens ap_expr
pp_arg (_, ApplicativeArgOne pat expr) =
ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL)
pp_arg (_, ApplicativeArgMany stmts return pat) =
ppr pat <+>
ptext (sLit "<-") <+>
ppr (HsDo DoExpr (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])
(error "pprStmt"))
pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc
pprTransformStmt bndrs using by
= sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs))
......@@ -1577,7 +1648,7 @@ pprComp :: (OutputableBndr id, Outputable body)
=> [LStmt id body] -> SDoc
pprComp quals -- Prints: body | qual1, ..., qualn
| not (null quals)
, L _ (LastStmt body _) <- last quals
, L _ (LastStmt body _ _) <- last quals
= hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals))
| otherwise
= pprPanic "pprComp" (pprQuals quals)
......@@ -1962,7 +2033,7 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <>
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsStmtContext idL -> StmtLR idL idR body -> SDoc
pprStmtInCtxt ctxt (LastStmt e _)
pprStmtInCtxt ctxt (LastStmt e _ _)
| isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
= hang (ptext (sLit "In the expression:")) 2 (ppr e)
......
......@@ -32,8 +32,13 @@ module HsUtils(
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
toHsType, toHsKind,
-- * Constructing general big tuples
-- $big_tuples
mkChunkified, chunkify,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind,
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
mkPatSynBind,
-- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
......@@ -42,6 +47,7 @@ module HsUtils(
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat,
nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
-- Types
mkHsAppTy, userHsTyVarBndrs,
......@@ -99,6 +105,7 @@ import FastString
import Util
import Bag
import Outputable
import Constants
import Data.Either
import Data.Function
......@@ -254,7 +261,7 @@ mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = s
mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
mkLastStmt body = LastStmt body noSyntaxExpr
mkLastStmt body = LastStmt body False noSyntaxExpr
mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
......@@ -425,6 +432,66 @@ nlTuplePat pats box = noLoc (TuplePat pats box [])
missingTupArg :: HsTupArg RdrName
missingTupArg = Missing placeHolderType
mkLHsPatTup :: [LPat id] -> LPat id
mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [id] -> LHsExpr id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
mkBigLHsTup = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [id] -> LPat id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsPatTup :: [LPat id] -> LPat id
mkBigLHsPatTup = mkChunkified mkLHsPatTup
-- $big_tuples
-- #big_tuples#
--
-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
-- we might concievably want to build such a massive tuple as part of the
-- output of a desugaring stage (notably that for list comprehensions).
--
-- We call tuples above this size \"big tuples\", and emulate them by
-- creating and pattern matching on >nested< tuples that are expressible
-- by GHC.
--
-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
-- construction to be big.
--
-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
-- and 'mkTupleCase' functions to do all your work with tuples you should be
-- fine, and not have to worry about the arity limitation at all.
-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
-> [a] -- ^ Possible \"big\" list of things to construct from
-> a -- ^ Constructed thing made possible by recursive decomposition
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
where
-- Each sub-list is short enough to fit in a tuple
mk_big_tuple [as] = small_tuple as
mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
chunkify :: [a] -> [[a]]
-- ^ Split a list into lists that are small enough to have a corresponding
-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
chunkify xs
| n_xs <= mAX_TUPLE_SIZE = [xs]
| otherwise = split xs
where
n_xs = length xs
split [] = []
split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
{-
************************************************************************
* *
......@@ -670,6 +737,7 @@ collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
$ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
collectStmtBinders ApplicativeStmt{} = []
----------------- Patterns --------------------------
......@@ -877,7 +945,11 @@ lStmtsImplicits = hs_lstmts
hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet
hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
hs_stmt (LetStmt binds) = hs_local_binds binds
hs_stmt (BodyStmt {}) = emptyNameSet
hs_stmt (LastStmt {}) = emptyNameSet
......
......@@ -602,6 +602,7 @@ data ExtensionFlag
| Opt_PolyKinds -- Kind polymorphism
| Opt_DataKinds -- Datatype promotion
| Opt_InstanceSigs
| Opt_ApplicativeDo
| Opt_StandaloneDeriving
| Opt_DeriveDataTypeable
......@@ -3158,6 +3159,7 @@ xFlags = [
flagSpec' "IncoherentInstances" Opt_IncoherentInstances
setIncoherentInsts,
flagSpec "InstanceSigs" Opt_InstanceSigs,
flagSpec "ApplicativeDo" Opt_ApplicativeDo,
flagSpec "InterruptibleFFI" Opt_InterruptibleFFI,
flagSpec "JavaScriptFFI" Opt_JavaScriptFFI,
flagSpec "KindSignatures" Opt_KindSignatures,
......
......@@ -1119,8 +1119,8 @@ checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)