{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
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,
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 )
selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
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 :: [Pat GhcTc] -> DsM [Id]
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
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))
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)
firstPat :: EquationInfo -> Pat GhcTc
firstPat :: EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
shiftEqns :: [EquationInfo] -> [EquationInfo]
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 ]
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
(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
| Id
newId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==Id
old = CoreExpr
body
| 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 :: 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
-> Type
-> [(Literal, MatchResult)]
-> MatchResult
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
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
-> Type
-> [CaseAlt DataCon]
-> MatchResult
mkCoAlgCaseMatchResult :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkCoAlgCaseMatchResult Id
var Type
ty [CaseAlt DataCon]
match_alts
| Bool
isNewtype
= 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))
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
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
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
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
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
mkErrorAppDs :: Id
-> Type
-> SDoc
-> 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)
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 :: 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
= 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
CoreExpr
_ -> Type -> Id
mkWildValBinder Type
ty1
mkCoreAppDs SDoc
s CoreExpr
fun CoreExpr
arg = SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp SDoc
s CoreExpr
fun CoreExpr
arg
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
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
mkSelectorBinds :: [[Tickish Id]]
-> LPat GhcTc
-> CoreExpr
-> DsM (Id,[(Id,CoreExpr)])
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'
= (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'
= 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
= 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)
; (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
= 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
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
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)
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
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
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
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
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
mkFailurePair :: CoreExpr
-> DsM (CoreBind,
CoreExpr)
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
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)
]
decideBangHood :: DynFlags
-> LPat GhcTc
-> LPat GhcTc
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
= 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)
addBang :: LPat GhcTc
-> LPat GhcTc
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')
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)
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
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))
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