{-
(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
        mkLHsVarPatTup, 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 HsSyn
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 pat :: LPat GhcTc
pat = LPat GhcTc -> DsM Id
selectMatchVar (LPat GhcTc -> SrcSpanLess (LPat GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc 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 :: [LPat GhcTc] -> DsM [Id]
selectMatchVars ps :: [LPat GhcTc]
ps = (LPat GhcTc -> DsM Id) -> [LPat GhcTc] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcTc -> DsM Id
selectMatchVar [LPat GhcTc]
ps

selectMatchVar :: Pat GhcTc -> DsM Id
-- Postcondition: the returned Id has an Internal Name
selectMatchVar :: LPat GhcTc -> DsM Id
selectMatchVar (BangPat _ pat :: LPat GhcTc
pat) = LPat GhcTc -> DsM Id
selectMatchVar (LPat GhcTc -> SrcSpanLess (LPat GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcTc
pat)
selectMatchVar (LazyPat _ pat :: LPat GhcTc
pat) = LPat GhcTc -> DsM Id
selectMatchVar (LPat GhcTc -> SrcSpanLess (LPat GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcTc
pat)
selectMatchVar (ParPat _ pat :: LPat GhcTc
pat)  = LPat GhcTc -> DsM Id
selectMatchVar (LPat GhcTc -> SrcSpanLess (LPat GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcTc
pat)
selectMatchVar (VarPat _ var :: 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 _ var :: Located (IdP GhcTc)
var _) = 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 other_pat :: LPat GhcTc
other_pat       = Type -> DsM Id
newSysLocalDsNoLP (LPat GhcTc -> Type
hsPatType LPat 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 -> LPat GhcTc
firstPat eqn :: 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 eqns :: [EquationInfo]
eqns = [ EquationInfo
eqn { eqn_pats :: [LPat GhcTc]
eqn_pats = [LPat GhcTc] -> [LPat GhcTc]
forall a. [a] -> [a]
tail (EquationInfo -> [LPat GhcTc]
eqn_pats EquationInfo
eqn) } | EquationInfo
eqn <- [EquationInfo]
eqns ]

-- Functions on MatchResults

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

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

cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult expr :: CoreExpr
expr = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CantFail (\_ -> 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 CantFail match_fn :: CoreExpr -> DsM CoreExpr
match_fn) _
  = CoreExpr -> DsM CoreExpr
match_fn (String -> CoreExpr
forall a. HasCallStack => String -> a
error "It can't fail!")

extractMatchResult (MatchResult CanFail match_fn :: CoreExpr -> DsM CoreExpr
match_fn) fail_expr :: CoreExpr
fail_expr = do
    (fail_bind :: CoreBind
fail_bind, if_it_fails :: 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 CanFail      body_fn1 :: CoreExpr -> DsM CoreExpr
body_fn1)
                    (MatchResult can_it_fail2 :: CanItFail
can_it_fail2 body_fn2 :: 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 fail :: CoreExpr
fail = do CoreExpr
body2 <- CoreExpr -> DsM CoreExpr
body_fn2 CoreExpr
fail
                      (fail_bind :: CoreBind
fail_bind, duplicatable_expr :: 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 CantFail _) _
  = MatchResult
match_result1

adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult encl_fn :: CoreExpr -> CoreExpr
encl_fn (MatchResult can_it_fail :: CanItFail
can_it_fail body_fn :: CoreExpr -> DsM CoreExpr
body_fn)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
can_it_fail (\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 encl_fn :: CoreExpr -> DsM CoreExpr
encl_fn (MatchResult can_it_fail :: CanItFail
can_it_fail body_fn :: CoreExpr -> DsM CoreExpr
body_fn)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
can_it_fail (\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 [] e :: CoreExpr
e = CoreExpr
e
wrapBinds ((new :: Id
new,old :: Id
old):prs :: [(Id, Id)]
prs) e :: 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 new :: Id
new old :: Id
old body :: 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 var :: Id
var body :: CoreExpr
body = 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 (CoreExpr -> Type
exprType CoreExpr
body)
                        [(AltCon
DEFAULT, [], CoreExpr
body)]

mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind :: 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 var' :: Id
var' viewExpr :: 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 var :: Id
var ty :: Type
ty
  = (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult (\e :: 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 pred_expr :: CoreExpr
pred_expr (MatchResult _ body_fn :: CoreExpr -> DsM CoreExpr
body_fn)
  = CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CanFail (\fail :: 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 var :: Id
var ty :: Type
ty match_alts :: [(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 fail :: 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 fail :: CoreExpr
fail (lit :: Literal
lit, MatchResult _ body_fn :: 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 var :: Id
var ty :: Type
ty match_alts :: [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
    (tc :: TyCon
tc, ty_args :: [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 var :: Id
var ty :: Type
ty alt :: 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 var :: Id
var ty :: Type
ty alt :: CaseAlt PatSyn
alt fail :: 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 _ mkCont :: 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 "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
    (matcher :: Id
matcher, needs_void_lam :: 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 cont :: 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 _   _  []            = String -> MatchResult
forall a. String -> a
panic "mkDataConCase: no alternatives"
mkDataConCase var :: Id
var ty :: Type
ty alts :: [CaseAlt DataCon]
alts@(alt1 :: CaseAlt DataCon
alt1:_) = 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
    (_, ty_args :: [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 fail :: 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 fail :: 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 _ body_fn :: CoreExpr -> DsM CoreExpr
body_fn }
      = do { CoreExpr
body <- CoreExpr -> DsM CoreExpr
body_fn CoreExpr
fail
           ; case DataCon -> Maybe DataConBoxer
dataConBoxer DataCon
con of {
                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 boxer :: [Type] -> [Id] -> UniqSM ([Id], [CoreBind])
boxer) ->
        do { UniqSupply
us <- TcRnIf DsGblEnv DsLclEnv UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
           ; let (rep_ids :: [Id]
rep_ids, binds :: [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 fail :: 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 can_it_fail :: CanItFail
can_it_fail _ <- [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 err_id :: Id
err_id ty :: Type
ty msg :: 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' hand the special-case desugaring of 'seq'.

Note [Desugaring seq (1)]  cf Trac #1031
~~~~~~~~~~~~~~~~~~~~~~~~~
   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 #)

Note [Desugaring seq (2)]  cf Trac #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.

Note [Desugaring seq (3)] cf Trac #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 _ (Var f :: Id
f `App` Type ty1 :: Type
ty1 `App` Type ty2 :: Type
ty2 `App` arg1 :: CoreExpr
arg1) arg2 :: CoreExpr
arg2
  | Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey            -- Note [Desugaring seq (1), (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 v1 :: Id
v1 | Name -> Bool
isInternalName (Id -> Name
idName Id
v1)
                          -> Id
v1        -- Note [Desugaring seq (2) and (3)]
                   _      -> Type -> Id
mkWildValBinder Type
ty1

mkCoreAppDs s :: SDoc
s fun :: CoreExpr
fun arg :: 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 s :: SDoc
s fun :: CoreExpr
fun args :: [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 e :: CoreExpr
e co :: 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 ticks :: [[Tickish Id]]
ticks pat :: LPat GhcTc
pat val_expr :: CoreExpr
val_expr
  | (LPat GhcTc -> Located (SrcSpanLess (LPat GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (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 tick :: [Tickish Id]
tick bndr_var :: 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 (LPat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 tick :: [Tickish Id]
tick binder :: 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 (LPat (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (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 (LPat (GhcPass p)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (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 lp :: 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 = LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_flat_prod_pat (LPat (GhcPass p) -> Bool)
-> (LPat (GhcPass p) -> LPat (GhcPass p))
-> LPat (GhcPass p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat (GhcPass p) -> LPat (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 _ p :: Pat (GhcPass p)
p)          = Pat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_flat_prod_lpat Pat (GhcPass p)
p
is_flat_prod_pat (TuplePat _ ps :: [Pat (GhcPass p)]
ps Boxed) = (Pat (GhcPass p) -> Bool) -> [Pat (GhcPass p)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat [Pat (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 _ pcon :: 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)
  = (Pat (GhcPass p) -> Bool) -> [Pat (GhcPass p)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat (HsConPatDetails (GhcPass p) -> [Pat (GhcPass p)]
forall p. HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails (GhcPass p)
ps)
is_flat_prod_pat _ = Bool
False

is_triv_lpat :: LPat (GhcPass p) -> Bool
is_triv_lpat :: LPat (GhcPass p) -> Bool
is_triv_lpat = LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_pat (LPat (GhcPass p) -> Bool)
-> (LPat (GhcPass p) -> LPat (GhcPass p))
-> LPat (GhcPass p)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat (GhcPass p) -> LPat (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 _ p :: Pat (GhcPass p)
p) = Pat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat Pat (GhcPass p)
p
is_triv_pat _            = 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 HsUtils.
*                                                                      *
********************************************************************* -}

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

mkLHsVarPatTup :: [Id] -> LPat GhcTc
mkLHsVarPatTup :: [Id] -> LPat GhcTc
mkLHsVarPatTup bs :: [Id]
bs  = [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup ((Id -> LPat GhcTc) -> [Id] -> [LPat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LPat GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id]
bs)

mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> LPat GhcTc
mkVanillaTuplePat pats :: [LPat GhcTc]
pats box :: Boxity
box = XTuplePat GhcTc -> [LPat GhcTc] -> Boxity -> LPat GhcTc
forall p. XTuplePat p -> [Pat p] -> Boxity -> Pat p
TuplePat ((LPat GhcTc -> Type) -> [LPat GhcTc] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> Type
hsLPatType [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 ids :: [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 bs :: [Id]
bs = [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId ((Id -> LPat GhcTc) -> [Id] -> [LPat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LPat GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id]
bs)

mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId = ([LPat GhcTc] -> LPat GhcTc) -> [LPat GhcTc] -> LPat GhcTc
forall a. ([a] -> a) -> [a] -> a
mkChunkified [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 expr :: CoreExpr
expr
  = do { Id
fail_fun_var <- Type -> DsM Id
newFailLocalDs (Type
voidPrimTy Type -> Type -> Type
`mkFunTy` 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 Trac #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 ixT :: Int
ixT ixF :: Int
ixF e :: 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 "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 dflags :: DynFlags
dflags lpat :: 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 (LPat p), SrcSpanLess (LPat p) ~ LPat p,
 XBangPat p ~ NoExt) =>
LPat p -> LPat p
go LPat GhcTc
lpat
  where
    go :: LPat p -> LPat p
go lp :: LPat p
lp@(LPat p -> Located (SrcSpanLess (LPat p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l p :: SrcSpanLess (LPat p)
p)
      = case SrcSpanLess (LPat p)
p of
           ParPat x p    -> SrcSpan -> SrcSpanLess (LPat p) -> LPat p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XParPat p -> LPat p -> LPat p
forall p. XParPat p -> Pat p -> Pat p
ParPat XParPat p
x (LPat p -> LPat p
go LPat p
p))
           LazyPat _ lp' -> LPat p
lp'
           BangPat _ _   -> LPat p
lp
           _             -> SrcSpan -> SrcSpanLess (LPat p) -> LPat p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat p -> LPat p -> LPat p
forall p. XBangPat p -> Pat p -> Pat p
BangPat XBangPat p
NoExt
noExt LPat p
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 (LPat p), SrcSpanLess (LPat p) ~ LPat p,
 XBangPat p ~ NoExt) =>
LPat p -> LPat p
go
  where
    go :: LPat p -> LPat p
go lp :: LPat p
lp@(LPat p -> Located (SrcSpanLess (LPat p))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L l :: SrcSpan
l p :: SrcSpanLess (LPat p)
p)
      = case SrcSpanLess (LPat p)
p of
           ParPat x p    -> SrcSpan -> SrcSpanLess (LPat p) -> LPat p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XParPat p -> LPat p -> LPat p
forall p. XParPat p -> Pat p -> Pat p
ParPat XParPat p
x (LPat p -> LPat p
go LPat p
p))
           LazyPat _ lp' -> SrcSpan -> SrcSpanLess (LPat p) -> LPat p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat p -> LPat p -> LPat p
forall p. XBangPat p -> Pat p -> Pat p
BangPat XBangPat p
NoExt
noExt LPat p
lp')
                                  -- Should we bring the extension value over?
           BangPat _ _   -> LPat p
lp
           _             -> SrcSpan -> SrcSpanLess (LPat p) -> LPat p
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat p -> LPat p -> LPat p
forall p. XBangPat p -> Pat p -> Pat p
BangPat XBangPat p
NoExt
noExt LPat p
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 _ (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 _ (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 _ (HsTick _ tickish e))
    | Just ticks :: 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 (\x :: 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 _ (HsBinTick _ ixT _ e))
    | Just ticks :: 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 (\x :: 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 _ (HsPar _ e))   = LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e
isTrueLHsExpr _                       = Maybe (CoreExpr -> DsM CoreExpr)
forall a. Maybe a
Nothing