Desugaring arrow commands
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module DsArrows ( dsProcExpr ) where
#include "HsVersions.h"
import DsUtils
import DsMonad
-import HsSyn hiding (collectPatBinders, collectLocatedPatBinders, collectl,
- collectPatsBinders, collectLocatedPatsBinders)
+import HsSyn hiding (collectPatBinders, collectPatsBinders )
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
import CoreSyn
import CoreFVs
import CoreUtils
+import MkCore
-import Id
import Name
+import Var
+import Id
import PrelInfo
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
-import Util
+import Outputable
import VarSet
import SrcLoc
\begin{code}
mkCorePairTy :: Type -> Type -> Type
-mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
\end{code}
\begin{code}
-mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
-mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
-
-mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
-mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
-
-mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
+mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id
mkHsEnvStackExpr env_ids stack_ids
- = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+ = foldl (\a b -> mkLHsTupleExpr [a,b])
+ (mkLHsVarTuple env_ids)
+ (map nlHsVar stack_ids)
\end{code}
Translation of arrow abstraction
dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
meth_ids <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat)
- (core_cmd, free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
+ (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
let env_ty = mkBigCoreVarTupTy env_ids
fail_expr <- mkFailExpr ProcExpr env_ty
var <- selectSimpleMatchVarL pat
(Lam var match_code)
core_cmd
return (bindCmdEnv meth_ids proc_code)
+dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c)
\end{code}
Translation of command judgements of the form
A | xs |- c :: [ts] t
\begin{code}
+dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id
+ -> DsM (CoreExpr, IdSet)
dsLCmd ids local_vars env_ids stack res_ty cmd
= dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- env_ty = mkBigCoreVarTupTy env_ids
core_arrow <- dsLExpr arrow
core_arg <- dsLExpr arg
stack_ids <- mapM newSysLocalDs stack
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- env_ty = mkBigCoreVarTupTy env_ids
core_arrow <- dsLExpr arrow
core_arg <- dsLExpr arg
(core_leaf, fvs, leaf_ids) <-
dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
return (fvs `minusVarSet` bound_vars,
- [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+ [mkHsEnvStackExpr leaf_ids stack_ids],
envStackType leaf_ids stack,
core_leaf)
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
let
- defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
+ defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = local_vars `unionVarSet` defined_vars
- (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
+ (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
stack_ids <- mapM newSysLocalDs stack
-- build a new environment, plus the stack, using the let bindings
core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
expr2 <- mkTickBox ix vars expr1
return (expr2,id_set)
+dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
+
-- A | ys |- c :: [ts] t (ys <= xs)
-- ---------------------
-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
let
- bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+ bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
- (core_stmts, fv_stmts, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
+ (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
as an arrow from one tuple type to another. A statement sequence is
translated to a composition of such arrows.
\begin{code}
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id
+ -> DsM (CoreExpr, IdSet)
dsCmdLStmt ids local_vars env_ids out_ids cmd
= dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
-dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds) = do
+dsCmdStmt ids local_vars env_ids out_ids
+ (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
+ , recS_rec_rets = rhss, recS_dicts = _binds }) = do
let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
return (core_body, env1_id_set `unionVarSet` env2_id_set)
+dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
+
-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
-- ss >>>
-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
+dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id]
+ -> DsM (CoreExpr, VarSet, [Var])
dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do
let
rec_id_set = mkVarSet rec_ids
dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
let
- bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
+ bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
- (core_stmts, fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
+ (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids
(mkBigCoreVarTupTy env_ids)
core_stmts,
fv_stmt)
+dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []"
+
\end{code}
Match a list of expressions against a list of patterns, left-to-right.
matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
match_code <- matchSimplys exps ctxt pats result_expr fail_expr
matchSimply exp ctxt pat match_code fail_expr
+matchSimplys _ _ _ _ _ = panic "matchSimplys"
\end{code}
List of leaf expressions, with set of variables bound in each
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
- mkVarSet (map unLoc (collectLocalBinders binds))
+ mkVarSet (collectLocalBinders binds)
in
[(expr,
- mkVarSet (map unLoc (collectLStmtsBinders stmts))
+ mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
| L _ (GRHS stmts expr) <- grhss]
\end{code}
-> LMatch Id -- the matches of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LMatch Id) -- updated match
-replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
-> LGRHS Id -- rhss of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LGRHS Id) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
= (leaves, L loc (GRHS stmts leaf))
+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
\end{code}
Balanced fold of a non-empty list.
fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
\end{code}
+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following functions to collect value variables from patterns are
copied from HsUtils, with one change: we also collect the dictionary
bindings (pat_binds) from ConPatOut. We need them for cases like
these bindings.
\begin{code}
-collectPatBinders :: LPat a -> [a]
-collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
-
-collectLocatedPatBinders :: LPat a -> [Located a]
-collectLocatedPatBinders pat = collectl pat []
-
-collectPatsBinders :: [LPat a] -> [a]
-collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+collectPatBinders :: OutputableBndr a => LPat a -> [a]
+collectPatBinders pat = collectl pat []
-collectLocatedPatsBinders :: [LPat a] -> [Located a]
-collectLocatedPatsBinders pats = foldr collectl [] pats
+collectPatsBinders :: OutputableBndr a => [LPat a] -> [a]
+collectPatsBinders pats = foldr collectl [] pats
---------------------
-collectl (L l pat) bndrs
+collectl :: OutputableBndr a => LPat a -> [a] -> [a]
+-- See Note [Dictionary binders in ConPatOut]
+collectl (L _ pat) bndrs
= go pat
where
- go (VarPat var) = L l var : bndrs
- go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
+ go (VarPat var) = var : bndrs
+ go (VarPatOut var bs) = var : collectHsBindsBinders bs
++ bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
- go (AsPat a pat) = a : collectl pat bndrs
+ go (AsPat (L _ a) pat) = a : collectl pat bndrs
go (ParPat pat) = collectl pat bndrs
go (ListPat pats _) = foldr collectl bndrs pats
go (PArrPat pats _) = foldr collectl bndrs pats
go (TuplePat pats _ _) = foldr collectl bndrs pats
- go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps)
+ go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps, pat_binds=ds}) =
- collectHsBindLocatedBinders ds
+ collectHsBindsBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _) = bndrs
go (NPat _ _ _) = bndrs
- go (NPlusKPat n _ _ _) = n : bndrs
+ go (NPlusKPat (L _ n) _ _ _) = n : bndrs
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
- go (TypePat ty) = bndrs
- go (CoPat _ pat ty) = collectl (noLoc pat) bndrs
+ go (TypePat _) = bndrs
+ go (CoPat _ pat _) = collectl (noLoc pat) bndrs
+ go p = pprPanic "collectl/go" (ppr p)
\end{code}