Commit 67cb4091 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Implement generalised list comprehensions

  This patch implements generalised list comprehensions, as described in 
  the paper "Comprehensive comprehensions" (Peyton Jones & Wadler, Haskell
  Workshop 2007).  If you don't use the new comprehensions, nothing
  should change.
  
  The syntax is not exactly as in the paper; see the user manual entry 
  for details.
  
  You need an accompanying patch to the base library for this stuff 
  to work.
  
  The patch is the work of Max Bolingbroke [batterseapower@hotmail.com], 
  with some advice from Simon PJ.
  
  The related GHC Wiki page is 
    http://hackage.haskell.org/trac/ghc/wiki/SQLLikeComprehensions 
parent fe784e7d
......@@ -65,7 +65,7 @@ addCoverageTicksToBinds
:: DynFlags
-> Module
-> ModLocation -- of the current module
-> [TyCon] -- type constructor in this module
-> [TyCon] -- type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
......@@ -442,23 +442,34 @@ addTickStmt isGuard (BindStmt pat e bind fail) = do
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' ty) = do
liftM3 ExprStmt
(addTick e)
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(return ty)
where
addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprAlways e
addTickStmt isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs) = do
liftM ParStmt (mapM process pairs)
where
process (stmts,ids) =
liftM2 (,)
(addTickLStmts isGuard stmts)
(return ids)
liftM ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
liftM3 TransformStmt
(addTickStmtAndBinders isGuard (stmts, ids))
(addTickLHsExprAlways usingExpr)
(addTickMaybeByLHsExpr maybeByExpr)
addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
liftM2 GroupStmt
(addTickStmtAndBinders isGuard (stmts, binderMap))
(case groupByClause of
GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
byExpr' <- addTickLHsExprAlways byExpr
return $ GroupBySomething eitherUsingExpr' byExpr')
where
mapEitherM f g x = do
case x of
Left a -> f a >>= (return . Left)
Right b -> g b >>= (return . Right)
addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
liftM5 RecStmt
(addTickLStmts isGuard stmts)
......@@ -467,6 +478,20 @@ addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
(return tys)
(addTickDictBinds dictbinds)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprAlways e
addTickStmtAndBinders isGuard (stmts, ids) =
liftM2 (,)
(addTickLStmts isGuard stmts)
(return ids)
addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
addTickMaybeByLHsExpr maybeByExpr =
case maybeByExpr of
Nothing -> return Nothing
Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
......
......@@ -164,7 +164,7 @@ with s1 being the "top", the first one to be matched with a lambda.
\begin{code}
envStackType :: [Id] -> [Type] -> Type
envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
envStackType ids stack_tys = foldl mkCorePairTy (mkBigCoreVarTupTy ids) stack_tys
----------------------------------------------
-- buildEnvStack
......@@ -173,7 +173,7 @@ envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
buildEnvStack :: [Id] -> [Id] -> CoreExpr
buildEnvStack env_ids stack_ids
= foldl mkCorePairExpr (mkTupleExpr env_ids) (map Var stack_ids)
= foldl mkCorePairExpr (mkBigCoreVarTup env_ids) (map Var stack_ids)
----------------------------------------------
-- matchEnvStack
......@@ -193,7 +193,7 @@ matchEnvStack :: [Id] -- x1..xn
-> DsM CoreExpr
matchEnvStack env_ids stack_ids body
= newUniqueSupply `thenDs` \ uniqs ->
newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
newSysLocalDs (mkBigCoreVarTupTy env_ids) `thenDs` \ tup_var ->
matchVarStack tup_var stack_ids
(coreCaseTuple uniqs tup_var env_ids body)
......@@ -257,11 +257,11 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
dsfixCmd meth_ids locals [] cmd_ty cmd
`thenDs` \ (core_cmd, free_vars, env_ids) ->
let
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
selectSimpleMatchVarL pat `thenDs` \ var ->
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
matchSimply (Var var) ProcExpr pat (mkBigCoreVarTup env_ids) fail_expr
`thenDs` \ match_code ->
let
pat_ty = hsLPatType pat
......@@ -303,7 +303,7 @@ dsCmd ids local_vars env_ids stack res_ty
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
......@@ -331,7 +331,7 @@ dsCmd ids local_vars env_ids stack res_ty
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
......@@ -587,7 +587,7 @@ dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
= let
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
dsLExpr op `thenDs` \ core_op ->
mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
......@@ -683,8 +683,8 @@ dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
dsCmdLStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
(mkTupleType env_ids)
(mkTupleType env_ids')
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids')
res_ty
core_stmt
core_stmts,
......@@ -721,12 +721,12 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
= dsfixCmd ids local_vars [] c_ty cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
matchEnvStack env_ids []
(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
`thenDs` \ core_mux ->
let
in_ty = mkTupleType env_ids
in_ty1 = mkTupleType env_ids1
out_ty = mkTupleType out_ids
in_ty = mkBigCoreVarTupTy env_ids
in_ty1 = mkBigCoreVarTupTy env_ids1
out_ty = mkBigCoreVarTupTy out_ids
before_c_ty = mkCorePairTy in_ty1 out_ty
after_c_ty = mkCorePairTy c_ty out_ty
in
......@@ -756,14 +756,14 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
pat_ty = hsLPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
env_ty2 = mkTupleType env_ids2
env_ty2 = mkBigCoreVarTupTy env_ids2
in
-- multiplexing function
-- \ (xs) -> ((xs1),(xs2))
matchEnvStack env_ids []
(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup env_ids2))
`thenDs` \ core_mux ->
-- projection function
......@@ -773,8 +773,8 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
newUniqueSupply `thenDs` \ uniqs ->
let
after_c_ty = mkCorePairTy pat_ty env_ty2
out_ty = mkTupleType out_ids
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
out_ty = mkBigCoreVarTupTy out_ids
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
in
mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
selectSimpleMatchVarL pat `thenDs` \ pat_id ->
......@@ -787,9 +787,9 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
-- put it all together
let
in_ty = mkTupleType env_ids
in_ty1 = mkTupleType env_ids1
in_ty2 = mkTupleType env_ids2
in_ty = mkBigCoreVarTupTy env_ids
in_ty1 = mkBigCoreVarTupTy env_ids1
in_ty2 = mkBigCoreVarTupTy env_ids2
before_c_ty = mkCorePairTy in_ty1 in_ty2
in
returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
......@@ -806,12 +806,12 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
-- build a new environment using the let bindings
= dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
= dsLocalBinds binds (mkBigCoreVarTup out_ids) `thenDs` \ core_binds ->
-- match the old environment against the input
matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
returnDs (do_arr ids
(mkTupleType env_ids)
(mkTupleType out_ids)
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy out_ids)
core_map,
exprFreeVars core_binds `intersectVarSet` local_vars)
......@@ -833,7 +833,7 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
= let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
env2_ty = mkTupleType env2_ids
env2_ty = mkBigCoreVarTupTy env2_ids
in
-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
......@@ -841,9 +841,9 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
newUniqueSupply `thenDs` \ uniqs ->
newSysLocalDs env2_ty `thenDs` \ env2_id ->
let
later_ty = mkTupleType later_ids
later_ty = mkBigCoreVarTupTy later_ids
post_pair_ty = mkCorePairTy later_ty env2_ty
post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
in
matchEnvStack later_ids [env2_id] post_loop_body
`thenDs` \ post_loop_fn ->
......@@ -856,10 +856,10 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
-- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
let
env1_ty = mkTupleType env1_ids
env1_ty = mkBigCoreVarTupTy env1_ids
pre_pair_ty = mkCorePairTy env1_ty env2_ty
pre_loop_body = mkCorePairExpr (mkTupleExpr env1_ids)
(mkTupleExpr env2_ids)
pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
(mkBigCoreVarTup env2_ids)
in
matchEnvStack env_ids [] pre_loop_body
......@@ -868,8 +868,8 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
-- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
let
env_ty = mkTupleType env_ids
out_ty = mkTupleType out_ids
env_ty = mkBigCoreVarTupTy env_ids
out_ty = mkBigCoreVarTupTy out_ids
core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
pre_loop_fn
(do_compose ids pre_pair_ty post_pair_ty out_ty
......@@ -888,7 +888,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
= let
rec_id_set = mkVarSet rec_ids
out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
out_ty = mkTupleType out_ids
out_ty = mkBigCoreVarTupTy out_ids
local_vars' = local_vars `unionVarSet` rec_id_set
in
......@@ -896,10 +896,10 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
mappM dsExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
later_ty = mkTupleType later_ids
later_tuple = mkBigCoreVarTup later_ids
later_ty = mkBigCoreVarTupTy later_ids
rec_tuple = mkBigCoreTup core_rhss
rec_ty = mkTupleType rec_ids
rec_ty = mkBigCoreVarTupTy rec_ids
out_pair = mkCorePairExpr later_tuple rec_tuple
out_pair_ty = mkCorePairTy later_ty rec_ty
in
......@@ -917,7 +917,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
let
env1_id_set = fv_stmts `minusVarSet` rec_id_set
env1_ids = varSetElems env1_id_set
env1_ty = mkTupleType env1_ids
env1_ty = mkBigCoreVarTupTy env1_ids
in_pair_ty = mkCorePairTy env1_ty rec_ty
core_body = mkBigCoreTup (map selectVar env_ids)
where
......@@ -932,7 +932,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
-- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
let
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
core_loop = do_loop ids env1_ty later_ty rec_ty
(do_map_arrow ids in_pair_ty env_ty out_pair_ty
squash_pair_fn
......@@ -984,9 +984,9 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
dsCmdLStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
(mkTupleType env_ids)
(mkTupleType env_ids')
(mkTupleType out_ids)
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids')
(mkBigCoreVarTupTy out_ids)
core_stmt
core_stmts,
fv_stmt)
......
......@@ -175,7 +175,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
-- Rec because of mixed-up dictionary bindings
core_bind = Rec (map do_one core_prs)
tup_expr = mkTupleExpr locals
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
Let core_bind tup_expr
......
This diff is collapsed.
This diff is collapsed.
......@@ -755,6 +755,12 @@ type LStmtLR idL idR = Located (StmtLR idL idR)
type Stmt id = StmtLR id id
data GroupByClause id = GroupByNothing (LHsExpr id) -- Using expression, i.e. "then group using f" ==> GroupByNothing f
| GroupBySomething (Either (LHsExpr id) (SyntaxExpr id))
(LHsExpr id)
-- "then group using f by e" ==> GroupBySomething (Left f) e
-- "then group by e" ==> GroupBySomething (Right _) e: in this case the expression is filled in by the renamer
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax. Otherwise they are unused.
data StmtLR idL idR
......@@ -772,8 +778,17 @@ data StmtLR idL idR
| LetStmt (HsLocalBindsLR idL idR)
-- ParStmts only occur in a list comprehension
| ParStmt [([LStmt idL], [idR])] -- After renaming, the ids are the binders
-- bound by the stmts and used subsequently
| ParStmt [([LStmt idL], [idR])]
-- After renaming, the ids are the binders bound by the stmts and used after them
| TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR))
-- After renaming, the IDs are the binders occurring within this transform statement that are used after it
-- "qs, then f by e" ==> TransformStmt (qs, binders) f (Just e)
-- "qs, then f" ==> TransformStmt (qs, binders) f Nothing
| GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR)
-- After renaming, the IDs are the binders occurring within this transform statement that are used after it
-- which are paired with the names which they group over in statements
-- Recursive statement (see Note [RecStmt] below)
| RecStmt [LStmtLR idL idR]
......@@ -853,8 +868,18 @@ pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
pprStmt (ExprStmt expr _ _) = ppr expr
pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (TransformStmt (stmts, bndrs) usingExpr maybeByExpr) = (hsep [stmtsDoc, ptext SLIT("then"), ppr usingExpr, byExprDoc])
where stmtsDoc = interpp'SP stmts
byExprDoc = maybe empty (\byExpr -> hsep [ptext SLIT("by"), ppr byExpr]) maybeByExpr
pprStmt (GroupStmt (stmts, bndrs) groupByClause) = (hsep [stmtsDoc, ptext SLIT("then group"), pprGroupByClause groupByClause])
where stmtsDoc = interpp'SP stmts
pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc
pprGroupByClause (GroupByNothing usingExpr) = hsep [ptext SLIT("using"), ppr usingExpr]
pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext SLIT("by"), ppr byExpr, usingExprDoc]
where usingExprDoc = either (\usingExpr -> hsep [ptext SLIT("using"), ppr usingExpr]) (const empty) eitherUsingExpr
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
pprDo DoExpr stmts body = ptext SLIT("do") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
......@@ -968,6 +993,7 @@ data HsStmtContext id
| PArrComp -- Parallel array comprehension
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
| TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
\end{code}
\begin{code}
......@@ -1002,6 +1028,7 @@ pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction")
pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
pprStmtContext (TransformStmtCtxt c) = sep [ptext SLIT("a transformed branch of"), pprStmtContext c]
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr = ptext SLIT("a 'do' expression")
pprStmtContext (MDoExpr _) = ptext SLIT("an 'mdo' expression")
......@@ -1031,6 +1058,7 @@ matchContextErrString RecUpd = "record update"
matchContextErrString LambdaExpr = "lambda"
matchContextErrString ProcExpr = "proc"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard"
matchContextErrString (StmtCtxt DoExpr) = "'do' expression"
matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression"
......
......@@ -139,6 +139,13 @@ mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
mkNPat lit neg = NPat lit neg noSyntaxExpr
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
mkTransformStmt stmts usingExpr = TransformStmt (stmts, []) usingExpr Nothing
mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)
mkGroupUsingStmt stmts usingExpr = GroupStmt (stmts, []) (GroupByNothing usingExpr)
mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
......@@ -351,6 +358,8 @@ collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (ExprStmt _ _ _) = []
collectStmtBinders (ParStmt xs) = collectLStmtsBinders
$ concatMap fst xs
collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
collectStmtBinders (GroupStmt (stmts, _) _) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
\end{code}
......
......@@ -32,8 +32,8 @@ import Data.Bits (shiftL)
All pretty arbitrary:
\begin{code}
mAX_TUPLE_SIZE = (62 :: Int) -- Should really match the number
-- of decls in Data.Tuple
mAX_TUPLE_SIZE = (62 :: Int) -- Should really match the number
-- of decls in Data.Tuple
mAX_CONTEXT_REDUCTION_DEPTH = (20 :: Int)
\end{code}
......
......@@ -225,6 +225,7 @@ data DynFlag
| Opt_KindSignatures
| Opt_PatternSignatures
| Opt_ParallelListComp
| Opt_TransformListComp
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_PatternGuards
......@@ -1284,9 +1285,10 @@ xFlags = [
( "PatternSignatures", Opt_PatternSignatures ),
( "EmptyDataDecls", Opt_EmptyDataDecls ),
( "ParallelListComp", Opt_ParallelListComp ),
( "TransformListComp", Opt_TransformListComp ),
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes ),
( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms ),
( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms ),
( "Rank2Types", Opt_Rank2Types ),
( "RankNTypes", Opt_RankNTypes ),
( "TypeOperators", Opt_TypeOperators ),
......
......@@ -450,6 +450,9 @@ data Token
| ITdotnet
| ITmdo
| ITfamily
| ITgroup
| ITby
| ITusing
-- Pragmas
| ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
......@@ -583,6 +586,9 @@ isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
isSpecial ITfamily = True
isSpecial ITgroup = True
isSpecial ITby = True
isSpecial ITusing = True
isSpecial _ = False
-- the bitmap provided as the third component indicates whether the
......@@ -621,9 +627,12 @@ reservedWordsFM = listToUFM $
( "where", ITwhere, 0 ),
( "_scc_", ITscc, 0 ), -- ToDo: remove
( "forall", ITforall, bit explicitForallBit),
( "forall", ITforall, bit explicitForallBit),
( "mdo", ITmdo, bit recursiveDoBit),
( "family", ITfamily, bit tyFamBit),
( "group", ITgroup, bit transformComprehensionsBit),
( "by", ITby, bit transformComprehensionsBit),
( "using", ITusing, bit transformComprehensionsBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
......@@ -1510,6 +1519,7 @@ recursiveDoBit = 13 -- mdo
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit = 15 -- (# and #)
standaloneDerivingBit = 16 -- standalone instance deriving declarations
transformComprehensionsBit = 17
genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
always _ = True
......@@ -1529,6 +1539,7 @@ recursiveDoEnabled flags = testBit flags recursiveDoBit
unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
-- PState for parsing options pragmas
--
......@@ -1590,6 +1601,7 @@ mkPState buf loc flags =
.|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
.|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
.|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
......
......@@ -243,6 +243,9 @@ incorrect.
'dotnet' { L _ ITdotnet }
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
'group' { L _ ITgroup } -- for list transform extension
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
'{-# INLINE' { L _ (ITinline_prag _) }
'{-# SPECIALISE' { L _ ITspec_prag }
......@@ -1229,7 +1232,7 @@ gdrhs :: { Located [LGRHS RdrName] }
| gdrh { L1 [$1] }
gdrh :: { LGRHS RdrName }
: '|' quals '=' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
: infixexp '::' sigtypedoc
......@@ -1423,7 +1426,7 @@ list :: { LHsExpr RdrName }
| texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
| texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
| texp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
| texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
lexps :: { Located [LHsExpr RdrName] }
: lexps ',' texp { LL ($3 : unLoc $1) }
......@@ -1432,23 +1435,50 @@ lexps :: { Located [LHsExpr RdrName] }
-----------------------------------------------------------------------------
-- List Comprehensions
pquals :: { Located [LStmt RdrName] } -- Either a singleton ParStmt,
-- or a reversed list of Stmts
: pquals1 { case unLoc $1 of
[qs] -> L1 qs
qss -> L1 [L1 (ParStmt stmtss)]
where
stmtss = [ (reverse qs, undefined)
| qs <- qss ]
}
flattenedpquals :: { Located [LStmt RdrName] }
: pquals { case (unLoc $1) of
ParStmt [(qs, _)] -> L1 qs
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
_ -> L1 [$1]
-- We actually found some actual parallel lists so
-- we leave them into as a ParStmt
}
pquals :: { LStmt RdrName }
: pquals1 { L1 (ParStmt [(qs, undefined) | qs <- (reverse (unLoc $1))]) }
pquals1 :: { Located [[LStmt RdrName]] }
: pquals1 '|' quals { LL (unLoc $3 : unLoc $1) }
| '|' quals { L (getLoc $2) [unLoc $2] }
: pquals1 '|' squals { LL (unLoc $3 : unLoc $1) }
| squals { L (getLoc $1) [unLoc $1] }
squals :: { Located [LStmt RdrName] }
: squals1 { L (getLoc $1) (reverse (unLoc $1)) }
squals1 :: { Located [LStmt RdrName] }
: transformquals1 { LL (unLoc $1) }
transformquals1 :: { Located [LStmt RdrName] }
: transformquals1 ',' transformqual { LL $ [LL ((unLoc $3) (unLoc $1))] }
| transformquals1 ',' qual { LL ($3 : unLoc $1) }
-- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) }
| transformqual { LL $ [LL ((unLoc $1) [])] }
| qual { L1 [$1] }
-- | '{|' pquals '|}' { L1 [$2] }
quals :: { Located [LStmt RdrName] }
: quals ',' qual { LL ($3 : unLoc $1) }
| qual { L1 [$1] }
-- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
-- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
-- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
-- a program that makes use of this temporary syntax you must supply that flag to GHC
transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
: 'then' exp { LL $ \leftStmts -> (mkTransformStmt (reverse leftStmts) $2) }
| 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt (reverse leftStmts) $2 $4) }
| 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt (reverse leftStmts) $4) }
| 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt (reverse leftStmts) $4) }
| 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt (reverse leftStmts) $4 $6) }
-----------------------------------------------------------------------------
-- Parallel array expressions
......@@ -1465,9 +1495,19 @@ parr :: { LHsExpr RdrName }
(reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
| texp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
| texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 }
-- We are reusing `lexps' and `flattenedpquals' from the list case.
-----------------------------------------------------------------------------
-- Guards
guardquals :: { Located [LStmt RdrName] }
: guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
-- We are reusing `lexps' and `pquals' from the list case.
guardquals1 :: { Located [LStmt RdrName] }
: guardquals1 ',' qual { LL ($3 : unLoc $1) }
| qual { L1 [$1] }
-----------------------------------------------------------------------------
-- Case alternatives
......@@ -1500,7 +1540,7 @@ gdpats :: { Located [LGRHS RdrName] }
| gdpat { L1 [$1] }
gdpat :: { LGRHS RdrName }
: '|' quals '->' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
: '|' guardquals '->' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
-- 'pat' recognises a pattern, including one with a bang at the top
-- e.g. "!x" or "!(x,y)" or "C a b" etc
......@@ -1546,13 +1586,13 @@ maybe_stmt :: { Maybe (LStmt RdrName) }
| {- nothing -} { Nothing }
stmt :: { LStmt RdrName }
: qual { $1 }
: qual { $1 }
| 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName }
: pat '<-' exp { LL $ mkBindStmt $1 $3 }
| exp { L1 $ mkExprStmt $1 }
| 'let' binds { LL $ LetStmt (unLoc $2) }
: pat '<-' exp { LL $ mkBindStmt $1 $3 }
| exp { L1 $ mkExprStmt $1 }
| 'let' binds { LL $ LetStmt (unLoc $2) }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
......
......@@ -175,12 +175,15 @@ basicKnownKeyNames
-- Stable pointers
newStablePtrName,
-- GHC Extensions
groupWithName,
-- Strings and lists
unpackCStringName, unpackCStringAppendName,
unpackCStringFoldrName, unpackCStringUtf8Name,
-- List operations
concatName, filterName,
concatName, filterName, mapName,
zipName, foldrName, buildName, augmentName, appendName,
-- Parallel array operations
......@@ -262,15 +265,15 @@ tYPEABLE = mkBaseModule FSLIT("Data.Typeable")
gENERICS = mkBaseModule FSLIT("Data.Generics.Basics")
dOTNET = mkBaseModule FSLIT("GHC.Dotnet")
rEAD_PREC = mkBaseModule FSLIT("Text.ParserCombinators.ReadPrec")
lEX = mkBaseModule FSLIT("Text.Read.Lex")
lEX = mkBaseModule FSLIT("Text.Read.Lex")
gHC_INT = mkBaseModule FSLIT("GHC.Int")
gHC_WORD = mkBaseModule FSLIT("GHC.Word")
mONAD = mkBaseModule FSLIT("Control.Monad")
mONAD_FIX = mkBaseModule FSLIT("Control.Monad.Fix")
aRROW = mkBaseModule FSLIT("Control.Arrow")
gHC_DESUGAR = mkBaseModule FSLIT("GHC.Desugar")
gHC_DESUGAR = mkBaseModule FSLIT("GHC.Desugar")
rANDOM = mkBaseModule FSLIT("System.Random")
gLA_EXTS = mkBaseModule FSLIT("GHC.Exts")
gHC_EXTS = mkBaseModule FSLIT("GHC.Exts")
mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule FSLIT(":Main") -- Root module for initialisation
......@@ -496,12 +499,16 @@ bindMName = methName gHC_BASE FSLIT(">>=") bindMClassOpKey
returnMName = methName gHC_BASE FSLIT("return") returnMClassOpKey
failMName = methName gHC_BASE FSLIT("fail") failMClassOpKey
-- Functions for GHC extensions
groupWithName = varQual gHC_EXTS FSLIT("groupWith") groupWithIdKey
-- Random PrelBase functions
fromStringName = methName dATA_STRING FSLIT("fromString") fromStringClassOpKey
otherwiseIdName = varQual gHC_BASE FSLIT("otherwise") otherwiseIdKey
foldrName = varQual gHC_BASE FSLIT("foldr") foldrIdKey
buildName = varQual gHC_BASE FSLIT("build") buildIdKey
augmentName = varQual gHC_BASE FSLIT("augment") augmentIdKey
mapName = varQual gHC_BASE FSLIT("map") mapIdKey
appendName = varQual gHC_BASE FSLIT("++") appendIdKey
andName = varQual gHC_BASE FSLIT("&&") andIdKey
orName = varQual gHC_BASE FSLIT("||") orIdKey
......@@ -975,6 +982,9 @@ breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 67
inlineIdKey = mkPreludeMiscIdUnique 68
mapIdKey = mkPreludeMiscIdUnique 69
groupWithIdKey = mkPreludeMiscIdUnique 70
-- Parallel array functions
singletonPIdKey = mkPreludeMiscIdUnique 79
nullPIdKey = mkPreludeMiscIdUnique 80
......
......@@ -745,7 +745,7 @@ newLocalsRn rdr_names_w_loc
mkInternalName uniq (rdrNameOcc rdr_name) loc
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [Located RdrName]
-> [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
......@@ -756,10 +756,8 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
checkShadowing doc_str rdr_names_w_loc `thenM_`
-- Make fresh Names and extend the environment
newLocalsRn rdr_names_w_loc `thenM` \ names ->
getLocalRdrEnv `thenM` \ local_env ->
setLocalRdrEnv (extendLocalRdrEnv local_env names)
(enclosed_scope names)
newLocalsRn rdr_names_w_loc `thenM` \names ->
bindLocalNames names (enclosed_scope names)
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
......
This diff is collapsed.
......@@ -12,7 +12,7 @@
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp) where
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where