{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Match ( match, matchEquations, matchWrapper, matchSimply
, matchSinglePat, matchSinglePatVar ) where
#include "HsVersions.h"
import GhcPrelude
import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
import BasicTypes ( Origin(..) )
import DynFlags
import GHC.Hs
import TcHsSyn
import TcEvidence
import TcRnMonad
import GHC.HsToCore.PmCheck
import CoreSyn
import Literal
import CoreUtils
import MkCore
import DsMonad
import DsBinds
import DsGRHSs
import DsUtils
import Id
import ConLike
import DataCon
import PatSyn
import MatchCon
import MatchLit
import Type
import Coercion ( eqCoercion )
import TyCon( isNewTyCon )
import TysWiredIn
import SrcLoc
import Maybes
import Util
import Name
import Outputable
import BasicTypes ( isGenerated, il_value, fl_value )
import FastString
import Unique
import UniqDFM
import Control.Monad( when, unless )
import Data.List ( groupBy )
import qualified Data.Map as Map
type MatchId = Id
match :: [MatchId]
-> Type
-> [EquationInfo]
-> DsM MatchResult
match :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match [] Type
ty [EquationInfo]
eqns
= ASSERT2( not (null eqns), ppr ty )
MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return ((MatchResult -> MatchResult -> MatchResult)
-> [MatchResult] -> MatchResult
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult -> MatchResult -> MatchResult
combineMatchResults [MatchResult]
match_results)
where
match_results :: [MatchResult]
match_results = [ ASSERT( null (eqn_pats eqn) )
EquationInfo -> MatchResult
eqn_rhs EquationInfo
eqn
| EquationInfo
eqn <- [EquationInfo]
eqns ]
match vars :: [MatchId]
vars@(MatchId
v:[MatchId]
_) 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
; ([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 :: [[(PatGroup, EquationInfo)]]
grouped = DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
groupEquations DynFlags
dflags [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 ([[(PatGroup, EquationInfo)]] -> TcRnIf DsGblEnv DsLclEnv ()
forall (t :: * -> *) b.
Foldable t =>
[t (PatGroup, b)] -> TcRnIf DsGblEnv DsLclEnv ()
debug [[(PatGroup, EquationInfo)]]
grouped)
; [MatchResult]
match_results <- [[(PatGroup, EquationInfo)]] -> DsM [MatchResult]
match_groups [[(PatGroup, EquationInfo)]]
grouped
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper -> MatchResult -> MatchResult
adjustMatchResult ((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) (MatchResult -> MatchResult) -> MatchResult -> MatchResult
forall a b. (a -> b) -> a -> b
$
(MatchResult -> MatchResult -> MatchResult)
-> [MatchResult] -> MatchResult
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult -> MatchResult -> MatchResult
combineMatchResults [MatchResult]
match_results) }
where
dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
dropGroup :: [(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup = ((PatGroup, EquationInfo) -> EquationInfo)
-> [(PatGroup, EquationInfo)] -> [EquationInfo]
forall a b. (a -> b) -> [a] -> [b]
map (PatGroup, EquationInfo) -> EquationInfo
forall a b. (a, b) -> b
snd
match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
match_groups :: [[(PatGroup, EquationInfo)]] -> DsM [MatchResult]
match_groups [] = MatchId -> Type -> DsM [MatchResult]
matchEmpty MatchId
v Type
ty
match_groups [[(PatGroup, EquationInfo)]]
gs = ([(PatGroup, EquationInfo)] -> DsM MatchResult)
-> [[(PatGroup, EquationInfo)]] -> DsM [MatchResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [(PatGroup, EquationInfo)] -> DsM MatchResult
match_group [[(PatGroup, EquationInfo)]]
gs
match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
match_group :: [(PatGroup, EquationInfo)] -> DsM MatchResult
match_group [] = String -> DsM MatchResult
forall a. String -> a
panic String
"match_group"
match_group eqns :: [(PatGroup, EquationInfo)]
eqns@((PatGroup
group,EquationInfo
_) : [(PatGroup, EquationInfo)]
_)
= case PatGroup
group of
PgCon {} -> [MatchId] -> Type -> [[EquationInfo]] -> DsM MatchResult
matchConFamily [MatchId]
vars Type
ty ([(DataCon, EquationInfo)] -> [[EquationInfo]]
forall a. Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
subGroupUniq [(DataCon
c,EquationInfo
e) | (PgCon DataCon
c, EquationInfo
e) <- [(PatGroup, EquationInfo)]
eqns])
PgSyn {} -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchPatSyn [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PgLit {} -> [MatchId] -> Type -> [[EquationInfo]] -> DsM MatchResult
matchLiterals [MatchId]
vars Type
ty ([(Literal, EquationInfo)] -> [[EquationInfo]]
forall a. Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
subGroupOrd [(Literal
l,EquationInfo
e) | (PgLit Literal
l, EquationInfo
e) <- [(PatGroup, EquationInfo)]
eqns])
PatGroup
PgAny -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchVariables [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PgN {} -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PgOverS {}-> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PgNpK {} -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPlusKPats [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PatGroup
PgBang -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PgCo {} -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchCoercion [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PgView {} -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchView [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
PatGroup
PgOverloadedList -> [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList [MatchId]
vars Type
ty ([(PatGroup, EquationInfo)] -> [EquationInfo]
dropGroup [(PatGroup, EquationInfo)]
eqns)
debug :: [t (PatGroup, b)] -> TcRnIf DsGblEnv DsLclEnv ()
debug [t (PatGroup, b)]
eqns =
let gs :: [[LHsExpr GhcTc]]
gs = (t (PatGroup, b) -> [LHsExpr GhcTc])
-> [t (PatGroup, b)] -> [[LHsExpr GhcTc]]
forall a b. (a -> b) -> [a] -> [b]
map (\t (PatGroup, b)
group -> ((PatGroup, b) -> [LHsExpr GhcTc] -> [LHsExpr GhcTc])
-> [LHsExpr GhcTc] -> t (PatGroup, b) -> [LHsExpr GhcTc]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (PatGroup
p,b
_) -> \[LHsExpr GhcTc]
acc ->
case PatGroup
p of PgView LHsExpr GhcTc
e Type
_ -> LHsExpr GhcTc
eLHsExpr GhcTc -> [LHsExpr GhcTc] -> [LHsExpr GhcTc]
forall a. a -> [a] -> [a]
:[LHsExpr GhcTc]
acc
PatGroup
_ -> [LHsExpr 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 = WarnReason -> SDoc -> TcRnIf DsGblEnv DsLclEnv ()
warnDs WarnReason
NoReason ([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
$ (([LHsExpr GhcTc] -> SDoc) -> [[LHsExpr GhcTc]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\[LHsExpr GhcTc]
g -> String -> SDoc
text String
"Putting these view expressions into the same case:" SDoc -> SDoc -> SDoc
<+> ([LHsExpr GhcTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsExpr GhcTc]
g))
(([LHsExpr GhcTc] -> Bool) -> [[LHsExpr GhcTc]] -> [[LHsExpr GhcTc]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([LHsExpr GhcTc] -> Bool) -> [LHsExpr GhcTc] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsExpr GhcTc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[LHsExpr GhcTc]]
gs))
matchEmpty :: MatchId -> Type -> DsM [MatchResult]
matchEmpty :: MatchId -> Type -> DsM [MatchResult]
matchEmpty MatchId
var Type
res_ty
= [MatchResult] -> DsM [MatchResult]
forall (m :: * -> *) a. Monad m => a -> m a
return [CanItFail -> (CoreExpr -> DsM CoreExpr) -> MatchResult
MatchResult CanItFail
CanFail 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 -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
var) (MatchId -> Type
idType MatchId
var) Type
res_ty
[(AltCon
DEFAULT, [], CoreExpr
fail)]
matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchVariables (MatchId
_:[MatchId]
vars) Type
ty [EquationInfo]
eqns = [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match [MatchId]
vars Type
ty ([EquationInfo] -> [EquationInfo]
shiftEqns [EquationInfo]
eqns)
matchVariables [] Type
_ [EquationInfo]
_ = String -> DsM MatchResult
forall a. String -> a
panic String
"matchVariables"
matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (MatchId
var:[MatchId]
vars) Type
ty [EquationInfo]
eqns
= do { MatchResult
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match (MatchId
varMatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM MatchResult)
-> [EquationInfo] -> DsM MatchResult
forall a b. (a -> b) -> a -> b
$
(EquationInfo -> EquationInfo) -> [EquationInfo] -> [EquationInfo]
forall a b. (a -> b) -> [a] -> [b]
map ((Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getBangPat) [EquationInfo]
eqns
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> Type -> MatchResult -> MatchResult
mkEvalMatchResult MatchId
var Type
ty MatchResult
match_result) }
matchBangs [] Type
_ [EquationInfo]
_ = String -> DsM MatchResult
forall a. String -> a
panic String
"matchBangs"
matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchCoercion (MatchId
var:[MatchId]
vars) Type
ty (eqns :: [EquationInfo]
eqns@(EquationInfo
eqn1:[EquationInfo]
_))
= do { let CoPat XCoPat GhcTc
_ HsWrapper
co Pat GhcTc
pat Type
_ = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; let pat_ty' :: Type
pat_ty' = Pat GhcTc -> Type
hsPatType Pat GhcTc
pat
; MatchId
var' <- MatchId -> Type -> DsM MatchId
newUniqueId MatchId
var Type
pat_ty'
; MatchResult
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match (MatchId
var'MatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM MatchResult)
-> [EquationInfo] -> DsM MatchResult
forall a b. (a -> b) -> a -> b
$
(EquationInfo -> EquationInfo) -> [EquationInfo] -> [EquationInfo]
forall a b. (a -> b) -> [a] -> [b]
map ((Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getCoPat) [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 -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Bind MatchId -> MatchResult -> MatchResult
mkCoLetMatchResult Bind MatchId
bind MatchResult
match_result) }
matchCoercion [MatchId]
_ Type
_ [EquationInfo]
_ = String -> DsM MatchResult
forall a. String -> a
panic String
"matchCoercion"
matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchView (MatchId
var:[MatchId]
vars) Type
ty (eqns :: [EquationInfo]
eqns@(EquationInfo
eqn1:[EquationInfo]
_))
= do {
let ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
viewExpr (LPat GhcTc -> Located (SrcSpanLess (Located (Pat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (Pat GhcTc))
pat) = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
; let pat_ty' :: Type
pat_ty' = Pat GhcTc -> Type
hsPatType SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
pat
; MatchId
var' <- MatchId -> Type -> DsM MatchId
newUniqueId MatchId
var Type
pat_ty'
; MatchResult
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match (MatchId
var'MatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM MatchResult)
-> [EquationInfo] -> DsM MatchResult
forall a b. (a -> b) -> a -> b
$
(EquationInfo -> EquationInfo) -> [EquationInfo] -> [EquationInfo]
forall a b. (a -> b) -> [a] -> [b]
map ((Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getViewPat) [EquationInfo]
eqns
; CoreExpr
viewExpr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
viewExpr
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> CoreExpr -> MatchResult -> MatchResult
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
match_result) }
matchView [MatchId]
_ Type
_ [EquationInfo]
_ = String -> DsM MatchResult
forall a. String -> a
panic String
"matchView"
matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList (MatchId
var:[MatchId]
vars) Type
ty (eqns :: [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 -> DsM MatchId
newUniqueId MatchId
var (Type -> Type
mkListTy Type
elt_ty)
; MatchResult
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match (MatchId
var'MatchId -> [MatchId] -> [MatchId]
forall a. a -> [a] -> [a]
:[MatchId]
vars) Type
ty ([EquationInfo] -> DsM MatchResult)
-> [EquationInfo] -> DsM MatchResult
forall a b. (a -> b) -> a -> b
$
(EquationInfo -> EquationInfo) -> [EquationInfo] -> [EquationInfo]
forall a b. (a -> b) -> [a] -> [b]
map ((Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat Pat GhcTc -> Pat GhcTc
getOLPat) [EquationInfo]
eqns
; CoreExpr
e' <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
e [MatchId -> CoreExpr
forall b. MatchId -> Expr b
Var MatchId
var]
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> CoreExpr -> MatchResult -> MatchResult
mkViewMatchResult MatchId
var' CoreExpr
e' MatchResult
match_result) }
matchOverloadedList [MatchId]
_ Type
_ [EquationInfo]
_ = String -> DsM MatchResult
forall a. String -> a
panic String
"matchOverloadedList"
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 (CoPat XCoPat GhcTc
_ HsWrapper
_ Pat GhcTc
pat Type
_) = 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 ) = Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (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) = Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (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 = do 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 (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat)
tidy1 MatchId
v Origin
o (SigPat XSigPat GhcTc
_ LPat GhcTc
pat LHsSigWcType (NoGhcTc GhcTc)
_) = MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (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
_ (LPat GhcTc -> Located (SrcSpanLess (Located (Pat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
p)) = MatchId
-> Origin -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
p
tidy1 MatchId
v Origin
_ (VarPat XVarPat GhcTc
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located MatchId))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located MatchId)
var))
= (DsWrapper, Pat GhcTc) -> DsM (DsWrapper, Pat GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchId -> MatchId -> DsWrapper
wrapBind SrcSpanLess (Located MatchId)
MatchId
var MatchId
v, XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat (MatchId -> Type
idType SrcSpanLess (Located MatchId)
MatchId
var))
tidy1 MatchId
v Origin
o (AsPat XAsPat GhcTc
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located MatchId))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located MatchId)
var) LPat GhcTc
pat)
= do { (DsWrapper
wrap, Pat GhcTc
pat') <- MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (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 SrcSpanLess (Located MatchId)
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) (LPat GhcTc -> [IdP GhcTc]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders 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 (Located (Pat GhcTc) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (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) <- [[Tickish MatchId]]
-> 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, Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
list_ConPat)
where
list_ConPat :: Located (Pat GhcTc)
list_ConPat = (Located (Pat GhcTc) -> Located (Pat GhcTc) -> Located (Pat GhcTc))
-> Located (Pat GhcTc)
-> [Located (Pat GhcTc)]
-> Located (Pat GhcTc)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Located (Pat GhcTc)
x Located (Pat GhcTc)
y -> DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
forall (p :: Pass).
DataCon -> [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
mkPrefixConPat DataCon
consDataCon [Located (Pat GhcTc)
LPat GhcTc
x, Located (Pat GhcTc)
LPat GhcTc
y] [Type
ty])
(Type -> LPat GhcTc
forall (p :: Pass). Type -> OutPat (GhcPass p)
mkNilPat Type
ty)
[Located (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, Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
tuple_ConPat)
where
arity :: Int
arity = [Located (Pat GhcTc)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located (Pat GhcTc)]
[LPat GhcTc]
pats
tuple_ConPat :: LPat GhcTc
tuple_ConPat = DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
forall (p :: Pass).
DataCon -> [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
mkPrefixConPat (Boxity -> Int -> DataCon
tupleDataCon Boxity
boxity Int
arity) [LPat GhcTc]
pats [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, Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
sum_ConPat)
where
sum_ConPat :: LPat GhcTc
sum_ConPat = DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
forall (p :: Pass).
DataCon -> [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
mkPrefixConPat (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity) [LPat GhcTc
pat] [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 (Located (HsOverLit GhcTc)
-> Located (SrcSpanLess (Located (HsOverLit GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ lit :: SrcSpanLess (Located (HsOverLit GhcTc))
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 = SrcSpanLess (Located (HsOverLit GhcTc))
HsOverLit GhcTc
lit{ ol_val :: OverLitVal
ol_val = OverLitVal -> OverLitVal
negateOverLitVal OverLitVal
v }
| Bool
otherwise = SrcSpanLess (Located (HsOverLit GhcTc))
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 SrcSpanLess (Located (HsOverLit GhcTc))
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
_ Located (IdP GhcTc)
_ (Located (HsOverLit GhcTc)
-> Located (SrcSpanLess (Located (HsOverLit GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (HsOverLit GhcTc))
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_)
= do { Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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 SrcSpanLess (Located (HsOverLit GhcTc))
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 -> SrcSpan -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat :: MatchId
-> Origin -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpan
_ (ParPat XParPat GhcTc
_ (LPat GhcTc -> Located (SrcSpanLess (Located (Pat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
p)) = MatchId
-> Origin -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpan
_ (SigPat XSigPat GhcTc
_ (LPat GhcTc -> Located (SrcSpanLess (Located (Pat GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
p) LHsSigWcType (NoGhcTc GhcTc)
_) = MatchId
-> Origin -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy_bang_pat MatchId
v Origin
o SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
p
tidy_bang_pat MatchId
v Origin
o SrcSpan
l (AsPat XAsPat GhcTc
x Located (IdP GhcTc)
v' LPat GhcTc
p)
= MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (XAsPat GhcTc -> Located (IdP GhcTc) -> LPat GhcTc -> Pat GhcTc
forall p. XAsPat p -> Located (IdP p) -> LPat p -> Pat p
AsPat XAsPat GhcTc
x Located (IdP GhcTc)
v' (SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField LPat GhcTc
p)))
tidy_bang_pat MatchId
v Origin
o SrcSpan
l (CoPat XCoPat GhcTc
x HsWrapper
w Pat GhcTc
p Type
t)
= MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o (XCoPat GhcTc -> HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc
forall p. XCoPat p -> HsWrapper -> Pat p -> Type -> Pat p
CoPat XCoPat GhcTc
x HsWrapper
w (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
p)) Type
t)
tidy_bang_pat MatchId
v Origin
o SrcSpan
_ 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 SrcSpan
_ 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 SrcSpan
_ 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 SrcSpan
_ 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 SrcSpan
l p :: Pat GhcTc
p@(ConPatOut { pat_con :: forall p. Pat p -> Located ConLike
pat_con = (Located ConLike -> Located (SrcSpanLess (Located ConLike))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (RealDataCon dc))
, pat_args :: forall p. Pat p -> HsConPatDetails p
pat_args = HsConPatDetails GhcTc
args
, pat_arg_tys :: forall p. Pat p -> [Type]
pat_arg_tys = [Type]
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 = SrcSpan -> Type -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg SrcSpan
l Type
ty HsConPatDetails GhcTc
args })
else MatchId -> Origin -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
tidy1 MatchId
v Origin
o Pat GhcTc
p
where
(Type
ty:[Type]
_) = DataCon -> [Type] -> [Type]
dataConInstArgTys DataCon
dc [Type]
arg_tys
tidy_bang_pat MatchId
_ Origin
_ SrcSpan
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 XBangPat GhcTc
NoExtField
noExtField (SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
p))
push_bang_into_newtype_arg :: SrcSpan
-> Type
-> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg :: SrcSpan -> Type -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
push_bang_into_newtype_arg SrcSpan
l Type
_ty (PrefixCon (LPat GhcTc
arg:[LPat GhcTc]
args))
= ASSERT( null args)
[Located (Pat GhcTc)]
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField LPat GhcTc
arg)]
push_bang_into_newtype_arg SrcSpan
l Type
_ty (RecCon HsRecFields GhcTc (LPat GhcTc)
rf)
| HsRecFields { rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = (LHsRecField GhcTc (LPat GhcTc)
-> Located (SrcSpanLess (LHsRecField GhcTc (Located (Pat GhcTc))))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lf SrcSpanLess (LHsRecField GhcTc (Located (Pat GhcTc)))
fld) : [LHsRecField GhcTc (LPat GhcTc)]
flds } <- HsRecFields GhcTc (LPat GhcTc)
rf
, HsRecField { hsRecFieldArg = arg } <- SrcSpanLess (LHsRecField GhcTc (Located (Pat GhcTc)))
fld
= ASSERT( null flds)
HsRecFields GhcTc (Located (Pat GhcTc))
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall arg rec. rec -> HsConDetails arg rec
RecCon (HsRecFields GhcTc (Located (Pat GhcTc))
HsRecFields GhcTc (LPat GhcTc)
rf { rec_flds :: [LHsRecField GhcTc (Located (Pat GhcTc))]
rec_flds = [SrcSpan
-> SrcSpanLess (LHsRecField GhcTc (Located (Pat GhcTc)))
-> LHsRecField GhcTc (Located (Pat GhcTc))
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lf (SrcSpanLess (LHsRecField GhcTc (Located (Pat GhcTc)))
HsRecField' (FieldOcc GhcTc) (Located (Pat GhcTc))
fld { hsRecFieldArg :: Located (Pat GhcTc)
hsRecFieldArg
= SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField Located (Pat GhcTc)
LPat GhcTc
arg) })] })
push_bang_into_newtype_arg SrcSpan
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
= [Located (Pat GhcTc)]
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [SrcSpan -> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XBangPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XBangPat p -> LPat p -> Pat p
BangPat XBangPat GhcTc
NoExtField
noExtField (SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XWildPat GhcTc -> Pat GhcTc
forall p. XWildPat p -> Pat p
WildPat Type
XWildPat GhcTc
ty)))]
push_bang_into_newtype_arg SrcSpan
_ Type
_ HsConPatDetails GhcTc
cd
= String
-> SDoc
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"push_bang_into_newtype_arg" (HsConPatDetails GhcTc -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsConPatDetails (GhcPass p) -> SDoc
pprConArgs HsConPatDetails GhcTc
cd)
matchWrapper
:: HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper :: HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([MatchId], CoreExpr)
matchWrapper HsMatchContext Name
ctxt Maybe (LHsExpr GhcTc)
mb_scr (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (Located [LMatch GhcTc (LHsExpr GhcTc)]
-> Located (SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
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 SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches of
[] -> (Type -> DsM MatchId)
-> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [MatchId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM MatchId
newSysLocalDsNoLP [Type]
arg_tys
(m:_) -> [Pat GhcTc] -> IOEnv (Env DsGblEnv DsLclEnv) [MatchId]
selectMatchVars ((Located (Pat GhcTc) -> Pat GhcTc)
-> [Located (Pat GhcTc)] -> [Pat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Located (Pat GhcTc) -> Pat GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LMatch GhcTc (LHsExpr GhcTc) -> [LPat GhcTc]
forall (id :: Pass) body.
LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats LMatch GhcTc (LHsExpr GhcTc)
m))
; [EquationInfo]
eqns_info <- (LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo)
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [EquationInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([MatchId]
-> LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
mk_eqn_info [MatchId]
new_vars) [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches
; Bool -> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Origin -> HsMatchContext Name -> Bool
forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
origin HsMatchContext Name
ctxt) (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
Maybe (LHsExpr GhcTc)
-> [MatchId]
-> TcRnIf DsGblEnv DsLclEnv ()
-> TcRnIf DsGblEnv DsLclEnv ()
forall a. Maybe (LHsExpr GhcTc) -> [MatchId] -> DsM a -> DsM a
addScrutTmCs Maybe (LHsExpr GhcTc)
mb_scr [MatchId]
new_vars (TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ())
-> TcRnIf DsGblEnv DsLclEnv () -> TcRnIf DsGblEnv DsLclEnv ()
forall a b. (a -> b) -> a -> b
$
DynFlags
-> DsMatchContext
-> [MatchId]
-> [LMatch GhcTc (LHsExpr GhcTc)]
-> TcRnIf DsGblEnv DsLclEnv ()
checkMatches DynFlags
dflags (HsMatchContext Name -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext Name
ctxt SrcSpan
locn) [MatchId]
new_vars [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
matches
; CoreExpr
result_expr <- DsM CoreExpr -> DsM CoreExpr
handleWarnings (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
HsMatchContext Name
-> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext Name
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 :: [MatchId]
-> LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
mk_eqn_info [MatchId]
vars (LMatch GhcTc (LHsExpr GhcTc)
-> Located (SrcSpanLess (LMatch GhcTc (LHsExpr GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_pats = pats, m_grhss = grhss }))
= do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let upats :: [Pat GhcTc]
upats = (Located (Pat GhcTc) -> Pat GhcTc)
-> [Located (Pat GhcTc)] -> [Pat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (Located (Pat GhcTc) -> Pat GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (Pat GhcTc) -> Pat GhcTc)
-> (Located (Pat GhcTc) -> Located (Pat GhcTc))
-> Located (Pat GhcTc)
-> Pat GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags) [Located (Pat GhcTc)]
[LPat GhcTc]
pats
dicts :: Bag MatchId
dicts = [Pat GhcTc] -> Bag MatchId
collectEvVarsPats [Pat GhcTc]
upats
; MatchResult
match_result <-
Bool
-> (DsM MatchResult -> DsM MatchResult)
-> DsM MatchResult
-> DsM MatchResult
forall a. Bool -> (a -> a) -> a -> a
applyWhen (DynFlags -> Origin -> Bool
needToRunPmCheck DynFlags
dflags Origin
origin)
(Bag MatchId -> DsM MatchResult -> DsM MatchResult
forall a. Bag MatchId -> DsM a -> DsM a
addTyCsDs Bag MatchId
dicts (DsM MatchResult -> DsM MatchResult)
-> (DsM MatchResult -> DsM MatchResult)
-> DsM MatchResult
-> DsM MatchResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (LHsExpr GhcTc)
-> [MatchId] -> DsM MatchResult -> DsM MatchResult
forall a. Maybe (LHsExpr GhcTc) -> [MatchId] -> DsM a -> DsM a
addScrutTmCs Maybe (LHsExpr GhcTc)
mb_scr [MatchId]
vars (DsM MatchResult -> DsM MatchResult)
-> (DsM MatchResult -> DsM MatchResult)
-> DsM MatchResult
-> DsM MatchResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat GhcTc] -> [MatchId] -> DsM MatchResult -> DsM MatchResult
forall a. [Pat GhcTc] -> [MatchId] -> DsM a -> DsM a
addPatTmCs [Pat GhcTc]
upats [MatchId]
vars)
(HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM MatchResult
dsGRHSs HsMatchContext Name
ctxt GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
rhs_ty)
; EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (EqnInfo :: [Pat GhcTc] -> Origin -> MatchResult -> EquationInfo
EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc]
upats
, eqn_orig :: Origin
eqn_orig = Origin
FromSource
, eqn_rhs :: MatchResult
eqn_rhs = MatchResult
match_result }) }
mk_eqn_info [MatchId]
_ (LMatch GhcTc (LHsExpr GhcTc)
-> Located (SrcSpanLess (LMatch GhcTc (LHsExpr GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XMatch nec)) = NoExtCon -> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
forall a. NoExtCon -> a
noExtCon XXMatch GhcTc (LHsExpr GhcTc)
NoExtCon
nec
mk_eqn_info [MatchId]
_ LMatch GhcTc (LHsExpr GhcTc)
_ = String -> IOEnv (Env DsGblEnv DsLclEnv) EquationInfo
forall a. String -> a
panic String
"mk_eqn_info: Impossible Match"
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
matchWrapper HsMatchContext Name
_ Maybe (LHsExpr GhcTc)
_ (XMatchGroup XXMatchGroup GhcTc (LHsExpr GhcTc)
nec) = NoExtCon -> DsM ([MatchId], CoreExpr)
forall a. NoExtCon -> a
noExtCon XXMatchGroup GhcTc (LHsExpr GhcTc)
NoExtCon
nec
matchEquations :: HsMatchContext Name
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations :: HsMatchContext Name
-> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext Name
ctxt [MatchId]
vars [EquationInfo]
eqns_info Type
rhs_ty
= do { let error_doc :: SDoc
error_doc = HsMatchContext Name -> SDoc
forall id. Outputable id => HsMatchContext id -> SDoc
matchContextErrString HsMatchContext Name
ctxt
; MatchResult
match_result <- [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match [MatchId]
vars Type
rhs_ty [EquationInfo]
eqns_info
; CoreExpr
fail_expr <- MatchId -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs MatchId
pAT_ERROR_ID Type
rhs_ty SDoc
error_doc
; MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult
match_result CoreExpr
fail_expr }
matchSimply :: CoreExpr
-> HsMatchContext Name
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply :: CoreExpr
-> HsMatchContext Name
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
matchSimply CoreExpr
scrut HsMatchContext Name
hs_ctx LPat GhcTc
pat CoreExpr
result_expr CoreExpr
fail_expr = do
let
match_result :: MatchResult
match_result = CoreExpr -> MatchResult
cantFailMatchResult CoreExpr
result_expr
rhs_ty :: Type
rhs_ty = CoreExpr -> Type
exprType CoreExpr
fail_expr
MatchResult
match_result' <- CoreExpr
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> DsM MatchResult
matchSinglePat CoreExpr
scrut HsMatchContext Name
hs_ctx LPat GhcTc
pat Type
rhs_ty MatchResult
match_result
MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult
match_result' CoreExpr
fail_expr
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
-> Type -> MatchResult -> DsM MatchResult
matchSinglePat :: CoreExpr
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> DsM MatchResult
matchSinglePat (Var MatchId
var) HsMatchContext Name
ctx LPat GhcTc
pat Type
ty MatchResult
match_result
| Bool -> Bool
not (Name -> Bool
isExternalName (MatchId -> Name
idName MatchId
var))
= MatchId
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> DsM MatchResult
matchSinglePatVar MatchId
var HsMatchContext Name
ctx LPat GhcTc
pat Type
ty MatchResult
match_result
matchSinglePat CoreExpr
scrut HsMatchContext Name
hs_ctx LPat GhcTc
pat Type
ty MatchResult
match_result
= do { MatchId
var <- LPat GhcTc -> DsM MatchId
selectSimpleMatchVarL LPat GhcTc
pat
; MatchResult
match_result' <- MatchId
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> DsM MatchResult
matchSinglePatVar MatchId
var HsMatchContext Name
hs_ctx LPat GhcTc
pat Type
ty MatchResult
match_result
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (DsWrapper -> MatchResult -> MatchResult
adjustMatchResult (MatchId -> CoreExpr -> DsWrapper
bindNonRec MatchId
var CoreExpr
scrut) MatchResult
match_result') }
matchSinglePatVar :: Id
-> HsMatchContext Name -> LPat GhcTc
-> Type -> MatchResult -> DsM MatchResult
matchSinglePatVar :: MatchId
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> DsM MatchResult
matchSinglePatVar MatchId
var HsMatchContext Name
ctx LPat GhcTc
pat Type
ty MatchResult
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
; DynFlags
-> DsMatchContext
-> MatchId
-> Pat GhcTc
-> TcRnIf DsGblEnv DsLclEnv ()
checkSingle DynFlags
dflags (HsMatchContext Name -> SrcSpan -> DsMatchContext
DsMatchContext HsMatchContext Name
ctx SrcSpan
locn) MatchId
var (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat)
; let eqn_info :: EquationInfo
eqn_info = EqnInfo :: [Pat GhcTc] -> Origin -> MatchResult -> EquationInfo
EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
pat)]
, eqn_orig :: Origin
eqn_orig = Origin
FromSource
, eqn_rhs :: MatchResult
eqn_rhs = MatchResult
match_result }
; [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
match [MatchId
var] Type
ty [EquationInfo
eqn_info] }
data PatGroup
= PgAny
| PgCon DataCon
| PgSyn PatSyn [Type]
| PgLit Literal
| PgN Rational
| PgOverS FastString
| PgNpK Integer
| PgBang
| PgCo Type
| PgView (LHsExpr GhcTc)
Type
| PgOverloadedList
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
groupEquations DynFlags
dflags [EquationInfo]
eqns
= ((PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool)
-> [(PatGroup, EquationInfo)] -> [[(PatGroup, EquationInfo)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
same_gp [(DynFlags -> Pat GhcTc -> PatGroup
patGroup DynFlags
dflags (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 -> [[EquationInfo]])
-> m
-> (a -> m -> Maybe [EquationInfo])
-> (a -> [EquationInfo] -> m -> m)
-> [(a, EquationInfo)] -> [[EquationInfo]]
subGroup :: (m -> [[EquationInfo]])
-> m
-> (a -> m -> Maybe [EquationInfo])
-> (a -> [EquationInfo] -> m -> m)
-> [(a, EquationInfo)]
-> [[EquationInfo]]
subGroup m -> [[EquationInfo]]
elems m
empty a -> m -> Maybe [EquationInfo]
lookup a -> [EquationInfo] -> m -> m
insert [(a, EquationInfo)]
group
= ([EquationInfo] -> [EquationInfo])
-> [[EquationInfo]] -> [[EquationInfo]]
forall a b. (a -> b) -> [a] -> [b]
map [EquationInfo] -> [EquationInfo]
forall a. [a] -> [a]
reverse ([[EquationInfo]] -> [[EquationInfo]])
-> [[EquationInfo]] -> [[EquationInfo]]
forall a b. (a -> b) -> a -> b
$ m -> [[EquationInfo]]
elems (m -> [[EquationInfo]]) -> m -> [[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 [EquationInfo]
lookup a
pg m
pg_map of
Just [EquationInfo]
eqns -> a -> [EquationInfo] -> m -> m
insert a
pg (EquationInfo
eqnEquationInfo -> [EquationInfo] -> [EquationInfo]
forall a. a -> [a] -> [a]
:[EquationInfo]
eqns) m
pg_map
Maybe [EquationInfo]
Nothing -> a -> [EquationInfo] -> m -> m
insert a
pg [EquationInfo
eqn] m
pg_map
subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
subGroupOrd :: [(a, EquationInfo)] -> [[EquationInfo]]
subGroupOrd = (Map a [EquationInfo] -> [[EquationInfo]])
-> Map a [EquationInfo]
-> (a -> Map a [EquationInfo] -> Maybe [EquationInfo])
-> (a
-> [EquationInfo] -> Map a [EquationInfo] -> Map a [EquationInfo])
-> [(a, EquationInfo)]
-> [[EquationInfo]]
forall m a.
(m -> [[EquationInfo]])
-> m
-> (a -> m -> Maybe [EquationInfo])
-> (a -> [EquationInfo] -> m -> m)
-> [(a, EquationInfo)]
-> [[EquationInfo]]
subGroup Map a [EquationInfo] -> [[EquationInfo]]
forall k a. Map k a -> [a]
Map.elems Map a [EquationInfo]
forall k a. Map k a
Map.empty a -> Map a [EquationInfo] -> Maybe [EquationInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a -> [EquationInfo] -> Map a [EquationInfo] -> Map a [EquationInfo]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
subGroupUniq :: [(a, EquationInfo)] -> [[EquationInfo]]
subGroupUniq =
(UniqDFM [EquationInfo] -> [[EquationInfo]])
-> UniqDFM [EquationInfo]
-> (a -> UniqDFM [EquationInfo] -> Maybe [EquationInfo])
-> (a
-> [EquationInfo]
-> UniqDFM [EquationInfo]
-> UniqDFM [EquationInfo])
-> [(a, EquationInfo)]
-> [[EquationInfo]]
forall m a.
(m -> [[EquationInfo]])
-> m
-> (a -> m -> Maybe [EquationInfo])
-> (a -> [EquationInfo] -> m -> m)
-> [(a, EquationInfo)]
-> [[EquationInfo]]
subGroup UniqDFM [EquationInfo] -> [[EquationInfo]]
forall elt. UniqDFM elt -> [elt]
eltsUDFM UniqDFM [EquationInfo]
forall elt. UniqDFM elt
emptyUDFM ((UniqDFM [EquationInfo] -> a -> Maybe [EquationInfo])
-> a -> UniqDFM [EquationInfo] -> Maybe [EquationInfo]
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqDFM [EquationInfo] -> a -> Maybe [EquationInfo]
forall key elt. Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM) (\a
k [EquationInfo]
v UniqDFM [EquationInfo]
m -> UniqDFM [EquationInfo]
-> a -> [EquationInfo] -> UniqDFM [EquationInfo]
forall key elt.
Uniquable key =>
UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM UniqDFM [EquationInfo]
m a
k [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 Rational
l1) (PgN Rational
l2) = Rational
l1Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
==Rational
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 (LHsExpr GhcTc -> SrcSpanLess (LHsExpr GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcTc
e) (LHsExpr GhcTc -> SrcSpanLess (LHsExpr GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcTc
e')
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp (HsPar XPar GhcTc
_ (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsExpr GhcTc)
e)) HsExpr GhcTc
e' = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e HsExpr GhcTc
e'
exp HsExpr GhcTc
e (HsPar XPar GhcTc
_ (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsExpr GhcTc)
e')) = HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
e SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e'
exp (HsWrap XWrap GhcTc
_ HsWrapper
h HsExpr GhcTc
e) (HsWrap XWrap GhcTc
_ 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 (HsVar XVar GhcTc
_ Located (IdP GhcTc)
i) (HsVar XVar GhcTc
_ Located (IdP GhcTc)
i') = Located MatchId
Located (IdP GhcTc)
i Located MatchId -> Located MatchId -> Bool
forall a. Eq a => a -> a -> Bool
== Located MatchId
Located (IdP 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 (HsOverLabel XOverLabel GhcTc
_ Maybe (IdP GhcTc)
l FastString
x) (HsOverLabel XOverLabel GhcTc
_ Maybe (IdP GhcTc)
l' FastString
x') = Maybe MatchId
Maybe (IdP GhcTc)
l Maybe MatchId -> Maybe MatchId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe MatchId
Maybe (IdP GhcTc)
l' Bool -> Bool -> Bool
&& FastString
x FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
x'
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
_ [LHsTupArg GhcTc]
es1 Boxity
_) (ExplicitTuple XExplicitTuple GhcTc
_ [LHsTupArg GhcTc]
es2 Boxity
_) =
(LHsTupArg GhcTc -> LHsTupArg GhcTc -> Bool)
-> [LHsTupArg GhcTc] -> [LHsTupArg GhcTc] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
eq_list LHsTupArg GhcTc -> LHsTupArg GhcTc -> Bool
forall a a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ HsTupArg GhcTc,
SrcSpanLess a ~ HsTupArg GhcTc) =>
a -> a -> Bool
tup_arg [LHsTupArg GhcTc]
es1 [LHsTupArg 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
_ Maybe (SyntaxExpr GhcTc)
_ LHsExpr GhcTc
e LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) (HsIf XIf GhcTc
_ Maybe (SyntaxExpr 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 (SyntaxExpr { syn_expr :: forall p. SyntaxExpr p -> HsExpr p
syn_expr = HsExpr GhcTc
expr1
, syn_arg_wraps :: forall p. SyntaxExpr p -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps1
, syn_res_wrap :: forall p. SyntaxExpr p -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap1 })
(SyntaxExpr { syn_expr :: forall p. SyntaxExpr p -> HsExpr p
syn_expr = HsExpr GhcTc
expr2
, syn_arg_wraps :: forall p. SyntaxExpr p -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps2
, syn_res_wrap :: forall p. SyntaxExpr p -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap2 })
= HsExpr GhcTc -> HsExpr GhcTc -> Bool
exp HsExpr GhcTc
expr1 HsExpr GhcTc
expr2 Bool -> Bool -> Bool
&&
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (String
-> (HsWrapper -> HsWrapper -> Bool)
-> [HsWrapper]
-> [HsWrapper]
-> [Bool]
forall a b c. 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
tup_arg :: a -> a -> Bool
tup_arg (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Present _ e1)) (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Present _ e2)) = LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
lexp LHsExpr GhcTc
e1 LHsExpr GhcTc
e2
tup_arg (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Missing t1)) (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Missing t2)) = Type -> Type -> Bool
eqType Type
XMissing GhcTc
t1 Type
XMissing GhcTc
t2
tup_arg a
_ a
_ = 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 Type
_ SDoc
_) (WpFun HsWrapper
w1' HsWrapper
w2' 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
aMatchId -> MatchId -> Bool
forall a. Eq a => a -> a -> Bool
==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 :: DynFlags -> Pat GhcTc -> PatGroup
patGroup :: DynFlags -> Pat GhcTc -> PatGroup
patGroup DynFlags
_ (ConPatOut { pat_con :: forall p. Pat p -> Located ConLike
pat_con = (Located ConLike -> Located (SrcSpanLess (Located ConLike))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located ConLike)
con)
, pat_arg_tys :: forall p. Pat p -> [Type]
pat_arg_tys = [Type]
tys })
| RealDataCon dcon <- SrcSpanLess (Located ConLike)
con = DataCon -> PatGroup
PgCon DataCon
dcon
| PatSynCon psyn <- SrcSpanLess (Located ConLike)
con = PatSyn -> [Type] -> PatGroup
PgSyn PatSyn
psyn [Type]
tys
patGroup DynFlags
_ (WildPat {}) = PatGroup
PgAny
patGroup DynFlags
_ (BangPat {}) = PatGroup
PgBang
patGroup DynFlags
_ (NPat XNPat GhcTc
_ (Located (HsOverLit GhcTc)
-> Located (SrcSpanLess (Located (HsOverLit GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (OverLit {ol_val=oval})) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_) =
case (OverLitVal
oval, Maybe (SyntaxExpr GhcTc) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SyntaxExpr GhcTc)
mb_neg) of
(HsIntegral IntegralLit
i, Bool
False) -> Rational -> PatGroup
PgN (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (IntegralLit -> Integer
il_value IntegralLit
i))
(HsIntegral IntegralLit
i, Bool
True ) -> Rational -> PatGroup
PgN (-Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (IntegralLit -> Integer
il_value IntegralLit
i))
(HsFractional FractionalLit
r, Bool
False) -> Rational -> PatGroup
PgN (FractionalLit -> Rational
fl_value FractionalLit
r)
(HsFractional FractionalLit
r, Bool
True ) -> Rational -> PatGroup
PgN (-FractionalLit -> Rational
fl_value FractionalLit
r)
(HsIsString SourceText
_ FastString
s, Bool
_) -> ASSERT(isNothing mb_neg)
FastString -> PatGroup
PgOverS FastString
s
patGroup DynFlags
_ (NPlusKPat XNPlusKPat GhcTc
_ Located (IdP GhcTc)
_ (Located (HsOverLit GhcTc)
-> Located (SrcSpanLess (Located (HsOverLit GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (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 DynFlags
_ (CoPat XCoPat GhcTc
_ HsWrapper
_ Pat GhcTc
p Type
_) = Type -> PatGroup
PgCo (Pat GhcTc -> Type
hsPatType Pat GhcTc
p)
patGroup DynFlags
_ (ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
expr LPat GhcTc
p) = LHsExpr GhcTc -> Type -> PatGroup
PgView LHsExpr GhcTc
expr (Pat GhcTc -> Type
hsPatType (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
p))
patGroup DynFlags
_ (ListPat (ListPatTc _ (Just _)) [LPat GhcTc]
_) = PatGroup
PgOverloadedList
patGroup DynFlags
dflags (LitPat XLitPat GhcTc
_ HsLit GhcTc
lit) = Literal -> PatGroup
PgLit (DynFlags -> HsLit GhcTc -> Literal
hsLitKey DynFlags
dflags HsLit GhcTc
lit)
patGroup DynFlags
_ 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)