{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.HsToCore.Utils (
EquationInfo(..),
firstPat, shiftEqns,
MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResultDs,
shareFailureHandler,
dsHandleMonadicFailure,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
wrapBind, wrapBinds,
mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
mkFailExpr,
seqVar,
mkLHsPatTup, mkVanillaTuplePat,
mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
mkSelectorBinds,
selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
mkOptTickBox, mkBinaryTickBox, decideBangHood,
isTrueLHsExpr
) where
import GHC.Prelude
import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr )
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Tc.Utils.TcType( tcSplitTyConApp )
import GHC.Core
import GHC.HsToCore.Monad
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Types.Id.Make
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Builtin.Types
import GHC.Types.Basic
import GHC.Core.ConLike
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
import GHC.Unit.Module
import GHC.Builtin.Names
import GHC.Types.Name( isInternalName )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Tc.Types.Evidence
import Control.Monad ( zipWithM )
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (maybeToList)
import qualified Data.List.NonEmpty as NEL
selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL Mult
w LPat GhcTc
pat = Mult -> Pat GhcTc -> DsM Id
selectMatchVar Mult
w (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id]
selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id]
selectMatchVars [(Mult, Pat GhcTc)]
ps = ((Mult, Pat GhcTc) -> DsM Id) -> [(Mult, Pat GhcTc)] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Mult -> Pat GhcTc -> DsM Id) -> (Mult, Pat GhcTc) -> DsM Id
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Mult -> Pat GhcTc -> DsM Id
selectMatchVar) [(Mult, Pat GhcTc)]
ps
selectMatchVar :: Mult -> Pat GhcTc -> DsM Id
selectMatchVar :: Mult -> Pat GhcTc -> DsM Id
selectMatchVar Mult
w (BangPat XBangPat GhcTc
_ LPat GhcTc
pat) = Mult -> Pat GhcTc -> DsM Id
selectMatchVar Mult
w (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
selectMatchVar Mult
w (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat) = Mult -> Pat GhcTc -> DsM Id
selectMatchVar Mult
w (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
selectMatchVar Mult
w (ParPat XParPat GhcTc
_ LHsToken "(" GhcTc
_ LPat GhcTc
pat LHsToken ")" GhcTc
_) = Mult -> Pat GhcTc -> DsM Id
selectMatchVar Mult
w (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
selectMatchVar Mult
_w (VarPat XVarPat GhcTc
_ LIdP GhcTc
var) = Id -> DsM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id
localiseId (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
var))
selectMatchVar Mult
_w (AsPat XAsPat GhcTc
_ LIdP GhcTc
var LPat GhcTc
_) = Bool -> DsM Id -> DsM Id
forall a. HasCallStack => Bool -> a -> a
assert (Mult -> Bool
isManyDataConTy Mult
_w ) (Id -> DsM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnN Id -> Id
forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
GenLocated SrcSpanAnnN Id
var))
selectMatchVar Mult
w Pat GhcTc
other_pat = Mult -> Mult -> DsM Id
newSysLocalDs Mult
w (Pat GhcTc -> Mult
hsPatType Pat GhcTc
other_pat)
firstPat :: EquationInfo -> Pat GhcTc
firstPat :: EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn = Bool -> Pat GhcTc -> Pat GhcTc
forall a. HasCallStack => Bool -> a -> a
assert ([Pat GhcTc] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull (EquationInfo -> [Pat GhcTc]
eqn_pats EquationInfo
eqn)) (Pat GhcTc -> Pat GhcTc) -> Pat GhcTc -> Pat GhcTc
forall a b. (a -> b) -> a -> b
$ [Pat GhcTc] -> Pat GhcTc
forall a. [a] -> a
head (EquationInfo -> [Pat GhcTc]
eqn_pats EquationInfo
eqn)
shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
shiftEqns :: f EquationInfo -> f EquationInfo
shiftEqns = (EquationInfo -> EquationInfo) -> f EquationInfo -> f EquationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((EquationInfo -> EquationInfo)
-> f EquationInfo -> f EquationInfo)
-> (EquationInfo -> EquationInfo)
-> f EquationInfo
-> f EquationInfo
forall a b. (a -> b) -> a -> b
$ \EquationInfo
eqn -> EquationInfo
eqn { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc] -> [Pat GhcTc]
forall a. [a] -> [a]
tail (EquationInfo -> [Pat GhcTc]
eqn_pats EquationInfo
eqn) }
matchCanFail :: MatchResult a -> Bool
matchCanFail :: MatchResult a -> Bool
matchCanFail (MR_Fallible {}) = Bool
True
matchCanFail (MR_Infallible {}) = Bool
False
alwaysFailMatchResult :: MatchResult CoreExpr
alwaysFailMatchResult :: MatchResult CoreExpr
alwaysFailMatchResult = (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr)
-> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
fail
cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr
cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
expr = DsM CoreExpr -> MatchResult CoreExpr
forall a. DsM a -> MatchResult a
MR_Infallible (DsM CoreExpr -> MatchResult CoreExpr)
-> DsM CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
MatchResult CoreExpr
match_result CoreExpr
failure_expr =
CoreExpr -> MatchResult CoreExpr -> DsM CoreExpr
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult
CoreExpr
failure_expr
(MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler MatchResult CoreExpr
match_result)
combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
combineMatchResults :: MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr
combineMatchResults match_result1 :: MatchResult CoreExpr
match_result1@(MR_Infallible DsM CoreExpr
_) MatchResult CoreExpr
_
= MatchResult CoreExpr
match_result1
combineMatchResults MatchResult CoreExpr
match_result1 MatchResult CoreExpr
match_result2 =
case MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler MatchResult CoreExpr
match_result1 of
MR_Infallible DsM CoreExpr
_ -> MatchResult CoreExpr
match_result1
MR_Fallible CoreExpr -> DsM CoreExpr
body_fn1 -> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr)
-> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail_expr ->
CoreExpr -> DsM CoreExpr
body_fn1 (CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoreExpr -> MatchResult CoreExpr -> DsM CoreExpr
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail_expr MatchResult CoreExpr
match_result2
adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b
adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b
adjustMatchResultDs a -> DsM b
encl_fn = \case
MR_Infallible DsM a
body_fn -> DsM b -> MatchResult b
forall a. DsM a -> MatchResult a
MR_Infallible (DsM b -> MatchResult b) -> DsM b -> MatchResult b
forall a b. (a -> b) -> a -> b
$
a -> DsM b
encl_fn (a -> DsM b) -> DsM a -> DsM b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DsM a
body_fn
MR_Fallible CoreExpr -> DsM a
body_fn -> (CoreExpr -> DsM b) -> MatchResult b
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM b) -> MatchResult b)
-> (CoreExpr -> DsM b) -> MatchResult b
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail ->
a -> DsM b
encl_fn (a -> DsM b) -> DsM a -> DsM b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoreExpr -> DsM a
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 = Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> Bind Id
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 CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult :: Bind Id -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult Bind Id
bind = (CoreExpr -> CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bind Id -> CoreExpr -> CoreExpr
mkCoreLet Bind Id
bind)
mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkViewMatchResult Id
var' CoreExpr
viewExpr = (CoreExpr -> CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr)
-> (CoreExpr -> CoreExpr)
-> MatchResult CoreExpr
-> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ Bind Id -> CoreExpr -> CoreExpr
mkCoreLet (Bind Id -> CoreExpr -> CoreExpr)
-> Bind Id -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
var' CoreExpr
viewExpr
mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr
mkEvalMatchResult :: Id -> Mult -> MatchResult CoreExpr -> MatchResult CoreExpr
mkEvalMatchResult Id
var Mult
ty = (CoreExpr -> CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr)
-> (CoreExpr -> CoreExpr)
-> MatchResult CoreExpr
-> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e ->
CoreExpr -> Id -> Mult -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Mult -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) Id
var Mult
ty [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
e]
mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult CoreExpr
pred_expr MatchResult CoreExpr
mr = (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr)
-> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail -> do
CoreExpr
body <- CoreExpr -> MatchResult CoreExpr -> DsM CoreExpr
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult CoreExpr
mr
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 CoreExpr)]
-> MatchResult CoreExpr
mkCoPrimCaseMatchResult :: Id
-> Mult
-> [(Literal, MatchResult CoreExpr)]
-> MatchResult CoreExpr
mkCoPrimCaseMatchResult Id
var Mult
ty [(Literal, MatchResult CoreExpr)]
match_alts
= (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible CoreExpr -> DsM CoreExpr
mk_case
where
mk_case :: CoreExpr -> DsM CoreExpr
mk_case CoreExpr
fail = do
[Alt Id]
alts <- ((Literal, MatchResult CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> [(Literal, MatchResult CoreExpr)]
-> 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 CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
forall b.
CoreExpr
-> (Literal, MatchResult (Expr b))
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
mk_alt CoreExpr
fail) [(Literal, MatchResult CoreExpr)]
sorted_alts
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Id -> Mult -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Mult -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) Id
var Mult
ty (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
fail Alt Id -> [Alt Id] -> [Alt Id]
forall a. a -> [a] -> [a]
: [Alt Id]
alts))
sorted_alts :: [(Literal, MatchResult CoreExpr)]
sorted_alts = ((Literal, MatchResult CoreExpr) -> Literal)
-> [(Literal, MatchResult CoreExpr)]
-> [(Literal, MatchResult CoreExpr)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Literal, MatchResult CoreExpr) -> Literal
forall a b. (a, b) -> a
fst [(Literal, MatchResult CoreExpr)]
match_alts
mk_alt :: CoreExpr
-> (Literal, MatchResult (Expr b))
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
mk_alt CoreExpr
fail (Literal
lit, MatchResult (Expr b)
mr)
= Bool
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Literal -> Bool
litIsLifted Literal
lit)) (IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b))
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
-> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
forall a b. (a -> b) -> a -> b
$
do Expr b
body <- CoreExpr -> MatchResult (Expr b) -> DsM (Expr b)
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult (Expr b)
mr
Alt b -> IOEnv (Env DsGblEnv DsLclEnv) (Alt b)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (Literal -> AltCon
LitAlt Literal
lit) [] Expr b
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 CoreExpr
alt_result :: MatchResult CoreExpr }
mkCoAlgCaseMatchResult
:: Id
-> Type
-> NonEmpty (CaseAlt DataCon)
-> MatchResult CoreExpr
mkCoAlgCaseMatchResult :: Id -> Mult -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
mkCoAlgCaseMatchResult Id
var Mult
ty NonEmpty (CaseAlt DataCon)
match_alts
| Bool
isNewtype
= Bool -> MatchResult CoreExpr -> MatchResult CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([CaseAlt DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CaseAlt DataCon]
match_alts_tail Bool -> Bool -> Bool
&& [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Id] -> [Id]
forall a. [a] -> [a]
tail [Id]
arg_ids1)) (MatchResult CoreExpr -> MatchResult CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$
Bind Id -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult (Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
arg_id1 CoreExpr
newtype_rhs) MatchResult CoreExpr
match_result1
| Bool
otherwise
= Id -> Mult -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
mkDataConCase Id
var Mult
ty NonEmpty (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 CoreExpr
alt_result = MatchResult CoreExpr
match_result1 } :| [CaseAlt DataCon]
match_alts_tail
= NonEmpty (CaseAlt DataCon)
match_alts
arg_id1 :: Id
arg_id1 = Bool -> Id -> Id
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Id]
arg_ids1) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$ [Id] -> Id
forall a. [a] -> a
head [Id]
arg_ids1
var_ty :: Mult
var_ty = Id -> Mult
idType Id
var
(TyCon
tc, [Mult]
ty_args) = Mult -> (TyCon, [Mult])
tcSplitTyConApp Mult
var_ty
newtype_rhs :: CoreExpr
newtype_rhs = TyCon -> [Mult] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tc [Mult]
ty_args (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var)
mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr
mkCoSynCaseMatchResult :: Id -> Mult -> CaseAlt PatSyn -> MatchResult CoreExpr
mkCoSynCaseMatchResult Id
var Mult
ty CaseAlt PatSyn
alt = (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr)
-> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> Mult -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase Id
var Mult
ty CaseAlt PatSyn
alt
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase :: Id -> Mult -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase Id
var Mult
ty CaseAlt PatSyn
alt CoreExpr
fail = do
Id
matcher_id <- Name -> DsM Id
dsLookupGlobalId Name
matcher_name
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
mkLHsWrap HsWrapper
wrapper (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
Id -> [Mult] -> LHsExpr GhcTc
nlHsTyApp Id
matcher_id [HasDebugCallStack => Mult -> Mult
Mult -> Mult
getRuntimeRep Mult
ty, Mult
ty]
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 -> MatchResult CoreExpr -> DsM CoreExpr
forall a. CoreExpr -> MatchResult a -> DsM a
runMatchResult CoreExpr
fail MatchResult CoreExpr
match_result
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 CoreExpr
alt_result = MatchResult CoreExpr
match_result} = CaseAlt PatSyn
alt
(Name
matcher_name, Mult
_, Bool
needs_void_lam) = PatSyn -> (Name, Mult, 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 -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
mkDataConCase :: Id -> Mult -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
mkDataConCase Id
var Mult
ty alts :: NonEmpty (CaseAlt DataCon)
alts@(CaseAlt DataCon
alt1 :| [CaseAlt DataCon]
_)
= (Maybe (Alt Id) -> [Alt Id] -> CoreExpr)
-> MatchResult (Maybe (Alt Id))
-> MatchResult [Alt Id]
-> MatchResult CoreExpr
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Maybe (Alt Id) -> [Alt Id] -> CoreExpr
mk_case MatchResult (Maybe (Alt Id))
mk_default MatchResult [Alt Id]
mk_alts
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
sorted_alts :: [ CaseAlt DataCon ]
sorted_alts :: [CaseAlt DataCon]
sorted_alts = (CaseAlt DataCon -> ConTag)
-> [CaseAlt DataCon] -> [CaseAlt DataCon]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (DataCon -> ConTag
dataConTag (DataCon -> ConTag)
-> (CaseAlt DataCon -> DataCon) -> CaseAlt DataCon -> ConTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseAlt DataCon -> DataCon
forall a. CaseAlt a -> a
alt_pat) ([CaseAlt DataCon] -> [CaseAlt DataCon])
-> [CaseAlt DataCon] -> [CaseAlt DataCon]
forall a b. (a -> b) -> a -> b
$ NonEmpty (CaseAlt DataCon) -> [CaseAlt DataCon]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (CaseAlt DataCon)
alts
var_ty :: Mult
var_ty = Id -> Mult
idType Id
var
(TyCon
_, [Mult]
ty_args) = Mult -> (TyCon, [Mult])
tcSplitTyConApp Mult
var_ty
mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr
mk_case :: Maybe (Alt Id) -> [Alt Id] -> CoreExpr
mk_case Maybe (Alt Id)
def [Alt Id]
alts = CoreExpr -> Scaled Mult -> Mult -> [Alt Id] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) (Id -> Scaled Mult
idScaledType Id
var) Mult
ty ([Alt Id] -> CoreExpr) -> [Alt Id] -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Maybe (Alt Id) -> [Alt Id]
forall a. Maybe a -> [a]
maybeToList Maybe (Alt Id)
def [Alt Id] -> [Alt Id] -> [Alt Id]
forall a. [a] -> [a] -> [a]
++ [Alt Id]
alts
mk_alts :: MatchResult [CoreAlt]
mk_alts :: MatchResult [Alt Id]
mk_alts = (CaseAlt DataCon -> MatchResult (Alt Id))
-> [CaseAlt DataCon] -> MatchResult [Alt Id]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CaseAlt DataCon -> MatchResult (Alt Id)
mk_alt [CaseAlt DataCon]
sorted_alts
mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt
mk_alt :: CaseAlt DataCon -> MatchResult (Alt Id)
mk_alt 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 CoreExpr
alt_result = MatchResult CoreExpr
match_result } =
((CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> MatchResult CoreExpr -> MatchResult (Alt Id))
-> MatchResult CoreExpr
-> (CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> MatchResult (Alt Id)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> MatchResult CoreExpr -> MatchResult (Alt Id)
forall a b. (a -> DsM b) -> MatchResult a -> MatchResult b
adjustMatchResultDs MatchResult CoreExpr
match_result ((CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> MatchResult (Alt Id))
-> (CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id))
-> MatchResult (Alt Id)
forall a b. (a -> b) -> a -> b
$ \CoreExpr
body -> do
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 (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [Id]
args CoreExpr
body)
Just (DCB [Mult] -> [Id] -> UniqSM ([Id], [Bind Id])
boxer) -> do
UniqSupply
us <- TcRnIf DsGblEnv DsLclEnv UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
let ([Id]
rep_ids, [Bind Id]
binds) = UniqSupply -> UniqSM ([Id], [Bind Id]) -> ([Id], [Bind Id])
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us ([Mult] -> [Id] -> UniqSM ([Id], [Bind Id])
boxer [Mult]
ty_args [Id]
args)
let rep_ids' :: [Id]
rep_ids' = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Mult -> Id -> Id
scaleVarBy (Id -> Mult
idMult Id
var)) [Id]
rep_ids
Alt Id -> IOEnv (Env DsGblEnv DsLclEnv) (Alt Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [Id]
rep_ids' ([Bind Id] -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets [Bind Id]
binds CoreExpr
body))
mk_default :: MatchResult (Maybe CoreAlt)
mk_default :: MatchResult (Maybe (Alt Id))
mk_default
| Bool
exhaustive_case = DsM (Maybe (Alt Id)) -> MatchResult (Maybe (Alt Id))
forall a. DsM a -> MatchResult a
MR_Infallible (DsM (Maybe (Alt Id)) -> MatchResult (Maybe (Alt Id)))
-> DsM (Maybe (Alt Id)) -> MatchResult (Maybe (Alt Id))
forall a b. (a -> b) -> a -> b
$ Maybe (Alt Id) -> DsM (Maybe (Alt Id))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Alt Id)
forall a. Maybe a
Nothing
| Bool
otherwise = (CoreExpr -> DsM (Maybe (Alt Id))) -> MatchResult (Maybe (Alt Id))
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM (Maybe (Alt Id)))
-> MatchResult (Maybe (Alt Id)))
-> (CoreExpr -> DsM (Maybe (Alt Id)))
-> MatchResult (Maybe (Alt Id))
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail -> Maybe (Alt Id) -> DsM (Maybe (Alt Id))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Alt Id) -> DsM (Maybe (Alt Id)))
-> Maybe (Alt Id) -> DsM (Maybe (Alt Id))
forall a b. (a -> b) -> a -> b
$ Alt Id -> Maybe (Alt Id)
forall a. a -> Maybe a
Just (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
fail)
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]
sorted_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 -> Mult -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
err_id Mult
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])
fail_expr :: CoreExpr
fail_expr = Id -> Mult -> String -> CoreExpr
mkRuntimeErrorApp Id
err_id Mult
unitTy String
full_msg
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 -> Scaled Mult -> Mult -> [Alt Id] -> CoreExpr
mkWildCase CoreExpr
fail_expr (Mult -> Scaled Mult
forall a. a -> Scaled a
unrestricted Mult
unitTy) Mult
ty []
mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
mkFailExpr :: HsMatchContext GhcRn -> Mult -> DsM CoreExpr
mkFailExpr HsMatchContext GhcRn
ctxt Mult
ty
= Id -> Mult -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
pAT_ERROR_ID Mult
ty (HsMatchContext GhcRn -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsMatchContext (GhcPass p) -> SDoc
matchContextErrString HsMatchContext GhcRn
ctxt)
mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs SDoc
_ (Var Id
f `App` Type Mult
_r `App` Type Mult
ty1 `App` Type Mult
ty2 `App` CoreExpr
arg1) CoreExpr
arg2
| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey
= CoreExpr -> Id -> Mult -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Mult -> [Alt b] -> Expr b
Case CoreExpr
arg1 Id
case_bndr Mult
ty2 [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt 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
_ -> Mult -> Mult -> Id
mkWildValBinder Mult
Many Mult
ty1
mkCoreAppDs SDoc
_ (Var Id
f `App` Type Mult
_r) CoreExpr
arg
| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey
, (CoreExpr
fun, [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
arg
, Bool -> Bool
not ([CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
args)
= (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Mult -> CoreExpr
forall b. Mult -> Expr b
Type (HasDebugCallStack => CoreExpr -> Mult
CoreExpr -> Mult
exprType CoreExpr
fun) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
fun)
CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreExpr]
args
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 :: [[CoreTickish]]
-> LPat GhcTc
-> CoreExpr
-> DsM (Id,[(Id,CoreExpr)])
mkSelectorBinds :: [[CoreTickish]]
-> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])
mkSelectorBinds [[CoreTickish]]
ticks LPat GhcTc
pat CoreExpr
val_expr
| L _ (VarPat _ (L _ v)) <- LPat GhcTc
pat'
= (Id, [(Id, CoreExpr)]) -> DsM (Id, [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
v, [(Id
v, CoreExpr
val_expr)])
| LPat GhcTc -> Bool
is_flat_prod_lpat LPat GhcTc
pat'
= do { let pat_ty :: Mult
pat_ty = LPat GhcTc -> Mult
hsLPatType LPat GhcTc
pat'
; Id
val_var <- Mult -> Mult -> DsM Id
newSysLocalDs Mult
Many Mult
pat_ty
; let mk_bind :: [CoreTickish] -> Id -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
mk_bind [CoreTickish]
tick Id
bndr_var
= do { CoreExpr
rhs_expr <- CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
val_var) HsMatchContext GhcRn
forall p. HsMatchContext p
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, [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
rhs_expr) }
; [(Id, CoreExpr)]
binds <- ([CoreTickish]
-> Id -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr))
-> [[CoreTickish]]
-> [Id]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM [CoreTickish] -> Id -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
mk_bind [[CoreTickish]]
ticks' [IdP GhcTc]
[Id]
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 <- Mult -> Mult -> DsM Id
newSysLocalDs Mult
Many Mult
tuple_ty
; CoreExpr
error_expr <- Id -> Mult -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
pAT_ERROR_ID Mult
tuple_ty (GenLocated SrcSpanAnnA (Pat GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat')
; CoreExpr
tuple_expr <- CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply CoreExpr
val_expr HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindRhs LPat GhcTc
pat
CoreExpr
local_tuple CoreExpr
error_expr
; let mk_tup_bind :: [CoreTickish] -> Id -> (Id, CoreExpr)
mk_tup_bind [CoreTickish]
tick Id
binder
= (Id
binder, [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
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 = ([CoreTickish] -> Id -> (Id, CoreExpr))
-> [[CoreTickish]] -> [Id] -> [(Id, CoreExpr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [CoreTickish] -> Id -> (Id, CoreExpr)
mk_tup_bind [[CoreTickish]]
ticks' [IdP GhcTc]
[Id]
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 = CollectFlag GhcTc -> LPat GhcTc -> [IdP GhcTc]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat'
ticks' :: [[CoreTickish]]
ticks' = [[CoreTickish]]
ticks [[CoreTickish]] -> [[CoreTickish]] -> [[CoreTickish]]
forall a. [a] -> [a] -> [a]
++ [CoreTickish] -> [[CoreTickish]]
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 [IdP GhcTc]
[Id]
binders
local_tuple :: CoreExpr
local_tuple = [Id] -> CoreExpr
mkBigCoreVarTup1 [IdP GhcTc]
[Id]
binders
tuple_ty :: Mult
tuple_ty = HasDebugCallStack => CoreExpr -> Mult
CoreExpr -> Mult
exprType CoreExpr
local_tuple
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
strip_bangs (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 (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 LPat (GhcPass p)
lp = LPat (GhcPass p)
lp
is_flat_prod_lpat :: LPat GhcTc -> Bool
is_flat_prod_lpat :: LPat GhcTc -> Bool
is_flat_prod_lpat = Pat GhcTc -> Bool
is_flat_prod_pat (Pat GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc
is_flat_prod_pat :: Pat GhcTc -> Bool
is_flat_prod_pat :: Pat GhcTc -> Bool
is_flat_prod_pat (ParPat XParPat GhcTc
_ LHsToken "(" GhcTc
_ LPat GhcTc
p LHsToken ")" GhcTc
_) = LPat GhcTc -> Bool
is_flat_prod_lpat LPat GhcTc
p
is_flat_prod_pat (TuplePat XTuplePat GhcTc
_ [LPat GhcTc]
ps Boxity
Boxed) = (GenLocated SrcSpanAnnA (Pat GhcTc) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated SrcSpanAnnA (Pat GhcTc) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
ps
is_flat_prod_pat (ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L _ pcon
, pat_args :: forall p. Pat p -> HsConPatDetails p
pat_args = HsConPatDetails GhcTc
ps})
| RealDataCon DataCon
con <- ConLike
pcon
, Just DataCon
_ <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe (DataCon -> TyCon
dataConTyCon DataCon
con)
= (GenLocated SrcSpanAnnA (Pat GhcTc) -> Bool)
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated SrcSpanAnnA (Pat GhcTc) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
is_triv_lpat (HsConPatDetails GhcTc -> [LPat GhcTc]
forall p. UnXRec p => HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails GhcTc
ps)
is_flat_prod_pat Pat GhcTc
_ = 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)
-> (GenLocated SrcSpanAnnA (Pat (GhcPass p)) -> Pat (GhcPass p))
-> GenLocated SrcSpanAnnA (Pat (GhcPass p))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat (GhcPass p)) -> Pat (GhcPass p)
forall l e. GenLocated l e -> e
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)
_ LHsToken "(" (GhcPass p)
_ LPat (GhcPass p)
p LHsToken ")" (GhcPass 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 [] = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (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 = SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a. [a] -> a
head [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
lpats)) (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$
[LPat GhcTc] -> Boxity -> Pat GhcTc
mkVanillaTuplePat [LPat GhcTc]
lpats Boxity
Boxed
mkVanillaTuplePat :: [LPat 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 ((GenLocated SrcSpanAnnA (Pat GhcTc) -> Mult)
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [Mult]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> Mult
GenLocated SrcSpanAnnA (Pat GhcTc) -> Mult
hsLPatType [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats) [LPat GhcTc]
pats Boxity
box
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
mkBigLHsVarTupId [Id]
ids = [LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId ((Id -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [Id] -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [Id]
ids)
mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId = ([GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a. ([a] -> a) -> [a] -> a
mkChunkified (\[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
e -> [LHsExpr GhcTc] -> XExplicitTuple GhcTc -> LHsExpr GhcTc
forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsTupleExpr [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
e NoExtField
XExplicitTuple GhcTc
noExtField)
mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
mkBigLHsVarPatTupId [Id]
bs = [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId ((Id -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id]
bs)
mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId = ([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a. ([a] -> a) -> [a] -> a
mkChunkified [LPat GhcTc] -> LPat GhcTc
[GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated SrcSpanAnnA (Pat GhcTc)
mkLHsPatTup
mkFailurePair :: CoreExpr
-> DsM (CoreBind,
CoreExpr)
mkFailurePair :: CoreExpr -> DsM (Bind Id, CoreExpr)
mkFailurePair CoreExpr
expr
= do { Id
fail_fun_var <- Mult -> Mult -> DsM Id
newFailLocalDs Mult
Many (Mult
unboxedUnitTy Mult -> Mult -> Mult
`mkVisFunTyMany` Mult
ty)
; Id
fail_fun_arg <- Mult -> Mult -> DsM Id
newSysLocalDs Mult
Many Mult
unboxedUnitTy
; let real_arg :: Id
real_arg = Id -> Id
setOneShotLambda Id
fail_fun_arg
; (Bind Id, CoreExpr) -> DsM (Bind Id, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> Bind Id
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 :: Mult
ty = HasDebugCallStack => CoreExpr -> Mult
CoreExpr -> Mult
exprType CoreExpr
expr
shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler = \case
mr :: MatchResult CoreExpr
mr@(MR_Infallible DsM CoreExpr
_) -> MatchResult CoreExpr
mr
MR_Fallible CoreExpr -> DsM CoreExpr
match_fn -> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr)
-> (CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail_expr -> do
(Bind Id
fail_bind, CoreExpr
shared_failure_handler) <- CoreExpr -> DsM (Bind Id, CoreExpr)
mkFailurePair CoreExpr
fail_expr
CoreExpr
body <- CoreExpr -> DsM CoreExpr
match_fn CoreExpr
shared_failure_handler
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
$ Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let Bind Id
fail_bind CoreExpr
body
dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
dsHandleMonadicFailure :: HsDoFlavour
-> LPat GhcTc
-> MatchResult CoreExpr
-> FailOperator GhcTc
-> DsM CoreExpr
dsHandleMonadicFailure HsDoFlavour
ctx LPat GhcTc
pat MatchResult CoreExpr
match FailOperator GhcTc
m_fail_op =
case MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler MatchResult CoreExpr
match of
MR_Infallible DsM CoreExpr
body -> DsM CoreExpr
body
MR_Fallible CoreExpr -> DsM CoreExpr
body -> do
SyntaxExprTc
fail_op <- case FailOperator GhcTc
m_fail_op of
FailOperator GhcTc
Nothing -> String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"missing fail op" (SDoc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc)
-> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Pattern match:" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (Pat GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is failable, and fail_expr was left unset"
Just SyntaxExpr GhcTc
fail_op -> SyntaxExprTc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SyntaxExprTc
SyntaxExpr GhcTc
fail_op
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CoreExpr
fail_msg <- String -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => String -> m CoreExpr
mkStringExpr (DynFlags
-> HsDoFlavour -> GenLocated SrcSpanAnnA (Pat GhcTc) -> String
forall e. DynFlags -> HsDoFlavour -> LocatedA e -> String
mk_fail_msg DynFlags
dflags HsDoFlavour
ctx LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
CoreExpr
fail_expr <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExprTc
SyntaxExpr GhcTc
fail_op [CoreExpr
fail_msg]
CoreExpr -> DsM CoreExpr
body CoreExpr
fail_expr
mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String
mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String
mk_fail_msg DynFlags
dflags HsDoFlavour
ctx LocatedA e
pat
= DynFlags -> SDoc -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Pattern match failure in" SDoc -> SDoc -> SDoc
<+> HsDoFlavour -> SDoc
pprHsDoFlavour HsDoFlavour
ctx
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LocatedA e -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedA e
pat)
mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox = (CoreExpr -> [CoreTickish] -> CoreExpr)
-> [CoreTickish] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CoreTickish -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreTickish] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick)
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox :: ConTag -> ConTag -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ConTag
ixT ConTag
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 -> Mult -> Mult -> Id
mkSysLocal (String -> FastString
fsLit String
"t1") Unique
uq Mult
One Mult
boolTy
let
falseBox :: CoreExpr
falseBox = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (Module -> ConTag -> CoreTickish
forall (pass :: TickishPass). Module -> ConTag -> GenTickish pass
HpcTick Module
this_mod ConTag
ixF) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
falseDataConId)
trueBox :: CoreExpr
trueBox = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (Module -> ConTag -> CoreTickish
forall (pass :: TickishPass). Module -> ConTag -> GenTickish pass
HpcTick Module
this_mod ConTag
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 -> Mult -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Mult -> [Alt b] -> Expr b
Case CoreExpr
e Id
bndr1 Mult
boolTy
[ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] CoreExpr
falseBox
, AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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
= GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall p l.
(XRec p (Pat p) ~ GenLocated l (Pat p), XBangPat p ~ NoExtField) =>
GenLocated l (Pat p) -> GenLocated l (Pat p)
go LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lpat
where
go :: GenLocated l (Pat p) -> GenLocated l (Pat p)
go lp :: GenLocated l (Pat p)
lp@(L l
l Pat p
p)
= case Pat p
p of
ParPat XParPat p
x LHsToken "(" p
lpar XRec p (Pat p)
p LHsToken ")" p
rpar -> l -> Pat p -> GenLocated l (Pat p)
forall l e. l -> e -> GenLocated l e
L l
l (XParPat p
-> LHsToken "(" p -> XRec p (Pat p) -> LHsToken ")" p -> Pat p
forall p.
XParPat p -> LHsToken "(" p -> LPat p -> LHsToken ")" p -> Pat p
ParPat XParPat p
x LHsToken "(" p
lpar (GenLocated l (Pat p) -> GenLocated l (Pat p)
go XRec p (Pat p)
GenLocated l (Pat p)
p) LHsToken ")" p
rpar)
LazyPat XLazyPat p
_ XRec p (Pat p)
lp' -> XRec p (Pat p)
GenLocated l (Pat p)
lp'
BangPat XBangPat p
_ XRec p (Pat p)
_ -> GenLocated l (Pat p)
lp
Pat p
_ -> l -> Pat p -> GenLocated l (Pat p)
forall l e. l -> e -> GenLocated l e
L l
l (XBangPat p -> XRec p (Pat p) -> Pat p
forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
XBangPat p
noExtField XRec p (Pat p)
GenLocated l (Pat p)
lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr (L _ (HsVar _ (L _ v)))
| Id
v Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
otherwiseIdKey
Bool -> Bool -> Bool
|| 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 (L _ (XExpr (ConLikeTc 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 (L _ (XExpr (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 (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
wrapped))
isTrueLHsExpr (L _ (XExpr (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 (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (Module -> ConTag -> CoreTickish
forall (pass :: TickishPass). Module -> ConTag -> GenTickish pass
HpcTick Module
this_mod ConTag
ixT) CoreExpr
e))
isTrueLHsExpr (L _ (HsPar _ _ e _)) = LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr LHsExpr GhcTc
e
isTrueLHsExpr LHsExpr GhcTc
_ = Maybe (CoreExpr -> DsM CoreExpr)
forall a. Maybe a
Nothing