%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[DsUtils]{Utilities for desugaring}
+
+Utilities for desugaring
This module exports some utility functions of no great interest.
dsSyntaxTable, lookupEvidence,
- selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+ selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+ mkTickBox, mkOptTickBox, mkBinaryTickBox
) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
-import TcHsSyn ( hsLPatType, hsPatType )
+import TcHsSyn
import CoreSyn
-import Constants ( mAX_TUPLE_SIZE )
+import Constants
import DsMonad
-import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec )
-import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, unwrapNewTypeBody )
-import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
-import Var ( Var )
-import Name ( Name )
-import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
-import TyCon ( isNewTyCon, tyConDataCons, tyConArity )
-import DataCon ( DataCon, dataConSourceArity, dataConTyCon, dataConTag, dataConRepArgTys )
-import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy,
- splitNewTyConApp )
-import Coercion ( Coercion, mkUnsafeCoercion )
-import TcType ( tcEqType )
-import TysPrim ( intPrimTy )
-import TysWiredIn ( nilDataCon, consDataCon,
- tupleCon, mkTupleTy,
- unitDataConId, unitTy,
- charTy, charDataCon,
- intTy, intDataCon,
- isPArrFakeCon )
-import BasicTypes ( Boxity(..) )
-import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet )
-import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
-import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
- plusIntegerName, timesIntegerName, smallIntegerDataConName,
- lengthPName, indexPName )
+import CoreUtils
+import MkId
+import Id
+import Var
+import Name
+import Literal
+import TyCon
+import DataCon
+import Type
+import Coercion
+import TysPrim
+import TysWiredIn
+import BasicTypes
+import UniqSet
+import UniqSupply
+import PrelNames
import Outputable
-import SrcLoc ( Located(..), unLoc )
-import Util ( isSingleton, zipEqual, sortWith )
-import ListSetOps ( assocDefault )
+import SrcLoc
+import Util
+import ListSetOps
import FastString
-import Data.Char ( ord )
+import Data.Char
+import DynFlags
#ifdef DEBUG
-import Util ( notNull ) -- Used in an assertion
+import Util
#endif
\end{code}
ty = exprType expr
\end{code}
-
+\begin{code}
+mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
+mkOptTickBox Nothing e = return e
+mkOptTickBox (Just ix) e = mkTickBox ix e
+
+mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
+mkTickBox ix e = do
+ uq <- newUnique
+ mod <- getModuleDs
+ let tick = mkTickBoxOpId uq mod ix
+ uq2 <- newUnique
+ let occName = mkVarOcc "tick"
+ let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal?
+ let var = Id.mkLocalId name realWorldStatePrimTy
+ return $ Case (Var tick)
+ var
+ ty
+ [(DEFAULT,[],e)]
+ where
+ ty = exprType e
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+ mod <- getModuleDs
+ uq <- newUnique
+ mod <- getModuleDs
+ let bndr1 = mkSysLocal FSLIT("t1") uq boolTy
+ falseBox <- mkTickBox ixF $ Var falseDataConId
+ trueBox <- mkTickBox ixT $ Var trueDataConId
+ return $ Case e bndr1 boolTy
+ [ (DataAlt falseDataCon, [], falseBox)
+ , (DataAlt trueDataCon, [], trueBox)
+ ]
+\end{code}
\ No newline at end of file