compiler/deSugar/DsUtils.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Utilities for desugaring
   7
   8 This module exports some utility functions of no great interest.
   9
  10 \begin{code}
  11
  12 module DsUtils (
  13         EquationInfo(..),
  14         firstPat, shiftEqns,
  15
  16         mkDsLet, mkDsLets, mkDsApp, mkDsApps,
  17
  18         MatchResult(..), CanItFail(..),
  19         cantFailMatchResult, alwaysFailMatchResult,
  20         extractMatchResult, combineMatchResults,
  21         adjustMatchResult,  adjustMatchResultDs,
  22         mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
  23         matchCanFail, mkEvalMatchResult,
  24         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
  25         wrapBind, wrapBinds,
  26
  27         mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
  28         mkIntExpr, mkCharExpr,
  29         mkStringExpr, mkStringExprFS, mkIntegerExpr,
  30         mkBuildExpr, mkFoldrExpr,
  31
  32     seqVar,
  33
  34     -- Core tuples
  35     mkCoreVarTup, mkCoreTup, mkCoreVarTupTy, mkCoreTupTy,
  36     mkBigCoreVarTup, mkBigCoreTup, mkBigCoreVarTupTy, mkBigCoreTupTy,
  37
  38     -- LHs tuples
  39     mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
  40     mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
  41
  42     -- Tuple bindings
  43         mkSelectorBinds, mkTupleSelector,
  44         mkSmallTupleCase, mkTupleCase,
  45
  46         dsSyntaxTable, lookupEvidence,
  47
  48         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
  49         mkTickBox, mkOptTickBox, mkBinaryTickBox
  50     ) where
  51
  52 #include "HsVersions.h"
  53
  54 import {-# SOURCE #-}   Match ( matchSimply )
  55 import {-# SOURCE #-}   DsExpr( dsExpr )
  56
  57 import HsSyn
  58 import TcHsSyn
  59 import CoreSyn
  60 import Constants
  61 import DsMonad
  62
  63 import CoreUtils
  64 import MkId
  65 import Id
  66 import Var
  67 import Name
  68 import Literal
  69 import TyCon
  70 import DataCon
  71 import Type
  72 import Coercion
  73 import TysPrim
  74 import TysWiredIn
  75 import BasicTypes
  76 import UniqSet
  77 import UniqSupply
  78 import PrelNames
  79 import Outputable
  80 import SrcLoc
  81 import Util
  82 import ListSetOps
  83 import FastString
  84 import StaticFlags
  85
  86 import Data.Char
  87
  88 infixl 4 `mkDsApp`, `mkDsApps`
  89 \end{code}
  90
  91
  92
  93 %************************************************************************
  94 %*                                                                      *
  95                 Rebindable syntax
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 \begin{code}
 100 dsSyntaxTable :: SyntaxTable Id
 101                -> DsM ([CoreBind],      -- Auxiliary bindings
 102                        [(Name,Id)])     -- Maps the standard name to its value
 103
 104 dsSyntaxTable rebound_ids = do
 105     (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
 106     return (concat binds_s, prs)
 107   where
 108         -- The cheapo special case can happen when we
 109         -- make an intermediate HsDo when desugaring a RecStmt
 110     mk_bind (std_name, HsVar id) = return ([], (std_name, id))
 111     mk_bind (std_name, expr) = do
 112            rhs <- dsExpr expr
 113            id <- newSysLocalDs (exprType rhs)
 114            return ([NonRec id rhs], (std_name, id))
 115
 116 lookupEvidence :: [(Name, Id)] -> Name -> Id
 117 lookupEvidence prs std_name
 118   = assocDefault (mk_panic std_name) prs std_name
 119   where
 120     mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
 121 \end{code}
 122
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection{Building lets}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 Use case, not let for unlifted types.  The simplifier will turn some
 131 back again.
 132
 133 \begin{code}
 134 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
 135 mkDsLet (NonRec bndr rhs) body  -- See Note [CoreSyn let/app invariant]
 136   | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
 137   = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 138 mkDsLet bind body
 139   = Let bind body
 140
 141 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
 142 mkDsLets binds body = foldr mkDsLet body binds
 143
 144 -----------
 145 mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr
 146 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
 147 -- See CoreSyn Note [CoreSyn let/app invariant]
 148 mkDsApp fun (Type ty) = App fun (Type ty)
 149 mkDsApp fun arg       = mk_val_app fun arg arg_ty res_ty
 150                       where
 151                         (arg_ty, res_ty) = splitFunTy (exprType fun)
 152
 153 -----------
 154 mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
 155 -- Slightly more efficient version of (foldl mkDsApp)
 156 mkDsApps fun args
 157   = go fun (exprType fun) args
 158   where
 159     go fun _      []               = fun
 160     go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
 161     go fun fun_ty (arg     : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
 162                                    where
 163                                      (arg_ty, res_ty) = splitFunTy fun_ty
 164 -----------
 165 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
 166 mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
 167   | f == seqId          -- Note [Desugaring seq (1), (2)]
 168   = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
 169   where
 170     case_bndr = case arg1 of
 171                    Var v1 | isLocalId v1 -> v1  -- Note [Desugaring seq (2) and (3)]
 172                    _                     -> mkWildId ty1
 173
 174 mk_val_app fun arg arg_ty _     -- See Note [CoreSyn let/app invariant]
 175   | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
 176   = App fun arg         -- The vastly common case
 177
 178 mk_val_app fun arg arg_ty res_ty
 179   = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
 180   where
 181     arg_id = mkWildId arg_ty    -- Lots of shadowing, but it doesn't matter,
 182                                 -- because 'fun ' should not have a free wild-id
 183 \end{code}
 184
 185 Note [Desugaring seq (1)]  cf Trac #1031
 186 ~~~~~~~~~~~~~~~~~~~~~~~~~
 187    f x y = x `seq` (y `seq` (# x,y #))
 188
 189 The [CoreSyn let/app invariant] means that, other things being equal, because
 190 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
 191
 192    f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
 193
 194 But that is bad for two reasons:
 195   (a) we now evaluate y before x, and
 196   (b) we can't bind v to an unboxed pair
 197
 198 Seq is very, very special!  So we recognise it right here, and desugar to
 199         case x of _ -> case y of _ -> (# x,y #)
 200
 201 Note [Desugaring seq (2)]  cf Trac #2231
 202 ~~~~~~~~~~~~~~~~~~~~~~~~~
 203 Consider
 204    let chp = case b of { True -> fst x; False -> 0 }
 205    in chp `seq` ...chp...
 206 Here the seq is designed to plug the space leak of retaining (snd x)
 207 for too long.
 208
 209 If we rely on the ordinary inlining of seq, we'll get
 210    let chp = case b of { True -> fst x; False -> 0 }
 211    case chp of _ { I# -> ...chp... }
 212
 213 But since chp is cheap, and the case is an alluring contet, we'll
 214 inline chp into the case scrutinee.  Now there is only one use of chp,
 215 so we'll inline a second copy.  Alas, we've now ruined the purpose of
 216 the seq, by re-introducing the space leak:
 217     case (case b of {True -> fst x; False -> 0}) of
 218       I# _ -> ...case b of {True -> fst x; False -> 0}...
 219
 220 We can try to avoid doing this by ensuring that the binder-swap in the
 221 case happens, so we get his at an early stage:
 222    case chp of chp2 { I# -> ...chp2... }
 223 But this is fragile.  The real culprit is the source program.  Perhaps we
 224 should have said explicitly
 225    let !chp2 = chp in ...chp2...
 226
 227 But that's painful.  So the code here does a little hack to make seq
 228 more robust: a saturated application of 'seq' is turned *directly* into
 229 the case expression. So we desugar to:
 230    let chp = case b of { True -> fst x; False -> 0 }
 231    case chp of chp { I# -> ...chp... }
 232 Notice the shadowing of the case binder! And now all is well.
 233
 234 The reason it's a hack is because if you define mySeq=seq, the hack
 235 won't work on mySeq.
 236
 237 Note [Desugaring seq (3)] cf Trac #2409
 238 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 239 The isLocalId ensures that we don't turn
 240         True `seq` e
 241 into
 242         case True of True { ... }
 243 which stupidly tries to bind the datacon 'True'.
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248 \subsection{ Selecting match variables}
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 We're about to match against some patterns.  We want to make some
 253 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 254 hand, which should indeed be bound to the pattern as a whole, then use it;
 255 otherwise, make one up.
 256
 257 \begin{code}
 258 selectSimpleMatchVarL :: LPat Id -> DsM Id
 259 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
 260
 261 -- (selectMatchVars ps tys) chooses variables of type tys
 262 -- to use for matching ps against.  If the pattern is a variable,
 263 -- we try to use that, to save inventing lots of fresh variables.
 264 --
 265 -- OLD, but interesting note:
 266 --    But even if it is a variable, its type might not match.  Consider
 267 --      data T a where
 268 --        T1 :: Int -> T Int
 269 --        T2 :: a   -> T a
 270 --
 271 --      f :: T a -> a -> Int
 272 --      f (T1 i) (x::Int) = x
 273 --      f (T2 i) (y::a)   = 0
 274 --    Then we must not choose (x::Int) as the matching variable!
 275 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
 276
 277 selectMatchVars :: [Pat Id] -> DsM [Id]
 278 selectMatchVars ps = mapM selectMatchVar ps
 279
 280 selectMatchVar :: Pat Id -> DsM Id
 281 selectMatchVar (BangPat pat)   = selectMatchVar (unLoc pat)
 282 selectMatchVar (LazyPat pat)   = selectMatchVar (unLoc pat)
 283 selectMatchVar (ParPat pat)    = selectMatchVar (unLoc pat)
 284 selectMatchVar (VarPat var)    = return var
 285 selectMatchVar (AsPat var _) = return (unLoc var)
 286 selectMatchVar other_pat       = newSysLocalDs (hsPatType other_pat)
 287                                   -- OK, better make up one...
 288 \end{code}
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 %* type synonym EquationInfo and access functions for its pieces        *
 294 %*                                                                      *
 295 %************************************************************************
 296 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
 297
 298 The ``equation info'' used by @match@ is relatively complicated and
 299 worthy of a type synonym and a few handy functions.
 300
 301 \begin{code}
 302 firstPat :: EquationInfo -> Pat Id
 303 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
 304
 305 shiftEqns :: [EquationInfo] -> [EquationInfo]
 306 -- Drop the first pattern in each equation
 307 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
 308 \end{code}
 309
 310 Functions on MatchResults
 311
 312 \begin{code}
 313 matchCanFail :: MatchResult -> Bool
 314 matchCanFail (MatchResult CanFail _)  = True
 315 matchCanFail (MatchResult CantFail _) = False
 316
 317 alwaysFailMatchResult :: MatchResult
 318 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
 319
 320 cantFailMatchResult :: CoreExpr -> MatchResult
 321 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
 322
 323 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
 324 extractMatchResult (MatchResult CantFail match_fn) _
 325   = match_fn (error "It can't fail!")
 326
 327 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
 328     (fail_bind, if_it_fails) <- mkFailurePair fail_expr
 329     body <- match_fn if_it_fails
 330     return (mkDsLet fail_bind body)
 331
 332
 333 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
 334 combineMatchResults (MatchResult CanFail      body_fn1)
 335                     (MatchResult can_it_fail2 body_fn2)
 336   = MatchResult can_it_fail2 body_fn
 337   where
 338     body_fn fail = do body2 <- body_fn2 fail
 339                       (fail_bind, duplicatable_expr) <- mkFailurePair body2
 340                       body1 <- body_fn1 duplicatable_expr
 341                       return (Let fail_bind body1)
 342
 343 combineMatchResults match_result1@(MatchResult CantFail _) _
 344   = match_result1
 345
 346 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
 347 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
 348   = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
 349
 350 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
 351 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 352   = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
 353
 354 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
 355 wrapBinds [] e = e
 356 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 357
 358 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
 359 wrapBind new old body   -- Can deal with term variables *or* type variables
 360   | new==old    = body
 361   | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
 362   | otherwise   = Let (NonRec new (Var old))         body
 363
 364 seqVar :: Var -> CoreExpr -> CoreExpr
 365 seqVar var body = Case (Var var) var (exprType body)
 366                         [(DEFAULT, [], body)]
 367
 368 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
 369 mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
 370
 371 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
 372 -- let var' = viewExpr var in mr
 373 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
 374 mkViewMatchResult var' viewExpr var =
 375     adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var))))
 376
 377 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 378 mkEvalMatchResult var ty
 379   = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
 380
 381 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
 382 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
 383   = MatchResult CanFail (\fail -> do body <- body_fn fail
 384                                      return (mkIfThenElse pred_expr body fail))
 385
 386 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 387                     -> Type                             -- Type of the case
 388                     -> [(Literal, MatchResult)]         -- Alternatives
 389                     -> MatchResult
 390 mkCoPrimCaseMatchResult var ty match_alts
 391   = MatchResult CanFail mk_case
 392   where
 393     mk_case fail = do
 394         alts <- mapM (mk_alt fail) sorted_alts
 395         return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
 396
 397     sorted_alts = sortWith fst match_alts       -- Right order for a Case
 398     mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
 399                                                   return (LitAlt lit, [], body)
 400
 401
 402 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
 403                     -> Type                                     -- Type of exp
 404                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
 405                     -> MatchResult
 406 mkCoAlgCaseMatchResult var ty match_alts
 407   | isNewTyCon tycon            -- Newtype case; use a let
 408   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
 409     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 410
 411   | isPArrFakeAlts match_alts   -- Sugared parallel array; use a literal case
 412   = MatchResult CanFail mk_parrCase
 413
 414   | otherwise                   -- Datatype case; use a case
 415   = MatchResult fail_flag mk_case
 416   where
 417     tycon = dataConTyCon con1
 418         -- [Interesting: becuase of GADTs, we can't rely on the type of
 419         --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
 420
 421         -- Stuff for newtype
 422     (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
 423     arg_id1     = ASSERT( notNull arg_ids1 ) head arg_ids1
 424     var_ty      = idType var
 425     (tc, ty_args) = splitNewTyConApp var_ty
 426     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
 427
 428         -- Stuff for data types
 429     data_cons      = tyConDataCons tycon
 430     match_results  = [match_result | (_,_,match_result) <- match_alts]
 431
 432     fail_flag | exhaustive_case
 433               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 434               | otherwise
 435               = CanFail
 436
 437     wild_var = mkWildId (idType var)
 438     sorted_alts  = sortWith get_tag match_alts
 439     get_tag (con, _, _) = dataConTag con
 440     mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
 441                       return (Case (Var var) wild_var ty (mk_default fail ++ alts))
 442
 443     mk_alt fail (con, args, MatchResult _ body_fn) = do
 444           body <- body_fn fail
 445           us <- newUniqueSupply
 446           return (mkReboxingAlt (uniqsFromSupply us) con args body)
 447
 448     mk_default fail | exhaustive_case = []
 449                     | otherwise       = [(DEFAULT, [], fail)]
 450
 451     un_mentioned_constructors
 452         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 453     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 454
 455         -- Stuff for parallel arrays
 456         --
 457         --  * the following is to desugar cases over fake constructors for
 458         --   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
 459         --   case
 460         --
 461         -- Concerning `isPArrFakeAlts':
 462         --
 463         --  * it is *not* sufficient to just check the type of the type
 464         --   constructor, as we have to be careful not to confuse the real
 465         --   representation of parallel arrays with the fake constructors;
 466         --   moreover, a list of alternatives must not mix fake and real
 467         --   constructors (this is checked earlier on)
 468         --
 469         -- FIXME: We actually go through the whole list and make sure that
 470         --        either all or none of the constructors are fake parallel
 471         --        array constructors.  This is to spot equations that mix fake
 472         --        constructors with the real representation defined in
 473         --        `PrelPArr'.  It would be nicer to spot this situation
 474         --        earlier and raise a proper error message, but it can really
 475         --        only happen in `PrelPArr' anyway.
 476         --
 477     isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
 478     isPArrFakeAlts ((dcon, _, _):alts) =
 479       case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
 480         (True , True ) -> True
 481         (False, False) -> False
 482         _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
 483     isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
 484     --
 485     mk_parrCase fail = do
 486       lengthP <- dsLookupGlobalId lengthPName
 487       alt <- unboxAlt
 488       return (Case (len lengthP) (mkWildId intTy) ty [alt])
 489       where
 490         elemTy      = case splitTyConApp (idType var) of
 491                         (_, [elemTy]) -> elemTy
 492                         _               -> panic panicMsg
 493         panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
 494         len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
 495         --
 496         unboxAlt = do
 497           l      <- newSysLocalDs intPrimTy
 498           indexP <- dsLookupGlobalId indexPName
 499           alts   <- mapM (mkAlt indexP) sorted_alts
 500           return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
 501           where
 502             wild = mkWildId intPrimTy
 503             dft  = (DEFAULT, [], fail)
 504         --
 505         -- each alternative matches one array length (corresponding to one
 506         -- fake array constructor), so the match is on a literal; each
 507         -- alternative's body is extended by a local binding for each
 508         -- constructor argument, which are bound to array elements starting
 509         -- with the first
 510         --
 511         mkAlt indexP (con, args, MatchResult _ bodyFun) = do
 512           body <- bodyFun fail
 513           return (LitAlt lit, [], mkDsLets binds body)
 514           where
 515             lit   = MachInt $ toInteger (dataConSourceArity con)
 516             binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
 517             --
 518             indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
 519 \end{code}
 520
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsection{Desugarer's versions of some Core functions}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 \begin{code}
 529 mkErrorAppDs :: Id              -- The error function
 530              -> Type            -- Type to which it should be applied
 531              -> String          -- The error message string to pass
 532              -> DsM CoreExpr
 533
 534 mkErrorAppDs err_id ty msg = do
 535     src_loc <- getSrcSpanDs
 536     let
 537         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 538         core_msg = Lit (mkStringLit full_msg)
 539         -- mkStringLit returns a result of type String#
 540     return (mkApps (Var err_id) [Type ty, core_msg])
 541 \end{code}
 542
 543
 544 *************************************************************
 545 %*                                                                      *
 546 \subsection{Making literals}
 547 %*                                                                      *
 548 %************************************************************************
 549
 550 \begin{code}
 551 mkCharExpr     :: Char       -> CoreExpr      -- Returns        C# c :: Int
 552 mkIntExpr      :: Integer    -> CoreExpr      -- Returns        I# i :: Int
 553 mkIntegerExpr  :: Integer    -> DsM CoreExpr  -- Result :: Integer
 554 mkStringExpr   :: String     -> DsM CoreExpr  -- Result :: String
 555 mkStringExprFS :: FastString -> DsM CoreExpr  -- Result :: String
 556
 557 mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
 558 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
 559
 560 mkIntegerExpr i
 561   | inIntRange i        -- Small enough, so start from an Int
 562     = do integer_id <- dsLookupGlobalId smallIntegerName
 563          return (mkSmallIntegerLit integer_id i)
 564
 565 -- Special case for integral literals with a large magnitude:
 566 -- They are transformed into an expression involving only smaller
 567 -- integral literals. This improves constant folding.
 568
 569   | otherwise = do       -- Big, so start from a string
 570       plus_id <- dsLookupGlobalId plusIntegerName
 571       times_id <- dsLookupGlobalId timesIntegerName
 572       integer_id <- dsLookupGlobalId smallIntegerName
 573       let
 574            lit i = mkSmallIntegerLit integer_id i
 575            plus a b  = Var plus_id  `App` a `App` b
 576            times a b = Var times_id `App` a `App` b
 577
 578            -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
 579            horner :: Integer -> Integer -> CoreExpr
 580            horner b i | abs q <= 1 = if r == 0 || r == i
 581                                      then lit i
 582                                      else lit r `plus` lit (i-r)
 583                       | r == 0     =               horner b q `times` lit b
 584                       | otherwise  = lit r `plus` (horner b q `times` lit b)
 585                       where
 586                         (q,r) = i `quotRem` b
 587
 588       return (horner tARGET_MAX_INT i)
 589
 590 mkSmallIntegerLit :: Id -> Integer -> CoreExpr
 591 mkSmallIntegerLit small_integer i = mkApps (Var small_integer) [mkIntLit i]
 592
 593 mkStringExpr str = mkStringExprFS (mkFastString str)
 594
 595 mkStringExprFS str
 596   | nullFS str
 597   = return (mkNilExpr charTy)
 598
 599   | lengthFS str == 1
 600   = do let the_char = mkCharExpr (headFS str)
 601        return (mkConsExpr charTy the_char (mkNilExpr charTy))
 602
 603   | all safeChar chars
 604   = do unpack_id <- dsLookupGlobalId unpackCStringName
 605        return (App (Var unpack_id) (Lit (MachStr str)))
 606
 607   | otherwise
 608   = do unpack_id <- dsLookupGlobalId unpackCStringUtf8Name
 609        return (App (Var unpack_id) (Lit (MachStr str)))
 610
 611   where
 612     chars = unpackFS str
 613     safeChar c = ord c >= 1 && ord c <= 0x7F
 614 \end{code}
 615
 616
 617 %************************************************************************
 618 %*                                                                      *
 619 \subsection[mkSelectorBind]{Make a selector bind}
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 This is used in various places to do with lazy patterns.
 624 For each binder $b$ in the pattern, we create a binding:
 625 \begin{verbatim}
 626     b = case v of pat' -> b'
 627 \end{verbatim}
 628 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 629
 630 ToDo: making these bindings should really depend on whether there's
 631 much work to be done per binding.  If the pattern is complex, it
 632 should be de-mangled once, into a tuple (and then selected from).
 633 Otherwise the demangling can be in-line in the bindings (as here).
 634
 635 Boring!  Boring!  One error message per binder.  The above ToDo is
 636 even more helpful.  Something very similar happens for pattern-bound
 637 expressions.
 638
 639 \begin{code}
 640 mkSelectorBinds :: LPat Id      -- The pattern
 641                 -> CoreExpr     -- Expression to which the pattern is bound
 642                 -> DsM [(Id,CoreExpr)]
 643
 644 mkSelectorBinds (L _ (VarPat v)) val_expr
 645   = return [(v, val_expr)]
 646
 647 mkSelectorBinds pat val_expr
 648   | isSingleton binders || is_simple_lpat pat = do
 649         -- Given   p = e, where p binds x,y
 650         -- we are going to make
 651         --      v = p   (where v is fresh)
 652         --      x = case v of p -> x
 653         --      y = case v of p -> x
 654
 655         -- Make up 'v'
 656         -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
 657         -- This does not matter after desugaring, but there's a subtle
 658         -- issue with implicit parameters. Consider
 659         --      (x,y) = ?i
 660         -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
 661         -- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why
 662         -- does it get that type?  So that when we abstract over it we get the
 663         -- right top-level type  (?i::Int) => ...)
 664         --
 665         -- So to get the type of 'v', use the pattern not the rhs.  Often more
 666         -- efficient too.
 667       val_var <- newSysLocalDs (hsLPatType pat)
 668
 669         -- For the error message we make one error-app, to avoid duplication.
 670         -- But we need it at different types... so we use coerce for that
 671       err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (showSDoc (ppr pat))
 672       err_var <- newSysLocalDs unitTy
 673       binds <- mapM (mk_bind val_var err_var) binders
 674       return ( (val_var, val_expr) :
 675                (err_var, err_expr) :
 676                binds )
 677
 678
 679   | otherwise = do
 680       error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (showSDoc (ppr pat))
 681       tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
 682       tuple_var <- newSysLocalDs tuple_ty
 683       let
 684           mk_tup_bind binder
 685             = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 686       return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 687   where
 688     binders     = collectPatBinders pat
 689     local_tuple = mkBigCoreVarTup binders
 690     tuple_ty    = exprType local_tuple
 691
 692     mk_bind scrut_var err_var bndr_var = do
 693     -- (mk_bind sv err_var) generates
 694     --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
 695     -- Remember, pat binds bv
 696         rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
 697                                 (Var bndr_var) error_expr
 698         return (bndr_var, rhs_expr)
 699       where
 700         error_expr = mkCoerce co (Var err_var)
 701         co         = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
 702
 703     is_simple_lpat p = is_simple_pat (unLoc p)
 704
 705     is_simple_pat (TuplePat ps Boxed _)        = all is_triv_lpat ps
 706     is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
 707     is_simple_pat (VarPat _)                   = True
 708     is_simple_pat (ParPat p)                   = is_simple_lpat p
 709     is_simple_pat _                                    = False
 710
 711     is_triv_lpat p = is_triv_pat (unLoc p)
 712
 713     is_triv_pat (VarPat _)  = True
 714     is_triv_pat (WildPat _) = True
 715     is_triv_pat (ParPat p)  = is_triv_lpat p
 716     is_triv_pat _           = False
 717 \end{code}
 718
 719
 720 %************************************************************************
 721 %*                                                                      *
 722                 Big Tuples
 723 %*                                                                      *
 724 %************************************************************************
 725
 726 Nesting policy.  Better a 2-tuple of 10-tuples (3 objects) than
 727 a 10-tuple of 2-tuples (11 objects).  So we want the leaves to be big.
 728
 729 \begin{code}
 730
 731 mkBigTuple :: ([a] -> a) -> [a] -> a
 732 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
 733   where
 734         -- Each sub-list is short enough to fit in a tuple
 735     mk_big_tuple [as] = small_tuple as
 736     mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
 737
 738 chunkify :: [a] -> [[a]]
 739 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
 740 -- But there may be more than mAX_TUPLE_SIZE sub-lists
 741 chunkify xs
 742   | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
 743   | otherwise                  = {- pprTrace "Big"   (ppr n_xs) -} (split xs)
 744   where
 745     n_xs     = length xs
 746     split [] = []
 747     split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
 748
 749 \end{code}
 750
 751 Creating tuples and their types for Core expressions
 752
 753 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
 754
 755 * If it has only one element, it is the identity function.
 756
 757 * If there are more elements than a big tuple can have, it nests
 758   the tuples.
 759
 760 \begin{code}
 761
 762 -- Small tuples: build exactly the specified tuple
 763 mkCoreVarTup :: [Id] -> CoreExpr
 764 mkCoreVarTup ids = mkCoreTup (map Var ids)
 765
 766 mkCoreVarTupTy :: [Id] -> Type
 767 mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
 768
 769
 770 mkCoreTup :: [CoreExpr] -> CoreExpr
 771 mkCoreTup []  = Var unitDataConId
 772 mkCoreTup [c] = c
 773 mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
 774                          (map (Type . exprType) cs ++ cs)
 775
 776 mkCoreTupTy :: [Type] -> Type
 777 mkCoreTupTy [ty] = ty
 778 mkCoreTupTy tys  = mkTupleTy Boxed (length tys) tys
 779
 780
 781
 782 -- Big tuples
 783 mkBigCoreVarTup :: [Id] -> CoreExpr
 784 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
 785
 786 mkBigCoreVarTupTy :: [Id] -> Type
 787 mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
 788
 789
 790 mkBigCoreTup :: [CoreExpr] -> CoreExpr
 791 mkBigCoreTup = mkBigTuple mkCoreTup
 792
 793 mkBigCoreTupTy :: [Type] -> Type
 794 mkBigCoreTupTy = mkBigTuple mkCoreTupTy
 795
 796 \end{code}
 797
 798 Creating tuples and their types for full Haskell expressions
 799
 800 \begin{code}
 801
 802 -- Smart constructors for source tuple expressions
 803 mkLHsVarTup :: [Id] -> LHsExpr Id
 804 mkLHsVarTup ids  = mkLHsTup (map nlHsVar ids)
 805
 806 mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
 807 mkLHsTup []     = nlHsVar unitDataConId
 808 mkLHsTup [lexp] = lexp
 809 mkLHsTup lexps  = L (getLoc (head lexps)) $
 810                   ExplicitTuple lexps Boxed
 811
 812 -- Smart constructors for source tuple patterns
 813 mkLHsVarPatTup :: [Id] -> LPat Id
 814 mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 815
 816 mkLHsPatTup :: [LPat Id] -> LPat Id
 817 mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
 818 mkLHsPatTup [lpat] = lpat
 819 mkLHsPatTup lpats  = L (getLoc (head lpats)) $
 820                      mkVanillaTuplePat lpats Boxed
 821
 822 -- The Big equivalents for the source tuple expressions
 823 mkBigLHsVarTup :: [Id] -> LHsExpr Id
 824 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
 825
 826 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
 827 mkBigLHsTup = mkBigTuple mkLHsTup
 828
 829
 830 -- The Big equivalents for the source tuple patterns
 831 mkBigLHsVarPatTup :: [Id] -> LPat Id
 832 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
 833
 834 mkBigLHsPatTup :: [LPat Id] -> LPat Id
 835 mkBigLHsPatTup = mkBigTuple mkLHsPatTup
 836 \end{code}
 837
 838
 839 @mkTupleSelector@ builds a selector which scrutises the given
 840 expression and extracts the one name from the list given.
 841 If you want the no-shadowing rule to apply, the caller
 842 is responsible for making sure that none of these names
 843 are in scope.
 844
 845 If there is just one id in the ``tuple'', then the selector is
 846 just the identity.
 847
 848 If it's big, it does nesting
 849         mkTupleSelector [a,b,c,d] b v e
 850           = case e of v {
 851                 (p,q) -> case p of p {
 852                            (a,b) -> b }}
 853 We use 'tpl' vars for the p,q, since shadowing does not matter.
 854
 855 In fact, it's more convenient to generate it innermost first, getting
 856
 857         case (case e of v
 858                 (p,q) -> p) of p
 859           (a,b) -> b
 860
 861 \begin{code}
 862 mkTupleSelector :: [Id]         -- The tuple args
 863                 -> Id           -- The selected one
 864                 -> Id           -- A variable of the same type as the scrutinee
 865                 -> CoreExpr     -- Scrutinee
 866                 -> CoreExpr
 867
 868 mkTupleSelector vars the_var scrut_var scrut
 869   = mk_tup_sel (chunkify vars) the_var
 870   where
 871     mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
 872     mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
 873                                 mk_tup_sel (chunkify tpl_vs) tpl_v
 874         where
 875           tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
 876           tpl_vs  = mkTemplateLocals tpl_tys
 877           [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
 878                                          the_var `elem` gp ]
 879 \end{code}
 880
 881 A generalization of @mkTupleSelector@, allowing the body
 882 of the case to be an arbitrary expression.
 883
 884 If the tuple is big, it is nested:
 885
 886         mkTupleCase uniqs [a,b,c,d] body v e
 887           = case e of v { (p,q) ->
 888             case p of p { (a,b) ->
 889             case q of q { (c,d) ->
 890             body }}}
 891
 892 To avoid shadowing, we use uniqs to invent new variables p,q.
 893
 894 ToDo: eliminate cases where none of the variables are needed.
 895
 896 \begin{code}
 897 mkTupleCase
 898         :: UniqSupply   -- for inventing names of intermediate variables
 899         -> [Id]         -- the tuple args
 900         -> CoreExpr     -- body of the case
 901         -> Id           -- a variable of the same type as the scrutinee
 902         -> CoreExpr     -- scrutinee
 903         -> CoreExpr
 904
 905 mkTupleCase uniqs vars body scrut_var scrut
 906   = mk_tuple_case uniqs (chunkify vars) body
 907   where
 908     -- This is the case where don't need any nesting
 909     mk_tuple_case _ [vars] body
 910       = mkSmallTupleCase vars body scrut_var scrut
 911
 912     -- This is the case where we must make nest tuples at least once
 913     mk_tuple_case us vars_s body
 914       = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
 915             in mk_tuple_case us' (chunkify vars') body'
 916
 917     one_tuple_case chunk_vars (us, vs, body)
 918       = let (us1, us2) = splitUniqSupply us
 919             scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
 920               (mkCoreTupTy (map idType chunk_vars))
 921             body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
 922         in (us2, scrut_var:vs, body')
 923 \end{code}
 924
 925 The same, but with a tuple small enough not to need nesting.
 926
 927 \begin{code}
 928 mkSmallTupleCase
 929         :: [Id]         -- the tuple args
 930         -> CoreExpr     -- body of the case
 931         -> Id           -- a variable of the same type as the scrutinee
 932         -> CoreExpr     -- scrutinee
 933         -> CoreExpr
 934
 935 mkSmallTupleCase [var] body _scrut_var scrut
 936   = bindNonRec var scrut body
 937 mkSmallTupleCase vars body scrut_var scrut
 938 -- One branch no refinement?
 939   = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
 940 \end{code}
 941
 942 %************************************************************************
 943 %*                                                                      *
 944 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 945 %*                                                                      *
 946 %************************************************************************
 947
 948 Call the constructor Ids when building explicit lists, so that they
 949 interact well with rules.
 950
 951 \begin{code}
 952 mkNilExpr :: Type -> CoreExpr
 953 mkNilExpr ty = mkConApp nilDataCon [Type ty]
 954
 955 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 956 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
 957
 958 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
 959 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
 960
 961 mkFoldrExpr :: PostTcType -> PostTcType -> CoreExpr -> CoreExpr -> CoreExpr -> DsM CoreExpr
 962 mkFoldrExpr elt_ty result_ty c n list = do
 963     foldr_id <- dsLookupGlobalId foldrName
 964     return (Var foldr_id `App` Type elt_ty
 965            `App` Type result_ty
 966            `App` c
 967            `App` n
 968            `App` list)
 969
 970 mkBuildExpr :: Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
 971 mkBuildExpr elt_ty mk_build_inside = do
 972     [n_tyvar] <- newTyVarsDs [alphaTyVar]
 973     let n_ty = mkTyVarTy n_tyvar
 974         c_ty = mkFunTys [elt_ty, n_ty] n_ty
 975     [c, n] <- newSysLocalsDs [c_ty, n_ty]
 976
 977     build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
 978
 979     build_id <- dsLookupGlobalId buildName
 980     return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
 981
 982 mkCoreSel :: [Id]       -- The tuple args
 983           -> Id         -- The selected one
 984           -> Id         -- A variable of the same type as the scrutinee
 985           -> CoreExpr   -- Scrutinee
 986           -> CoreExpr
 987
 988 -- mkCoreSel [x] x v e
 989 -- ===>  e
 990 mkCoreSel [var] should_be_the_same_var _ scrut
 991   = ASSERT(var == should_be_the_same_var)
 992     scrut
 993
 994 -- mkCoreSel [x,y,z] x v e
 995 -- ===>  case e of v { (x,y,z) -> x
 996 mkCoreSel vars the_var scrut_var scrut
 997   = ASSERT( notNull vars )
 998     Case scrut scrut_var (idType the_var)
 999          [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
1000 \end{code}
1001
1002 %************************************************************************
1003 %*                                                                      *
1004 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
1005 %*                                                                      *
1006 %************************************************************************
1007
1008 Generally, we handle pattern matching failure like this: let-bind a
1009 fail-variable, and use that variable if the thing fails:
1010 \begin{verbatim}
1011         let fail.33 = error "Help"
1012         in
1013         case x of
1014                 p1 -> ...
1015                 p2 -> fail.33
1016                 p3 -> fail.33
1017                 p4 -> ...
1018 \end{verbatim}
1019 Then
1020 \begin{itemize}
1021 \item
1022 If the case can't fail, then there'll be no mention of @fail.33@, and the
1023 simplifier will later discard it.
1024
1025 \item
1026 If it can fail in only one way, then the simplifier will inline it.
1027
1028 \item
1029 Only if it is used more than once will the let-binding remain.
1030 \end{itemize}
1031
1032 There's a problem when the result of the case expression is of
1033 unboxed type.  Then the type of @fail.33@ is unboxed too, and
1034 there is every chance that someone will change the let into a case:
1035 \begin{verbatim}
1036         case error "Help" of
1037           fail.33 -> case ....
1038 \end{verbatim}
1039
1040 which is of course utterly wrong.  Rather than drop the condition that
1041 only boxed types can be let-bound, we just turn the fail into a function
1042 for the primitive case:
1043 \begin{verbatim}
1044         let fail.33 :: Void -> Int#
1045             fail.33 = \_ -> error "Help"
1046         in
1047         case x of
1048                 p1 -> ...
1049                 p2 -> fail.33 void
1050                 p3 -> fail.33 void
1051                 p4 -> ...
1052 \end{verbatim}
1053
1054 Now @fail.33@ is a function, so it can be let-bound.
1055
1056 \begin{code}
1057 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
1058               -> DsM (CoreBind, -- Binds the newly-created fail variable
1059                                 -- to either the expression or \ _ -> expression
1060                       CoreExpr) -- Either the fail variable, or fail variable
1061                                 -- applied to unit tuple
1062 mkFailurePair expr
1063   | isUnLiftedType ty = do
1064      fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
1065      fail_fun_arg <- newSysLocalDs unitTy
1066      return (NonRec fail_fun_var (Lam fail_fun_arg expr),
1067              App (Var fail_fun_var) (Var unitDataConId))
1068
1069   | otherwise = do
1070      fail_var <- newFailLocalDs ty
1071      return (NonRec fail_var expr, Var fail_var)
1072   where
1073     ty = exprType expr
1074 \end{code}
1075
1076 \begin{code}
1077 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
1078 mkOptTickBox Nothing e   = return e
1079 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
1080
1081 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
1082 mkTickBox ix vars e = do
1083        uq <- newUnique
1084        mod <- getModuleDs
1085        let tick | opt_Hpc   = mkTickBoxOpId uq mod ix
1086                 | otherwise = mkBreakPointOpId uq mod ix
1087        uq2 <- newUnique
1088        let occName = mkVarOcc "tick"
1089        let name = mkInternalName uq2 occName noSrcSpan   -- use mkSysLocal?
1090        let var  = Id.mkLocalId name realWorldStatePrimTy
1091        scrut <-
1092           if opt_Hpc
1093             then return (Var tick)
1094             else do
1095               let tickVar = Var tick
1096               let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
1097               let scrutApTy = App tickVar (Type tickType)
1098               return (mkApps scrutApTy (map Var vars) :: Expr Id)
1099        return $ Case scrut var ty [(DEFAULT,[],e)]
1100   where
1101      ty = exprType e
1102
1103 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
1104 mkBinaryTickBox ixT ixF e = do
1105        uq <- newUnique
1106        let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
1107        falseBox <- mkTickBox ixF [] $ Var falseDataConId
1108        trueBox  <- mkTickBox ixT [] $ Var trueDataConId
1109        return $ Case e bndr1 boolTy
1110                        [ (DataAlt falseDataCon, [], falseBox)
1111                        , (DataAlt trueDataCon,  [], trueBox)
1112                        ]
1113 \end{code}