%
+% (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}
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 ( hsPatType )
+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 HsUtils
+import VarSet
+import SrcLoc
+
+import Data.List
\end{code}
\begin{code}
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
`thenDs` \ match_code ->
let
- pat_ty = hsPatType pat
+ pat_ty = hsLPatType pat
proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
(Lam var match_code)
core_cmd
dsLookupDataCon leftDataConName `thenDs` \ left_con ->
dsLookupDataCon rightDataConName `thenDs` \ right_con ->
let
- left_id = nlHsVar (dataConWrapId left_con)
- right_id = nlHsVar (dataConWrapId right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
+ left_id = HsVar (dataConWrapId left_con)
+ right_id = HsVar (dataConWrapId right_con)
+ 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.
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
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
- = dsfixCmd ids local_vars [] (hsPatType pat) cmd
+ = dsfixCmd ids local_vars [] (hsLPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
- pat_ty = hsPatType pat
+ pat_ty = hsLPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
env_ty2 = mkTupleType env_ids2