{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Match
( match, matchEquations, matchWrapper, matchSimply
, matchSinglePat, matchSinglePatVar
)
where
import GHC.Prelude
import GHC.Platform
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
import GHC.Types.Basic
import GHC.Types.SourceText
( FractionalLit,
IntegralLit(il_value),
negateFractionalLit,
integralFractionalLit )
import GHC.Driver.DynFlags
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Match.Constructor
import GHC.HsToCore.Match.Literal
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.Type
import GHC.Core.TyCo.Compare( eqType, eqTypes )
import GHC.Core.Coercion ( eqCoercion )
import GHC.Core.TyCon ( isNewTyCon )
import GHC.Core.Multiplicity
import GHC.Builtin.Types
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Types.SrcLoc
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Types.Unique
import GHC.Types.Unique.DFM
import Control.Monad ( zipWithM, unless )
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
type MatchId = Id
match :: [MatchId]
-> Type
-> [EquationInfo]
-> DsM (MatchResult CoreExpr)
match :: [Id] -> Type -> [EquationInfoNE] -> DsM (MatchResult CoreExpr)
match [] Type
ty [EquationInfoNE]
eqns
= Bool
-> SDoc -> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not ([EquationInfoNE] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EquationInfoNE]
eqns)) (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) (DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr))
-> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$
NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
combineEqnRhss ([EquationInfoNE] -> NonEmpty EquationInfoNE
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [EquationInfoNE]
eqns)
match (Id
v:[Id]
vs) Type
ty [EquationInfoNE]
eqns
= Bool
-> SDoc -> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ((Id -> Bool) -> NonEmpty Id -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> Bool
isInternalName (Name -> Bool) -> (Id -> Name) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName) NonEmpty Id
vars) (NonEmpty Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty Id
vars) (DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr))
-> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$
do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
; let grouped = Platform
-> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
groupEquations Platform
platform [EquationInfoNE]
tidy_eqns
; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- match_groups grouped
; return $ foldr (.) id aux_binds <$>
foldr1 combineMatchResults match_results
}
where
vars :: NonEmpty Id
vars = Id
v Id -> [Id] -> NonEmpty Id
forall a. a -> [a] -> NonEmpty a
:| [Id]
vs
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
dropGroup :: forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup = ((PatGroup, EquationInfoNE) -> EquationInfoNE)
-> f (PatGroup, EquationInfoNE) -> f EquationInfoNE
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatGroup, EquationInfoNE) -> EquationInfoNE
forall a b. (a, b) -> b
snd
match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr))
match_groups :: [NonEmpty (PatGroup, EquationInfoNE)]
-> DsM (NonEmpty (MatchResult CoreExpr))
match_groups [] = Id -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty Id
v Type
ty
match_groups (NonEmpty (PatGroup, EquationInfoNE)
g:[NonEmpty (PatGroup, EquationInfoNE)]
gs) = (NonEmpty (PatGroup, EquationInfoNE) -> DsM (MatchResult CoreExpr))
-> NonEmpty (NonEmpty (PatGroup, EquationInfoNE))
-> DsM (NonEmpty (MatchResult CoreExpr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM NonEmpty (PatGroup, EquationInfoNE) -> DsM (MatchResult CoreExpr)
match_group (NonEmpty (NonEmpty (PatGroup, EquationInfoNE))
-> DsM (NonEmpty (MatchResult CoreExpr)))
-> NonEmpty (NonEmpty (PatGroup, EquationInfoNE))
-> DsM (NonEmpty (MatchResult CoreExpr))
forall a b. (a -> b) -> a -> b
$ NonEmpty (PatGroup, EquationInfoNE)
g NonEmpty (PatGroup, EquationInfoNE)
-> [NonEmpty (PatGroup, EquationInfoNE)]
-> NonEmpty (NonEmpty (PatGroup, EquationInfoNE))
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty (PatGroup, EquationInfoNE)]
gs
match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr)
match_group :: NonEmpty (PatGroup, EquationInfoNE) -> DsM (MatchResult CoreExpr)
match_group eqns :: NonEmpty (PatGroup, EquationInfoNE)
eqns@((PatGroup
group,EquationInfoNE
_) :| [(PatGroup, EquationInfoNE)]
_)
= case PatGroup
group of
PgCon {} -> NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfoNE)
-> DsM (MatchResult CoreExpr)
matchConFamily NonEmpty Id
vars Type
ty ([NonEmpty EquationInfoNE] -> NonEmpty (NonEmpty EquationInfoNE)
forall {a}. [a] -> NonEmpty a
ne ([NonEmpty EquationInfoNE] -> NonEmpty (NonEmpty EquationInfoNE))
-> [NonEmpty EquationInfoNE] -> NonEmpty (NonEmpty EquationInfoNE)
forall a b. (a -> b) -> a -> b
$ [(DataCon, EquationInfoNE)] -> [NonEmpty EquationInfoNE]
forall a.
Uniquable a =>
[(a, EquationInfoNE)] -> [NonEmpty EquationInfoNE]
subGroupUniq [(DataCon
c,EquationInfoNE
e) | (PgCon DataCon
c, EquationInfoNE
e) <- [(PatGroup, EquationInfoNE)]
eqns'])
PgSyn {} -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchPatSyn NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PgLit {} -> NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfoNE)
-> DsM (MatchResult CoreExpr)
matchLiterals NonEmpty Id
vars Type
ty ([NonEmpty EquationInfoNE] -> NonEmpty (NonEmpty EquationInfoNE)
forall {a}. [a] -> NonEmpty a
ne ([NonEmpty EquationInfoNE] -> NonEmpty (NonEmpty EquationInfoNE))
-> [NonEmpty EquationInfoNE] -> NonEmpty (NonEmpty EquationInfoNE)
forall a b. (a -> b) -> a -> b
$ [(Literal, EquationInfoNE)] -> [NonEmpty EquationInfoNE]
forall a.
Ord a =>
[(a, EquationInfoNE)] -> [NonEmpty EquationInfoNE]
subGroupOrd [(Literal
l,EquationInfoNE
e) | (PgLit Literal
l, EquationInfoNE
e) <- [(PatGroup, EquationInfoNE)]
eqns'])
PatGroup
PgAny -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchVariables NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PgN {} -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPats NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PgOverS {}-> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPats NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PgNpK {} -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPlusKPats NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PatGroup
PgBang -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchBangs NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PgCo {} -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchCoercion NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
PgView {} -> NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchView NonEmpty Id
vars Type
ty (NonEmpty (PatGroup, EquationInfoNE) -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfoNE) -> f EquationInfoNE
dropGroup NonEmpty (PatGroup, EquationInfoNE)
eqns)
where eqns' :: [(PatGroup, EquationInfoNE)]
eqns' = NonEmpty (PatGroup, EquationInfoNE) -> [(PatGroup, EquationInfoNE)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (PatGroup, EquationInfoNE)
eqns
ne :: [a] -> NonEmpty a
ne [a]
l = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
l of
Just NonEmpty a
nel -> NonEmpty a
nel
Maybe (NonEmpty a)
Nothing -> String -> SDoc -> NonEmpty a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"match match_group" (SDoc -> NonEmpty a) -> SDoc -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Empty result should be impossible since input was non-empty"
debug :: [t (PatGroup, b)] -> TcRnIf DsGblEnv DsLclEnv ()
debug [t (PatGroup, b)]
eqns =
let gs :: [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
gs = (t (PatGroup, b) -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
-> [t (PatGroup, b)] -> [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
forall a b. (a -> b) -> [a] -> [b]
map (\t (PatGroup, b)
group -> ((PatGroup, b)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)])
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> t (PatGroup, b)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (PatGroup
p,b
_) -> \[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
acc ->
case PatGroup
p of PgView XRec GhcTc (HsExpr GhcTc)
e Type
_ -> XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
eGenLocated SrcSpanAnnA (HsExpr GhcTc)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
acc
PatGroup
_ -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
acc) [] t (PatGroup, b)
group) [t (PatGroup, b)]
eqns
maybeWarn :: [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
-> TcRnIf DsGblEnv DsLclEnv ()
maybeWarn [] = () -> TcRnIf DsGblEnv DsLclEnv ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeWarn [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
l = DsMessage -> TcRnIf DsGblEnv DsLclEnv ()
diagnosticDs ([[XRec GhcTc (HsExpr GhcTc)]] -> DsMessage
DsAggregatedViewExpressions [[XRec GhcTc (HsExpr GhcTc)]]
[[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
l)
in
[[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
-> TcRnIf DsGblEnv DsLclEnv ()
maybeWarn ([[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
-> TcRnIf DsGblEnv DsLclEnv ())
-> [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
-> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$ ([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> Bool)
-> [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
-> [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
gs
matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty :: Id -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty Id
var Type
res_ty
= NonEmpty (MatchResult CoreExpr)
-> DsM (NonEmpty (MatchResult CoreExpr))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(CoreExpr -> DsM CoreExpr) -> MatchResult CoreExpr
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible CoreExpr -> DsM CoreExpr
mk_seq]
where
mk_seq :: CoreExpr -> DsM CoreExpr
mk_seq CoreExpr
fail = CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var) (Id -> Scaled Type
idScaledType Id
var) Type
res_ty
[AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
fail]
matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchVariables :: NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchVariables (Id
_ :| [Id]
vars) Type
ty NonEmpty EquationInfoNE
eqns = [Id] -> Type -> [EquationInfoNE] -> DsM (MatchResult CoreExpr)
match [Id]
vars Type
ty ([EquationInfoNE] -> DsM (MatchResult CoreExpr))
-> [EquationInfoNE] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfoNE -> [EquationInfoNE]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty EquationInfoNE -> [EquationInfoNE])
-> NonEmpty EquationInfoNE -> [EquationInfoNE]
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfoNE -> NonEmpty EquationInfoNE
forall (f :: * -> *).
Functor f =>
f EquationInfoNE -> f EquationInfoNE
shiftEqns NonEmpty EquationInfoNE
eqns
matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchBangs :: NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchBangs (Id
var :| [Id]
vars) Type
ty NonEmpty EquationInfoNE
eqns
= do { match_result <- [Id] -> Type -> [EquationInfoNE] -> DsM (MatchResult CoreExpr)
match (Id
varId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
vars) Type
ty ([EquationInfoNE] -> DsM (MatchResult CoreExpr))
-> [EquationInfoNE] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfoNE -> [EquationInfoNE]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty EquationInfoNE -> [EquationInfoNE])
-> NonEmpty EquationInfoNE -> [EquationInfoNE]
forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getBangPat (EquationInfoNE -> EquationInfoNE)
-> NonEmpty EquationInfoNE -> NonEmpty EquationInfoNE
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfoNE
eqns
; return (mkEvalMatchResult var ty match_result) }
matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchCoercion :: NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchCoercion (Id
var :| [Id]
vars) Type
ty eqns :: NonEmpty EquationInfoNE
eqns@(EquationInfoNE
eqn1 :| [EquationInfoNE]
_)
= do { let XPat (CoPat HsWrapper
co Pat GhcTc
pat Type
_) = EquationInfoNE -> Pat GhcTc
firstPat EquationInfoNE
eqn1
; let pat_ty' :: Type
pat_ty' = Pat GhcTc -> Type
hsPatType Pat GhcTc
pat
; var' <- Id -> Type -> Type -> DsM Id
newUniqueId Id
var (HasDebugCallStack => Id -> Type
Id -> Type
idMult Id
var) Type
pat_ty'
; match_result <- match (var':vars) ty $ NE.toList $
decomposeFirstPat getCoPat <$> eqns
; dsHsWrapper co $ \DsWrapper
core_wrap -> do
{ let bind :: Bind Id
bind = Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
var' (DsWrapper
core_wrap (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var))
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bind Id -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult Bind Id
bind MatchResult CoreExpr
match_result) } }
matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchView :: NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchView (Id
var :| [Id]
vars) Type
ty eqns :: NonEmpty EquationInfoNE
eqns@(EquationInfoNE
eqn1 :| [EquationInfoNE]
_)
= do {
let TcViewPat HsExpr GhcTc
viewExpr Pat GhcTc
pat = EquationInfoNE -> Pat GhcTc
firstPat EquationInfoNE
eqn1
; let pat_ty' :: Type
pat_ty' = Pat GhcTc -> Type
hsPatType Pat GhcTc
pat
; var' <- Id -> Type -> Type -> DsM Id
newUniqueId Id
var (HasDebugCallStack => Id -> Type
Id -> Type
idMult Id
var) Type
pat_ty'
; match_result <- match (var':vars) ty $ NE.toList $
decomposeFirstPat getViewPat <$> eqns
; viewExpr' <- dsExpr viewExpr
; return (mkViewMatchResult var'
(mkCoreApp (text "matchView") viewExpr' (Var var))
match_result) }
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE
decomposeFirstPat Pat GhcTc -> Pat GhcTc
extract eqn :: EquationInfoNE
eqn@(EqnMatch { eqn_pat :: EquationInfoNE -> LPat GhcTc
eqn_pat = LPat GhcTc
pat }) = EquationInfoNE
eqn{eqn_pat = fmap extract pat}
decomposeFirstPat Pat GhcTc -> Pat GhcTc
_ (EqnDone {}) = String -> EquationInfoNE
forall a. HasCallStack => String -> a
panic String
"decomposeFirstPat"
getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
getCoPat :: Pat GhcTc -> Pat GhcTc
getCoPat (XPat (CoPat HsWrapper
_ Pat GhcTc
pat Type
_)) = Pat GhcTc
pat
getCoPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. HasCallStack => String -> a
panic String
"getCoPat"
getBangPat :: Pat GhcTc -> Pat GhcTc
getBangPat (BangPat XBangPat GhcTc
_ LPat GhcTc
pat ) = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
getBangPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. HasCallStack => String -> a
panic String
"getBangPat"
getViewPat :: Pat GhcTc -> Pat GhcTc
getViewPat (TcViewPat HsExpr GhcTc
_ Pat GhcTc
pat) = Pat GhcTc
pat
getViewPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. HasCallStack => String -> a
panic String
"getViewPat"
pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc
pattern $mTcViewPat :: forall {r}.
Pat GhcTc -> (HsExpr GhcTc -> Pat GhcTc -> r) -> ((# #) -> r) -> r
TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))
getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
getTcViewPat (ViewPat XViewPat GhcTc
_ XRec GhcTc (HsExpr GhcTc)
viewLExpr LPat GhcTc
pat) = (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
viewLExpr, GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
getTcViewPat (XPat (ExpansionPat Pat (GhcPass 'Renamed)
_ Pat GhcTc
p)) = Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
getTcViewPat Pat GhcTc
p
getTcViewPat Pat GhcTc
p = String -> SDoc -> (HsExpr GhcTc, Pat GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getTcViewPat" (Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
p)
tidyEqnInfo :: Id -> EquationInfo
-> DsM (DsWrapper, EquationInfo)
tidyEqnInfo :: Id
-> EquationInfoNE
-> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfoNE)
tidyEqnInfo Id
_ eqn :: EquationInfoNE
eqn@(EqnDone {}) = (DsWrapper, EquationInfoNE)
-> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfoNE)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, EquationInfoNE
eqn)
tidyEqnInfo Id
v eqn :: EquationInfoNE
eqn@(EqnMatch { eqn_pat :: EquationInfoNE -> LPat GhcTc
eqn_pat = (L SrcSpanAnnA
loc Pat GhcTc
pat) }) = do
(wrap, pat') <- Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v (Bool -> Bool
not (Bool -> Bool) -> (SrcSpanAnnA -> Bool) -> SrcSpanAnnA -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Bool
isGoodSrcSpan (SrcSpan -> Bool)
-> (SrcSpanAnnA -> SrcSpan) -> SrcSpanAnnA -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (SrcSpanAnnA -> Bool) -> SrcSpanAnnA -> Bool
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
loc) Pat GhcTc
pat
return (wrap, eqn{eqn_pat = L loc pat' })
tidy1 :: Id
-> Bool
-> Pat GhcTc
-> DsM (DsWrapper,
Pat GhcTc)
tidy1 :: Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (ParPat XParPat GhcTc
_ LPat GhcTc
pat) = Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
tidy1 Id
v Bool
g (SigPat XSigPat GhcTc
_ LPat GhcTc
pat HsPatSigType (NoGhcTc GhcTc)
_) = Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
tidy1 Id
_ Bool
_ (WildPat XWildPat GhcTc
ty) = (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcTc
ty)
tidy1 Id
v Bool
g (BangPat XBangPat GhcTc
_ (L SrcSpanAnnA
l Pat GhcTc
p)) = Id
-> Bool -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l Pat GhcTc
p
tidy1 Id
v Bool
_ (VarPat XVarPat GhcTc
_ (L SrcSpanAnnN
_ Id
var))
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id -> DsWrapper
wrapBind Id
var Id
v, XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat (Id -> Type
idType Id
var))
tidy1 Id
v Bool
g (AsPat XAsPat GhcTc
_ (L SrcSpanAnnN
_ Id
var) LPat GhcTc
pat)
= do { (wrap, pat') <- Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat)
; return (wrapBind var v . wrap, pat') }
tidy1 Id
v Bool
_ (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat)
= SrcSpan -> DsM (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat) (DsM (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc))
-> DsM (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a b. (a -> b) -> a -> b
$
do { let unlifted_bndrs :: [Id]
unlifted_bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType) (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)
; Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
unlifted_bndrs) (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
DsMessage -> TcRnIf DsGblEnv DsLclEnv ()
diagnosticDs ([Id] -> DsMessage
DsLazyPatCantBindVarsOfUnliftedType [Id]
unlifted_bndrs)
; (_,sel_prs) <- [[CoreTickish]]
-> LPat GhcTc
-> HsMatchContextRn
-> CoreExpr
-> DsM (Id, [(Id, CoreExpr)])
mkSelectorBinds [] LPat GhcTc
pat HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
LazyPatCtx (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v)
; let sel_binds = [Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
rhs | (Id
b,CoreExpr
rhs) <- [(Id, CoreExpr)]
sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
tidy1 Id
_ Bool
_ (ListPat XListPat GhcTc
ty [LPat GhcTc]
pats)
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
list_ConPat)
where
list_ConPat :: GenLocated SrcSpanAnnA (Pat GhcTc)
list_ConPat = (GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ GenLocated SrcSpanAnnA (Pat GhcTc)
x GenLocated SrcSpanAnnA (Pat GhcTc)
y -> DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat DataCon
consDataCon [Item [GenLocated SrcSpanAnnA (Pat GhcTc)]
GenLocated SrcSpanAnnA (Pat GhcTc)
x, Item [GenLocated SrcSpanAnnA (Pat GhcTc)]
GenLocated SrcSpanAnnA (Pat GhcTc)
y] [Item [Type]
XListPat GhcTc
ty])
(Type -> LPat GhcTc
mkNilPat XListPat GhcTc
Type
ty)
[LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
tidy1 Id
_ Bool
_ (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
pats Boxity
boxity)
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
tuple_ConPat)
where
arity :: Int
arity = [GenLocated SrcSpanAnnA (Pat GhcTc)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
tuple_ConPat :: LPat GhcTc
tuple_ConPat = DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat (Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity Int
arity) [LPat GhcTc]
pats [Type]
tys'
tys' :: [Type]
tys' = case Boxity
boxity of
Boxity
Unboxed -> (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep [Type]
XTuplePat GhcTc
tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
XTuplePat GhcTc
tys
Boxity
Boxed -> [Type]
XTuplePat GhcTc
tys
tidy1 Id
_ Bool
_ (SumPat XSumPat GhcTc
tys LPat GhcTc
pat Int
alt Int
arity)
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
sum_ConPat)
where
sum_ConPat :: LPat GhcTc
sum_ConPat = DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity) [Item [GenLocated SrcSpanAnnA (Pat GhcTc)]
LPat GhcTc
pat] ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep [Type]
XSumPat GhcTc
tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
XSumPat GhcTc
tys)
tidy1 Id
_ Bool
g (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit)
= do { Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
g (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
HsLit GhcTc -> TcRnIf DsGblEnv DsLclEnv ()
warnAboutOverflowedLit HsLit GhcTc
lit
; (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, HsLit GhcTc -> Pat GhcTc
tidyLitPat HsLit GhcTc
lit) }
tidy1 Id
_ Bool
g (NPat XNPat GhcTc
ty (L EpAnnCO
_ lit :: HsOverLit GhcTc
lit@OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
v }) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq)
= do { Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
g (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
let lit' :: HsOverLit GhcTc
lit' | Just SyntaxExpr GhcTc
_ <- Maybe (SyntaxExpr GhcTc)
mb_neg = HsOverLit GhcTc
lit{ ol_val = negateOverLitVal v }
| Bool
otherwise = HsOverLit GhcTc
lit
in HsOverLit GhcTc -> TcRnIf DsGblEnv DsLclEnv ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit'
; (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, HsOverLit GhcTc
-> Maybe (SyntaxExpr GhcTc)
-> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
tidyNPat HsOverLit GhcTc
lit Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq XNPat GhcTc
Type
ty) }
tidy1 Id
_ Bool
g n :: Pat GhcTc
n@(NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
_ (L EpAnnCO
_ HsOverLit GhcTc
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_)
= do { Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
g (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$ do
HsOverLit GhcTc -> TcRnIf DsGblEnv DsLclEnv ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit1
HsOverLit GhcTc -> TcRnIf DsGblEnv DsLclEnv ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit2
; (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, Pat GhcTc
n) }
tidy1 Id
_ Bool
_ (OrPat XOrPat GhcTc
ty NonEmpty (LPat GhcTc)
lpats)
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, XViewPat GhcTc
-> XRec GhcTc (HsExpr GhcTc) -> LPat GhcTc -> Pat GhcTc
forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat XViewPat GhcTc
XOrPat GhcTc
ty (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XLam GhcTc
-> HsLamVariant
-> MatchGroup GhcTc (XRec GhcTc (HsExpr GhcTc))
-> HsExpr GhcTc
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
EpAnnLam
forall a. NoAnn a => a
noAnn HsLamVariant
LamCase MatchGroup GhcTc (XRec GhcTc (HsExpr GhcTc))
mg)) (DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat DataCon
trueDataCon [] []))
where
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg :: MatchGroup GhcTc (XRec GhcTc (HsExpr GhcTc))
mg = XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> XRec
GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
MG XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
MatchGroupTc
mgtc ([GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ((GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcTc -> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
match_true (NonEmpty (GenLocated SrcSpanAnnA (Pat GhcTc))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (LPat GhcTc)
NonEmpty (GenLocated SrcSpanAnnA (Pat GhcTc))
lpats) [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [LPat GhcTc -> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
match_false (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat XOrPat GhcTc
XWildPat GhcTc
ty)]))
mgtc :: MatchGroupTc
mgtc = MatchGroupTc
{ mg_arg_tys :: [Scaled Type]
mg_arg_tys = [Type -> Scaled Type
forall a. a -> Scaled a
tymult XOrPat GhcTc
Type
ty]
, mg_res_ty :: Type
mg_res_ty = Type
boolTy
, mg_origin :: Origin
mg_origin = GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
SkipPmc
}
match_true :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
match_true :: LPat GhcTc -> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
match_true LPat GhcTc
lpat = LPat GhcTc
-> XRec GhcTc (HsExpr GhcTc)
-> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
mk_match LPat GhcTc
lpat (Id -> XRec GhcTc (HsExpr GhcTc)
hs_var Id
trueDataConId)
match_false :: LPat GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
match_false :: LPat GhcTc -> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
match_false LPat GhcTc
lpat = LPat GhcTc
-> XRec GhcTc (HsExpr GhcTc)
-> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
mk_match LPat GhcTc
lpat (Id -> XRec GhcTc (HsExpr GhcTc)
hs_var Id
falseDataConId)
mk_match :: LPat GhcTc -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
mk_match :: LPat GhcTc
-> XRec GhcTc (HsExpr GhcTc)
-> LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
mk_match LPat GhcTc
lpat XRec GhcTc (HsExpr GhcTc)
body = Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsMatchContext (LIdP (NoGhcTc GhcTc))
-> XRec GhcTc [LPat GhcTc]
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p body.
XCMatch p body
-> HsMatchContext (LIdP (NoGhcTc p))
-> XRec p [LPat p]
-> GRHSs p body
-> Match p body
Match XCMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
NoExtField
noExtField HsMatchContext (LIdP (NoGhcTc GhcTc))
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
CaseAlt ([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [Item [GenLocated SrcSpanAnnA (Pat GhcTc)]
LPat GhcTc
lpat]) (XRec GhcTc (HsExpr GhcTc)
-> GRHSs GhcTc (XRec GhcTc (HsExpr GhcTc))
single_grhs XRec GhcTc (HsExpr GhcTc)
body)
hs_var :: Var -> LHsExpr GhcTc
hs_var :: Id -> XRec GhcTc (HsExpr GhcTc)
hs_var Id
v = (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (Id -> GenLocated SrcSpanAnnN Id
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Id
v))
single_grhs :: LHsExpr GhcTc -> GRHSs GhcTc (LHsExpr GhcTc)
single_grhs :: XRec GhcTc (HsExpr GhcTc)
-> GRHSs GhcTc (XRec GhcTc (HsExpr GhcTc))
single_grhs XRec GhcTc (HsExpr GhcTc)
e = XCGRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> HsLocalBinds GhcTc
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
EpAnnComments
emptyComments [GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
EpAnnCO (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [XRec GhcTc (StmtLR GhcTc GhcTc (XRec GhcTc (HsExpr GhcTc)))]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. NoAnn a => a
noAnn [] XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e] (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
NoExtField
noExtField)
tidy1 Id
_ Bool
_ Pat GhcTc
non_interesting_pat
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, Pat GhcTc
non_interesting_pat)
tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat :: Id
-> Bool -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
_ (ParPat XParPat GhcTc
_ (L SrcSpanAnnA
l Pat GhcTc
p)) = Id
-> Bool -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l Pat GhcTc
p
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
_ (SigPat XSigPat GhcTc
_ (L SrcSpanAnnA
l Pat GhcTc
p) HsPatSigType (NoGhcTc GhcTc)
_) = Id
-> Bool -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l Pat GhcTc
p
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l (AsPat XAsPat GhcTc
x LIdP GhcTc
v' LPat GhcTc
p)
= Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (XAsPat GhcTc -> LIdP GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat XAsPat GhcTc
x LIdP GhcTc
v' (SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField LPat GhcTc
p)))
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l (XPat (CoPat HsWrapper
w Pat GhcTc
p Type
t))
= Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (XXPat GhcTc -> Pat GhcTc
forall p. XXPat p -> Pat p
XPat (XXPat GhcTc -> Pat GhcTc) -> XXPat GhcTc -> Pat GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> Pat GhcTc -> Type -> XXPatGhcTc
CoPat HsWrapper
w (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField (SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcTc
p)) Type
t)
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l (OrPat XOrPat GhcTc
x (LPat GhcTc
p:|[LPat GhcTc]
ps))
= Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (XOrPat GhcTc -> NonEmpty (LPat GhcTc) -> Pat GhcTc
forall p. XOrPat p -> NonEmpty (LPat p) -> Pat p
OrPat XOrPat GhcTc
x (SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField LPat GhcTc
p) GenLocated SrcSpanAnnA (Pat GhcTc)
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> NonEmpty (GenLocated SrcSpanAnnA (Pat GhcTc))
forall a. a -> [a] -> NonEmpty a
:| [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
ps))
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
_ p :: Pat GhcTc
p@(LitPat {}) = Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g Pat GhcTc
p
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
_ p :: Pat GhcTc
p@(ListPat {}) = Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g Pat GhcTc
p
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
_ p :: Pat GhcTc
p@(TuplePat {}) = Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g Pat GhcTc
p
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
_ p :: Pat GhcTc
p@(SumPat {}) = Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g Pat GhcTc
p
tidy_bang_pat Id
v Bool
g SrcSpanAnnA
l p :: Pat GhcTc
p@(ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L SrcSpanAnnN
_ (RealDataCon DataCon
dc)
, pat_args :: forall p. Pat p -> HsConPatDetails p
pat_args = HsConPatDetails GhcTc
args
, pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = ConPatTc
{ cpt_arg_tys :: ConPatTc -> [Type]
cpt_arg_tys = [Type]
arg_tys
}
})
=
if TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
then Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g (Pat GhcTc
p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
else Id -> Bool -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Bool
g Pat GhcTc
p
where
(Scaled Type
ty:[Scaled Type]
_) = DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
dc [Type]
arg_tys
tidy_bang_pat Id
_ Bool
_ SrcSpanAnnA
l Pat GhcTc
p = (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField (SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcTc
p))
push_bang_into_newtype_arg :: SrcSpanAnnA
-> Type
-> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg :: SrcSpanAnnA
-> Type -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg SrcSpanAnnA
l Type
_ty (PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)]
ts (LPat GhcTc
arg:[LPat GhcTc]
args))
= Bool -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
args) (HsConPatDetails GhcTc -> HsConPatDetails GhcTc)
-> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
forall a b. (a -> b) -> a -> b
$
[HsConPatTyArg (NoGhcTc GhcTc)]
-> [LPat GhcTc] -> HsConPatDetails GhcTc
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)]
ts [SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField LPat GhcTc
arg)]
push_bang_into_newtype_arg SrcSpanAnnA
l Type
_ty (RecCon HsRecFields GhcTc (LPat GhcTc)
rf)
| HsRecFields { rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = L SrcSpanAnnA
lf HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
fld : [LHsRecField GhcTc (LPat GhcTc)]
flds } <- HsRecFields GhcTc (LPat GhcTc)
rf
, HsFieldBind { hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (Pat GhcTc)
arg } <- HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc))
fld
= Bool -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsRecField GhcTc (LPat GhcTc)]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcTc))
(GenLocated SrcSpanAnnA (Pat GhcTc)))]
flds) (HsConPatDetails GhcTc -> HsConPatDetails GhcTc)
-> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
forall a b. (a -> b) -> a -> b
$
HsRecFields GhcTc (LPat GhcTc) -> HsConPatDetails GhcTc
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields GhcTc (LPat GhcTc)
rf { rec_flds = [L lf (fld { hfbRHS
= L l (BangPat noExtField arg) })] })
push_bang_into_newtype_arg SrcSpanAnnA
l Type
ty (RecCon HsRecFields GhcTc (LPat GhcTc)
rf)
| HsRecFields { rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [] } <- HsRecFields GhcTc (LPat GhcTc)
rf
= [HsConPatTyArg (GhcPass 'Renamed)]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> HsConDetails
(HsConPatTyArg (GhcPass 'Renamed))
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] [SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcTc
Type
ty)))]
push_bang_into_newtype_arg SrcSpanAnnA
_ Type
_ HsConPatDetails GhcTc
cd
= String
-> SDoc
-> HsConDetails
(HsConPatTyArg (GhcPass 'Renamed))
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"push_bang_into_newtype_arg" (HsConPatDetails GhcTc -> SDoc
forall (p :: Pass).
(OutputableBndrId p, Outputable (Anno (IdGhcP p))) =>
HsConPatDetails (GhcPass p) -> SDoc
pprConArgs HsConPatDetails GhcTc
cd)
matchWrapper
:: HsMatchContextRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper :: HsMatchContextRn
-> Maybe [XRec GhcTc (HsExpr GhcTc)]
-> MatchGroup GhcTc (XRec GhcTc (HsExpr GhcTc))
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContextRn
ctxt Maybe [XRec GhcTc (HsExpr GhcTc)]
scrs (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches
, mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = MatchGroupTc [Scaled Type]
arg_tys Type
rhs_ty Origin
origin
})
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; locn <- getSrcSpanDs
; new_vars <- case matches of
[] -> [Scaled Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
newSysLocalsDs [Scaled Type]
arg_tys
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
m:[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
_) ->
[(Type, Pat GhcTc)] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
selectMatchVars (String
-> (Scaled Type
-> GenLocated SrcSpanAnnA (Pat GhcTc) -> (Type, Pat GhcTc))
-> [Scaled Type]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [(Type, Pat GhcTc)]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"matchWrapper"
(\Scaled Type
a GenLocated SrcSpanAnnA (Pat GhcTc)
b -> (Scaled Type -> Type
forall a. Scaled a -> Type
scaledMult Scaled Type
a, GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
b))
[Scaled Type]
arg_tys
(LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [LPat GhcTc]
forall (id :: Pass) body.
LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
m))
; tracePm "matchWrapper"
(vcat [ ppr ctxt
, text "scrs" <+> ppr scrs
, text "matches group" <+> ppr matches
, text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)])
; matches_nablas <-
if isMatchContextPmChecked dflags origin ctxt
then addHsScrutTmCs (concat scrs) new_vars $
pmcMatches origin (DsMatchContext ctxt locn) new_vars matches
else do { ldi_nablas <- getLdiNablas
; pure $ initNablasMatches ldi_nablas matches }
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
; result_expr <- discard_warnings_if_skip_pmc origin $
matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
where
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info :: LMatch GhcTc (XRec GhcTc (HsExpr GhcTc))
-> (Nablas, NonEmpty Nablas)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfoNE
mk_eqn_info (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats = L EpaLocation
_ [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss })) (Nablas
pat_nablas, NonEmpty Nablas
rhss_nablas)
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let upats = (GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags) [GenLocated SrcSpanAnnA (Pat GhcTc)]
pats
; match_result <- updPmNablas pat_nablas $
dsGRHSs ctxt grhss rhs_ty rhss_nablas
; return $ mkEqnInfo upats match_result }
discard_warnings_if_skip_pmc :: Origin -> DsM a -> DsM a
discard_warnings_if_skip_pmc Origin
orig =
if Origin -> Bool
requiresPMC Origin
orig
then DsM a -> DsM a
forall a. a -> a
id
else DsM a -> DsM a
forall a. DsM a -> DsM a
discardWarningsDs
initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches :: forall b. Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches Nablas
ldi_nablas [LMatch GhcTc b]
ms
= (GenLocated (Anno (Match GhcTc b)) (Match GhcTc b)
-> (Nablas, NonEmpty Nablas))
-> [GenLocated (Anno (Match GhcTc b)) (Match GhcTc b)]
-> [(Nablas, NonEmpty Nablas)]
forall a b. (a -> b) -> [a] -> [b]
map (\(L Anno (Match GhcTc b)
_ Match GhcTc b
m) -> (Nablas
ldi_nablas, Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
forall b. Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs Nablas
ldi_nablas (Match GhcTc b -> GRHSs GhcTc b
forall p body. Match p body -> GRHSs p body
m_grhss Match GhcTc b
m))) [LMatch GhcTc b]
[GenLocated (Anno (Match GhcTc b)) (Match GhcTc b)]
ms
initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs :: forall b. Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs Nablas
ldi_nablas GRHSs GhcTc b
m
= String -> Maybe (NonEmpty Nablas) -> NonEmpty Nablas
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"GRHSs non-empty"
(Maybe (NonEmpty Nablas) -> NonEmpty Nablas)
-> Maybe (NonEmpty Nablas) -> NonEmpty Nablas
forall a b. (a -> b) -> a -> b
$ [Nablas] -> Maybe (NonEmpty Nablas)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
([Nablas] -> Maybe (NonEmpty Nablas))
-> [Nablas] -> Maybe (NonEmpty Nablas)
forall a b. (a -> b) -> a -> b
$ Int -> Nablas -> [Nablas]
forall a. Int -> a -> [a]
replicate ([GenLocated (Anno (GRHS GhcTc b)) (GRHS GhcTc b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (GRHSs GhcTc b -> [LGRHS GhcTc b]
forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs GRHSs GhcTc b
m)) Nablas
ldi_nablas
matchEquations :: HsMatchContextRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations :: HsMatchContextRn
-> [Id] -> [EquationInfoNE] -> Type -> DsM CoreExpr
matchEquations HsMatchContextRn
ctxt [Id]
vars [EquationInfoNE]
eqns_info Type
rhs_ty
= do { match_result <- [Id] -> Type -> [EquationInfoNE] -> DsM (MatchResult CoreExpr)
match [Id]
vars Type
rhs_ty [EquationInfoNE]
eqns_info
; fail_expr <- mkFailExpr ctxt rhs_ty
; extractMatchResult match_result fail_expr }
matchSimply :: CoreExpr
-> HsMatchContextRn
-> Mult
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply :: CoreExpr
-> HsMatchContextRn
-> Type
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply CoreExpr
scrut HsMatchContextRn
hs_ctx Type
mult LPat GhcTc
pat CoreExpr
result_expr CoreExpr
fail_expr = do
let
match_result :: MatchResult CoreExpr
match_result = CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
result_expr
rhs_ty :: Type
rhs_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
fail_expr
match_result' <- CoreExpr
-> HsMatchContextRn
-> LPat GhcTc
-> Type
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePat CoreExpr
scrut HsMatchContextRn
hs_ctx LPat GhcTc
pat Type
mult Type
rhs_ty MatchResult CoreExpr
match_result
extractMatchResult match_result' fail_expr
matchSinglePat :: CoreExpr -> HsMatchContextRn -> LPat GhcTc -> Mult
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePat :: CoreExpr
-> HsMatchContextRn
-> LPat GhcTc
-> Type
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePat (Var Id
var) HsMatchContextRn
ctx LPat GhcTc
pat Type
_ Type
ty MatchResult CoreExpr
match_result
| Bool -> Bool
not (Name -> Bool
isExternalName (Id -> Name
idName Id
var))
= Id
-> Maybe CoreExpr
-> HsMatchContextRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
forall a. Maybe a
Nothing HsMatchContextRn
ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
matchSinglePat CoreExpr
scrut HsMatchContextRn
hs_ctx LPat GhcTc
pat Type
mult Type
ty MatchResult CoreExpr
match_result
= do { var <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL Type
mult LPat GhcTc
pat
; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result
; return $ bindNonRec var scrut <$> match_result'
}
matchSinglePatVar :: Id
-> Maybe CoreExpr
-> HsMatchContextRn -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar :: Id
-> Maybe CoreExpr
-> HsMatchContextRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
mb_scrut HsMatchContextRn
ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
= Bool
-> SDoc -> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isInternalName (Id -> Name
idName Id
var)) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var) (DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr))
-> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$
do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; locn <- getSrcSpanDs
; ldi_nablas <-
if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat
then addCoreScrutTmCs (maybeToList mb_scrut) [var] $
pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
else getLdiNablas
; let eqn_info = EqnMatch { eqn_pat :: LPat GhcTc
eqn_pat = DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
pat
, eqn_rest :: EquationInfoNE
eqn_rest =
MatchResult CoreExpr -> EquationInfoNE
EqnDone (MatchResult CoreExpr -> EquationInfoNE)
-> MatchResult CoreExpr -> EquationInfoNE
forall a b. (a -> b) -> a -> b
$ Nablas -> MatchResult CoreExpr -> MatchResult CoreExpr
forall r. Nablas -> MatchResult r -> MatchResult r
updPmNablasMatchResult Nablas
ldi_nablas MatchResult CoreExpr
match_result }
; match [var] ty [eqn_info] }
updPmNablasMatchResult :: Nablas -> MatchResult r -> MatchResult r
updPmNablasMatchResult :: forall r. Nablas -> MatchResult r -> MatchResult r
updPmNablasMatchResult Nablas
nablas = \case
MR_Infallible DsM r
body_fn -> DsM r -> MatchResult r
forall a. DsM a -> MatchResult a
MR_Infallible (DsM r -> MatchResult r) -> DsM r -> MatchResult r
forall a b. (a -> b) -> a -> b
$
Nablas -> DsM r -> DsM r
forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
nablas DsM r
body_fn
MR_Fallible CoreExpr -> DsM r
body_fn -> (CoreExpr -> DsM r) -> MatchResult r
forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible ((CoreExpr -> DsM r) -> MatchResult r)
-> (CoreExpr -> DsM r) -> MatchResult r
forall a b. (a -> b) -> a -> b
$ \CoreExpr
fail ->
Nablas -> DsM r -> DsM r
forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
nablas (DsM r -> DsM r) -> DsM r -> DsM r
forall a b. (a -> b) -> a -> b
$ CoreExpr -> DsM r
body_fn CoreExpr
fail
data PatGroup
= PgAny
| PgCon DataCon
| PgSyn PatSyn [Type]
| PgLit Literal
| PgN FractionalLit
| PgOverS FastString
| PgNpK Integer
| PgBang
| PgCo Type
| PgView (LHsExpr GhcTc)
Type
instance Show PatGroup where
show :: PatGroup -> String
show PatGroup
PgAny = String
"PgAny"
show (PgCon DataCon
_) = String
"PgCon"
show (PgLit Literal
_) = String
"PgLit"
show (PgView XRec GhcTc (HsExpr GhcTc)
_ Type
_) = String
"PgView"
show PatGroup
_ = String
"PgOther"
groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
groupEquations :: Platform
-> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
groupEquations Platform
platform [EquationInfoNE]
eqns
= ((PatGroup, EquationInfoNE) -> (PatGroup, EquationInfoNE) -> Bool)
-> [(PatGroup, EquationInfoNE)]
-> [NonEmpty (PatGroup, EquationInfoNE)]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy (PatGroup, EquationInfoNE) -> (PatGroup, EquationInfoNE) -> Bool
same_gp ([(PatGroup, EquationInfoNE)]
-> [NonEmpty (PatGroup, EquationInfoNE)])
-> [(PatGroup, EquationInfoNE)]
-> [NonEmpty (PatGroup, EquationInfoNE)]
forall a b. (a -> b) -> a -> b
$ [(Platform -> Pat GhcTc -> PatGroup
patGroup Platform
platform (EquationInfoNE -> Pat GhcTc
firstPat EquationInfoNE
eqn), EquationInfoNE
eqn) | EquationInfoNE
eqn <- [EquationInfoNE]
eqns]
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
(PatGroup
pg1,EquationInfoNE
_) same_gp :: (PatGroup, EquationInfoNE) -> (PatGroup, EquationInfoNE) -> Bool
`same_gp` (PatGroup
pg2,EquationInfoNE
_) = PatGroup
pg1 PatGroup -> PatGroup -> Bool
`sameGroup` PatGroup
pg2
subGroup :: (m -> [NonEmpty EquationInfo])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfo))
-> (a -> NonEmpty EquationInfo -> m -> m)
-> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroup :: forall m a.
(m -> [NonEmpty EquationInfoNE])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfoNE))
-> (a -> NonEmpty EquationInfoNE -> m -> m)
-> [(a, EquationInfoNE)]
-> [NonEmpty EquationInfoNE]
subGroup m -> [NonEmpty EquationInfoNE]
elems m
empty a -> m -> Maybe (NonEmpty EquationInfoNE)
lookup a -> NonEmpty EquationInfoNE -> m -> m
insert [(a, EquationInfoNE)]
group
= (NonEmpty EquationInfoNE -> NonEmpty EquationInfoNE)
-> [NonEmpty EquationInfoNE] -> [NonEmpty EquationInfoNE]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty EquationInfoNE -> NonEmpty EquationInfoNE
forall a. NonEmpty a -> NonEmpty a
NE.reverse ([NonEmpty EquationInfoNE] -> [NonEmpty EquationInfoNE])
-> [NonEmpty EquationInfoNE] -> [NonEmpty EquationInfoNE]
forall a b. (a -> b) -> a -> b
$ m -> [NonEmpty EquationInfoNE]
elems (m -> [NonEmpty EquationInfoNE]) -> m -> [NonEmpty EquationInfoNE]
forall a b. (a -> b) -> a -> b
$ (m -> (a, EquationInfoNE) -> m) -> m -> [(a, EquationInfoNE)] -> m
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' m -> (a, EquationInfoNE) -> m
accumulate m
empty [(a, EquationInfoNE)]
group
where
accumulate :: m -> (a, EquationInfoNE) -> m
accumulate m
pg_map (a
pg, EquationInfoNE
eqn)
= case a -> m -> Maybe (NonEmpty EquationInfoNE)
lookup a
pg m
pg_map of
Just NonEmpty EquationInfoNE
eqns -> a -> NonEmpty EquationInfoNE -> m -> m
insert a
pg (EquationInfoNE
-> NonEmpty EquationInfoNE -> NonEmpty EquationInfoNE
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons EquationInfoNE
eqn NonEmpty EquationInfoNE
eqns) m
pg_map
Maybe (NonEmpty EquationInfoNE)
Nothing -> a -> NonEmpty EquationInfoNE -> m -> m
insert a
pg [Item (NonEmpty EquationInfoNE)
EquationInfoNE
eqn] m
pg_map
subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd :: forall a.
Ord a =>
[(a, EquationInfoNE)] -> [NonEmpty EquationInfoNE]
subGroupOrd = (Map a (NonEmpty EquationInfoNE) -> [NonEmpty EquationInfoNE])
-> Map a (NonEmpty EquationInfoNE)
-> (a
-> Map a (NonEmpty EquationInfoNE)
-> Maybe (NonEmpty EquationInfoNE))
-> (a
-> NonEmpty EquationInfoNE
-> Map a (NonEmpty EquationInfoNE)
-> Map a (NonEmpty EquationInfoNE))
-> [(a, EquationInfoNE)]
-> [NonEmpty EquationInfoNE]
forall m a.
(m -> [NonEmpty EquationInfoNE])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfoNE))
-> (a -> NonEmpty EquationInfoNE -> m -> m)
-> [(a, EquationInfoNE)]
-> [NonEmpty EquationInfoNE]
subGroup Map a (NonEmpty EquationInfoNE) -> [NonEmpty EquationInfoNE]
forall k a. Map k a -> [a]
Map.elems Map a (NonEmpty EquationInfoNE)
forall k a. Map k a
Map.empty a
-> Map a (NonEmpty EquationInfoNE)
-> Maybe (NonEmpty EquationInfoNE)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
-> NonEmpty EquationInfoNE
-> Map a (NonEmpty EquationInfoNE)
-> Map a (NonEmpty EquationInfoNE)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq :: forall a.
Uniquable a =>
[(a, EquationInfoNE)] -> [NonEmpty EquationInfoNE]
subGroupUniq =
(UniqDFM a (NonEmpty EquationInfoNE) -> [NonEmpty EquationInfoNE])
-> UniqDFM a (NonEmpty EquationInfoNE)
-> (a
-> UniqDFM a (NonEmpty EquationInfoNE)
-> Maybe (NonEmpty EquationInfoNE))
-> (a
-> NonEmpty EquationInfoNE
-> UniqDFM a (NonEmpty EquationInfoNE)
-> UniqDFM a (NonEmpty EquationInfoNE))
-> [(a, EquationInfoNE)]
-> [NonEmpty EquationInfoNE]
forall m a.
(m -> [NonEmpty EquationInfoNE])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfoNE))
-> (a -> NonEmpty EquationInfoNE -> m -> m)
-> [(a, EquationInfoNE)]
-> [NonEmpty EquationInfoNE]
subGroup UniqDFM a (NonEmpty EquationInfoNE) -> [NonEmpty EquationInfoNE]
forall {k} (key :: k) elt. UniqDFM key elt -> [elt]
eltsUDFM UniqDFM a (NonEmpty EquationInfoNE)
forall {k} (key :: k) elt. UniqDFM key elt
emptyUDFM ((UniqDFM a (NonEmpty EquationInfoNE)
-> a -> Maybe (NonEmpty EquationInfoNE))
-> a
-> UniqDFM a (NonEmpty EquationInfoNE)
-> Maybe (NonEmpty EquationInfoNE)
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqDFM a (NonEmpty EquationInfoNE)
-> a -> Maybe (NonEmpty EquationInfoNE)
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM) (\a
k NonEmpty EquationInfoNE
v UniqDFM a (NonEmpty EquationInfoNE)
m -> UniqDFM a (NonEmpty EquationInfoNE)
-> a
-> NonEmpty EquationInfoNE
-> UniqDFM a (NonEmpty EquationInfoNE)
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM UniqDFM a (NonEmpty EquationInfoNE)
m a
k NonEmpty EquationInfoNE
v)
sameGroup :: PatGroup -> PatGroup -> Bool
sameGroup :: PatGroup -> PatGroup -> Bool
sameGroup PatGroup
PgAny PatGroup
PgAny = Bool
True
sameGroup PatGroup
PgBang PatGroup
PgBang = Bool
True
sameGroup (PgCon DataCon
_) (PgCon DataCon
_) = Bool
True
sameGroup (PgSyn PatSyn
p1 [Type]
t1) (PgSyn PatSyn
p2 [Type]
t2) = PatSyn
p1PatSyn -> PatSyn -> Bool
forall a. Eq a => a -> a -> Bool
==PatSyn
p2 Bool -> Bool -> Bool
&& [Type] -> [Type] -> Bool
eqTypes [Type]
t1 [Type]
t2
sameGroup (PgLit Literal
_) (PgLit Literal
_) = Bool
True
sameGroup (PgN FractionalLit
l1) (PgN FractionalLit
l2) = FractionalLit
l1FractionalLit -> FractionalLit -> Bool
forall a. Eq a => a -> a -> Bool
==FractionalLit
l2
sameGroup (PgOverS FastString
s1) (PgOverS FastString
s2) = FastString
s1FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
==FastString
s2
sameGroup (PgNpK Integer
l1) (PgNpK Integer
l2) = Integer
l1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
l2
sameGroup (PgCo Type
t1) (PgCo Type
t2) = Type
t1 HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
t2
sameGroup (PgView XRec GhcTc (HsExpr GhcTc)
e1 Type
t1) (PgView XRec GhcTc (HsExpr GhcTc)
e2 Type
t2) = (XRec GhcTc (HsExpr GhcTc), Type)
-> (XRec GhcTc (HsExpr GhcTc), Type) -> Bool
viewLExprEq (XRec GhcTc (HsExpr GhcTc)
e1,Type
t1) (XRec GhcTc (HsExpr GhcTc)
e2,Type
t2)
sameGroup PatGroup
_ PatGroup
_ = Bool
False
viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
viewLExprEq :: (XRec GhcTc (HsExpr GhcTc), Type)
-> (XRec GhcTc (HsExpr GhcTc), Type) -> Bool
viewLExprEq (XRec GhcTc (HsExpr GhcTc)
e1,Type
_) (XRec GhcTc (HsExpr GhcTc)
e2,Type
_) = XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e2
where
lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp :: XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e XRec GhcTc (HsExpr GhcTc)
e' = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e) (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc XRec GhcTc (HsExpr GhcTc)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e')
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp (HsPar XPar GhcTc
_ (L SrcSpanAnnA
_ HsExpr GhcTc
e)) HsExpr GhcTc
e' = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
e HsExpr GhcTc
e'
exp HsExpr GhcTc
e (HsPar XPar GhcTc
_ (L SrcSpanAnnA
_ HsExpr GhcTc
e')) = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
e HsExpr GhcTc
e'
exp (XExpr (WrapExpr HsWrapper
h HsExpr GhcTc
e)) (XExpr (WrapExpr HsWrapper
h' HsExpr GhcTc
e')) =
HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
h HsWrapper
h' Bool -> Bool -> Bool
&& HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
e HsExpr GhcTc
e'
exp (XExpr (ExpandedThingTc HsThingRn
o HsExpr GhcTc
x)) (XExpr (ExpandedThingTc HsThingRn
o' HsExpr GhcTc
x'))
| HsThingRn -> Bool
isHsThingRnExpr HsThingRn
o
, HsThingRn -> Bool
isHsThingRnExpr HsThingRn
o'
= HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
x HsExpr GhcTc
x'
exp (HsVar XVar GhcTc
_ LIdP GhcTc
i) (HsVar XVar GhcTc
_ LIdP GhcTc
i') = LIdP GhcTc
GenLocated SrcSpanAnnN Id
i GenLocated SrcSpanAnnN Id -> GenLocated SrcSpanAnnN Id -> Bool
forall a. Eq a => a -> a -> Bool
== LIdP GhcTc
GenLocated SrcSpanAnnN Id
i'
exp (XExpr (ConLikeTc ConLike
c [Id]
_ [Scaled Type]
_)) (XExpr (ConLikeTc ConLike
c' [Id]
_ [Scaled Type]
_)) = ConLike
c ConLike -> ConLike -> Bool
forall a. Eq a => a -> a -> Bool
== ConLike
c'
exp (HsIPVar XIPVar GhcTc
_ HsIPName
i) (HsIPVar XIPVar GhcTc
_ HsIPName
i') = HsIPName
i HsIPName -> HsIPName -> Bool
forall a. Eq a => a -> a -> Bool
== HsIPName
i'
exp (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
l) (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
l') =
HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType (HsOverLit GhcTc -> Type
overLitType HsOverLit GhcTc
l) (HsOverLit GhcTc -> Type
overLitType HsOverLit GhcTc
l') Bool -> Bool -> Bool
&& HsOverLit GhcTc
l HsOverLit GhcTc -> HsOverLit GhcTc -> Bool
forall a. Eq a => a -> a -> Bool
== HsOverLit GhcTc
l'
exp (HsApp XApp GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e2) (HsApp XApp GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1' XRec GhcTc (HsExpr GhcTc)
e2') = XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e1' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e2 XRec GhcTc (HsExpr GhcTc)
e2'
exp (OpApp XOpApp GhcTc
_ XRec GhcTc (HsExpr GhcTc)
l XRec GhcTc (HsExpr GhcTc)
g XRec GhcTc (HsExpr GhcTc)
ri) (OpApp XOpApp GhcTc
_ XRec GhcTc (HsExpr GhcTc)
l' XRec GhcTc (HsExpr GhcTc)
o' XRec GhcTc (HsExpr GhcTc)
ri') =
XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
l XRec GhcTc (HsExpr GhcTc)
l' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
g XRec GhcTc (HsExpr GhcTc)
o' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
ri XRec GhcTc (HsExpr GhcTc)
ri'
exp (NegApp XNegApp GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e SyntaxExpr GhcTc
n) (NegApp XNegApp GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e' SyntaxExpr GhcTc
n') = XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e XRec GhcTc (HsExpr GhcTc)
e' Bool -> Bool -> Bool
&& SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
syn_exp SyntaxExpr GhcTc
n SyntaxExpr GhcTc
n'
exp (SectionL XSectionL GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e2) (SectionL XSectionL GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1' XRec GhcTc (HsExpr GhcTc)
e2') =
XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e1' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e2 XRec GhcTc (HsExpr GhcTc)
e2'
exp (SectionR XSectionR GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e2) (SectionR XSectionR GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1' XRec GhcTc (HsExpr GhcTc)
e2') =
XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e1' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e2 XRec GhcTc (HsExpr GhcTc)
e2'
exp (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
es1 Boxity
_) (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
es2 Boxity
_) =
(HsTupArg GhcTc -> HsTupArg GhcTc -> Bool)
-> [HsTupArg GhcTc] -> [HsTupArg GhcTc] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eq_list HsTupArg GhcTc -> HsTupArg GhcTc -> Bool
tup_arg [HsTupArg GhcTc]
es1 [HsTupArg GhcTc]
es2
exp (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ XRec GhcTc (HsExpr GhcTc)
e) (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ XRec GhcTc (HsExpr GhcTc)
e') = XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e XRec GhcTc (HsExpr GhcTc)
e'
exp (HsIf XIf GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e2) (HsIf XIf GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e' XRec GhcTc (HsExpr GhcTc)
e1' XRec GhcTc (HsExpr GhcTc)
e2') =
XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e XRec GhcTc (HsExpr GhcTc)
e' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e1' Bool -> Bool -> Bool
&& XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e2 XRec GhcTc (HsExpr GhcTc)
e2'
exp HsExpr GhcTc
_ HsExpr GhcTc
_ = Bool
False
syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
syn_exp (SyntaxExprTc { syn_expr :: SyntaxExprTc -> HsExpr GhcTc
syn_expr = HsExpr GhcTc
expr1
, syn_arg_wraps :: SyntaxExprTc -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps1
, syn_res_wrap :: SyntaxExprTc -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap1 })
(SyntaxExprTc { syn_expr :: SyntaxExprTc -> HsExpr GhcTc
syn_expr = HsExpr GhcTc
expr2
, syn_arg_wraps :: SyntaxExprTc -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps2
, syn_res_wrap :: SyntaxExprTc -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap2 })
= HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
expr1 HsExpr GhcTc
expr2 Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (String
-> (HsWrapper -> HsWrapper -> Bool)
-> [HsWrapper]
-> [HsWrapper]
-> [Bool]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"viewLExprEq" HsWrapper -> HsWrapper -> Bool
wrap [HsWrapper]
arg_wraps1 [HsWrapper]
arg_wraps2) Bool -> Bool -> Bool
&&
HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
res_wrap1 HsWrapper
res_wrap2
syn_exp SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc = Bool
True
syn_exp SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_ = Bool
False
tup_arg :: HsTupArg GhcTc -> HsTupArg GhcTc -> Bool
tup_arg (Present XPresent GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e1) (Present XPresent GhcTc
_ XRec GhcTc (HsExpr GhcTc)
e2) = XRec GhcTc (HsExpr GhcTc) -> XRec GhcTc (HsExpr GhcTc) -> Bool
lexp XRec GhcTc (HsExpr GhcTc)
e1 XRec GhcTc (HsExpr GhcTc)
e2
tup_arg (Missing (Scaled Type
_ Type
t1)) (Missing (Scaled Type
_ Type
t2)) = HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType Type
t1 Type
t2
tup_arg HsTupArg GhcTc
_ HsTupArg GhcTc
_ = Bool
False
wrap :: HsWrapper -> HsWrapper -> Bool
wrap :: HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
WpHole HsWrapper
WpHole = Bool
True
wrap (WpCompose HsWrapper
w1 HsWrapper
w2) (WpCompose HsWrapper
w1' HsWrapper
w2') = HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
w1 HsWrapper
w1' Bool -> Bool -> Bool
&& HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
w2 HsWrapper
w2'
wrap (WpFun HsWrapper
w1 HsWrapper
w2 Scaled Type
_) (WpFun HsWrapper
w1' HsWrapper
w2' Scaled Type
_) = HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
w1 HsWrapper
w1' Bool -> Bool -> Bool
&& HsWrapper -> HsWrapper -> Bool
wrap HsWrapper
w2 HsWrapper
w2'
wrap (WpCast TcCoercionR
co) (WpCast TcCoercionR
co') = TcCoercionR
co TcCoercionR -> TcCoercionR -> Bool
`eqCoercion` TcCoercionR
co'
wrap (WpEvApp EvTerm
et1) (WpEvApp EvTerm
et2) = EvTerm
et1 EvTerm -> EvTerm -> Bool
`ev_term` EvTerm
et2
wrap (WpTyApp Type
t) (WpTyApp Type
t') = HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType Type
t Type
t'
wrap HsWrapper
_ HsWrapper
_ = Bool
False
ev_term :: EvTerm -> EvTerm -> Bool
ev_term :: EvTerm -> EvTerm -> Bool
ev_term (EvExpr (Var Id
a)) (EvExpr (Var Id
b))
= Id -> Type
idType Id
a HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Id -> Type
idType Id
b
ev_term (EvExpr (Coercion TcCoercionR
a)) (EvExpr (Coercion TcCoercionR
b))
= TcCoercionR
a TcCoercionR -> TcCoercionR -> Bool
`eqCoercion` TcCoercionR
b
ev_term EvTerm
_ EvTerm
_ = Bool
False
eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
eq_list :: forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eq_list a -> a -> Bool
_ [] [] = Bool
True
eq_list a -> a -> Bool
_ [] (a
_:[a]
_) = Bool
False
eq_list a -> a -> Bool
_ (a
_:[a]
_) [] = Bool
False
eq_list a -> a -> Bool
eq (a
x:[a]
xs) (a
y:[a]
ys) = a -> a -> Bool
eq a
x a
y Bool -> Bool -> Bool
&& (a -> a -> Bool) -> [a] -> [a] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eq_list a -> a -> Bool
eq [a]
xs [a]
ys
patGroup :: Platform -> Pat GhcTc -> PatGroup
patGroup :: Platform -> Pat GhcTc -> PatGroup
patGroup Platform
_ (ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L SrcSpanAnnN
_ ConLike
con
, pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = ConPatTc { cpt_arg_tys :: ConPatTc -> [Type]
cpt_arg_tys = [Type]
tys }
})
| RealDataCon DataCon
dcon <- ConLike
con = DataCon -> PatGroup
PgCon DataCon
dcon
| PatSynCon PatSyn
psyn <- ConLike
con = PatSyn -> [Type] -> PatGroup
PgSyn PatSyn
psyn [Type]
tys
patGroup Platform
_ (WildPat {}) = PatGroup
PgAny
patGroup Platform
_ (BangPat {}) = PatGroup
PgBang
patGroup Platform
_ (NPat XNPat GhcTc
_ (L EpAnnCO
_ (OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=OverLitVal
oval})) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_) =
case (OverLitVal
oval, Maybe SyntaxExprTc -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
mb_neg) of
(HsIntegral IntegralLit
i, Bool
is_neg) -> FractionalLit -> PatGroup
PgN (Bool -> Integer -> FractionalLit
integralFractionalLit Bool
is_neg (if Bool
is_neg
then Integer -> Integer
forall a. Num a => a -> a
negate (IntegralLit -> Integer
il_value IntegralLit
i)
else IntegralLit -> Integer
il_value IntegralLit
i))
(HsFractional FractionalLit
f, Bool
is_neg)
| Bool
is_neg -> FractionalLit -> PatGroup
PgN (FractionalLit -> PatGroup) -> FractionalLit -> PatGroup
forall a b. (a -> b) -> a -> b
$! FractionalLit -> FractionalLit
negateFractionalLit FractionalLit
f
| Bool
otherwise -> FractionalLit -> PatGroup
PgN FractionalLit
f
(HsIsString SourceText
_ FastString
s, Bool
_) -> Bool -> PatGroup -> PatGroup
forall a. HasCallStack => Bool -> a -> a
assert (Maybe SyntaxExprTc -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
mb_neg) (PatGroup -> PatGroup) -> PatGroup -> PatGroup
forall a b. (a -> b) -> a -> b
$
FastString -> PatGroup
PgOverS FastString
s
patGroup Platform
_ (NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
_ (L EpAnnCO
_ (OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=OverLitVal
oval})) HsOverLit GhcTc
_ SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_) =
case OverLitVal
oval of
HsIntegral IntegralLit
i -> Integer -> PatGroup
PgNpK (IntegralLit -> Integer
il_value IntegralLit
i)
OverLitVal
_ -> String -> SDoc -> PatGroup
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"patGroup NPlusKPat" (OverLitVal -> SDoc
forall a. Outputable a => a -> SDoc
ppr OverLitVal
oval)
patGroup Platform
_ (ViewPat XViewPat GhcTc
_ XRec GhcTc (HsExpr GhcTc)
expr LPat GhcTc
p) = XRec GhcTc (HsExpr GhcTc) -> Type -> PatGroup
PgView XRec GhcTc (HsExpr GhcTc)
expr (Pat GhcTc -> Type
hsPatType (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
p))
patGroup Platform
platform (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit) = Literal -> PatGroup
PgLit (Platform -> HsLit GhcTc -> Literal
hsLitKey Platform
platform HsLit GhcTc
lit)
patGroup Platform
_ EmbTyPat{} = PatGroup
PgAny
patGroup Platform
platform (XPat XXPat GhcTc
ext) = case XXPat GhcTc
ext of
CoPat HsWrapper
_ Pat GhcTc
p Type
_ -> Type -> PatGroup
PgCo (Pat GhcTc -> Type
hsPatType Pat GhcTc
p)
ExpansionPat Pat (GhcPass 'Renamed)
_ Pat GhcTc
p -> Platform -> Pat GhcTc -> PatGroup
patGroup Platform
platform Pat GhcTc
p
patGroup Platform
_ Pat GhcTc
pat = String -> SDoc -> PatGroup
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"patGroup" (Pat GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
pat)