%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[DsArrows]{Desugaring arrow commands}
+
+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 Match ( matchSimply )
-import DsUtils ( mkErrorAppDs,
- mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
- mkTupleCase, mkBigCoreTup, mkTupleType,
- mkTupleExpr, mkTupleSelector,
- dsSyntaxTable, lookupEvidence )
+import Match
+import DsUtils
import DsMonad
-import HsSyn
-import TcHsSyn ( hsLPatType )
+import HsSyn hiding (collectPatBinders, collectLocatedPatBinders, collectl,
+ collectPatsBinders, collectLocatedPatsBinders)
+import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
-import TcType ( Type, tcSplitAppTy, mkFunTy )
-import Type ( mkTyConApp, funArgTy )
+import TcType
+import Type
import CoreSyn
-import CoreFVs ( exprFreeVars )
-import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
-
-import Id ( Id, idType )
-import Name ( Name )
-import PrelInfo ( pAT_ERROR_ID )
-import DataCon ( dataConWrapId )
-import TysWiredIn ( tupleCon )
-import BasicTypes ( Boxity(..) )
-import PrelNames ( eitherTyConName, leftDataConName, rightDataConName,
- arrAName, composeAName, firstAName,
- appAName, choiceAName, loopAName )
-import Util ( mapAccumL )
-import Outputable
-
-import HsUtils ( collectPatBinders, collectPatsBinders )
-import VarSet ( IdSet, mkVarSet, varSetElems,
- intersectVarSet, minusVarSet, extendVarSetList,
- unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc ( Located(..), unLoc, noLoc )
+import CoreFVs
+import CoreUtils
+
+import Id
+import Name
+import PrelInfo
+import DataCon
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import Util
+
+import VarSet
+import SrcLoc
+
+import Data.List
\end{code}
\begin{code}
\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
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
-> 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)
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
= 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 ->
= 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 ->
let
left_id = HsVar (dataConWrapId left_con)
right_id = HsVar (dataConWrapId right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) right_id) e
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
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
returnDs (mkApps (App core_op (Type env_ty)) core_args,
unionVarSets fv_sets)
+
+dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr)
+ = dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
+ mkTickBox ix vars expr1 `thenDs` \ expr2 ->
+ return (expr2,id_set)
+
-- A | ys |- c :: [ts] t (ys <= xs)
-- ---------------------
-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c
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,
= 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
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
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 ->
-- 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 $
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)
= 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)
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 ->
-- 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
-- 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
= 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
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
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
-- 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
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)
fold_pairs [x] = [x]
fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
\end{code}
+
+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
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+ GT -> returnA -< z+x
+
+The type checker turns the case into
+
+ case compare x y of
+ GT { p77 = plusInt } -> returnA -< p77 z x
+
+Here p77 is a local binding for the (+) operation.
+
+See comments in HsUtils for why the other version does not include
+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)
+
+collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl (L l pat) bndrs
+ = go pat
+ where
+ go (VarPat var) = L l var : bndrs
+ go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders 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 (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 (ConPatOut {pat_args=ps, pat_binds=ds}) =
+ collectHsBindLocatedBinders ds
+ ++ foldr collectl bndrs (hsConPatArgs ps)
+ go (LitPat _) = bndrs
+ go (NPat _ _ _) = bndrs
+ go (NPlusKPat 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
+\end{code}
projects / ghc-hetmet.git / blobdiff