{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Utilities for desugaring

This module exports some utility functions of no great interest.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
        EquationInfo(..),
        firstPat, shiftEqns,

        MatchResult(..), CanItFail(..), CaseAlt(..),
        cantFailMatchResult, alwaysFailMatchResult,
        extractMatchResult, combineMatchResults,
        adjustMatchResult,  adjustMatchResultDs,
        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
        matchCanFail, mkEvalMatchResult,
        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
        wrapBind, wrapBinds,

        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,

        seqVar,

        -- LHs tuples
        mkLHsPatTup, mkVanillaTuplePat,
        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,

        mkSelectorBinds,

        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
        isTrueLHsExpr
    ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-} Match  ( matchSimply )
import {-# SOURCE #-} DsExpr ( dsLExpr )

import GHC.Hs
import TcHsSyn
import TcType( tcSplitTyConApp )
import CoreSyn
import DsMonad

import CoreUtils
import MkCore
import MkId
import Id
import Literal
import TyCon
import DataCon
import PatSyn
import Type
import Coercion
import TysPrim
import TysWiredIn
import BasicTypes
import ConLike
import UniqSet
import UniqSupply
import Module
import PrelNames
import Name( isInternalName )
import Outputable
import SrcLoc
import Util
import DynFlags
import FastString
import qualified GHC.LanguageExtensions as LangExt

import TcEvidence

import Control.Monad    ( zipWithM )

{-
************************************************************************
*                                                                      *
\subsection{ Selecting match variables}
*                                                                      *
************************************************************************

We're about to match against some patterns.  We want to make some
@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.
-}

selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
-- Postcondition: the returned Id has an Internal Name
selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
selectSimpleMatchVarL LPat GhcTc
pat = Pat GhcTc -> DsM Id
selectMatchVar (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat)

-- (selectMatchVars ps tys) chooses variables of type tys
-- to use for matching ps against.  If the pattern is a variable,
-- we try to use that, to save inventing lots of fresh variables.
--
-- OLD, but interesting note:
--    But even if it is a variable, its type might not match.  Consider
--      data T a where
--        T1 :: Int -> T Int
--        T2 :: a   -> T a
--
--      f :: T a -> a -> Int
--      f (T1 i) (x::Int) = x
--      f (T2 i) (y::a)   = 0
--    Then we must not choose (x::Int) as the matching variable!
-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat

selectMatchVars :: [Pat GhcTc] -> DsM [Id]
-- Postcondition: the returned Ids have Internal Names
selectMatchVars :: [Pat GhcTc] -> DsM [Id]
selectMatchVars [Pat GhcTc]
ps = (Pat GhcTc -> DsM Id) -> [Pat GhcTc] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat GhcTc -> DsM Id
selectMatchVar [Pat GhcTc]
ps

selectMatchVar :: Pat GhcTc -> DsM Id
-- Postcondition: the returned Id has an Internal Name
selectMatchVar :: Pat GhcTc -> DsM Id
selectMatchVar (BangPat XBangPat GhcTc
_ LPat GhcTc
pat) = Pat GhcTc -> DsM Id
selectMatchVar (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat)
selectMatchVar (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat) = Pat GhcTc -> DsM Id
selectMatchVar (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat)
selectMatchVar (ParPat XParPat GhcTc
_ LPat GhcTc
pat)  = Pat GhcTc -> DsM Id
selectMatchVar (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat)
selectMatchVar (VarPat XVarPat GhcTc
_ Located (IdP GhcTc)
var)  = Id -> DsM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id
localiseId (Located Id -> SrcSpanLess (Located Id)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Id
Located (IdP GhcTc)
var))
                                  -- Note [Localise pattern binders]
selectMatchVar (AsPat XAsPat GhcTc
_ Located (IdP GhcTc)
var LPat GhcTc
_) = Id -> DsM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Id -> SrcSpanLess (Located Id)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Id
Located (IdP GhcTc)
var)
selectMatchVar Pat GhcTc
other_pat       = Type -> DsM Id
newSysLocalDsNoLP (Pat GhcTc -> Type
hsPatType Pat GhcTc
other_pat)
                                  -- OK, better make up one...

{- Note [Localise pattern binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider     module M where
               [Just a] = e
After renaming it looks like
             module M where
               [Just M.a] = e

We don't generalise, since it's a pattern binding, monomorphic, etc,
so after desugaring we may get something like
             M.a = case e of (v:_) ->
                   case v of Just M.a -> M.a
Notice the "M.a" in the pattern; after all, it was in the original
pattern.  However, after optimisation those pattern binders can become
let-binders, and then end up floated to top level.  They have a
different *unique* by then (the simplifier is good about maintaining
proper scoping), but it's BAD to have two top-level bindings with the
External Name M.a, because that turns into two linker symbols for M.a.
It's quite rare for this to actually *happen* -- the only case I know
of is tc003 compiled with the 'hpc' way -- but that only makes it
all the more annoying.

To avoid this, we craftily call 'localiseId' in the desugarer, which
simply turns the External Name for the Id into an Internal one, but
doesn't change the unique.  So the desugarer produces this:
             M.a{r8} = case e of (v:_) ->
                       case v of Just a{r8} -> M.a{r8}
The unique is still 'r8', but the binding site in the pattern
is now an Internal Name.  Now the simplifier's usual mechanisms
will propagate that Name to all the occurrence sites, as well as
un-shadowing it, so we'll get
             M.a{r8} = case e of (v:_) ->
                       case v of Just a{s77} -> a{s77}
In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
runs on the output of the desugarer, so all is well by the end of
the desugaring pass.

See also Note [MatchIds] in Match.hs

************************************************************************
*                                                                      *
* type synonym EquationInfo and access functions for its pieces        *
*                                                                      *
************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}

The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
-}

firstPat :: EquationInfo -> Pat GhcTc
firstPat :: EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)

shiftEqns :: [EquationInfo] -> [EquationInfo]
-- Drop the first pattern in each equation
shiftEqns :: [EquationInfo] -> [EquationInfo]
shiftEqns [EquationInfo]
eqns = [ EquationInfo
eqn { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc] -> [Pat GhcTc]
forall a. [a] -> [a]
tail (EquationInfo -> [Pat GhcTc]
eqn_pats EquationInfo
eqn) } | EquationInfo
eqn <- [EquationInfo]
eqns ]

-- Functions on MatchResults

matchCanFail :: MatchResult -> Bool
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanItFail
CanFail CoreExpr -> DsM CoreExpr
_)  = Bool
True
matchCanFail (MatchResult CanItFail
CantFail CoreExpr -> DsM CoreExpr
_) = Bool
False

alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CanFail (\CoreExpr
fail -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
fail)

cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult CoreExpr
expr = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CantFail (\CoreExpr
_ -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr)

extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult (MatchResult CanItFail
CantFail CoreExpr -> DsM CoreExpr
match_fn) CoreExpr
_
  = CoreExpr -> DsM CoreExpr
match_fn (String -> CoreExpr
forall a. HasCallStack => String -> a
error String
"It can't fail!")

extractMatchResult (MatchResult CanItFail
CanFail CoreExpr -> DsM CoreExpr
match_fn) CoreExpr
fail_expr = do
    (CoreBind
fail_bind, CoreExpr
if_it_fails) <- CoreExpr -> DsM (CoreBind, CoreExpr)
mkFailurePair CoreExpr
fail_expr
    CoreExpr
body <- CoreExpr -> DsM CoreExpr
match_fn CoreExpr
if_it_fails
    CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
mkCoreLet CoreBind
fail_bind CoreExpr
body)


combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults (MatchResult CanItFail
CanFail      CoreExpr -> DsM CoreExpr
body_fn1)
                    (MatchResult CanItFail
can_it_fail2 CoreExpr -> DsM CoreExpr
body_fn2)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
can_it_fail2 CoreExpr -> DsM CoreExpr
body_fn
  where
    body_fn :: CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail = do CoreExpr
body2 <- CoreExpr -> DsM CoreExpr
body_fn2 CoreExpr
fail
                      (CoreBind
fail_bind, CoreExpr
duplicatable_expr) <- CoreExpr -> DsM (CoreBind, CoreExpr)
mkFailurePair CoreExpr
body2
                      CoreExpr
body1 <- CoreExpr -> DsM CoreExpr
body_fn1 CoreExpr
duplicatable_expr
                      CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
fail_bind CoreExpr
body1)

combineMatchResults match_result1 :: MatchResult
match_result1@(MatchResult CanItFail
CantFail CoreExpr -> DsM CoreExpr
_) MatchResult
_
  = MatchResult
match_result1

adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult CoreExpr -> CoreExpr
encl_fn (MatchResult CanItFail
can_it_fail CoreExpr -> DsM CoreExpr
body_fn)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
can_it_fail (\CoreExpr
fail -> CoreExpr -> CoreExpr
encl_fn (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail)

adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
adjustMatchResultDs CoreExpr -> DsM CoreExpr
encl_fn (MatchResult CanItFail
can_it_fail CoreExpr -> DsM CoreExpr
body_fn)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
can_it_fail (\CoreExpr
fail -> CoreExpr -> DsM CoreExpr
encl_fn (CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail)

wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds :: [(Id, Id)] -> CoreExpr -> CoreExpr
wrapBinds [] CoreExpr
e = CoreExpr
e
wrapBinds ((Id
new,Id
old):[(Id, Id)]
prs) CoreExpr
e = Id -> Id -> CoreExpr -> CoreExpr
wrapBind Id
new Id
old ([(Id, Id)] -> CoreExpr -> CoreExpr
wrapBinds [(Id, Id)]
prs CoreExpr
e)

wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
wrapBind :: Id -> Id -> CoreExpr -> CoreExpr
wrapBind Id
new Id
old CoreExpr
body   -- NB: this function must deal with term
  | Id
newId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==Id
old    = CoreExpr
body  -- variables, type variables or coercion variables
  | Bool
otherwise   = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
new (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
old)) CoreExpr
body

seqVar :: Var -> CoreExpr -> CoreExpr
seqVar :: Id -> CoreExpr -> CoreExpr
seqVar Id
var CoreExpr
body = CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) Id
var CoreExpr
body

mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult CoreBind
bind = (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult (CoreBind -> CoreExpr -> CoreExpr
mkCoreLet CoreBind
bind)

-- (mkViewMatchResult var' viewExpr mr) makes the expression
-- let var' = viewExpr in mr
mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
mkViewMatchResult Id
var' CoreExpr
viewExpr =
    (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult (CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
var' CoreExpr
viewExpr))

mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult Id
var Type
ty
  = (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult (\CoreExpr
e -> CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) Id
var Type
ty [(AltCon
DEFAULT, [], CoreExpr
e)])

mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult CoreExpr
pred_expr (MatchResult CanItFail
_ CoreExpr -> DsM CoreExpr
body_fn)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CanFail (\CoreExpr
fail -> do CoreExpr
body <- CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail
                                     CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
pred_expr CoreExpr
body CoreExpr
fail))

mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
                        -> Type                      -- Type of the case
                        -> [(Literal, MatchResult)]  -- Alternatives
                        -> MatchResult               -- Literals are all unlifted
mkCoPrimCaseMatchResult :: Id -> Type -> [(Literal, MatchResult)] -> MatchResult
mkCoPrimCaseMatchResult Id
var Type
ty [(Literal, MatchResult)]
match_alts
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CanFail CoreExpr -> DsM CoreExpr
mk_case
  where
    mk_case :: CoreExpr -> DsM CoreExpr
mk_case CoreExpr
fail = do
        [Alt Id]
alts <- ((Literal, MatchResult) -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> [(Literal, MatchResult)]
-> IOEnv (Env DsGblEnv DsLclEnv) [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CoreExpr
-> (Literal, MatchResult) -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
forall a.
CoreExpr
-> (Literal, MatchResult)
-> IOEnv (Env DsGblEnv DsLclEnv) (AltCon, [a], CoreExpr)
mk_alt CoreExpr
fail) [(Literal, MatchResult)]
sorted_alts
        CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) Id
var Type
ty ((AltCon
DEFAULT, [], CoreExpr
fail) Alt Id -> [Alt Id] -> [Alt Id]
forall a. a -> [a] -> [a]
: [Alt Id]
alts))

    sorted_alts :: [(Literal, MatchResult)]
sorted_alts = ((Literal, MatchResult) -> Literal)
-> [(Literal, MatchResult)] -> [(Literal, MatchResult)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Literal, MatchResult) -> Literal
forall a b. (a, b) -> a
fst [(Literal, MatchResult)]
match_alts       -- Right order for a Case
    mk_alt :: CoreExpr
-> (Literal, MatchResult)
-> IOEnv (Env DsGblEnv DsLclEnv) (AltCon, [a], CoreExpr)
mk_alt CoreExpr
fail (Literal
lit, MatchResult CanItFail
_ CoreExpr -> DsM CoreExpr
body_fn)
       = ASSERT( not (litIsLifted lit) )
         do CoreExpr
body <- CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail
            (AltCon, [a], CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (AltCon, [a], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> AltCon
LitAlt Literal
lit, [], CoreExpr
body)

data CaseAlt a = MkCaseAlt{ CaseAlt a -> a
alt_pat :: a,
                            CaseAlt a -> [Id]
alt_bndrs :: [Var],
                            CaseAlt a -> HsWrapper
alt_wrapper :: HsWrapper,
                            CaseAlt a -> MatchResult
alt_result :: MatchResult }

mkCoAlgCaseMatchResult
  :: Id                 -- Scrutinee
  -> Type               -- Type of exp
  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
  -> MatchResult
mkCoAlgCaseMatchResult :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkCoAlgCaseMatchResult Id
var Type
ty [CaseAlt DataCon]
match_alts
  | Bool
isNewtype  -- Newtype case; use a let
  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
    CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg_id1 CoreExpr
newtype_rhs) MatchResult
match_result1

  | Bool
otherwise
  = Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkDataConCase Id
var Type
ty [CaseAlt DataCon]
match_alts
  where
    isNewtype :: Bool
isNewtype = TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon (CaseAlt DataCon -> DataCon
forall a. CaseAlt a -> a
alt_pat CaseAlt DataCon
alt1))

        -- [Interesting: because of GADTs, we can't rely on the type of
        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]

    alt1 :: CaseAlt DataCon
alt1@MkCaseAlt{ alt_bndrs :: forall a. CaseAlt a -> [Id]
alt_bndrs = [Id]
arg_ids1, alt_result :: forall a. CaseAlt a -> MatchResult
alt_result = MatchResult
match_result1 }
      = ASSERT( notNull match_alts ) head match_alts
    -- Stuff for newtype
    arg_id1 :: Id
arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1
    var_ty :: Type
var_ty        = Id -> Type
idType Id
var
    (TyCon
tc, [Type]
ty_args) = Type -> (TyCon, [Type])
tcSplitTyConApp Type
var_ty      -- Don't look through newtypes
                                                -- (not that splitTyConApp does, these days)
    newtype_rhs :: CoreExpr
newtype_rhs = TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tc [Type]
ty_args (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var)

mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
mkCoSynCaseMatchResult Id
var Type
ty CaseAlt PatSyn
alt = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CanFail ((CoreExpr -> DsM CoreExpr) -> MatchResult)
-> (CoreExpr -> DsM CoreExpr) -> MatchResult
forall a b. (a -> b) -> a -> b
$ Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase Id
var Type
ty CaseAlt PatSyn
alt

sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
sort_alts = (CaseAlt DataCon -> Int) -> [CaseAlt DataCon] -> [CaseAlt DataCon]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (DataCon -> Int
dataConTag (DataCon -> Int)
-> (CaseAlt DataCon -> DataCon) -> CaseAlt DataCon -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseAlt DataCon -> DataCon
forall a. CaseAlt a -> a
alt_pat)

mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase Id
var Type
ty CaseAlt PatSyn
alt CoreExpr
fail = do
    CoreExpr
matcher <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (LHsExpr GhcTc -> DsM CoreExpr) -> LHsExpr GhcTc -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrapper (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                         IdP GhcTc -> [Type] -> LHsExpr GhcTc
forall (id :: Pass).
IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
nlHsTyApp Id
IdP GhcTc
matcher [HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty, Type
ty]
    let MatchResult CanItFail
_ CoreExpr -> DsM CoreExpr
mkCont = MatchResult
match_result
    CoreExpr
cont <- [Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id]
bndrs (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> DsM CoreExpr
mkCont CoreExpr
fail
    CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs (String -> SDoc
text String
"patsyn" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var) CoreExpr
matcher [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var, CoreExpr -> CoreExpr
ensure_unstrict CoreExpr
cont, Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
voidArgId CoreExpr
fail]
  where
    MkCaseAlt{ alt_pat :: forall a. CaseAlt a -> a
alt_pat = PatSyn
psyn,
               alt_bndrs :: forall a. CaseAlt a -> [Id]
alt_bndrs = [Id]
bndrs,
               alt_wrapper :: forall a. CaseAlt a -> HsWrapper
alt_wrapper = HsWrapper
wrapper,
               alt_result :: forall a. CaseAlt a -> MatchResult
alt_result = MatchResult
match_result} = CaseAlt PatSyn
alt
    (Id
matcher, Bool
needs_void_lam) = PatSyn -> (Id, Bool)
patSynMatcher PatSyn
psyn

    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
    -- on these extra Void# arguments
    ensure_unstrict :: CoreExpr -> CoreExpr
ensure_unstrict CoreExpr
cont | Bool
needs_void_lam = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
voidArgId CoreExpr
cont
                         | Bool
otherwise      = CoreExpr
cont

mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkDataConCase Id
_   Type
_  []            = String -> MatchResult
forall a. String -> a
panic String
"mkDataConCase: no alternatives"
mkDataConCase Id
var Type
ty alts :: [CaseAlt DataCon]
alts@(CaseAlt DataCon
alt1:[CaseAlt DataCon]
_) = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
fail_flag CoreExpr -> DsM CoreExpr
mk_case
  where
    con1 :: DataCon
con1          = CaseAlt DataCon -> DataCon
forall a. CaseAlt a -> a
alt_pat CaseAlt DataCon
alt1
    tycon :: TyCon
tycon         = DataCon -> TyCon
dataConTyCon DataCon
con1
    data_cons :: [DataCon]
data_cons     = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    match_results :: [MatchResult]
match_results = (CaseAlt DataCon -> MatchResult)
-> [CaseAlt DataCon] -> [MatchResult]
forall a b. (a -> b) -> [a] -> [b]
map CaseAlt DataCon -> MatchResult
forall a. CaseAlt a -> MatchResult
alt_result [CaseAlt DataCon]
alts

    sorted_alts :: [CaseAlt DataCon]
    sorted_alts :: [CaseAlt DataCon]
sorted_alts  = [CaseAlt DataCon] -> [CaseAlt DataCon]
sort_alts [CaseAlt DataCon]
alts

    var_ty :: Type
var_ty       = Id -> Type
idType Id
var
    (TyCon
_, [Type]
ty_args) = Type -> (TyCon, [Type])
tcSplitTyConApp Type
var_ty -- Don't look through newtypes
                                          -- (not that splitTyConApp does, these days)

    mk_case :: CoreExpr -> DsM CoreExpr
    mk_case :: CoreExpr -> DsM CoreExpr
mk_case CoreExpr
fail = do
        [Alt Id]
alts <- (CaseAlt DataCon -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> [CaseAlt DataCon] -> IOEnv (Env DsGblEnv DsLclEnv) [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CoreExpr
-> CaseAlt DataCon -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
mk_alt CoreExpr
fail) [CaseAlt DataCon]
sorted_alts
        CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Type -> Type -> [Alt Id] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) (Id -> Type
idType Id
var) Type
ty (CoreExpr -> [Alt Id]
mk_default CoreExpr
fail [Alt Id] -> [Alt Id] -> [Alt Id]
forall a. [a] -> [a] -> [a]
++ [Alt Id]
alts)

    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
    mk_alt :: CoreExpr
-> CaseAlt DataCon -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
mk_alt CoreExpr
fail MkCaseAlt{ alt_pat :: forall a. CaseAlt a -> a
alt_pat = DataCon
con,
                           alt_bndrs :: forall a. CaseAlt a -> [Id]
alt_bndrs = [Id]
args,
                           alt_result :: forall a. CaseAlt a -> MatchResult
alt_result = MatchResult CanItFail
_ CoreExpr -> DsM CoreExpr
body_fn }
      = do { CoreExpr
body <- CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail
           ; case DataCon -> Maybe DataConBoxer
dataConBoxer DataCon
con of {
                Maybe DataConBoxer
Nothing -> Alt Id -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> AltCon
DataAlt DataCon
con, [Id]
args, CoreExpr
body) ;
                Just (DCB [Type] -> [Id] -> UniqSM ([Id], [CoreBind])
boxer) ->
        do { UniqSupply
us <- TcRnIf DsGblEnv DsLclEnv UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
           ; let ([Id]
rep_ids, [CoreBind]
binds) = UniqSupply -> UniqSM ([Id], [CoreBind]) -> ([Id], [CoreBind])
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])
boxer [Type]
ty_args [Id]
args)
           ; Alt Id -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> AltCon
DataAlt DataCon
con, [Id]
rep_ids, [CoreBind] -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets [CoreBind]
binds CoreExpr
body) } } }

    mk_default :: CoreExpr -> [CoreAlt]
    mk_default :: CoreExpr -> [Alt Id]
mk_default CoreExpr
fail | Bool
exhaustive_case = []
                    | Bool
otherwise       = [(AltCon
DEFAULT, [], CoreExpr
fail)]

    fail_flag :: CanItFail
    fail_flag :: CanItFail
fail_flag | Bool
exhaustive_case
              = (CanItFail -> CanItFail -> CanItFail)
-> CanItFail -> [CanItFail] -> CanItFail
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CanItFail -> CanItFail -> CanItFail
orFail CanItFail
CantFail [CanItFail
can_it_fail | MatchResult CanItFail
can_it_fail CoreExpr -> DsM CoreExpr
_ <- [MatchResult]
match_results]
              | Bool
otherwise
              = CanItFail
CanFail

    mentioned_constructors :: UniqSet DataCon
mentioned_constructors = [DataCon] -> UniqSet DataCon
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([DataCon] -> UniqSet DataCon) -> [DataCon] -> UniqSet DataCon
forall a b. (a -> b) -> a -> b
$ (CaseAlt DataCon -> DataCon) -> [CaseAlt DataCon] -> [DataCon]
forall a b. (a -> b) -> [a] -> [b]
map CaseAlt DataCon -> DataCon
forall a. CaseAlt a -> a
alt_pat [CaseAlt DataCon]
alts
    un_mentioned_constructors :: UniqSet DataCon
un_mentioned_constructors
        = [DataCon] -> UniqSet DataCon
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [DataCon]
data_cons UniqSet DataCon -> UniqSet DataCon -> UniqSet DataCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet DataCon
mentioned_constructors
    exhaustive_case :: Bool
exhaustive_case = UniqSet DataCon -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet DataCon
un_mentioned_constructors

{-
************************************************************************
*                                                                      *
\subsection{Desugarer's versions of some Core functions}
*                                                                      *
************************************************************************
-}

mkErrorAppDs :: Id              -- The error function
             -> Type            -- Type to which it should be applied
             -> SDoc            -- The error message string to pass
             -> DsM CoreExpr

mkErrorAppDs :: Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
err_id Type
ty SDoc
msg = do
    SrcSpan
src_loc <- DsM SrcSpan
getSrcSpanDs
    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let
        full_msg :: String
full_msg = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags ([SDoc] -> SDoc
hcat [SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
src_loc, SDoc
vbar, SDoc
msg])
        core_msg :: CoreExpr
core_msg = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
full_msg)
        -- mkLitString returns a result of type String#
    CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
err_id) [Type -> CoreExpr
forall b. Type -> Expr b
Type (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty), Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
core_msg])

{-
'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.

Note [Desugaring seq]
~~~~~~~~~~~~~~~~~~~~~

There are a few subtleties in the desugaring of `seq`:

 1. (as described in #1031)

    Consider,
       f x y = x `seq` (y `seq` (# x,y #))

    The [CoreSyn let/app invariant] means that, other things being equal, because
    the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:

       f x y = case (y `seq` (# x,y #)) of v -> x `seq` v

    But that is bad for two reasons:
      (a) we now evaluate y before x, and
      (b) we can't bind v to an unboxed pair

    Seq is very, very special!  So we recognise it right here, and desugar to
            case x of _ -> case y of _ -> (# x,y #)

 2. (as described in #2273)

    Consider
       let chp = case b of { True -> fst x; False -> 0 }
       in chp `seq` ...chp...
    Here the seq is designed to plug the space leak of retaining (snd x)
    for too long.

    If we rely on the ordinary inlining of seq, we'll get
       let chp = case b of { True -> fst x; False -> 0 }
       case chp of _ { I# -> ...chp... }

    But since chp is cheap, and the case is an alluring contet, we'll
    inline chp into the case scrutinee.  Now there is only one use of chp,
    so we'll inline a second copy.  Alas, we've now ruined the purpose of
    the seq, by re-introducing the space leak:
        case (case b of {True -> fst x; False -> 0}) of
          I# _ -> ...case b of {True -> fst x; False -> 0}...

    We can try to avoid doing this by ensuring that the binder-swap in the
    case happens, so we get his at an early stage:
       case chp of chp2 { I# -> ...chp2... }
    But this is fragile.  The real culprit is the source program.  Perhaps we
    should have said explicitly
       let !chp2 = chp in ...chp2...

    But that's painful.  So the code here does a little hack to make seq
    more robust: a saturated application of 'seq' is turned *directly* into
    the case expression, thus:
       x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
       e1 `seq` e2 ==> case x of _ -> e2

    So we desugar our example to:
       let chp = case b of { True -> fst x; False -> 0 }
       case chp of chp { I# -> ...chp... }
    And now all is well.

    The reason it's a hack is because if you define mySeq=seq, the hack
    won't work on mySeq.

 3. (as described in #2409)

    The isLocalId ensures that we don't turn
            True `seq` e
    into
            case True of True { ... }
    which stupidly tries to bind the datacon 'True'.
-}

-- NB: Make sure the argument is not levity polymorphic
mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs SDoc
_ (Var Id
f `App` Type Type
_r `App` Type Type
ty1 `App` Type Type
ty2 `App` CoreExpr
arg1) CoreExpr
arg2
  | Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey            -- Note [Desugaring seq], points (1) and (2)
  = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg1 Id
case_bndr Type
ty2 [(AltCon
DEFAULT,[],CoreExpr
arg2)]
  where
    case_bndr :: Id
case_bndr = case CoreExpr
arg1 of
                   Var Id
v1 | Name -> Bool
isInternalName (Id -> Name
idName Id
v1)
                          -> Id
v1        -- Note [Desugaring seq], points (2) and (3)
                   CoreExpr
_      -> Type -> Id
mkWildValBinder Type
ty1

mkCoreAppDs SDoc
s CoreExpr
fun CoreExpr
arg = SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp SDoc
s CoreExpr
fun CoreExpr
arg  -- The rest is done in MkCore

-- NB: No argument can be levity polymorphic
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs SDoc
s CoreExpr
fun [CoreExpr]
args = (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs SDoc
s) CoreExpr
fun [CoreExpr]
args

mkCastDs :: CoreExpr -> Coercion -> CoreExpr
-- We define a desugarer-specific version of CoreUtils.mkCast,
-- because in the immediate output of the desugarer, we can have
-- apparently-mis-matched coercions:  E.g.
--     let a = b
--     in (x :: a) |> (co :: b ~ Int)
-- Lint know about type-bindings for let and does not complain
-- So here we do not make the assertion checks that we make in
-- CoreUtils.mkCast; and we do less peephole optimisation too
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
mkCastDs CoreExpr
e Coercion
co | Coercion -> Bool
isReflCo Coercion
co = CoreExpr
e
              | Bool
otherwise   = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co

{-
************************************************************************
*                                                                      *
               Tuples and selector bindings
*                                                                      *
************************************************************************

This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
\begin{verbatim}
    b = case v of pat' -> b'
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.

ToDo: making these bindings should really depend on whether there's
much work to be done per binding.  If the pattern is complex, it
should be de-mangled once, into a tuple (and then selected from).
Otherwise the demangling can be in-line in the bindings (as here).

Boring!  Boring!  One error message per binder.  The above ToDo is
even more helpful.  Something very similar happens for pattern-bound
expressions.

Note [mkSelectorBinds]
~~~~~~~~~~~~~~~~~~~~~~
mkSelectorBinds is used to desugar a pattern binding {p = e},
in a binding group:
  let { ...; p = e; ... } in body
where p binds x,y (this list of binders can be empty).
There are two cases.

------ Special case (A) -------
  For a pattern that is just a variable,
     let !x = e in body
  ==>
     let x = e in x `seq` body
  So we return the binding, with 'x' as the variable to seq.

------ Special case (B) -------
  For a pattern that is essentially just a tuple:
      * A product type, so cannot fail
      * Only one level, so that
          - generating multiple matches is fine
          - seq'ing it evaluates the same as matching it
  Then instead we generate
       { v = e
       ; x = case v of p -> x
       ; y = case v of p -> y }
  with 'v' as the variable to force

------ General case (C) -------
  In the general case we generate these bindings:
       let { ...; p = e; ... } in body
  ==>
       let { t = case e of p -> (x,y)
           ; x = case t of (x,y) -> x
           ; y = case t of (x,y) -> y }
       in t `seq` body

  Note that we return 't' as the variable to force if the pattern
  is strict (i.e. with -XStrict or an outermost-bang-pattern)

  Note that (A) /includes/ the situation where

   * The pattern binds exactly one variable
        let !(Just (Just x) = e in body
     ==>
       let { t = case e of Just (Just v) -> Unit v
           ; v = case t of Unit v -> v }
       in t `seq` body
    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
    Note that forcing 't' makes the pattern match happen,
    but does not force 'v'.

  * The pattern binds no variables
        let !(True,False) = e in body
    ==>
        let t = case e of (True,False) -> ()
        in t `seq` body


------ Examples ----------
  *   !(_, (_, a)) = e
    ==>
      t = case e of (_, (_, a)) -> Unit a
      a = case t of Unit a -> a

    Note that
     - Forcing 't' will force the pattern to match fully;
       e.g. will diverge if (snd e) is bottom
     - But 'a' itself is not forced; it is wrapped in a one-tuple
       (see Note [One-tuples] in TysWiredIn)

  *   !(Just x) = e
    ==>
      t = case e of Just x -> Unit x
      x = case t of Unit x -> x

    Again, forcing 't' will fail if 'e' yields Nothing.

Note that even though this is rather general, the special cases
work out well:

* One binder, not -XStrict:

    let Just (Just v) = e in body
  ==>
    let t = case e of Just (Just v) -> Unit v
        v = case t of Unit v -> v
    in body
  ==>
    let v = case (case e of Just (Just v) -> Unit v) of
              Unit v -> v
    in body
  ==>
    let v = case e of Just (Just v) -> v
    in body

* Non-recursive, -XStrict
     let p = e in body
  ==>
     let { t = case e of p -> (x,y)
         ; x = case t of (x,y) -> x
         ; y = case t of (x,y) -> x }
     in t `seq` body
  ==> {inline seq, float x,y bindings inwards}
     let t = case e of p -> (x,y) in
     case t of t' ->
     let { x = case t' of (x,y) -> x
         ; y = case t' of (x,y) -> x } in
     body
  ==> {inline t, do case of case}
     case e of p ->
     let t = (x,y) in
     let { x = case t' of (x,y) -> x
         ; y = case t' of (x,y) -> x } in
     body
  ==> {case-cancellation, drop dead code}
     case e of p -> body

* Special case (B) is there to avoid fruitlessly taking the tuple
  apart and rebuilding it. For example, consider
     { K x y = e }
  where K is a product constructor.  Then general case (A) does:
     { t = case e of K x y -> (x,y)
     ; x = case t of (x,y) -> x
     ; y = case t of (x,y) -> y }
  In the lazy case we can't optimise out this fruitless taking apart
  and rebuilding.  Instead (B) builds
     { v = e
     ; x = case v of K x y -> x
     ; y = case v of K x y -> y }
  which is better.
-}

mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
                -> LPat GhcTc     -- ^ The pattern
                -> CoreExpr       -- ^ Expression to which the pattern is bound
                -> DsM (Id,[(Id,CoreExpr)])
                -- ^ Id the rhs is bound to, for desugaring strict
                -- binds (see Note [Desugar Strict binds] in DsBinds)
                -- and all the desugared binds

mkSelectorBinds :: [[Tickish Id]]
-> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])
mkSelectorBinds [[Tickish Id]]
ticks LPat GhcTc
pat CoreExpr
val_expr
  | (LPat GhcTc -> Located (SrcSpanLess (Located (Pat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (VarPat _ (dL->L _ v))) <- LPat GhcTc
pat'     -- Special case (A)
  = (Id, [(Id, CoreExpr)]) -> DsM (Id, [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanLess (Located Id)
Id
v, [(SrcSpanLess (Located Id)
Id
v, CoreExpr
val_expr)])

  | LPat GhcTc -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_flat_prod_lpat LPat GhcTc
pat'           -- Special case (B)
  = do { let pat_ty :: Type
pat_ty = LPat GhcTc -> Type
hsLPatType LPat GhcTc
pat'
       ; Id
val_var <- Type -> DsM Id
newSysLocalDsNoLP Type
pat_ty

       ; let mk_bind :: [Tickish Id] -> Id -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
mk_bind [Tickish Id]
tick Id
bndr_var
               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
               -- Remember, 'pat' binds 'bv'
               = do { CoreExpr
rhs_expr <- CoreExpr
-> HsMatchContext Name
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
val_var) HsMatchContext Name
forall id. HsMatchContext id
PatBindRhs LPat GhcTc
pat'
                                       (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bndr_var)
                                       (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bndr_var)  -- Neat hack
                      -- Neat hack: since 'pat' can't fail, the
                      -- "fail-expr" passed to matchSimply is not
                      -- used. But it /is/ used for its type, and for
                      -- that bndr_var is just the ticket.
                    ; (Id, CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr_var, [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox [Tickish Id]
tick CoreExpr
rhs_expr) }

       ; [(Id, CoreExpr)]
binds <- ([Tickish Id]
 -> Id -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr))
-> [[Tickish Id]]
-> [Id]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM [Tickish Id] -> Id -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
mk_bind [[Tickish Id]]
ticks' [Id]
[IdP GhcTc]
binders
       ; (Id, [(Id, CoreExpr)]) -> DsM (Id, [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ( Id
val_var, (Id
val_var, CoreExpr
val_expr) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
binds) }

  | Bool
otherwise                          -- General case (C)
  = do { Id
tuple_var  <- Type -> DsM Id
newSysLocalDs Type
tuple_ty
       ; CoreExpr
error_expr <- Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
pAT_ERROR_ID Type
tuple_ty (Located (Pat GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (Pat GhcTc)
LPat GhcTc
pat')
       ; CoreExpr
tuple_expr <- CoreExpr
-> HsMatchContext Name
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply CoreExpr
val_expr HsMatchContext Name
forall id. HsMatchContext id
PatBindRhs LPat GhcTc
pat
                                   CoreExpr
local_tuple CoreExpr
error_expr
       ; let mk_tup_bind :: [Tickish Id] -> Id -> (Id, CoreExpr)
mk_tup_bind [Tickish Id]
tick Id
binder
               = (Id
binder, [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox [Tickish Id]
tick (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                          [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkTupleSelector1 [Id]
local_binders Id
binder
                                           Id
tuple_var (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tuple_var))
             tup_binds :: [(Id, CoreExpr)]
tup_binds = ([Tickish Id] -> Id -> (Id, CoreExpr))
-> [[Tickish Id]] -> [Id] -> [(Id, CoreExpr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Tickish Id] -> Id -> (Id, CoreExpr)
mk_tup_bind [[Tickish Id]]
ticks' [Id]
[IdP GhcTc]
binders
       ; (Id, [(Id, CoreExpr)]) -> DsM (Id, [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
tuple_var, (Id
tuple_var, CoreExpr
tuple_expr) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
tup_binds) }
  where
    pat' :: LPat GhcTc
pat' = LPat GhcTc -> LPat GhcTc
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
strip_bangs LPat GhcTc
pat
           -- Strip the bangs before looking for case (A) or (B)
           -- The incoming pattern may well have a bang on it

    binders :: [IdP GhcTc]
binders = LPat GhcTc -> [IdP GhcTc]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcTc
pat'
    ticks' :: [[Tickish Id]]
ticks'  = [[Tickish Id]]
ticks [[Tickish Id]] -> [[Tickish Id]] -> [[Tickish Id]]
forall a. [a] -> [a] -> [a]
++ [Tickish Id] -> [[Tickish Id]]
forall a. a -> [a]
repeat []

    local_binders :: [Id]
local_binders = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
localiseId [Id]
[IdP GhcTc]
binders      -- See Note [Localise pattern binders]
    local_tuple :: CoreExpr
local_tuple   = [Id] -> CoreExpr
mkBigCoreVarTup1 [Id]
[IdP GhcTc]
binders
    tuple_ty :: Type
tuple_ty      = CoreExpr -> Type
exprType CoreExpr
local_tuple

strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
-- Remove outermost bangs and parens
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
strip_bangs (LPat (GhcPass p)
-> Located (SrcSpanLess (Located (Pat (GhcPass p))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (ParPat _ p))  = LPat (GhcPass p) -> LPat (GhcPass p)
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
strip_bangs LPat (GhcPass p)
p
strip_bangs (LPat (GhcPass p)
-> Located (SrcSpanLess (Located (Pat (GhcPass p))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (BangPat _ p)) = LPat (GhcPass p) -> LPat (GhcPass p)
forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
strip_bangs LPat (GhcPass p)
p
strip_bangs LPat (GhcPass p)
lp                      = LPat (GhcPass p)
lp

is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
is_flat_prod_lpat = Pat (GhcPass p) -> Bool
forall (p :: Pass). Pat (GhcPass p) -> Bool
is_flat_prod_pat (Pat (GhcPass p) -> Bool)
-> (Located (Pat (GhcPass p)) -> Pat (GhcPass p))
-> Located (Pat (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Pat (GhcPass p)) -> Pat (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

is_flat_prod_pat :: Pat (GhcPass p) -> Bool
is_flat_prod_pat :: Pat (GhcPass p) -> Bool
is_flat_prod_pat (ParPat XParPat (GhcPass p)
_ LPat (GhcPass p)
p)          = LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_flat_prod_lpat LPat (GhcPass p)
p
is_flat_prod_pat (TuplePat XTuplePat (GhcPass p)
_ [LPat (GhcPass p)]
ps Boxity
Boxed) = (Located (Pat (GhcPass p)) -> Bool)
-> [Located (Pat (GhcPass p))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Located (Pat (GhcPass p)) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat [Located (Pat (GhcPass p))]
[LPat (GhcPass p)]
ps
is_flat_prod_pat (ConPatOut { pat_con :: forall p. Pat p -> Located ConLike
pat_con  = (Located ConLike -> Located (SrcSpanLess (Located ConLike))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located ConLike)
pcon)
                            , pat_args :: forall p. Pat p -> HsConPatDetails p
pat_args = HsConPatDetails (GhcPass p)
ps})
  | RealDataCon con <- SrcSpanLess (Located ConLike)
pcon
  , TyCon -> Bool
isProductTyCon (DataCon -> TyCon
dataConTyCon DataCon
con)
  = (Located (Pat (GhcPass p)) -> Bool)
-> [Located (Pat (GhcPass p))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Located (Pat (GhcPass p)) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat (HsConPatDetails (GhcPass p) -> [LPat (GhcPass p)]
forall p. HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails (GhcPass p)
ps)
is_flat_prod_pat Pat (GhcPass p)
_ = Bool
False

is_triv_lpat :: LPat (GhcPass p) -> Bool
is_triv_lpat :: LPat (GhcPass p) -> Bool
is_triv_lpat = Pat (GhcPass p) -> Bool
forall (p :: Pass). Pat (GhcPass p) -> Bool
is_triv_pat (Pat (GhcPass p) -> Bool)
-> (Located (Pat (GhcPass p)) -> Pat (GhcPass p))
-> Located (Pat (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Pat (GhcPass p)) -> Pat (GhcPass p)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

is_triv_pat :: Pat (GhcPass p) -> Bool
is_triv_pat :: Pat (GhcPass p) -> Bool
is_triv_pat (VarPat {})  = Bool
True
is_triv_pat (WildPat{})  = Bool
True
is_triv_pat (ParPat XParPat (GhcPass p)
_ LPat (GhcPass p)
p) = LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat LPat (GhcPass p)
p
is_triv_pat Pat (GhcPass p)
_            = Bool
False


{- *********************************************************************
*                                                                      *
  Creating big tuples and their types for full Haskell expressions.
  They work over *Ids*, and create tuples replete with their types,
  which is whey they are not in GHC.Hs.Utils.
*                                                                      *
********************************************************************* -}

mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup []     = SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc))
-> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc] -> Boxity -> Pat GhcTc
mkVanillaTuplePat [] Boxity
Boxed
mkLHsPatTup [LPat GhcTc
lpat] = LPat GhcTc
lpat
mkLHsPatTup [LPat GhcTc]
lpats  = SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (Located (Pat GhcTc) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc ([Located (Pat GhcTc)] -> Located (Pat GhcTc)
forall a. [a] -> a
head [Located (Pat GhcTc)]
[LPat GhcTc]
lpats)) (SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc))
-> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$
                     [LPat GhcTc] -> Boxity -> Pat GhcTc
mkVanillaTuplePat [LPat GhcTc]
lpats Boxity
Boxed

mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc
mkVanillaTuplePat [LPat GhcTc]
pats Boxity
box = XTuplePat GhcTc -> [LPat GhcTc] -> Boxity -> Pat GhcTc
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat ((Located (Pat GhcTc) -> Type) -> [Located (Pat GhcTc)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcTc) -> Type
LPat GhcTc -> Type
hsLPatType [Located (Pat GhcTc)]
[LPat GhcTc]
pats) [LPat GhcTc]
pats Boxity
box

-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
mkBigLHsVarTupId [Id]
ids = [LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId ((Id -> LHsExpr GhcTc) -> [Id] -> [LHsExpr GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [Id]
ids)

mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId = ([LHsExpr GhcTc] -> LHsExpr GhcTc)
-> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall a. ([a] -> a) -> [a] -> a
mkChunkified [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsTupleExpr

-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
mkBigLHsVarPatTupId [Id]
bs = [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId ((Id -> Located (Pat GhcTc)) -> [Id] -> [Located (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Located (Pat GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id]
bs)

mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId = ([Located (Pat GhcTc)] -> Located (Pat GhcTc))
-> [Located (Pat GhcTc)] -> Located (Pat GhcTc)
forall a. ([a] -> a) -> [a] -> a
mkChunkified [Located (Pat GhcTc)] -> Located (Pat GhcTc)
[LPat GhcTc] -> LPat GhcTc
mkLHsPatTup

{-
************************************************************************
*                                                                      *
        Code for pattern-matching and other failures
*                                                                      *
************************************************************************

Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
        let fail.33 = error "Help"
        in
        case x of
                p1 -> ...
                p2 -> fail.33
                p3 -> fail.33
                p4 -> ...
\end{verbatim}
Then
\begin{itemize}
\item
If the case can't fail, then there'll be no mention of @fail.33@, and the
simplifier will later discard it.

\item
If it can fail in only one way, then the simplifier will inline it.

\item
Only if it is used more than once will the let-binding remain.
\end{itemize}

There's a problem when the result of the case expression is of
unboxed type.  Then the type of @fail.33@ is unboxed too, and
there is every chance that someone will change the let into a case:
\begin{verbatim}
        case error "Help" of
          fail.33 -> case ....
\end{verbatim}

which is of course utterly wrong.  Rather than drop the condition that
only boxed types can be let-bound, we just turn the fail into a function
for the primitive case:
\begin{verbatim}
        let fail.33 :: Void -> Int#
            fail.33 = \_ -> error "Help"
        in
        case x of
                p1 -> ...
                p2 -> fail.33 void
                p3 -> fail.33 void
                p4 -> ...
\end{verbatim}

Now @fail.33@ is a function, so it can be let-bound.

We would *like* to use join points here; in fact, these "fail variables" are
paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
CPS functions - i.e. they take "join points" as parameters. It's not impossible
to imagine extending our type system to allow passing join points around (very
carefully), but we certainly don't support it now.

99.99% of the time, the fail variables wind up as join points in short order
anyway, and the Void# doesn't do much harm.
-}

mkFailurePair :: CoreExpr       -- Result type of the whole case expression
              -> DsM (CoreBind, -- Binds the newly-created fail variable
                                -- to \ _ -> expression
                      CoreExpr) -- Fail variable applied to realWorld#
-- See Note [Failure thunks and CPR]
mkFailurePair :: CoreExpr -> DsM (CoreBind, CoreExpr)
mkFailurePair CoreExpr
expr
  = do { Id
fail_fun_var <- Type -> DsM Id
newFailLocalDs (Type
voidPrimTy Type -> Type -> Type
`mkVisFunTy` Type
ty)
       ; Id
fail_fun_arg <- Type -> DsM Id
newSysLocalDs Type
voidPrimTy
       ; let real_arg :: Id
real_arg = Id -> Id
setOneShotLambda Id
fail_fun_arg
       ; (CoreBind, CoreExpr) -> DsM (CoreBind, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
fail_fun_var (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
real_arg CoreExpr
expr),
                 CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fail_fun_var) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
voidPrimId)) }
  where
    ty :: Type
ty = CoreExpr -> Type
exprType CoreExpr
expr

{-
Note [Failure thunks and CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(This note predates join points as formal entities (hence the quotation marks).
We can't use actual join points here (see above); if we did, this would also
solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
join points] in WorkWrap.)

When we make a failure point we ensure that it
does not look like a thunk. Example:

   let fail = \rw -> error "urk"
   in case x of
        [] -> fail realWorld#
        (y:ys) -> case ys of
                    [] -> fail realWorld#
                    (z:zs) -> (y,z)

Reason: we know that a failure point is always a "join point" and is
entered at most once.  Adding a dummy 'realWorld' token argument makes
it clear that sharing is not an issue.  And that in turn makes it more
CPR-friendly.  This matters a lot: if you don't get it right, you lose
the tail call property.  For example, see #3403.


************************************************************************
*                                                                      *
              Ticks
*                                                                      *
********************************************************************* -}

mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox = (CoreExpr -> [Tickish Id] -> CoreExpr)
-> [Tickish Id] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Tickish Id -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick)

mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox Int
ixT Int
ixF CoreExpr
e = do
       Unique
uq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       let bndr1 :: Id
bndr1 = FastString -> Unique -> Type -> Id
mkSysLocal (String -> FastString
fsLit String
"t1") Unique
uq Type
boolTy
       let
           falseBox :: CoreExpr
falseBox = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Module -> Int -> Tickish Id
forall id. Module -> Int -> Tickish id
HpcTick Module
this_mod Int
ixF) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
falseDataConId)
           trueBox :: CoreExpr
trueBox  = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Module -> Int -> Tickish Id
forall id. Module -> Int -> Tickish id
HpcTick Module
this_mod Int
ixT) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
trueDataConId)
       --
       CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
e Id
bndr1 Type
boolTy
                       [ (DataCon -> AltCon
DataAlt DataCon
falseDataCon, [], CoreExpr
falseBox)
                       , (DataCon -> AltCon
DataAlt DataCon
trueDataCon,  [], CoreExpr
trueBox)
                       ]



-- *******************************************************************

{- Note [decideBangHood]
~~~~~~~~~~~~~~~~~~~~~~~~
With -XStrict we may make /outermost/ patterns more strict.
E.g.
       let (Just x) = e in ...
          ==>
       let !(Just x) = e in ...
and
       f x = e
          ==>
       f !x = e

This adjustment is done by decideBangHood,

  * Just before constructing an EqnInfo, in Match
      (matchWrapper and matchSinglePat)

  * When desugaring a pattern-binding in DsBinds.dsHsBind

Note that it is /not/ done recursively.  See the -XStrict
spec in the user manual.

Specifically:
   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
   !pat    => !pat   -- always
   pat     => !pat   -- when -XStrict
   pat     => pat    -- otherwise
-}


-- | Use -XStrict to add a ! or remove a ~
-- See Note [decideBangHood]
decideBangHood :: DynFlags
               -> LPat GhcTc  -- ^ Original pattern
               -> LPat GhcTc  -- Pattern with bang if necessary
decideBangHood :: DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
lpat
  | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags)
  = LPat GhcTc
lpat
  | Bool
otherwise   --  -XStrict
  = LPat GhcTc -> LPat GhcTc
forall p.
(HasSrcSpan (XRec p Pat), SrcSpanLess (XRec p Pat) ~ Pat p,
 XBangPat p ~ NoExtField) =>
XRec p Pat -> XRec p Pat
go LPat GhcTc
lpat
  where
    go :: XRec p Pat -> XRec p Pat
go lp :: XRec p Pat
lp@(XRec p Pat -> Located (SrcSpanLess (XRec p Pat))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (XRec p Pat)
p)
      = case SrcSpanLess (XRec p Pat)
p of
           ParPat x p    -> SrcSpan -> SrcSpanLess (XRec p Pat) -> XRec p Pat
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XParPat p -> XRec p Pat -> Pat p
forall p. XParPat p -> LPat p -> Pat p
ParPat XParPat p
x (XRec p Pat -> XRec p Pat
go XRec p Pat
p))
           LazyPat _ lp' -> XRec p Pat
lp'
           BangPat _ _   -> XRec p Pat
lp
           SrcSpanLess (XRec p Pat)
_             -> SrcSpan -> SrcSpanLess (XRec p Pat) -> XRec p Pat
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat p -> XRec p Pat -> Pat p
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat p
NoExtField
noExtField XRec p Pat
lp)

-- | Unconditionally make a 'Pat' strict.
addBang :: LPat GhcTc -- ^ Original pattern
        -> LPat GhcTc -- ^ Banged pattern
addBang :: LPat GhcTc -> LPat GhcTc
addBang = LPat GhcTc -> LPat GhcTc
forall p.
(HasSrcSpan (XRec p Pat), XBangPat p ~ NoExtField,
 SrcSpanLess (XRec p Pat) ~ Pat p) =>
XRec p Pat -> XRec p Pat
go
  where
    go :: XRec p Pat -> XRec p Pat
go lp :: XRec p Pat
lp@(XRec p Pat -> Located (SrcSpanLess (XRec p Pat))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (XRec p Pat)
p)
      = case SrcSpanLess (XRec p Pat)
p of
           ParPat x p    -> SrcSpan -> SrcSpanLess (XRec p Pat) -> XRec p Pat
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XParPat p -> XRec p Pat -> Pat p
forall p. XParPat p -> LPat p -> Pat p
ParPat XParPat p
x (XRec p Pat -> XRec p Pat
go XRec p Pat
p))
           LazyPat _ lp' -> SrcSpan -> SrcSpanLess (XRec p Pat) -> XRec p Pat
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat p -> XRec p Pat -> Pat p
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat p
NoExtField
noExtField XRec p Pat
lp')
                                  -- Should we bring the extension value over?
           BangPat _ _   -> XRec p Pat
lp
           SrcSpanLess (XRec p Pat)
_             -> SrcSpan -> SrcSpanLess (XRec p Pat) -> XRec p Pat
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat p -> XRec p Pat -> Pat p
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat p
NoExtField
noExtField XRec p Pat
lp)

isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)

-- Returns Just {..} if we're sure that the expression is True
-- I.e.   * 'True' datacon
--        * 'otherwise' Id
--        * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsVar _ (dL->L _ v)))
  |  SrcSpanLess (Located Id)
Id
v Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
otherwiseIdKey
     Bool -> Bool -> Bool
|| SrcSpanLess (Located Id)
Id
v Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
trueDataConId
                                              = (CoreExpr -> DsM CoreExpr) -> Maybe (CoreExpr -> DsM CoreExpr)
forall a. a -> Maybe a
Just CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return
        -- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsConLikeOut _ con))
  | ConLike
con ConLike -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
trueDataCon = (CoreExpr -> DsM CoreExpr) -> Maybe (CoreExpr -> DsM CoreExpr)
forall a. a -> Maybe a
Just CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return
isTrueLHsExpr (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsTick _ tickish e))
    | Just CoreExpr -> DsM CoreExpr
ticks <- LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e
    = (CoreExpr -> DsM CoreExpr) -> Maybe (CoreExpr -> DsM CoreExpr)
forall a. a -> Maybe a
Just (\CoreExpr
x -> do CoreExpr
wrapped <- CoreExpr -> DsM CoreExpr
ticks CoreExpr
x
                     CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
Tickish (IdP GhcTc)
tickish CoreExpr
wrapped))
   -- This encodes that the result is constant True for Hpc tick purposes;
   -- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsBinTick _ ixT _ e))
    | Just CoreExpr -> DsM CoreExpr
ticks <- LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e
    = (CoreExpr -> DsM CoreExpr) -> Maybe (CoreExpr -> DsM CoreExpr)
forall a. a -> Maybe a
Just (\CoreExpr
x -> do CoreExpr
e <- CoreExpr -> DsM CoreExpr
ticks CoreExpr
x
                     Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
                     CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Module -> Int -> Tickish Id
forall id. Module -> Int -> Tickish id
HpcTick Module
this_mod Int
ixT) CoreExpr
e))

isTrueLHsExpr (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsPar _ e))   = LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e
isTrueLHsExpr LHsExpr GhcTc
_                       = Maybe (CoreExpr -> DsM CoreExpr)
forall a. Maybe a
Nothing