{-# 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 "HsVersions.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 :: [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [] Kind
ty [EquationInfo]
eqns
= ASSERT2( not (null eqns), ppr ty )
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (Id
v:[Id]
vs) Kind
ty [EquationInfo]
eqns
= ASSERT2( all (isInternalName . idName) vars, ppr vars )
do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; ([DsWrapper]
aux_binds, [EquationInfo]
tidy_eqns) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (Id -> EquationInfo -> DsM (DsWrapper, EquationInfo)
tidyEqnInfo Id
v) [EquationInfo]
eqns
; let grouped :: [NonEmpty (PatGroup, EquationInfo)]
grouped = Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
groupEquations Platform
platform [EquationInfo]
tidy_eqns
; forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_view_pattern_commoning (forall {t :: * -> *} {b}.
Foldable t =>
[t (PatGroup, b)] -> IOEnv (Env 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
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [DsWrapper]
aux_binds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
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 Id
vars = Id
v forall a. a -> [a] -> NonEmpty a
:| [Id]
vs
dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
dropGroup :: forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 [] = Id -> Kind -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty Id
v Kind
ty
match_groups (NonEmpty (PatGroup, EquationInfo)
g:[NonEmpty (PatGroup, EquationInfo)]
gs) = 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 forall a b. (a -> b) -> a -> b
$ NonEmpty (PatGroup, EquationInfo)
g 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 Id
-> Kind
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
matchConFamily NonEmpty Id
vars Kind
ty (forall {a}. [a] -> NonEmpty a
ne forall a b. (a -> b) -> a -> b
$ forall a.
Uniquable a =>
[(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq [(DataCon
c,EquationInfo
e) | (PgCon DataCon
c, EquationInfo
e) <- [(PatGroup, EquationInfo)]
eqns'])
PgSyn {} -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchPatSyn NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgLit {} -> NonEmpty Id
-> Kind
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
matchLiterals NonEmpty Id
vars Kind
ty (forall {a}. [a] -> NonEmpty a
ne forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd [(Literal
l,EquationInfo
e) | (PgLit Literal
l, EquationInfo
e) <- [(PatGroup, EquationInfo)]
eqns'])
PatGroup
PgAny -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchVariables NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgN {} -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgOverS {}-> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgNpK {} -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPlusKPats NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PatGroup
PgBang -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgCo {} -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchCoercion NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PgView {} -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchView NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
PatGroup
PgOverloadedList -> NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList NonEmpty Id
vars Kind
ty (forall (f :: * -> *).
Functor f =>
f (PatGroup, EquationInfo) -> f EquationInfo
dropGroup NonEmpty (PatGroup, EquationInfo)
eqns)
where eqns' :: [(PatGroup, EquationInfo)]
eqns' = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (PatGroup, EquationInfo)
eqns
ne :: [a] -> NonEmpty a
ne [a]
l = case forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [a]
l of
Just NonEmpty a
nel -> NonEmpty a
nel
Maybe (NonEmpty a)
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"match match_group" 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)] -> IOEnv (Env DsGblEnv DsLclEnv) ()
debug [t (PatGroup, b)]
eqns =
let gs :: [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
gs = forall a b. (a -> b) -> [a] -> [b]
map (\t (PatGroup, b)
group -> 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 Kind
_ -> LHsExpr GhcTc
eforall 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] -> IOEnv (Env DsGblEnv DsLclEnv) ()
maybeWarn [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeWarn [SDoc]
l = WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs WarnReason
NoReason ([SDoc] -> SDoc
vcat [SDoc]
l)
in
[SDoc] -> IOEnv (Env DsGblEnv DsLclEnv) ()
maybeWarn forall a b. (a -> b) -> a -> b
$ (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
<+> (forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g))
(forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
gs))
matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty :: Id -> Kind -> DsM (NonEmpty (MatchResult CoreExpr))
matchEmpty Id
var Kind
res_ty
= forall (m :: * -> *) a. Monad m => a -> m a
return [forall a. (CoreExpr -> DsM a) -> MatchResult a
MR_Fallible CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
mk_seq]
where
mk_seq :: CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
mk_seq CoreExpr
fail = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CoreExpr -> Scaled Kind -> Kind -> [CoreAlt] -> CoreExpr
mkWildCase (forall b. Id -> Expr b
Var Id
var) (Id -> Scaled Kind
idScaledType Id
var) Kind
res_ty
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
fail]
matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchVariables :: NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchVariables (Id
_ :| [Id]
vars) Kind
ty NonEmpty EquationInfo
eqns = [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id]
vars Kind
ty forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Functor f => f EquationInfo -> f EquationInfo
shiftEqns NonEmpty EquationInfo
eqns
matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs :: NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchBangs (Id
var :| [Id]
vars) Kind
ty NonEmpty EquationInfo
eqns
= do { MatchResult CoreExpr
match_result <- [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (Id
varforall a. a -> [a] -> [a]
:[Id]
vars) Kind
ty forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getBangPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Kind -> MatchResult CoreExpr -> MatchResult CoreExpr
mkEvalMatchResult Id
var Kind
ty MatchResult CoreExpr
match_result) }
matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchCoercion :: NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchCoercion (Id
var :| [Id]
vars) Kind
ty (eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
eqn1 :| [EquationInfo]
_))
= do { let XPat (CoPat HsWrapper
co Pat GhcTc
pat Kind
_) = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; let pat_ty' :: Kind
pat_ty' = Pat GhcTc -> Kind
hsPatType Pat GhcTc
pat
; Id
var' <- Id -> Kind -> Kind -> DsM Id
newUniqueId Id
var (Id -> Kind
idMult Id
var) Kind
pat_ty'
; MatchResult CoreExpr
match_result <- [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (Id
var'forall a. a -> [a] -> [a]
:[Id]
vars) Kind
ty forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getCoPat 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 Id
bind = forall b. b -> Expr b -> Bind b
NonRec Id
var' (DsWrapper
core_wrap (forall b. Id -> Expr b
Var Id
var))
; 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 EquationInfo -> DsM (MatchResult CoreExpr)
matchView :: NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchView (Id
var :| [Id]
vars) Kind
ty (eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
eqn1 :| [EquationInfo]
_))
= do {
let ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
viewExpr (L SrcSpanAnnA
_ Pat GhcTc
pat) = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; let pat_ty' :: Kind
pat_ty' = Pat GhcTc -> Kind
hsPatType Pat GhcTc
pat
; Id
var' <- Id -> Kind -> Kind -> DsM Id
newUniqueId Id
var (Id -> Kind
idMult Id
var) Kind
pat_ty'
; MatchResult CoreExpr
match_result <- [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (Id
var'forall a. a -> [a] -> [a]
:[Id]
vars) Kind
ty forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getViewPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; CoreExpr
viewExpr' <- LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsLExpr LHsExpr GhcTc
viewExpr
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkViewMatchResult Id
var'
(SDoc -> CoreExpr -> DsWrapper
mkCoreAppDs (String -> SDoc
text String
"matchView") CoreExpr
viewExpr' (forall b. Id -> Expr b
Var Id
var))
MatchResult CoreExpr
match_result) }
matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList :: NonEmpty Id
-> Kind -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchOverloadedList (Id
var :| [Id]
vars) Kind
ty (eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
eqn1 :| [EquationInfo]
_))
= do { let ListPat (ListPatTc Kind
elt_ty (Just (Kind
_,SyntaxExpr GhcTc
e))) [LPat GhcTc]
_ = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; Id
var' <- Id -> Kind -> Kind -> DsM Id
newUniqueId Id
var (Id -> Kind
idMult Id
var) (Kind -> Kind
mkListTy Kind
elt_ty)
; MatchResult CoreExpr
match_result <- [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match (Id
var'forall a. a -> [a] -> [a]
:[Id]
vars) Kind
ty forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$
(Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getOLPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EquationInfo
eqns
; CoreExpr
e' <- SyntaxExpr GhcTc
-> [CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
e [forall b. Id -> Expr b
Var Id
var]
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkViewMatchResult Id
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 forall a. a -> [a] -> [a]
: [Pat GhcTc]
pats}
decomposeFirstPat Pat GhcTc -> Pat GhcTc
_ EquationInfo
_ = forall a. String -> a
panic String
"decomposeFirstPat"
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
getCoPat :: Pat GhcTc -> Pat GhcTc
getCoPat (XPat (CoPat HsWrapper
_ Pat GhcTc
pat Kind
_)) = Pat GhcTc
pat
getCoPat Pat GhcTc
_ = forall a. String -> a
panic String
"getCoPat"
getBangPat :: Pat GhcTc -> Pat GhcTc
getBangPat (BangPat XBangPat GhcTc
_ LPat GhcTc
pat ) = forall l e. GenLocated l e -> e
unLoc LPat GhcTc
pat
getBangPat Pat GhcTc
_ = forall a. String -> a
panic String
"getBangPat"
getViewPat :: Pat GhcTc -> Pat GhcTc
getViewPat (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ LPat GhcTc
pat) = forall l e. GenLocated l e -> e
unLoc LPat GhcTc
pat
getViewPat Pat GhcTc
_ = forall a. String -> a
panic String
"getViewPat"
getOLPat :: Pat GhcTc -> Pat GhcTc
getOLPat (ListPat (ListPatTc Kind
ty (Just (Kind, SyntaxExpr GhcTc)
_)) [LPat GhcTc]
pats)
= forall p. XListPat p -> [LPat p] -> Pat p
ListPat (Kind -> Maybe (Kind, SyntaxExpr GhcTc) -> ListPatTc
ListPatTc Kind
ty forall a. Maybe a
Nothing) [LPat GhcTc]
pats
getOLPat Pat GhcTc
_ = forall a. String -> a
panic String
"getOLPat"
tidyEqnInfo :: Id -> EquationInfo
-> DsM (DsWrapper, EquationInfo)
tidyEqnInfo :: Id -> EquationInfo -> DsM (DsWrapper, EquationInfo)
tidyEqnInfo Id
_ (EqnInfo { eqn_pats :: EquationInfo -> [Pat GhcTc]
eqn_pats = [] })
= forall a. String -> a
panic String
"tidyEqnInfo"
tidyEqnInfo Id
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') <- Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
orig Pat GhcTc
pat
; forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
wrap, EquationInfo
eqn { eqn_pats :: [Pat GhcTc]
eqn_pats = Pat GhcTc
pat' forall a. a -> [a] -> [a]
: [Pat GhcTc]
pats }) }
tidy1 :: Id
-> Origin
-> Pat GhcTc
-> DsM (DsWrapper,
Pat GhcTc)
tidy1 :: Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (ParPat XParPat GhcTc
_ LPat GhcTc
pat) = Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
pat)
tidy1 Id
v Origin
o (SigPat XSigPat GhcTc
_ LPat GhcTc
pat HsPatSigType (NoGhcTc GhcTc)
_) = Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
pat)
tidy1 Id
_ Origin
_ (WildPat XWildPat GhcTc
ty) = forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, forall p. XWildPat p -> Pat p
WildPat XWildPat GhcTc
ty)
tidy1 Id
v Origin
o (BangPat XBangPat GhcTc
_ (L SrcSpanAnnA
l Pat GhcTc
p)) = Id
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
l Pat GhcTc
p
tidy1 Id
v Origin
_ (VarPat XVarPat GhcTc
_ (L SrcSpanAnnN
_ Id
var))
= forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id -> DsWrapper
wrapBind Id
var Id
v, forall p. XWildPat p -> Pat p
WildPat (Id -> Kind
idType Id
var))
tidy1 Id
v Origin
o (AsPat XAsPat GhcTc
_ (L SrcSpanAnnN
_ Id
var) LPat GhcTc
pat)
= do { (DsWrapper
wrap, Pat GhcTc
pat') <- Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
pat)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Id -> DsWrapper
wrapBind Id
var Id
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. DsWrapper
wrap, Pat GhcTc
pat') }
tidy1 Id
v Origin
_ (LazyPat XLazyPat GhcTc
_ LPat GhcTc
pat)
= do { let unlifted_bndrs :: [Id]
unlifted_bndrs = forall a. (a -> Bool) -> [a] -> [a]
filter (HasDebugCallStack => Kind -> Bool
isUnliftedType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Kind
idType) (forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders LPat GhcTc
pat)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
unlifted_bndrs) forall a b. (a -> b) -> a -> b
$
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LPat GhcTc
pat) forall a b. (a -> b) -> a -> b
$
SDoc -> IOEnv (Env 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 (forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id))
[Id]
unlifted_bndrs)))
; (Id
_,[(Id, CoreExpr)]
sel_prs) <- [[CoreTickish]]
-> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])
mkSelectorBinds [] LPat GhcTc
pat (forall b. Id -> Expr b
Var Id
v)
; let sel_binds :: [Bind Id]
sel_binds = [forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
rhs | (Id
b,CoreExpr
rhs) <- [(Id, CoreExpr)]
sel_prs]
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Bind Id] -> DsWrapper
mkCoreLets [Bind Id]
sel_binds, forall p. XWildPat p -> Pat p
WildPat (Id -> Kind
idType Id
v)) }
tidy1 Id
_ Origin
_ (ListPat (ListPatTc Kind
ty Maybe (Kind, SyntaxExpr GhcTc)
Nothing) [LPat GhcTc]
pats )
= forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
list_ConPat)
where
list_ConPat :: GenLocated SrcSpanAnnA (Pat GhcTc)
list_ConPat = 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] -> [Kind] -> LPat GhcTc
mkPrefixConPat DataCon
consDataCon [GenLocated SrcSpanAnnA (Pat GhcTc)
x, GenLocated SrcSpanAnnA (Pat GhcTc)
y] [Kind
ty])
(Kind -> LPat GhcTc
mkNilPat Kind
ty)
[LPat GhcTc]
pats
tidy1 Id
_ Origin
_ (TuplePat XTuplePat GhcTc
tys [LPat GhcTc]
pats Boxity
boxity)
= forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, forall l e. GenLocated l e -> e
unLoc LPat GhcTc
tuple_ConPat)
where
arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPat GhcTc]
pats
tuple_ConPat :: LPat GhcTc
tuple_ConPat = DataCon -> [LPat GhcTc] -> [Kind] -> LPat GhcTc
mkPrefixConPat (Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity Int
arity) [LPat GhcTc]
pats [Kind]
tys'
tys' :: [Kind]
tys' = case Boxity
boxity of
Boxity
Unboxed -> forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Kind -> Kind
getRuntimeRep XTuplePat GhcTc
tys forall a. [a] -> [a] -> [a]
++ XTuplePat GhcTc
tys
Boxity
Boxed -> XTuplePat GhcTc
tys
tidy1 Id
_ Origin
_ (SumPat XSumPat GhcTc
tys LPat GhcTc
pat Int
alt Int
arity)
= forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, forall l e. GenLocated l e -> e
unLoc LPat GhcTc
sum_ConPat)
where
sum_ConPat :: LPat GhcTc
sum_ConPat = DataCon -> [LPat GhcTc] -> [Kind] -> LPat GhcTc
mkPrefixConPat (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity) [LPat GhcTc
pat] (forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Kind -> Kind
getRuntimeRep XSumPat GhcTc
tys forall a. [a] -> [a] -> [a]
++ XSumPat GhcTc
tys)
tidy1 Id
_ Origin
o (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit)
= do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin -> Bool
isGenerated Origin
o) forall a b. (a -> b) -> a -> b
$
HsLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedLit HsLit GhcTc
lit
; forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, HsLit GhcTc -> Pat GhcTc
tidyLitPat HsLit GhcTc
lit) }
tidy1 Id
_ Origin
o (NPat XNPat GhcTc
ty (L SrcSpan
_ 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 { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin -> Bool
isGenerated Origin
o) 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 -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit'
; forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, HsOverLit GhcTc
-> Maybe (SyntaxExpr GhcTc)
-> SyntaxExpr GhcTc
-> Kind
-> Pat GhcTc
tidyNPat HsOverLit GhcTc
lit Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq XNPat GhcTc
ty) }
tidy1 Id
_ Origin
o n :: Pat GhcTc
n@(NPlusKPat XNPlusKPat GhcTc
_ LIdP GhcTc
_ (L SrcSpan
_ HsOverLit GhcTc
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_)
= do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin -> Bool
isGenerated Origin
o) forall a b. (a -> b) -> a -> b
$ do
HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit1
HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit2
; forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, Pat GhcTc
n) }
tidy1 Id
_ Origin
_ Pat GhcTc
non_interesting_pat
= 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 :: Id
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
_ (ParPat XParPat GhcTc
_ (L SrcSpanAnnA
l Pat GhcTc
p)) = Id
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
l Pat GhcTc
p
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
_ (SigPat XSigPat GhcTc
_ (L SrcSpanAnnA
l Pat GhcTc
p) HsPatSigType (NoGhcTc GhcTc)
_) = Id
-> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
l Pat GhcTc
p
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
l (AsPat XAsPat GhcTc
x LIdP GhcTc
v' LPat GhcTc
p)
= Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat XAsPat GhcTc
x LIdP GhcTc
v' (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
noExtField LPat GhcTc
p)))
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
l (XPat (CoPat HsWrapper
w Pat GhcTc
p Kind
t))
= Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (forall p. XXPat p -> Pat p
XPat forall a b. (a -> b) -> a -> b
$ HsWrapper -> Pat GhcTc -> Kind -> CoPat
CoPat HsWrapper
w (forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l Pat GhcTc
p)) Kind
t)
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(LitPat {}) = Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o Pat GhcTc
p
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(ListPat {}) = Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o Pat GhcTc
p
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(TuplePat {}) = Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o Pat GhcTc
p
tidy_bang_pat Id
v Origin
o SrcSpanAnnA
_ p :: Pat GhcTc
p@(SumPat {}) = Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o Pat GhcTc
p
tidy_bang_pat Id
v Origin
o 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 -> [Kind]
cpt_arg_tys = [Kind]
arg_tys
}
})
=
if TyCon -> Bool
isNewTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)
then Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o (Pat GhcTc
p { pat_args :: HsConPatDetails GhcTc
pat_args = SrcSpanAnnA
-> Kind -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg SrcSpanAnnA
l (forall a. Scaled a -> a
scaledThing Scaled Kind
ty) HsConPatDetails GhcTc
args })
else Id -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 Id
v Origin
o Pat GhcTc
p
where
(Scaled Kind
ty:[Scaled Kind]
_) = DataCon -> [Kind] -> [Scaled Kind]
dataConInstArgTys DataCon
dc [Kind]
arg_tys
tidy_bang_pat Id
_ Origin
_ SrcSpanAnnA
l Pat GhcTc
p = forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper
idDsWrapper, forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
noExtField (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
-> Kind -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg SrcSpanAnnA
l Kind
_ty (PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
ts (LPat GhcTc
arg:[LPat GhcTc]
args))
= ASSERT( null args)
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsPatSigType (NoGhcTc GhcTc)]
ts [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
noExtField LPat GhcTc
arg)]
push_bang_into_newtype_arg SrcSpanAnnA
l Kind
_ty (RecCon HsRecFields GhcTc (LPat GhcTc)
rf)
| HsRecFields { rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = L SrcSpanAnnA
lf HsRecField' (FieldOcc GhcTc) (GenLocated SrcSpanAnnA (Pat GhcTc))
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)
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields GhcTc (LPat GhcTc)
rf { rec_flds :: [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))]
rec_flds = [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
= forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
noExtField GenLocated SrcSpanAnnA (Pat GhcTc)
arg) })] })
push_bang_into_newtype_arg SrcSpanAnnA
l Kind
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
= forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p. XBangPat p -> LPat p -> Pat p
BangPat NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA (forall p. XWildPat p -> Pat p
WildPat Kind
ty)))]
push_bang_into_newtype_arg SrcSpanAnnA
_ Kind
_ HsConPatDetails GhcTc
cd
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"push_bang_into_newtype_arg" (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 ([Id], 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 SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches
, mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext = MatchGroupTc [Scaled Kind]
arg_tys Kind
rhs_ty
, mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin = Origin
origin })
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; SrcSpan
locn <- DsM SrcSpan
getSrcSpanDs
; [Id]
new_vars <- case [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches of
[] -> [Scaled Kind] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
newSysLocalsDsNoLP [Scaled Kind]
arg_tys
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
m:[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
_) ->
[(Kind, Pat GhcTc)] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
selectMatchVars (forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"matchWrapper"
(\Scaled Kind
a GenLocated SrcSpanAnnA (Pat GhcTc)
b -> (forall a. Scaled a -> Kind
scaledMult Scaled Kind
a, forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
b))
[Scaled Kind]
arg_tys
(forall (id :: Pass) body.
LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
m))
; [(Nablas, NonEmpty Nablas)]
matches_nablas <- if forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
origin HsMatchContext (GhcPass 'Renamed)
ctxt
then forall a. Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
addHsScrutTmCs Maybe (LHsExpr GhcTc)
mb_scr [Id]
new_vars forall a b. (a -> b) -> a -> b
$
DsMatchContext
-> [Id]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> DsM [(Nablas, NonEmpty Nablas)]
pmcMatches (HsMatchContext (GhcPass 'Renamed) -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext (GhcPass 'Renamed)
ctxt SrcSpan
locn) [Id]
new_vars [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches
else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b. [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches)
; [EquationInfo]
eqns_info <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM LMatch GhcTc (LHsExpr GhcTc)
-> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
matches [(Nablas, NonEmpty Nablas)]
matches_nablas
; CoreExpr
result_expr <- IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
handleWarnings forall a b. (a -> b) -> a -> b
$
HsMatchContext (GhcPass 'Renamed)
-> [Id]
-> [EquationInfo]
-> Kind
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
matchEquations HsMatchContext (GhcPass 'Renamed)
ctxt [Id]
new_vars [EquationInfo]
eqns_info Kind
rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
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) -> DsM EquationInfo
mk_eqn_info (L SrcSpanAnnA
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat 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 { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let upats :: [Pat GhcTc]
upats = forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags) [LPat GhcTc]
pats
; MatchResult CoreExpr
match_result <- forall a. Nablas -> DsM a -> DsM a
updPmNablas Nablas
pat_nablas forall a b. (a -> b) -> a -> b
$
HsMatchContext (GhcPass 'Renamed)
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Kind
-> NonEmpty Nablas
-> DsM (MatchResult CoreExpr)
dsGRHSs HsMatchContext (GhcPass 'Renamed)
ctxt GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss Kind
rhs_ty NonEmpty Nablas
rhss_nablas
; forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
handleWarnings = if Origin -> Bool
isGenerated Origin
origin
then forall a. DsM a -> DsM a
discardWarningsDs
else forall a. a -> a
id
initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches :: forall b. [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches [LMatch GhcTc b]
ms
= forall a b. (a -> b) -> [a] -> [b]
map (\(L Anno (Match GhcTc b)
_ Match GhcTc b
m) -> (Nablas
initNablas, forall b. GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs (forall p body. Match p body -> GRHSs p body
m_grhss Match GhcTc b
m))) [LMatch GhcTc b]
ms
initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs :: forall b. GRHSs GhcTc b -> NonEmpty Nablas
initNablasGRHSs GRHSs GhcTc b
m = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"GRHSs non-empty"
forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty
forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length (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)
-> [Id]
-> [EquationInfo]
-> Kind
-> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
matchEquations HsMatchContext (GhcPass 'Renamed)
ctxt [Id]
vars [EquationInfo]
eqns_info Kind
rhs_ty
= do { MatchResult CoreExpr
match_result <- [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id]
vars Kind
rhs_ty [EquationInfo]
eqns_info
; CoreExpr
fail_expr <- HsMatchContext (GhcPass 'Renamed)
-> Kind -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
mkFailExpr HsMatchContext (GhcPass 'Renamed)
ctxt Kind
rhs_ty
; MatchResult CoreExpr
-> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) 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
-> IOEnv (Env DsGblEnv DsLclEnv) 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 :: Kind
rhs_ty = CoreExpr -> Kind
exprType CoreExpr
fail_expr
MatchResult CoreExpr
match_result' <- CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Kind
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePat CoreExpr
scrut HsMatchContext (GhcPass 'Renamed)
hs_ctx LPat GhcTc
pat Kind
rhs_ty MatchResult CoreExpr
match_result
MatchResult CoreExpr
-> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) 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
-> Kind
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePat (Var Id
var) HsMatchContext (GhcPass 'Renamed)
ctx LPat GhcTc
pat Kind
ty MatchResult CoreExpr
match_result
| Bool -> Bool
not (Name -> Bool
isExternalName (Id -> Name
idName Id
var))
= Id
-> Maybe CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Kind
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var forall a. Maybe a
Nothing HsMatchContext (GhcPass 'Renamed)
ctx LPat GhcTc
pat Kind
ty MatchResult CoreExpr
match_result
matchSinglePat CoreExpr
scrut HsMatchContext (GhcPass 'Renamed)
hs_ctx LPat GhcTc
pat Kind
ty MatchResult CoreExpr
match_result
= do { Id
var <- Kind -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL Kind
Many LPat GhcTc
pat
; MatchResult CoreExpr
match_result' <- Id
-> Maybe CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Kind
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var (forall a. a -> Maybe a
Just CoreExpr
scrut) HsMatchContext (GhcPass 'Renamed)
hs_ctx LPat GhcTc
pat Kind
ty MatchResult CoreExpr
match_result
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> DsWrapper
bindNonRec Id
var CoreExpr
scrut 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 :: Id
-> Maybe CoreExpr
-> HsMatchContext (GhcPass 'Renamed)
-> LPat GhcTc
-> Kind
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
mb_scrut HsMatchContext (GhcPass 'Renamed)
ctx LPat GhcTc
pat Kind
ty MatchResult CoreExpr
match_result
= ASSERT2( isInternalName (idName var), ppr var )
do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; SrcSpan
locn <- DsM SrcSpan
getSrcSpanDs
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
FromSource HsMatchContext (GhcPass 'Renamed)
ctx) forall a b. (a -> b) -> a -> b
$
forall a. Maybe CoreExpr -> [Id] -> DsM a -> DsM a
addCoreScrutTmCs Maybe CoreExpr
mb_scrut [Id
var] forall a b. (a -> b) -> a -> b
$
DsMatchContext
-> Id -> Pat GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
pmcPatBind (HsMatchContext (GhcPass 'Renamed) -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext (GhcPass 'Renamed)
ctx SrcSpan
locn) Id
var (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
pat)
; let eqn_info :: EquationInfo
eqn_info = EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [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 }
; [Id] -> Kind -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id
var] Kind
ty [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
= forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NEL.groupBy (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
same_gp 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 :: forall m a.
(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
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> NonEmpty a
NEL.reverse forall a b. (a -> b) -> a -> b
$ m -> [NonEmpty EquationInfo]
elems forall a b. (a -> b) -> a -> b
$ 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 (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 [EquationInfo
eqn] m
pg_map
subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd :: forall a. Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupOrd = forall m a.
(m -> [NonEmpty EquationInfo])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfo))
-> (a -> NonEmpty EquationInfo -> m -> m)
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
subGroup forall k a. Map k a -> [a]
Map.elems forall k a. Map k a
Map.empty forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup 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, EquationInfo)] -> [NonEmpty EquationInfo]
subGroupUniq =
forall m a.
(m -> [NonEmpty EquationInfo])
-> m
-> (a -> m -> Maybe (NonEmpty EquationInfo))
-> (a -> NonEmpty EquationInfo -> m -> m)
-> [(a, EquationInfo)]
-> [NonEmpty EquationInfo]
subGroup forall key elt. UniqDFM key elt -> [elt]
eltsUDFM forall key elt. UniqDFM key elt
emptyUDFM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM) (\a
k NonEmpty EquationInfo
v UniqDFM a (NonEmpty EquationInfo)
m -> 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 [Kind]
t1) (PgSyn PatSyn
p2 [Kind]
t2) = PatSyn
p1forall a. Eq a => a -> a -> Bool
==PatSyn
p2 Bool -> Bool -> Bool
&& [Kind] -> [Kind] -> Bool
eqTypes [Kind]
t1 [Kind]
t2
sameGroup (PgLit Literal
_) (PgLit Literal
_) = Bool
True
sameGroup (PgN FractionalLit
l1) (PgN FractionalLit
l2) = FractionalLit
l1forall a. Eq a => a -> a -> Bool
==FractionalLit
l2
sameGroup (PgOverS FastString
s1) (PgOverS FastString
s2) = FastString
s1forall a. Eq a => a -> a -> Bool
==FastString
s2
sameGroup (PgNpK Integer
l1) (PgNpK Integer
l2) = Integer
l1forall a. Eq a => a -> a -> Bool
==Integer
l2
sameGroup (PgCo Kind
t1) (PgCo Kind
t2) = Kind
t1 Kind -> Kind -> Bool
`eqType` Kind
t2
sameGroup (PgView LHsExpr GhcTc
e1 Kind
t1) (PgView LHsExpr GhcTc
e2 Kind
t2) = (LHsExpr GhcTc, Kind) -> (LHsExpr GhcTc, Kind) -> Bool
viewLExprEq (LHsExpr GhcTc
e1,Kind
t1) (LHsExpr GhcTc
e2,Kind
t2)
sameGroup PatGroup
_ PatGroup
_ = Bool
False
viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
viewLExprEq :: (LHsExpr GhcTc, Kind) -> (LHsExpr GhcTc, Kind) -> Bool
viewLExprEq (LHsExpr GhcTc
e1,Kind
_) (LHsExpr GhcTc
e2,Kind
_) = 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 (forall l e. GenLocated l e -> e
unLoc LHsExpr GhcTc
e) (forall l e. GenLocated l e -> e
unLoc LHsExpr 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 (HsWrap HsWrapper
h HsExpr GhcTc
e))) (XExpr (WrapExpr (HsWrap 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 (ExpansionExpr (HsExpanded HsExpr (GhcPass 'Renamed)
_ HsExpr GhcTc
b))) (XExpr (ExpansionExpr (HsExpanded HsExpr (GhcPass 'Renamed)
_ HsExpr GhcTc
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') = LIdP GhcTc
i forall a. Eq a => a -> a -> Bool
== LIdP GhcTc
i'
exp (HsConLikeOut XConLikeOut GhcTc
_ ConLike
c) (HsConLikeOut XConLikeOut GhcTc
_ ConLike
c') = ConLike
c forall a. Eq a => a -> a -> Bool
== ConLike
c'
exp (HsIPVar XIPVar GhcTc
_ HsIPName
i) (HsIPVar XIPVar GhcTc
_ HsIPName
i') = HsIPName
i forall a. Eq a => a -> a -> Bool
== HsIPName
i'
exp (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
l) (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
l') =
Kind -> Kind -> Bool
eqType (HsOverLit GhcTc -> Kind
overLitType HsOverLit GhcTc
l) (HsOverLit GhcTc -> Kind
overLitType HsOverLit GhcTc
l') Bool -> Bool -> Bool
&& HsOverLit GhcTc
l 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
_) =
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 :: 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
&&
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (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
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
_ 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 Kind
_ Kind
t1)) (Missing (Scaled Kind
_ Kind
t2)) = Kind -> Kind -> Bool
eqType Kind
t1 Kind
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 Kind
_ SDoc
_) (WpFun HsWrapper
w1' HsWrapper
w2' Scaled Kind
_ 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 Kind
t) (WpTyApp Kind
t') = Kind -> Kind -> Bool
eqType Kind
t Kind
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 -> Kind
idType Id
a Kind -> Kind -> Bool
`eqType` Id -> Kind
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
&& 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 -> [Kind]
cpt_arg_tys = [Kind]
tys }
})
| RealDataCon DataCon
dcon <- ConLike
con = DataCon -> PatGroup
PgCon DataCon
dcon
| PatSynCon PatSyn
psyn <- ConLike
con = PatSyn -> [Kind] -> PatGroup
PgSyn PatSyn
psyn [Kind]
tys
patGroup Platform
_ (WildPat {}) = PatGroup
PgAny
patGroup Platform
_ (BangPat {}) = PatGroup
PgBang
patGroup Platform
_ (NPat XNPat GhcTc
_ (L SrcSpan
_ (OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=OverLitVal
oval})) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_) =
case (OverLitVal
oval, forall a. Maybe a -> Bool
isJust Maybe (SyntaxExpr GhcTc)
mb_neg) of
(HsIntegral IntegralLit
i, Bool
is_neg) -> FractionalLit -> PatGroup
PgN (Bool -> Integer -> FractionalLit
integralFractionalLit Bool
is_neg (if Bool
is_neg
then 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 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 SrcSpan
_ (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
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"patGroup NPlusKPat" (forall a. Outputable a => a -> SDoc
ppr OverLitVal
oval)
patGroup Platform
_ (XPat (CoPat HsWrapper
_ Pat GhcTc
p Kind
_)) = Kind -> PatGroup
PgCo (Pat GhcTc -> Kind
hsPatType Pat GhcTc
p)
patGroup Platform
_ (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
expr LPat GhcTc
p) = LHsExpr GhcTc -> Kind -> PatGroup
PgView LHsExpr GhcTc
expr (Pat GhcTc -> Kind
hsPatType (forall l e. GenLocated l e -> e
unLoc LPat GhcTc
p))
patGroup Platform
_ (ListPat (ListPatTc Kind
_ (Just (Kind, SyntaxExpr GhcTc)
_)) [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 = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"patGroup" (forall a. Outputable a => a -> SDoc
ppr Pat GhcTc
pat)