{-# LANGUAGE CPP #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.HsToCore.Match
( match, matchEquations, matchWrapper, matchSimply
, matchSinglePat, matchSinglePatVar
)
where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Platform
import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Hs
import GHC.Tc.Utils.Zonk
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
import GHC.Core
import GHC.Types.Literal
import GHC.Core.Utils
import GHC.Core.Make
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.HsToCore.Match.Constructor
import GHC.HsToCore.Match.Literal
import GHC.Core.Type
import GHC.Core.Coercion ( eqCoercion )
import GHC.Core.TyCon ( isNewTyCon )
import GHC.Core.Multiplicity
import GHC.Builtin.Types
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, when )
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as Map
type MatchId = Id
match :: [MatchId]
-> Type
-> [EquationInfo]
-> DsM (MatchResult CoreExpr)
match :: [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [] Type
ty [EquationInfo]
eqns
= ASSERT2( not (null eqns), ppr ty )
MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr)
-> [MatchResult CoreExpr] -> MatchResult CoreExpr
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr
combineMatchResults [MatchResult CoreExpr]
match_results)
where
match_results :: [MatchResult CoreExpr]
match_results = [ ASSERT( null (eqn_pats eqn) )
EquationInfo -> MatchResult CoreExpr
eqn_rhs EquationInfo
eqn
| EquationInfo
eqn <- [EquationInfo]
eqns ]
match (MatchId
v:[MatchId]
vs) Type
ty [EquationInfo]
eqns
= ASSERT2( all (isInternalName . idName) vars, ppr vars )
do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; ([DsWrapper]
aux_binds, [EquationInfo]
tidy_eqns) <- (EquationInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfo))
-> [EquationInfo]
-> IOEnv (Env DsGblEnv DsLclEnv) ([DsWrapper], [EquationInfo])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (MatchId
-> EquationInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfo)
tidyEqnInfo MatchId
v) [EquationInfo]
eqns
; let grouped :: [NonEmpty (PatGroup, EquationInfo)]
grouped = Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
groupEquations Platform
platform [EquationInfo]
tidy_eqns
; DumpFlag
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_view_pattern_commoning ([NonEmpty (PatGroup, EquationInfo)] -> TcRnIf DsGblEnv DsLclEnv ()
forall (t :: * -> *) b.
Foldable t =>
[t (PatGroup, b)] -> TcRnIf DsGblEnv DsLclEnv ()
debug [NonEmpty (PatGroup, EquationInfo)]
grouped)
; NonEmpty (MatchResult CoreExpr)
match_results <- [NonEmpty (PatGroup, EquationInfo)]
-> DsM (NonEmpty (MatchResult CoreExpr))
match_groups [NonEmpty (PatGroup, EquationInfo)]
grouped
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchResult CoreExpr -> DsM (MatchResult CoreExpr))
-> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ (DsWrapper -> DsWrapper -> DsWrapper)
-> DsWrapper -> [DsWrapper] -> DsWrapper
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DsWrapper -> DsWrapper -> DsWrapper
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) DsWrapper
forall a. a -> a
id [DsWrapper]
aux_binds DsWrapper -> MatchResult CoreExpr -> MatchResult CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr)
-> NonEmpty (MatchResult CoreExpr) -> MatchResult CoreExpr
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr
combineMatchResults NonEmpty (MatchResult CoreExpr)
match_results
}
where
vars :: NonEmpty MatchId
vars = MatchId
v MatchId -> [MatchId] -> NonEmpty MatchId
forall a. a -> [a] -> NonEmpty a
:| [MatchId]
vs
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
dropGroup :: f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup = ((PatGroup, EquationInfo) -> EquationInfo)
-> f (PatGroup, EquationInfo) -> f EquationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatGroup, EquationInfo) -> EquationInfo
forall a b. (a, b) -> b
snd
match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
match_groups :: [NonEmpty (PatGroup, EquationInfo)]
-> DsM (NonEmpty (MatchResult CoreExpr))
match_groups [] = MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty MatchId
v Type
ty
match_groups (NonEmpty (PatGroup, EquationInfo)
g:[NonEmpty (PatGroup, EquationInfo)]
gs) = (NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr))
-> NonEmpty (NonEmpty (PatGroup, EquationInfo))
-> DsM (NonEmpty (MatchResult CoreExpr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr)
match_group (NonEmpty (NonEmpty (PatGroup, EquationInfo))
-> DsM (NonEmpty (MatchResult CoreExpr)))
-> NonEmpty (NonEmpty (PatGroup, EquationInfo))
-> DsM (NonEmpty (MatchResult CoreExpr))
forall a b. (a -> b) -> a -> b
$ NonEmpty (PatGroup, EquationInfo)
g NonEmpty (PatGroup, EquationInfo)
-> [NonEmpty (PatGroup, EquationInfo)]
-> NonEmpty (NonEmpty (PatGroup, EquationInfo))
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty (PatGroup, EquationInfo)]
gs
match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr)
match_group eqns :: NonEmpty (PatGroup, EquationInfo)
eqns@((PatGroup
group,EquationInfo
_) :| [(PatGroup, EquationInfo)]
_)
= case PatGroup
group of
PgCon {} -> NonEmpty MatchId
-> Type
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
matchConFamily NonEmpty MatchId
vars Type
ty ([NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo)
forall a. [a] -> NonEmpty a
ne ([NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo))
-> [NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo)
forall a b. (a -> b) -> a -> b
$ [(DataCon, EquationInfo)] -> [NonEmpty EquationInfo]
forall a.
Uniquable a =>
[(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq [(DataCon
c,EquationInfo
e) | (PgCon DataCon
c, EquationInfo
e) <- [(PatGroup, EquationInfo)]
eqns'])
PgSyn {} -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchPatSyn NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgLit {} -> NonEmpty MatchId
-> Type
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
matchLiterals NonEmpty MatchId
vars Type
ty ([NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo)
forall a. [a] -> NonEmpty a
ne ([NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo))
-> [NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo)
forall a b. (a -> b) -> a -> b
$ [(Literal, EquationInfo)] -> [NonEmpty EquationInfo]
forall a. Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd [(Literal
l,EquationInfo
e) | (PgLit Literal
l, EquationInfo
e) <- [(PatGroup, EquationInfo)]
eqns'])
PatGroup
PgAny -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchVariables NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgN {} -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgOverS {}-> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgNpK {} -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPlusKPats NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PatGroup
PgBang -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgCo {} -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchCoercion NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgView {} -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchView NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PatGroup
PgOverloadedList -> NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList NonEmpty MatchId
vars Type
ty (NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
where eqns' :: [(PatGroup, EquationInfo)]
eqns' = NonEmpty (PatGroup, EquationInfo) -> [(PatGroup, EquationInfo)]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (PatGroup, EquationInfo)
eqns
ne :: [a] -> NonEmpty a
ne [a]
l = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NEL.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
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 (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 LHsExpr GhcTc
e Type
_ -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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 :: [SDoc] -> TcRnIf DsGblEnv DsLclEnv ()
maybeWarn [] = () -> TcRnIf DsGblEnv DsLclEnv ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeWarn [SDoc]
l = DiagnosticReason -> SDoc -> TcRnIf DsGblEnv DsLclEnv ()
diagnosticDs DiagnosticReason
WarningWithoutFlag ([SDoc] -> SDoc
vcat [SDoc]
l)
in
[SDoc] -> TcRnIf DsGblEnv DsLclEnv ()
maybeWarn ([SDoc] -> TcRnIf DsGblEnv DsLclEnv ())
-> [SDoc] -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$ (([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> SDoc)
-> [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g -> String -> SDoc
text String
"Putting these view expressions into the same case:" SDoc -> SDoc -> SDoc
<+> ([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g))
(([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 (t :: * -> *) a. Foldable t => t a -> Bool
null) [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
gs))
matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty MatchId
var Type
res_ty
= NonEmpty (MatchResult CoreExpr)
-> DsM (NonEmpty (MatchResult CoreExpr))
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 (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 (MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
var) (MatchId -> Scaled Type
idScaledType MatchId
var) Type
res_ty
[AltCon -> [MatchId] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
fail]
matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchVariables :: NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchVariables (MatchId
_ :| [MatchId]
vars) Type
ty NonEmpty EquationInfo
eqns = [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [MatchId]
vars Type
ty ([EquationInfo] -> DsM (MatchResult CoreExpr))
-> [EquationInfo] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> [EquationInfo]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty EquationInfo -> [EquationInfo])
-> NonEmpty EquationInfo -> [EquationInfo]
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> NonEmpty EquationInfo
forall (f :: * -> *). Functor f => f EquationInfo -> f EquationInfo
shiftEqns NonEmpty EquationInfo
eqns
matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs :: NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs (MatchId
var :| [MatchId]
vars) Type
ty NonEmpty EquationInfo
eqns
= do { MatchResult CoreExpr
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (MatchId
varMatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM (MatchResult CoreExpr))
-> [EquationInfo] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> [EquationInfo]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty EquationInfo -> [EquationInfo])
-> NonEmpty EquationInfo -> [EquationInfo]
forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getBangPat (EquationInfo -> EquationInfo)
-> NonEmpty EquationInfo -> NonEmpty EquationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr
mkEvalMatchResult MatchId
var Type
ty MatchResult CoreExpr
match_result) }
matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchCoercion :: NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchCoercion (MatchId
var :| [MatchId]
vars) Type
ty (eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
eqn1 :| [EquationInfo]
_))
= do { let XPat (CoPat co pat _) = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; let pat_ty' :: Type
pat_ty' = Pat GhcTc -> Type
hsPatType Pat GhcTc
pat
; MatchId
var' <- MatchId -> Type -> Type -> DsM MatchId
newUniqueId MatchId
var (MatchId -> Type
idMult MatchId
var) Type
pat_ty'
; MatchResult CoreExpr
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (MatchId
var'MatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM (MatchResult CoreExpr))
-> [EquationInfo] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> [EquationInfo]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty EquationInfo -> [EquationInfo])
-> NonEmpty EquationInfo -> [EquationInfo]
forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getCoPat (EquationInfo -> EquationInfo)
-> NonEmpty EquationInfo -> NonEmpty EquationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; DsWrapper
core_wrap <- HsWrapper -> DsM DsWrapper
dsHsWrapper HsWrapper
co
; let bind :: Bind MatchId
bind = MatchId -> CoreExpr -> Bind MatchId
forall b. b -> Expr b -> Bind b
NonRec MatchId
var' (DsWrapper
core_wrap (MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
var))
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bind MatchId -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult Bind MatchId
bind MatchResult CoreExpr
match_result) }
matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchView :: NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchView (MatchId
var :| [MatchId]
vars) Type
ty (eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
eqn1 :| [EquationInfo]
_))
= do {
let ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
viewExpr (L _ pat) = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; let pat_ty' :: Type
pat_ty' = Pat GhcTc -> Type
hsPatType Pat GhcTc
pat
; MatchId
var' <- MatchId -> Type -> Type -> DsM MatchId
newUniqueId MatchId
var (MatchId -> Type
idMult MatchId
var) Type
pat_ty'
; MatchResult CoreExpr
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (MatchId
var'MatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM (MatchResult CoreExpr))
-> [EquationInfo] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> [EquationInfo]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty EquationInfo -> [EquationInfo])
-> NonEmpty EquationInfo -> [EquationInfo]
forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getViewPat (EquationInfo -> EquationInfo)
-> NonEmpty EquationInfo -> NonEmpty EquationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; CoreExpr
viewExpr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
viewExpr
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkViewMatchResult MatchId
var'
(SDoc -> CoreExpr -> DsWrapper
mkCoreAppDs (String -> SDoc
text String
"matchView") CoreExpr
viewExpr' (MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
var))
MatchResult CoreExpr
match_result) }
matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList :: NonEmpty MatchId
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList (MatchId
var :| [MatchId]
vars) Type
ty (eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
eqn1 :| [EquationInfo]
_))
= do { let ListPat (ListPatTc elt_ty (Just (_,e))) [LPat GhcTc]
_ = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; MatchId
var' <- MatchId -> Type -> Type -> DsM MatchId
newUniqueId MatchId
var (MatchId -> Type
idMult MatchId
var) (Type -> Type
mkListTy Type
elt_ty)
; MatchResult CoreExpr
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (MatchId
var'MatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM (MatchResult CoreExpr))
-> [EquationInfo] -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> [EquationInfo]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty EquationInfo -> [EquationInfo])
-> NonEmpty EquationInfo -> [EquationInfo]
forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getOLPat (EquationInfo -> EquationInfo)
-> NonEmpty EquationInfo -> NonEmpty EquationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; CoreExpr
e' <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
e [MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
var]
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkViewMatchResult MatchId
var' CoreExpr
e' MatchResult CoreExpr
match_result)
}
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
extractpat (eqn :: EquationInfo
eqn@(EqnInfo { eqn_pats :: EquationInfo -> [Pat GhcTc]
eqn_pats = Pat GhcTc
pat : [Pat GhcTc]
pats }))
= EquationInfo
eqn { eqn_pats :: [Pat GhcTc]
eqn_pats = Pat GhcTc -> Pat GhcTc
extractpat Pat GhcTc
pat Pat GhcTc -> [Pat GhcTc] -> [Pat GhcTc]
forall a. a -> [a] -> [a]
: [Pat GhcTc]
pats}
decomposeFirstPat Pat GhcTc -> Pat GhcTc
_ EquationInfo
_ = String -> EquationInfo
forall a. String -> a
panic String
"decomposeFirstPat"
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
getCoPat :: Pat GhcTc -> Pat GhcTc
getCoPat (XPat (CoPat _ pat _)) = Pat GhcTc
pat
getCoPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. 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 GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat
getBangPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. String -> a
panic String
"getBangPat"
getViewPat :: Pat GhcTc -> Pat GhcTc
getViewPat (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ LPat GhcTc
pat) = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat
getViewPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. String -> a
panic String
"getViewPat"
getOLPat :: Pat GhcTc -> Pat GhcTc
getOLPat (ListPat (ListPatTc ty (Just _)) [LPat GhcTc]
pats)
= XListPat GhcTc -> [LPat GhcTc] -> Pat GhcTc
forall p. XListPat p -> [LPat p] -> Pat p
ListPat (Type -> Maybe (Type, SyntaxExpr GhcTc) -> ListPatTc
ListPatTc Type
ty Maybe (Type, SyntaxExpr GhcTc)
forall a. Maybe a
Nothing) [LPat GhcTc]
pats
getOLPat Pat GhcTc
_ = String -> Pat GhcTc
forall a. String -> a
panic String
"getOLPat"
tidyEqnInfo :: Id -> EquationInfo
-> DsM (DsWrapper, EquationInfo)
tidyEqnInfo :: MatchId
-> EquationInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfo)
tidyEqnInfo MatchId
_ (EqnInfo { eqn_pats :: EquationInfo -> [Pat GhcTc]
eqn_pats = [] })
= String -> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfo)
forall a. String -> a
panic String
"tidyEqnInfo"
tidyEqnInfo MatchId
v eqn :: EquationInfo
eqn@(EqnInfo { eqn_pats :: EquationInfo -> [Pat GhcTc]
eqn_pats = Pat GhcTc
pat : [Pat GhcTc]
pats, eqn_orig :: EquationInfo -> Origin
eqn_orig = Origin
orig })
= do { (DsWrapper
wrap, Pat GhcTc
pat') <- MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
orig Pat GhcTc
pat
; (DsWrapper, EquationInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (DsWrapper, EquationInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
wrap, EquationInfo
eqn { eqn_pats :: [Pat GhcTc]
eqn_pats = Pat GhcTc
pat' Pat GhcTc -> [Pat GhcTc] -> [Pat GhcTc]
forall a. a -> [a] -> [a]
: [Pat GhcTc]
pats }) }
tidy1 :: Id
-> Origin
-> Pat GhcTc
-> DsM (DsWrapper,
Pat GhcTc)
tidy1 :: MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (ParPat XParPat GhcTc
_ LPat GhcTc
pat) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat)
tidy1 MatchId
v Origin
o (SigPat XSigPat GhcTc
_ LPat GhcTc
pat HsPatSigType (NoGhcTc GhcTc)
_) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat)
tidy1 MatchId
_ Origin
_ (WildPat XWildPat GhcTc
ty) = (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
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 MatchId
v Origin
o (BangPat XBangPat GhcTc
_ (L l p)) = MatchId
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
l Pat GhcTc
p
tidy1 MatchId
v Origin
_ (VarPat XVarPat GhcTc
_ (L _ var))
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> MatchId -> DsWrapper
wrapBind MatchId
var MatchId
v, XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat (MatchId -> Type
idType MatchId
var))
tidy1 MatchId
v Origin
o (AsPat XAsPat GhcTc
_ (L _ var) LPat GhcTc
pat)
= do { (DsWrapper
wrap, Pat GhcTc
pat') <- MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat)
; (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> MatchId -> DsWrapper
wrapBind MatchId
var MatchId
v DsWrapper -> DsWrapper -> DsWrapper
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DsWrapper
wrap, Pat GhcTc
pat') }
tidy1 MatchId
v Origin
_ (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat)
= do { let unlifted_bndrs :: [MatchId]
unlifted_bndrs = (MatchId -> Bool) -> [MatchId] -> [MatchId]
forall a. (a -> Bool) -> [a] -> [a]
filter (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool) -> (MatchId -> Type) -> MatchId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchId -> 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 ([MatchId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MatchId]
unlifted_bndrs) (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat) (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRnIf DsGblEnv DsLclEnv ()
errDs (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A lazy (~) pattern cannot bind variables of unlifted type." SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Unlifted variables:")
Int
2 ([SDoc] -> SDoc
vcat ((MatchId -> SDoc) -> [MatchId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\MatchId
id -> MatchId -> SDoc
forall a. Outputable a => a -> SDoc
ppr MatchId
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (MatchId -> Type
idType MatchId
id))
[MatchId]
unlifted_bndrs)))
; (MatchId
_,[(MatchId, CoreExpr)]
sel_prs) <- [[CoreTickish]]
-> LPat GhcTc -> CoreExpr -> DsM (MatchId, [(MatchId, CoreExpr)])
mkSelectorBinds [] LPat GhcTc
pat (MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
v)
; let sel_binds :: [Bind MatchId]
sel_binds = [MatchId -> CoreExpr -> Bind MatchId
forall b. b -> Expr b -> Bind b
NonRec MatchId
b CoreExpr
rhs | (MatchId
b,CoreExpr
rhs) <- [(MatchId, CoreExpr)]
sel_prs]
; (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bind MatchId] -> DsWrapper
mkCoreLets [Bind MatchId]
sel_binds, XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat (MatchId -> Type
idType MatchId
v)) }
tidy1 MatchId
_ Origin
_ (ListPat (ListPatTc ty Nothing) [LPat GhcTc]
pats )
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
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 (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]
Type
ty])
(Type -> LPat GhcTc
mkNilPat Type
ty)
[GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
pats
tidy1 MatchId
_ Origin
_ (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
pats Boxity
boxity)
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
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)
LPat GhcTc
tuple_ConPat)
where
arity :: Int
arity = [GenLocated SrcSpanAnnA (Pat GhcTc)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat 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 MatchId
_ Origin
_ (SumPat XSumPat GhcTc
tys LPat GhcTc
pat Int
alt Int
arity)
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
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)
LPat 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 MatchId
_ Origin
o (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit)
= do { Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin -> Bool
isGenerated Origin
o) (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 (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, HsLit GhcTc -> Pat GhcTc
tidyLitPat HsLit GhcTc
lit) }
tidy1 MatchId
_ Origin
o (NPat XNPat GhcTc
ty (L _ lit@OverLit { ol_val = 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 (Origin -> Bool
isGenerated Origin
o) (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 :: OverLitVal
ol_val = OverLitVal -> OverLitVal
negateOverLitVal OverLitVal
v }
| Bool
otherwise = HsOverLit GhcTc
lit
in HsOverLit GhcTc -> TcRnIf DsGblEnv DsLclEnv ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit'
; (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
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 Type
XNPat GhcTc
ty) }
tidy1 MatchId
_ Origin
o n :: Pat GhcTc
n@(NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
_ (L _ lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_)
= do { Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin -> Bool
isGenerated Origin
o) (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 (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, Pat GhcTc
n) }
tidy1 MatchId
_ Origin
_ Pat GhcTc
non_interesting_pat
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, Pat GhcTc
non_interesting_pat)
tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat :: MatchId
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
_ (ParPat XParPat GhcTc
_ (L l p)) = MatchId
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
l Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
_ (SigPat XSigPat GhcTc
_ (L l p) HsPatSigType (NoGhcTc GhcTc)
_) = MatchId
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
l Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
l (AsPat XAsPat GhcTc
x LIdP GhcTc
v' LPat GhcTc
p)
= MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (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 NoExtField
XBangPat GhcTc
noExtField LPat GhcTc
p)))
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
l (XPat (CoPat w p t))
= MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (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 -> CoPat
CoPat HsWrapper
w (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
XBangPat GhcTc
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 MatchId
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(LitPat {}) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(ListPat {}) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(TuplePat {}) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(SumPat {}) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpanAnnA
l p :: Pat GhcTc
p@(ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p)
pat_con = L _ (RealDataCon 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 = arg_tys
}
})
=
if TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
then MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (Pat GhcTc
p { pat_args :: HsConPatDetails GhcTc
pat_args = SrcSpanAnnA
-> Type -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg SrcSpanAnnA
l (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty) HsConPatDetails GhcTc
args })
else MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o Pat GhcTc
p
where
(Scaled Type
ty:[Scaled Type]
_) = DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
dc [Type]
arg_tys
tidy_bang_pat MatchId
_ Origin
_ SrcSpanAnnA
l Pat GhcTc
p = (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
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 NoExtField
XBangPat GhcTc
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 [HsPatSigType (NoGhcTc GhcTc)]
ts (LPat GhcTc
arg:[LPat GhcTc]
args))
= ASSERT( null args)
[HsPatSigType (GhcPass 'Renamed)]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> HsConDetails
(HsPatSigType (GhcPass 'Renamed))
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsPatSigType (GhcPass 'Renamed)]
[HsPatSigType (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 NoExtField
XBangPat GhcTc
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 lf fld : [LHsRecField GhcTc (LPat GhcTc)]
flds } <- HsRecFields GhcTc (LPat GhcTc)
rf
, HsRecField { hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = GenLocated SrcSpanAnnA (Pat GhcTc)
arg } <- HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc))
fld
= ASSERT( null flds)
HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
-> HsConDetails
(HsPatSigType (GhcPass 'Renamed))
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))
HsRecFields GhcTc (LPat GhcTc)
rf { rec_flds :: [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))]
rec_flds = [SrcSpanAnnA
-> HsRecField'
(FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated
SrcSpanAnnA
(HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lf (HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc))
fld { hsRecFieldArg :: GenLocated SrcSpanAnnA (Pat GhcTc)
hsRecFieldArg
= 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 NoExtField
XBangPat GhcTc
noExtField GenLocated SrcSpanAnnA (Pat GhcTc)
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 = [] } <- HsRecFields GhcTc (LPat GhcTc)
rf
= [HsPatSigType (GhcPass 'Renamed)]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> HsConDetails
(HsPatSigType (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 NoExtField
XBangPat GhcTc
noExtField (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat Type
XWildPat GhcTc
ty)))]
push_bang_into_newtype_arg SrcSpanAnnA
_ Type
_ HsConPatDetails GhcTc
cd
= String
-> SDoc
-> HsConDetails
(HsPatSigType (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
:: HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper :: HsMatchContext (GhcPass 'Renamed)
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([MatchId], CoreExpr)
matchWrapper HsMatchContext (GhcPass 'Renamed)
ctxt Maybe (LHsExpr GhcTc)
mb_scr (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L _ matches
, mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = MatchGroupTc arg_tys rhs_ty
, mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
= do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; SrcSpan
locn <- DsM SrcSpan
getSrcSpanDs
; [MatchId]
new_vars <- case [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches of
[] -> [Scaled Type] -> IOEnv (Env DsGblEnv DsLclEnv) [MatchId]
newSysLocalsDsNoLP [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) [MatchId]
selectMatchVars (String
-> (Scaled Type
-> GenLocated SrcSpanAnnA (Pat GhcTc) -> (Type, Pat GhcTc))
-> [Scaled Type]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> [(Type, Pat GhcTc)]
forall a b c. 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 GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
m))
; [(Nablas, NonEmpty Nablas)]
matches_nablas <- if DynFlags -> Origin -> HsMatchContext (GhcPass 'Renamed) -> Bool
forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
origin HsMatchContext (GhcPass 'Renamed)
ctxt
then Maybe (LHsExpr GhcTc)
-> [MatchId]
-> DsM [(Nablas, NonEmpty Nablas)]
-> DsM [(Nablas, NonEmpty Nablas)]
forall a. Maybe (LHsExpr GhcTc) -> [MatchId] -> DsM a -> DsM a
addHsScrutTmCs Maybe (LHsExpr GhcTc)
mb_scr [MatchId]
new_vars (DsM [(Nablas, NonEmpty Nablas)]
-> DsM [(Nablas, NonEmpty Nablas)])
-> DsM [(Nablas, NonEmpty Nablas)]
-> DsM [(Nablas, NonEmpty Nablas)]
forall a b. (a -> b) -> a -> b
$
DsMatchContext
-> [MatchId]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> DsM [(Nablas, NonEmpty Nablas)]
pmcMatches (HsMatchContext (GhcPass 'Renamed) -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext (GhcPass 'Renamed)
ctxt SrcSpan
locn) [MatchId]
new_vars [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[LMatch GhcTc (LHsExpr GhcTc)]
matches
else [(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> [(Nablas, NonEmpty Nablas)]
forall b. [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
matches)
; [EquationInfo]
eqns_info <- (GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (Nablas, NonEmpty Nablas)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo)
-> [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [(Nablas, NonEmpty Nablas)]
-> IOEnv (Env DsGblEnv DsLclEnv) [EquationInfo]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (Nablas, NonEmpty Nablas)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
LMatch GhcTc (LHsExpr GhcTc)
-> (Nablas, NonEmpty Nablas)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
mk_eqn_info [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches [(Nablas, NonEmpty Nablas)]
matches_nablas
; CoreExpr
result_expr <- DsM CoreExpr -> DsM CoreExpr
handleWarnings (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
HsMatchContext (GhcPass 'Renamed)
-> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext (GhcPass 'Renamed)
ctxt [MatchId]
new_vars [EquationInfo]
eqns_info Type
rhs_ty
; ([MatchId], CoreExpr) -> DsM ([MatchId], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([MatchId]
new_vars, CoreExpr
result_expr) }
where
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc)
-> (Nablas, NonEmpty Nablas)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (Nablas
pat_nablas, NonEmpty Nablas
rhss_nablas)
= do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let upats :: [Pat GhcTc]
upats = (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [Pat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> (GenLocated SrcSpanAnnA (Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> Pat GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags) [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
pats
; MatchResult CoreExpr
match_result <- Nablas -> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
pat_nablas (DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr))
-> DsM (MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$
HsMatchContext (GhcPass 'Renamed)
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Type
-> NonEmpty Nablas
-> DsM (MatchResult CoreExpr)
dsGRHSs HsMatchContext (GhcPass 'Renamed)
ctxt GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
rhs_ty NonEmpty Nablas
rhss_nablas
; EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
forall (m :: * -> *) a. Monad m => a -> m a
return EqnInfo :: [Pat GhcTc] -> Origin -> MatchResult CoreExpr -> EquationInfo
EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc]
upats
, eqn_orig :: Origin
eqn_orig = Origin
FromSource
, eqn_rhs :: MatchResult CoreExpr
eqn_rhs = MatchResult CoreExpr
match_result } }
handleWarnings :: DsM CoreExpr -> DsM CoreExpr
handleWarnings = if Origin -> Bool
isGenerated Origin
origin
then DsM CoreExpr -> DsM CoreExpr
forall a. DsM a -> DsM a
discardWarningsDs
else DsM CoreExpr -> DsM CoreExpr
forall a. a -> a
id
initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches [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
initNablas, GRHSs GhcTc b -> NonEmpty Nablas
forall b. GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs (Match GhcTc b -> GRHSs GhcTc b
forall p body. Match p body -> GRHSs p body
m_grhss Match GhcTc b
m))) [GenLocated (Anno (Match GhcTc b)) (Match GhcTc b)]
[LMatch GhcTc b]
ms
initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs GRHSs GhcTc b
m = String -> Maybe (NonEmpty Nablas) -> NonEmpty Nablas
forall a. HasCallStack => 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)
NEL.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 (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
initNablas
matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations :: HsMatchContext (GhcPass 'Renamed)
-> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext (GhcPass 'Renamed)
ctxt [MatchId]
vars [EquationInfo]
eqns_info Type
rhs_ty
= do { MatchResult CoreExpr
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [MatchId]
vars Type
rhs_ty [EquationInfo]
eqns_info
; CoreExpr
fail_expr <- HsMatchContext (GhcPass 'Renamed) -> Type -> DsM CoreExpr
mkFailExpr HsMatchContext (GhcPass 'Renamed)
ctxt Type
rhs_ty
; MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult CoreExpr
match_result CoreExpr
fail_expr }
matchSimply :: CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply :: CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply CoreExpr
scrut HsMatchContext (GhcPass 'Renamed)
hs_ctx 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 = CoreExpr -> Type
exprType CoreExpr
fail_expr
MatchResult CoreExpr
match_result' <- CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePat CoreExpr
scrut HsMatchContext (GhcPass 'Renamed)
hs_ctx LPat GhcTc
pat Type
rhs_ty MatchResult CoreExpr
match_result
MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult CoreExpr
match_result' CoreExpr
fail_expr
matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePat :: CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePat (Var MatchId
var) HsMatchContext (GhcPass 'Renamed)
ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
| Bool -> Bool
not (Name -> Bool
isExternalName (MatchId -> Name
idName MatchId
var))
= MatchId
-> Maybe CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar MatchId
var Maybe CoreExpr
forall a. Maybe a
Nothing HsMatchContext (GhcPass 'Renamed)
ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
matchSinglePat CoreExpr
scrut HsMatchContext (GhcPass 'Renamed)
hs_ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
= do { MatchId
var <- Type -> LPat GhcTc -> DsM MatchId
selectSimpleMatchVarL Type
Many LPat GhcTc
pat
; MatchResult CoreExpr
match_result' <- MatchId
-> Maybe CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar MatchId
var (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
scrut) HsMatchContext (GhcPass 'Renamed)
hs_ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchResult CoreExpr -> DsM (MatchResult CoreExpr))
-> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a b. (a -> b) -> a -> b
$ MatchId -> CoreExpr -> DsWrapper
bindNonRec MatchId
var CoreExpr
scrut DsWrapper -> MatchResult CoreExpr -> MatchResult CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchResult CoreExpr
match_result'
}
matchSinglePatVar :: Id
-> Maybe CoreExpr
-> HsMatchContext GhcRn -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar :: MatchId
-> Maybe CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar MatchId
var Maybe CoreExpr
mb_scrut HsMatchContext (GhcPass 'Renamed)
ctx LPat GhcTc
pat Type
ty MatchResult CoreExpr
match_result
= ASSERT2( isInternalName (idName var), ppr var )
do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; SrcSpan
locn <- DsM SrcSpan
getSrcSpanDs
; Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Origin -> HsMatchContext (GhcPass 'Renamed) -> Bool
forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
FromSource HsMatchContext (GhcPass 'Renamed)
ctx) (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
Maybe CoreExpr
-> [MatchId]
-> TcRnIf DsGblEnv DsLclEnv ()
-> TcRnIf DsGblEnv DsLclEnv ()
forall a. Maybe CoreExpr -> [MatchId] -> DsM a -> DsM a
addCoreScrutTmCs Maybe CoreExpr
mb_scrut [Item [MatchId]
MatchId
var] (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
DsMatchContext
-> MatchId -> Pat GhcTc -> TcRnIf DsGblEnv DsLclEnv ()
pmcPatBind (HsMatchContext (GhcPass 'Renamed) -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext (GhcPass 'Renamed)
ctx SrcSpan
locn) MatchId
var (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat)
; let eqn_info :: EquationInfo
eqn_info = EqnInfo :: [Pat GhcTc] -> Origin -> MatchResult CoreExpr -> EquationInfo
EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc (DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
pat)]
, eqn_orig :: Origin
eqn_orig = Origin
FromSource
, eqn_rhs :: MatchResult CoreExpr
eqn_rhs = MatchResult CoreExpr
match_result }
; [MatchId] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Item [MatchId]
MatchId
var] Type
ty [Item [EquationInfo]
EquationInfo
eqn_info] }
data PatGroup
= PgAny
| PgCon DataCon
| PgSyn PatSyn [Type]
| PgLit Literal
| PgN FractionalLit
| PgOverS FastString
| PgNpK Integer
| PgBang
| PgCo Type
| PgView (LHsExpr GhcTc)
Type
| PgOverloadedList
groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
groupEquations Platform
platform [EquationInfo]
eqns
= ((PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool)
-> [(PatGroup, EquationInfo)]
-> [NonEmpty (PatGroup, EquationInfo)]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NEL.groupBy (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
same_gp ([(PatGroup, EquationInfo)] -> [NonEmpty (PatGroup, EquationInfo)])
-> [(PatGroup, EquationInfo)]
-> [NonEmpty (PatGroup, EquationInfo)]
forall a b. (a -> b) -> a -> b
$ [(Platform -> Pat GhcTc -> PatGroup
patGroup Platform
platform (EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn), EquationInfo
eqn) | EquationInfo
eqn <- [EquationInfo]
eqns]
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
(PatGroup
pg1,EquationInfo
_) same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
`same_gp` (PatGroup
pg2,EquationInfo
_) = 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 :: (m -> [NonEmpty EquationInfo])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfo))
-> (a -> NonEmpty EquationInfo -> m -> m)
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
subGroup m -> [NonEmpty EquationInfo]
elems m
empty a -> m -> Maybe (NonEmpty EquationInfo)
lookup a -> NonEmpty EquationInfo -> m -> m
insert [(a, EquationInfo)]
group
= (NonEmpty EquationInfo -> NonEmpty EquationInfo)
-> [NonEmpty EquationInfo] -> [NonEmpty EquationInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty EquationInfo -> NonEmpty EquationInfo
forall a. NonEmpty a -> NonEmpty a
NEL.reverse ([NonEmpty EquationInfo] -> [NonEmpty EquationInfo])
-> [NonEmpty EquationInfo] -> [NonEmpty EquationInfo]
forall a b. (a -> b) -> a -> b
$ m -> [NonEmpty EquationInfo]
elems (m -> [NonEmpty EquationInfo]) -> m -> [NonEmpty EquationInfo]
forall a b. (a -> b) -> a -> b
$ (m -> (a, EquationInfo) -> m) -> m -> [(a, EquationInfo)] -> m
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' m -> (a, EquationInfo) -> m
accumulate m
empty [(a, EquationInfo)]
group
where
accumulate :: m -> (a, EquationInfo) -> m
accumulate m
pg_map (a
pg, EquationInfo
eqn)
= case a -> m -> Maybe (NonEmpty EquationInfo)
lookup a
pg m
pg_map of
Just NonEmpty EquationInfo
eqns -> a -> NonEmpty EquationInfo -> m -> m
insert a
pg (EquationInfo -> NonEmpty EquationInfo -> NonEmpty EquationInfo
forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons EquationInfo
eqn NonEmpty EquationInfo
eqns) m
pg_map
Maybe (NonEmpty EquationInfo)
Nothing -> a -> NonEmpty EquationInfo -> m -> m
insert a
pg [Item (NonEmpty EquationInfo)
EquationInfo
eqn] m
pg_map
subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd :: [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd = (Map a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo])
-> Map a (NonEmpty EquationInfo)
-> (a
-> Map a (NonEmpty EquationInfo) -> Maybe (NonEmpty EquationInfo))
-> (a
-> NonEmpty EquationInfo
-> Map a (NonEmpty EquationInfo)
-> Map a (NonEmpty EquationInfo))
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
forall m a.
(m -> [NonEmpty EquationInfo])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfo))
-> (a -> NonEmpty EquationInfo -> m -> m)
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
subGroup Map a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo]
forall k a. Map k a -> [a]
Map.elems Map a (NonEmpty EquationInfo)
forall k a. Map k a
Map.empty a -> Map a (NonEmpty EquationInfo) -> Maybe (NonEmpty EquationInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
-> NonEmpty EquationInfo
-> Map a (NonEmpty EquationInfo)
-> Map a (NonEmpty EquationInfo)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq :: [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq =
(UniqDFM a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo])
-> UniqDFM a (NonEmpty EquationInfo)
-> (a
-> UniqDFM a (NonEmpty EquationInfo)
-> Maybe (NonEmpty EquationInfo))
-> (a
-> NonEmpty EquationInfo
-> UniqDFM a (NonEmpty EquationInfo)
-> UniqDFM a (NonEmpty EquationInfo))
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
forall m a.
(m -> [NonEmpty EquationInfo])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfo))
-> (a -> NonEmpty EquationInfo -> m -> m)
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
subGroup UniqDFM a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo]
forall key elt. UniqDFM key elt -> [elt]
eltsUDFM UniqDFM a (NonEmpty EquationInfo)
forall key elt. UniqDFM key elt
emptyUDFM ((UniqDFM a (NonEmpty EquationInfo)
-> a -> Maybe (NonEmpty EquationInfo))
-> a
-> UniqDFM a (NonEmpty EquationInfo)
-> Maybe (NonEmpty EquationInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqDFM a (NonEmpty EquationInfo)
-> a -> Maybe (NonEmpty EquationInfo)
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM) (\a
k NonEmpty EquationInfo
v UniqDFM a (NonEmpty EquationInfo)
m -> UniqDFM a (NonEmpty EquationInfo)
-> a -> NonEmpty EquationInfo -> UniqDFM a (NonEmpty EquationInfo)
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM UniqDFM a (NonEmpty EquationInfo)
m a
k NonEmpty EquationInfo
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 Type -> Type -> Bool
`eqType` Type
t2
sameGroup (PgView LHsExpr GhcTc
e1 Type
t1) (PgView LHsExpr GhcTc
e2 Type
t2) = (LHsExpr GhcTc, Type) -> (LHsExpr GhcTc, Type) -> Bool
viewLExprEq (LHsExpr GhcTc
e1,Type
t1) (LHsExpr GhcTc
e2,Type
t2)
sameGroup PatGroup
_ PatGroup
_ = Bool
False
viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
viewLExprEq :: (LHsExpr GhcTc, Type) -> (LHsExpr GhcTc, Type) -> Bool
viewLExprEq (LHsExpr GhcTc
e1,Type
_) (LHsExpr GhcTc
e2,Type
_) = LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e2
where
lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e LHsExpr GhcTc
e' = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
e) (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
e')
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp (HsPar XPar GhcTc
_ (L _ e)) HsExpr GhcTc
e' = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
e HsExpr GhcTc
e'
exp HsExpr GhcTc
e (HsPar XPar GhcTc
_ (L _ e')) = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
e HsExpr GhcTc
e'
exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' 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 (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =
HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
b HsExpr GhcTc
b'
exp (HsVar XVar GhcTc
_ LIdP GhcTc
i) (HsVar XVar GhcTc
_ LIdP GhcTc
i') = GenLocated SrcSpanAnnN MatchId
LIdP GhcTc
i GenLocated SrcSpanAnnN MatchId
-> GenLocated SrcSpanAnnN MatchId -> Bool
forall a. Eq a => a -> a -> Bool
== GenLocated SrcSpanAnnN MatchId
LIdP GhcTc
i'
exp (HsConLikeOut XConLikeOut GhcTc
_ ConLike
c) (HsConLikeOut XConLikeOut GhcTc
_ ConLike
c') = 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') =
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
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) (HsApp XApp GhcTc
_ LHsExpr GhcTc
e1' LHsExpr GhcTc
e2') = LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e1' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e2 LHsExpr GhcTc
e2'
exp (OpApp XOpApp GhcTc
_ LHsExpr GhcTc
l LHsExpr GhcTc
o LHsExpr GhcTc
ri) (OpApp XOpApp GhcTc
_ LHsExpr GhcTc
l' LHsExpr GhcTc
o' LHsExpr GhcTc
ri') =
LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
l LHsExpr GhcTc
l' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
o LHsExpr GhcTc
o' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
ri LHsExpr GhcTc
ri'
exp (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
n) (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e' SyntaxExpr GhcTc
n') = LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e LHsExpr GhcTc
e' Bool -> Bool -> Bool
&& SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
syn_exp SyntaxExpr GhcTc
n SyntaxExpr GhcTc
n'
exp (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1' LHsExpr GhcTc
e2') =
LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e1' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e2 LHsExpr GhcTc
e2'
exp (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1' LHsExpr GhcTc
e2') =
LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e1' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e2 LHsExpr 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
_ LHsExpr GhcTc
e) (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e') = LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e LHsExpr GhcTc
e'
exp (HsIf XIf GhcTc
_ LHsExpr GhcTc
e LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) (HsIf XIf GhcTc
_ LHsExpr GhcTc
e' LHsExpr GhcTc
e1' LHsExpr GhcTc
e2') =
LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e LHsExpr GhcTc
e' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e1' Bool -> Bool -> Bool
&& LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e2 LHsExpr 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 = expr1
, syn_arg_wraps = arg_wraps1
, syn_res_wrap = res_wrap1 })
(SyntaxExprTc { syn_expr = expr2
, syn_arg_wraps = arg_wraps2
, syn_res_wrap = 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. 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
NoSyntaxExprTc SyntaxExpr GhcTc
NoSyntaxExprTc = Bool
True
syn_exp SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_ = Bool
False
tup_arg :: HsTupArg GhcTc -> HsTupArg GhcTc -> Bool
tup_arg (Present XPresent GhcTc
_ LHsExpr GhcTc
e1) (Present XPresent GhcTc
_ LHsExpr GhcTc
e2) = LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e2
tup_arg (Missing (Scaled _ t1)) (Missing (Scaled _ t2)) = 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
_ SDoc
_) (WpFun HsWrapper
w1' HsWrapper
w2' Scaled Type
_ SDoc
_) = 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') = 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 MatchId
a)) (EvExpr (Var MatchId
b))
= MatchId -> Type
idType MatchId
a Type -> Type -> Bool
`eqType` MatchId -> Type
idType MatchId
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 :: (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 _ con
, pat_con_ext :: forall p. Pat p -> XConPat p
pat_con_ext = ConPatTc { cpt_arg_tys = 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 _ (OverLit {ol_val=oval})) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_) =
case (OverLitVal
oval, Maybe SyntaxExprTc -> Bool
forall a. Maybe a -> Bool
isJust Maybe SyntaxExprTc
Maybe (SyntaxExpr GhcTc)
mb_neg) of
(HsIntegral IntegralLit
i, Bool
is_neg) -> FractionalLit -> PatGroup
PgN (Bool -> Integer -> FractionalLit
integralFractionalLit Bool
is_neg (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
_) -> ASSERT(isNothing mb_neg)
FastString -> PatGroup
PgOverS FastString
s
patGroup Platform
_ (NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
_ (L _ (OverLit {ol_val=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
_ (XPat (CoPat _ p _)) = Type -> PatGroup
PgCo (Pat GhcTc -> Type
hsPatType Pat GhcTc
p)
patGroup Platform
_ (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
expr LPat GhcTc
p) = LHsExpr GhcTc -> Type -> PatGroup
PgView LHsExpr GhcTc
expr (Pat GhcTc -> Type
hsPatType (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
p))
patGroup Platform
_ (ListPat (ListPatTc _ (Just _)) [LPat GhcTc]
_) = PatGroup
PgOverloadedList
patGroup Platform
platform (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit) = Literal -> PatGroup
PgLit (Platform -> HsLit GhcTc -> Literal
hsLitKey Platform
platform HsLit GhcTc
lit)
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)