{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.HsToCore.Pmc.Solver (
Nabla, Nablas(..), initNablas,
PhiCt(..), PhiCts,
addPhiCtNablas,
addPhiCtsNablas,
isInhabited,
generateInhabitingPatterns, GenerateInhabitingPatternsMode(..)
) where
import GHC.Prelude
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)
import GHC.HsToCore.Types (DsGblEnv(..))
import GHC.Driver.DynFlags
import GHC.Driver.Config
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Monad (allM)
import GHC.Utils.Panic
import GHC.Data.Bag
import GHC.Types.CompleteMatch
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSet
import GHC.Types.Unique.SDFM
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader (lookupGRE_Name, GlobalRdrEnv)
import GHC.Types.Var (EvVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Supply
import GHC.Tc.Utils.Monad (getGblEnv)
import GHC.Core
import GHC.Core.FVs (exprFreeVars)
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Map.Expr
import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred)
import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)
import GHC.Core.Utils (exprType)
import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr)
import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Data.Maybe
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst (elemSubst)
import GHC.Core.Type
import GHC.Tc.Solver (tcNormalise, tcCheckGivens, tcCheckWanteds)
import GHC.Core.Unify (tcMatchTy)
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.HsToCore.Monad hiding (foldlM)
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import Control.Applicative ((<|>))
import Control.Monad (foldM, forM, guard, mzero, when, filterM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict
import Data.Coerce
import Data.Foldable (foldlM, minimumBy, toList)
import Data.Monoid (Any(..))
import Data.List (sortBy, find)
import qualified Data.List.NonEmpty as NE
import Data.Ord (comparing)
addPhiCtsNablas :: Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas :: Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas Nablas
nablas PhiCts
cts = (Nabla -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla))
-> Nablas -> DsM Nablas
forall (m :: * -> *).
Monad m =>
(Nabla -> m (Maybe Nabla)) -> Nablas -> m Nablas
liftNablasM (\Nabla
d -> Nabla -> PhiCts -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
addPhiCts Nabla
d PhiCts
cts) Nablas
nablas
addPhiCtNablas :: Nablas -> PhiCt -> DsM Nablas
addPhiCtNablas :: Nablas -> PhiCt -> DsM Nablas
addPhiCtNablas Nablas
nablas PhiCt
ct = Nablas -> PhiCts -> DsM Nablas
addPhiCtsNablas Nablas
nablas (PhiCt -> PhiCts
forall a. a -> Bag a
unitBag PhiCt
ct)
liftNablasM :: Monad m => (Nabla -> m (Maybe Nabla)) -> Nablas -> m Nablas
liftNablasM :: forall (m :: * -> *).
Monad m =>
(Nabla -> m (Maybe Nabla)) -> Nablas -> m Nablas
liftNablasM Nabla -> m (Maybe Nabla)
f (MkNablas Bag Nabla
ds) = Bag Nabla -> Nablas
MkNablas (Bag Nabla -> Nablas)
-> (Bag (Maybe Nabla) -> Bag Nabla) -> Bag (Maybe Nabla) -> Nablas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (Maybe Nabla) -> Bag Nabla
forall a. Bag (Maybe a) -> Bag a
catBagMaybes (Bag (Maybe Nabla) -> Nablas) -> m (Bag (Maybe Nabla)) -> m Nablas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Nabla -> m (Maybe Nabla)) -> Bag Nabla -> m (Bag (Maybe Nabla))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bag a -> f (Bag b)
traverse Nabla -> m (Maybe Nabla)
f Bag Nabla
ds)
isInhabited :: Nablas -> DsM Bool
isInhabited :: Nablas -> DsM Bool
isInhabited (MkNablas Bag Nabla
ds) = Bool -> DsM Bool
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Bool
not (Bag Nabla -> Bool
forall a. Bag a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag Nabla
ds))
updRcm :: (DsCompleteMatch -> (Bool, DsCompleteMatch))
-> ResidualCompleteMatches -> (Maybe ResidualCompleteMatches)
updRcm :: (DsCompleteMatch -> (Bool, DsCompleteMatch))
-> ResidualCompleteMatches -> Maybe ResidualCompleteMatches
updRcm DsCompleteMatch -> (Bool, DsCompleteMatch)
f (RCM Maybe DsCompleteMatch
vanilla Maybe [DsCompleteMatch]
pragmas)
| Bool -> Bool
not Bool
any_change = Maybe ResidualCompleteMatches
forall a. Maybe a
Nothing
| Bool
otherwise = ResidualCompleteMatches -> Maybe ResidualCompleteMatches
forall a. a -> Maybe a
Just (Maybe DsCompleteMatch
-> Maybe [DsCompleteMatch] -> ResidualCompleteMatches
RCM Maybe DsCompleteMatch
vanilla' Maybe [DsCompleteMatch]
pragmas')
where
f' :: DsCompleteMatch -> (Any, DsCompleteMatch)
f' :: DsCompleteMatch -> (Any, DsCompleteMatch)
f' = (DsCompleteMatch -> (Bool, DsCompleteMatch))
-> DsCompleteMatch -> (Any, DsCompleteMatch)
forall a b. Coercible a b => a -> b
coerce DsCompleteMatch -> (Bool, DsCompleteMatch)
f
(Any
chgd, Maybe DsCompleteMatch
vanilla') = (DsCompleteMatch -> (Any, DsCompleteMatch))
-> Maybe DsCompleteMatch -> (Any, Maybe DsCompleteMatch)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse DsCompleteMatch -> (Any, DsCompleteMatch)
f' Maybe DsCompleteMatch
vanilla
(Any
chgds, Maybe [DsCompleteMatch]
pragmas') = ([DsCompleteMatch] -> (Any, [DsCompleteMatch]))
-> Maybe [DsCompleteMatch] -> (Any, Maybe [DsCompleteMatch])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((DsCompleteMatch -> (Any, DsCompleteMatch))
-> [DsCompleteMatch] -> (Any, [DsCompleteMatch])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DsCompleteMatch -> (Any, DsCompleteMatch)
f') Maybe [DsCompleteMatch]
pragmas
any_change :: Bool
any_change = Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ Any
chgd Any -> Any -> Any
forall a. Monoid a => a -> a -> a
`mappend` Any
chgds
vanillaCompleteMatchTC :: TyCon -> Maybe DsCompleteMatch
vanillaCompleteMatchTC :: TyCon -> Maybe DsCompleteMatch
vanillaCompleteMatchTC TyCon
tc =
let mb_dcs :: Maybe [DataCon]
mb_dcs |
TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tYPETyCon = [DataCon] -> Maybe [DataCon]
forall a. a -> Maybe a
Just []
|
TyCon -> Bool
isTypeDataTyCon TyCon
tc = [DataCon] -> Maybe [DataCon]
forall a. a -> Maybe a
Just []
| Bool
otherwise = TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
in UniqDSet ConLike -> DsCompleteMatch
forall con. UniqDSet con -> CompleteMatchX con
vanillaCompleteMatch (UniqDSet ConLike -> DsCompleteMatch)
-> ([DataCon] -> UniqDSet ConLike) -> [DataCon] -> DsCompleteMatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConLike] -> UniqDSet ConLike
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([ConLike] -> UniqDSet ConLike)
-> ([DataCon] -> [ConLike]) -> [DataCon] -> UniqDSet ConLike
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon ([DataCon] -> DsCompleteMatch)
-> Maybe [DataCon] -> Maybe DsCompleteMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [DataCon]
mb_dcs
addCompleteMatches :: ResidualCompleteMatches -> DsM ResidualCompleteMatches
addCompleteMatches :: ResidualCompleteMatches -> DsM ResidualCompleteMatches
addCompleteMatches (RCM Maybe DsCompleteMatch
v Maybe [DsCompleteMatch]
Nothing) = Maybe DsCompleteMatch
-> Maybe [DsCompleteMatch] -> ResidualCompleteMatches
RCM Maybe DsCompleteMatch
v (Maybe [DsCompleteMatch] -> ResidualCompleteMatches)
-> ([DsCompleteMatch] -> Maybe [DsCompleteMatch])
-> [DsCompleteMatch]
-> ResidualCompleteMatches
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DsCompleteMatch] -> Maybe [DsCompleteMatch]
forall a. a -> Maybe a
Just ([DsCompleteMatch] -> ResidualCompleteMatches)
-> IOEnv (Env DsGblEnv DsLclEnv) [DsCompleteMatch]
-> DsM ResidualCompleteMatches
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) [DsCompleteMatch]
dsGetCompleteMatches
addCompleteMatches ResidualCompleteMatches
rcm = ResidualCompleteMatches -> DsM ResidualCompleteMatches
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResidualCompleteMatches
rcm
addConLikeMatches :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addConLikeMatches :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addConLikeMatches (RealDataCon DataCon
dc) ResidualCompleteMatches
rcm = TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addTyConMatches (DataCon -> TyCon
dataConTyCon DataCon
dc) ResidualCompleteMatches
rcm
addConLikeMatches (PatSynCon PatSyn
_) ResidualCompleteMatches
rcm = ResidualCompleteMatches -> DsM ResidualCompleteMatches
addCompleteMatches ResidualCompleteMatches
rcm
addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addTyConMatches TyCon
tc ResidualCompleteMatches
rcm = ResidualCompleteMatches -> ResidualCompleteMatches
add_tc_match (ResidualCompleteMatches -> ResidualCompleteMatches)
-> DsM ResidualCompleteMatches -> DsM ResidualCompleteMatches
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addCompleteMatches ResidualCompleteMatches
rcm
where
add_tc_match :: ResidualCompleteMatches -> ResidualCompleteMatches
add_tc_match ResidualCompleteMatches
rcm
= ResidualCompleteMatches
rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}
markMatched :: PmAltCon -> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches)
markMatched :: PmAltCon
-> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches)
markMatched (PmAltLit PmLit
_) ResidualCompleteMatches
_ = Maybe ResidualCompleteMatches
-> DsM (Maybe ResidualCompleteMatches)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ResidualCompleteMatches
forall a. Maybe a
Nothing
markMatched (PmAltConLike ConLike
cl) ResidualCompleteMatches
rcm = do
rcm' <- ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addConLikeMatches ConLike
cl ResidualCompleteMatches
rcm
let go DsCompleteMatch
cm = case UniqDSet ConLike -> ConLike -> Maybe ConLike
forall a. Uniquable a => UniqDSet a -> a -> Maybe a
lookupUniqDSet (DsCompleteMatch -> UniqDSet ConLike
forall con. CompleteMatchX con -> UniqDSet con
cmConLikes DsCompleteMatch
cm) ConLike
cl of
Maybe ConLike
Nothing -> (Bool
False, DsCompleteMatch
cm)
Just ConLike
_ -> (Bool
True, DsCompleteMatch
cm { cmConLikes = delOneFromUniqDSet (cmConLikes cm) cl })
pure $ updRcm go rcm'
data TopNormaliseTypeResult
= NormalisedByConstraints Type
| HadRedexes Type [(Type, DataCon, Type)] Type
tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)
tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)
tntrGuts (NormalisedByConstraints Type
ty) = (Type
ty, [], Type
ty)
tntrGuts (HadRedexes Type
src_ty [(Type, DataCon, Type)]
ds Type
core_ty) = (Type
src_ty, [(Type, DataCon, Type)]
ds, Type
core_ty)
instance Outputable TopNormaliseTypeResult where
ppr :: TopNormaliseTypeResult -> SDoc
ppr (NormalisedByConstraints Type
ty) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NormalisedByConstraints" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty
ppr (HadRedexes Type
src_ty [(Type, DataCon, Type)]
ds Type
core_ty) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HadRedexes" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
fields
where
fields :: SDoc
fields = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"src_ty =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
src_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"newtype_dcs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Type, DataCon, Type)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, DataCon, Type)]
ds
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"core_ty =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
core_ty ])
pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult
pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult
pmTopNormaliseType (TySt Int
_ InertSet
inert) Type
typ = {-# SCC "pmTopNormaliseType" #-} do
env <- DsM FamInstEnvs
dsGetFamInstEnvs
tracePm "normalise" (ppr typ)
typ' <- initTcDsForSolver $ tcNormalise inert typ
pure $ case topNormaliseTypeX (stepper env) comb typ' of
Maybe
((ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)]),
Type)
Nothing -> Type -> TopNormaliseTypeResult
NormalisedByConstraints Type
typ'
Just ((ThetaType -> ThetaType
ty_f,[(Type, DataCon, Type)] -> [(Type, DataCon, Type)]
tm_f), Type
ty) -> Type -> [(Type, DataCon, Type)] -> Type -> TopNormaliseTypeResult
HadRedexes Type
src_ty [(Type, DataCon, Type)]
newtype_dcs Type
core_ty
where
src_ty :: Type
src_ty = Type -> ThetaType -> Type
eq_src_ty Type
ty (Type
typ' Type -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
: ThetaType -> ThetaType
ty_f [Type
ty])
newtype_dcs :: [(Type, DataCon, Type)]
newtype_dcs = [(Type, DataCon, Type)] -> [(Type, DataCon, Type)]
tm_f []
core_ty :: Type
core_ty = Type
ty
where
eq_src_ty :: Type -> [Type] -> Type
eq_src_ty :: Type -> ThetaType -> Type
eq_src_ty Type
ty ThetaType
tys = Type -> (Type -> Type) -> Maybe Type -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type
ty Type -> Type
forall a. a -> a
id ((Type -> Bool) -> ThetaType -> Maybe Type
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Type -> Bool
is_closed_or_data_family ThetaType
tys)
is_closed_or_data_family :: Type -> Bool
is_closed_or_data_family :: Type -> Bool
is_closed_or_data_family Type
ty = Type -> Bool
pmIsClosedType Type
ty Bool -> Bool -> Bool
|| Type -> Bool
isDataFamilyAppType Type
ty
comb :: (b -> c, b -> c) -> (a -> b, a -> b) -> (a -> c, a -> c)
comb (b -> c
tyf1, b -> c
tmf1) (a -> b
tyf2, a -> b
tmf2) = (b -> c
tyf1 (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
tyf2, b -> c
tmf1 (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
tmf2)
stepper :: FamInstEnvs
-> NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
stepper FamInstEnvs
env = NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
newTypeStepper NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
-> NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
-> NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
forall ev.
NormaliseStepper ev -> NormaliseStepper ev -> NormaliseStepper ev
`composeSteppers` FamInstEnvs
-> NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
forall a.
FamInstEnvs -> NormaliseStepper (ThetaType -> ThetaType, a -> a)
tyFamStepper FamInstEnvs
env
newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
newTypeStepper :: NormaliseStepper
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
newTypeStepper RecTcChecker
rec_nts TyCon
tc ThetaType
tys
| Just (Type
ty', Coercion
_co) <- TyCon -> ThetaType -> Maybe (Type, Coercion)
instNewTyCon_maybe TyCon
tc ThetaType
tys
, let orig_ty :: Type
orig_ty = TyCon -> ThetaType -> Type
TyConApp TyCon
tc ThetaType
tys
= case RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc of
Just RecTcChecker
rec_nts' -> let tyf :: ThetaType -> ThetaType
tyf = (Type
orig_tyType -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
:)
tmf :: [(Type, DataCon, Type)] -> [(Type, DataCon, Type)]
tmf = ((Type
orig_ty, TyCon -> DataCon
tyConSingleDataCon TyCon
tc, Type
ty')(Type, DataCon, Type)
-> [(Type, DataCon, Type)] -> [(Type, DataCon, Type)]
forall a. a -> [a] -> [a]
:)
in RecTcChecker
-> Type
-> (ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
-> NormaliseStepResult
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
forall ev. RecTcChecker -> Type -> ev -> NormaliseStepResult ev
NS_Step RecTcChecker
rec_nts' Type
ty' (ThetaType -> ThetaType
tyf, [(Type, DataCon, Type)] -> [(Type, DataCon, Type)]
tmf)
Maybe RecTcChecker
Nothing -> NormaliseStepResult
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
forall ev. NormaliseStepResult ev
NS_Abort
| Bool
otherwise
= NormaliseStepResult
(ThetaType -> ThetaType,
[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
forall ev. NormaliseStepResult ev
NS_Done
tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)
tyFamStepper :: forall a.
FamInstEnvs -> NormaliseStepper (ThetaType -> ThetaType, a -> a)
tyFamStepper FamInstEnvs
env RecTcChecker
rec_nts TyCon
tc ThetaType
tys
= case FamInstEnvs -> TyCon -> ThetaType -> Maybe HetReduction
topReduceTyFamApp_maybe FamInstEnvs
env TyCon
tc ThetaType
tys of
Just (HetReduction (Reduction Coercion
_ Type
rhs) MCoercionN
_)
-> RecTcChecker
-> Type
-> (ThetaType -> ThetaType, a -> a)
-> NormaliseStepResult (ThetaType -> ThetaType, a -> a)
forall ev. RecTcChecker -> Type -> ev -> NormaliseStepResult ev
NS_Step RecTcChecker
rec_nts Type
rhs ((Type
rhsType -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
:), a -> a
forall a. a -> a
id)
Maybe HetReduction
_ -> NormaliseStepResult (ThetaType -> ThetaType, a -> a)
forall ev. NormaliseStepResult ev
NS_Done
pmIsClosedType :: Type -> Bool
pmIsClosedType :: Type -> Bool
pmIsClosedType Type
ty
= case HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
splitTyConApp_maybe Type
ty of
Just (TyCon
tc, ThetaType
ty_args)
| TyCon -> Bool
is_algebraic_like TyCon
tc Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
isFamilyTyCon TyCon
tc)
-> Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (ThetaType
ty_args ThetaType -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` TyCon -> Int
tyConArity TyCon
tc) (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) Bool
True
Maybe (TyCon, ThetaType)
_other -> Bool
False
where
is_algebraic_like :: TyCon -> Bool
is_algebraic_like :: TyCon -> Bool
is_algebraic_like TyCon
tc = TyCon -> Bool
isAlgTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tYPETyCon
normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type
normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type
normaliseSourceTypeWHNF TyState
_ Type
ty | Type -> Bool
isSourceTypeInWHNF Type
ty = Type -> DsM Type
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
normaliseSourceTypeWHNF TyState
ty_st Type
ty =
TyState -> Type -> DsM TopNormaliseTypeResult
pmTopNormaliseType TyState
ty_st Type
ty DsM TopNormaliseTypeResult
-> (TopNormaliseTypeResult -> DsM Type) -> DsM Type
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) a
-> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
NormalisedByConstraints Type
ty -> Type -> DsM Type
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
HadRedexes Type
ty [(Type, DataCon, Type)]
_ Type
_ -> Type -> DsM Type
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
isSourceTypeInWHNF :: Type -> Bool
isSourceTypeInWHNF :: Type -> Bool
isSourceTypeInWHNF Type
ty
| Just (TyCon
tc, ThetaType
_) <- HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
splitTyConApp_maybe Type
ty = Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc)
| Bool
otherwise = Bool
False
data PhiCt
= PhiTyCt !PredType
| PhiCoreCt !Id !CoreExpr
| PhiConCt !Id !PmAltCon ![TyVar] ![PredType] ![Id]
| PhiNotConCt !Id !PmAltCon
| PhiBotCt !Id
| PhiNotBotCt !Id
instance Outputable PhiCt where
ppr :: PhiCt -> SDoc
ppr (PhiTyCt Type
ty_ct) = Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty_ct
ppr (PhiCoreCt Id
x CoreExpr
e) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e
ppr (PhiConCt Id
x PmAltCon
con [Id]
tvs ThetaType
dicts [Id]
args) =
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (PmAltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmAltCon
con SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
pp_tvs [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
pp_dicts [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
pp_args) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x
where
pp_tvs :: [SDoc]
pp_tvs = (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'@') (SDoc -> SDoc) -> (Id -> SDoc) -> Id -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [Id]
tvs
pp_dicts :: [SDoc]
pp_dicts = (Type -> SDoc) -> ThetaType -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
dicts
pp_args :: [SDoc]
pp_args = (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
args
ppr (PhiNotConCt Id
x PmAltCon
con) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"≁" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PmAltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmAltCon
con
ppr (PhiBotCt Id
x) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"~ ⊥"
ppr (PhiNotBotCt Id
x) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"≁ ⊥"
type PhiCts = Bag PhiCt
initFuel :: Int
initFuel :: Int
initFuel = Int
4
addPhiCts :: Nabla -> PhiCts -> DsM (Maybe Nabla)
addPhiCts :: Nabla -> PhiCts -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
addPhiCts Nabla
nabla PhiCts
cts = MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla))
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
forall a b. (a -> b) -> a -> b
$ do
let (ThetaType
ty_cts, [PhiCt]
tm_cts) = PhiCts -> (ThetaType, [PhiCt])
partitionPhiCts PhiCts
cts
nabla' <- Nabla -> Bag Type -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addTyCts Nabla
nabla (ThetaType -> Bag Type
forall a. [a] -> Bag a
listToBag ThetaType
ty_cts)
nabla'' <- foldlM addPhiTmCt nabla' (listToBag tm_cts)
inhabitationTest initFuel (nabla_ty_st nabla) nabla''
partitionPhiCts :: PhiCts -> ([PredType], [PhiCt])
partitionPhiCts :: PhiCts -> (ThetaType, [PhiCt])
partitionPhiCts = (PhiCt -> Either Type PhiCt) -> [PhiCt] -> (ThetaType, [PhiCt])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith PhiCt -> Either Type PhiCt
to_either ([PhiCt] -> (ThetaType, [PhiCt]))
-> (PhiCts -> [PhiCt]) -> PhiCts -> (ThetaType, [PhiCt])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhiCts -> [PhiCt]
forall a. Bag a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
where
to_either :: PhiCt -> Either Type PhiCt
to_either (PhiTyCt Type
pred_ty) = Type -> Either Type PhiCt
forall a b. a -> Either a b
Left Type
pred_ty
to_either PhiCt
ct = PhiCt -> Either Type PhiCt
forall a b. b -> Either a b
Right PhiCt
ct
addTyCts :: Nabla -> Bag PredType -> MaybeT DsM Nabla
addTyCts :: Nabla -> Bag Type -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addTyCts nabla :: Nabla
nabla@MkNabla{ nabla_ty_st :: Nabla -> TyState
nabla_ty_st = TyState
ty_st } Bag Type
new_ty_cs = do
ty_st' <- DsM (Maybe TyState)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) TyState
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (TyState -> Bag Type -> DsM (Maybe TyState)
tyOracle TyState
ty_st Bag Type
new_ty_cs)
pure nabla{ nabla_ty_st = ty_st' }
tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState)
tyOracle :: TyState -> Bag Type -> DsM (Maybe TyState)
tyOracle ty_st :: TyState
ty_st@(TySt Int
n InertSet
inert) Bag Type
cts
| Bag Type -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Type
cts
= Maybe TyState -> DsM (Maybe TyState)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyState -> Maybe TyState
forall a. a -> Maybe a
Just TyState
ty_st)
| Bool
otherwise
= {-# SCC "tyOracle" #-}
do { evs <- (Type -> IOEnv (Env DsGblEnv DsLclEnv) Id)
-> Bag Type -> IOEnv (Env DsGblEnv DsLclEnv) (Bag Id)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bag a -> f (Bag b)
traverse Type -> IOEnv (Env DsGblEnv DsLclEnv) Id
nameTyCt Bag Type
cts
; tracePm "tyOracle" (ppr n $$ ppr cts $$ ppr inert)
; mb_new_inert <- initTcDsForSolver $ tcCheckGivens inert evs
; return (TySt (n+1) <$> mb_new_inert) }
nameTyCt :: PredType -> DsM EvVar
nameTyCt :: Type -> IOEnv (Env DsGblEnv DsLclEnv) Id
nameTyCt Type
pred_ty = do
unique <- IOEnv (Env DsGblEnv DsLclEnv) Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
let occname = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit (String
"pm_"String -> String -> String
forall a. [a] -> [a] -> [a]
++Unique -> String
forall a. Show a => a -> String
show Unique
unique))
return (mkUserLocalOrCoVar occname unique ManyTy pred_ty noSrcSpan)
addPhiTmCt :: Nabla -> PhiCt -> MaybeT DsM Nabla
addPhiTmCt :: Nabla -> PhiCt -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addPhiTmCt Nabla
_ (PhiTyCt Type
ct) = String -> SDoc -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addPhiCt:TyCt" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ct)
addPhiTmCt Nabla
nabla (PhiCoreCt Id
x CoreExpr
e) = Nabla
-> Id -> CoreExpr -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addCoreCt Nabla
nabla Id
x CoreExpr
e
addPhiTmCt Nabla
nabla (PhiConCt Id
x PmAltCon
con [Id]
tvs ThetaType
dicts [Id]
args) = do
nabla' <- Nabla -> Bag Type -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addTyCts Nabla
nabla (ThetaType -> Bag Type
forall a. [a] -> Bag a
listToBag ThetaType
dicts)
nabla'' <- addConCt nabla' x con tvs args
foldlM addNotBotCt nabla'' (filterUnliftedFields con args)
addPhiTmCt Nabla
nabla (PhiNotConCt Id
x PmAltCon
con) = Nabla
-> Id -> PmAltCon -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotConCt Nabla
nabla Id
x PmAltCon
con
addPhiTmCt Nabla
nabla (PhiBotCt Id
x) = Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addBotCt Nabla
nabla Id
x
addPhiTmCt Nabla
nabla (PhiNotBotCt Id
x) = Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotBotCt Nabla
nabla Id
x
filterUnliftedFields :: PmAltCon -> [Id] -> [Id]
filterUnliftedFields :: PmAltCon -> [Id] -> [Id]
filterUnliftedFields PmAltCon
con [Id]
args =
[ Id
arg | (Id
arg, HsImplBang
bang) <- String -> [Id] -> [HsImplBang] -> [(Id, HsImplBang)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"addPhiCt" [Id]
args (PmAltCon -> [HsImplBang]
pmAltConImplBangs PmAltCon
con)
, HsImplBang -> Bool
isBanged HsImplBang
bang Bool -> Bool -> Bool
|| Type -> Bool
definitelyUnliftedType (Id -> Type
idType Id
arg) ]
addBotCt :: Nabla -> Id -> MaybeT DsM Nabla
addBotCt :: Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addBotCt nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts=UniqSDFM Id VarInfo
env } } Id
x = do
let (Id
y, vi :: VarInfo
vi@VI { vi_bot :: VarInfo -> BotInfo
vi_bot = BotInfo
bot }) = TmState -> Id -> (Id, VarInfo)
lookupVarInfoNT (Nabla -> TmState
nabla_tm_st Nabla
nabla) Id
x
case BotInfo
bot of
BotInfo
IsNotBot -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
BotInfo
IsBot -> Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla
BotInfo
MaybeBot
| Type -> Bool
definitelyUnliftedType (Id -> Type
idType Id
x)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Bool
otherwise
-> do
let vi' :: VarInfo
vi' = VarInfo
vi{ vi_bot = IsBot }
Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } }
addNotBotCt :: Nabla -> Id -> MaybeT DsM Nabla
addNotBotCt :: Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotBotCt nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts=UniqSDFM Id VarInfo
env} } Id
x = do
let (Id
y, vi :: VarInfo
vi@VI { vi_bot :: VarInfo -> BotInfo
vi_bot = BotInfo
bot }) = TmState -> Id -> (Id, VarInfo)
lookupVarInfoNT (Nabla -> TmState
nabla_tm_st Nabla
nabla) Id
x
case BotInfo
bot of
BotInfo
IsBot -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
BotInfo
IsNotBot -> Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla
BotInfo
MaybeBot -> do
let vi' :: VarInfo
vi' = VarInfo
vi{ vi_bot = IsNotBot}
Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a b. (a -> b) -> a -> b
$ Id -> Nabla -> Nabla
markDirty Id
y
(Nabla -> Nabla) -> Nabla -> Nabla
forall a b. (a -> b) -> a -> b
$ Nabla
nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env y vi' } }
addNotConCt :: Nabla -> Id -> PmAltCon -> MaybeT DsM Nabla
addNotConCt :: Nabla
-> Id -> PmAltCon -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotConCt Nabla
_ Id
_ (PmAltConLike (RealDataCon DataCon
dc))
| DataCon -> Bool
isNewDataCon DataCon
dc = MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
addNotConCt Nabla
nabla Id
x PmAltCon
nalt = do
(mb_mark_dirty, nabla') <- (VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Maybe Id, VarInfo))
-> Nabla
-> Id
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Maybe Id, Nabla)
forall (f :: * -> *) a.
Functor f =>
(VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)
trvVarInfo VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Maybe Id, VarInfo)
go Nabla
nabla Id
x
pure $ case mb_mark_dirty of
Just Id
x -> Id -> Nabla -> Nabla
markDirty Id
x Nabla
nabla'
Maybe Id
Nothing -> Nabla
nabla'
where
go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo)
go :: VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Maybe Id, VarInfo)
go vi :: VarInfo
vi@(VI Id
x' [PmAltConApp]
pos PmAltConSet
neg BotInfo
_ ResidualCompleteMatches
rcm) = do
let contradicts :: PmAltCon -> PmAltConApp -> Bool
contradicts PmAltCon
nalt PmAltConApp
sol = PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon (PmAltConApp -> PmAltCon
paca_con PmAltConApp
sol) PmAltCon
nalt PmEquality -> PmEquality -> Bool
forall a. Eq a => a -> a -> Bool
== PmEquality
Equal
Bool -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ((PmAltConApp -> Bool) -> [PmAltConApp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PmAltCon -> PmAltConApp -> Bool
contradicts PmAltCon
nalt) [PmAltConApp]
pos))
let implies :: PmAltCon -> PmAltConApp -> Bool
implies PmAltCon
nalt PmAltConApp
sol = PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon (PmAltConApp -> PmAltCon
paca_con PmAltConApp
sol) PmAltCon
nalt PmEquality -> PmEquality -> Bool
forall a. Eq a => a -> a -> Bool
== PmEquality
Disjoint
let neg' :: PmAltConSet
neg'
| (PmAltConApp -> Bool) -> [PmAltConApp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PmAltCon -> PmAltConApp -> Bool
implies PmAltCon
nalt) [PmAltConApp]
pos = PmAltConSet
neg
| PmAltCon -> Bool
hasRequiredTheta PmAltCon
nalt = PmAltConSet
neg
| Bool
otherwise = PmAltConSet -> PmAltCon -> PmAltConSet
extendPmAltConSet PmAltConSet
neg PmAltCon
nalt
Bool -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (PmAltCon -> Bool
isPmAltConMatchStrict PmAltCon
nalt)
let vi' :: VarInfo
vi' = VarInfo
vi{ vi_neg = neg', vi_bot = IsNotBot }
mb_rcm' <- DsM (Maybe ResidualCompleteMatches)
-> MaybeT
(IOEnv (Env DsGblEnv DsLclEnv)) (Maybe ResidualCompleteMatches)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PmAltCon
-> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches)
markMatched PmAltCon
nalt ResidualCompleteMatches
rcm)
pure $ case mb_rcm' of
Just ResidualCompleteMatches
rcm' -> (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
x', VarInfo
vi'{ vi_rcm = rcm' })
Maybe ResidualCompleteMatches
Nothing -> (Maybe Id
forall a. Maybe a
Nothing, VarInfo
vi')
hasRequiredTheta :: PmAltCon -> Bool
hasRequiredTheta :: PmAltCon -> Bool
hasRequiredTheta (PmAltConLike ConLike
cl) = ThetaType -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ThetaType
req_theta
where
([Id]
_,[Id]
_,[EqSpec]
_,ThetaType
_,ThetaType
req_theta,[Scaled Type]
_,Type
_) = ConLike
-> ([Id], [Id], [EqSpec], ThetaType, ThetaType, [Scaled Type],
Type)
conLikeFullSig ConLike
cl
hasRequiredTheta PmAltCon
_ = Bool
False
addConCt :: Nabla -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Nabla
addConCt :: Nabla
-> Id
-> PmAltCon
-> [Id]
-> [Id]
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addConCt nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts=UniqSDFM Id VarInfo
env } } Id
x PmAltCon
alt [Id]
tvs [Id]
args = do
let vi :: VarInfo
vi@(VI Id
_ [PmAltConApp]
pos PmAltConSet
neg BotInfo
bot ResidualCompleteMatches
_) = TmState -> Id -> VarInfo
lookupVarInfo TmState
ts Id
x
Bool -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (PmAltCon -> PmAltConSet -> Bool
elemPmAltConSet PmAltCon
alt PmAltConSet
neg))
Bool -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((PmAltConApp -> Bool) -> [PmAltConApp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((PmEquality -> PmEquality -> Bool
forall a. Eq a => a -> a -> Bool
/= PmEquality
Disjoint) (PmEquality -> Bool)
-> (PmAltConApp -> PmEquality) -> PmAltConApp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon PmAltCon
alt (PmAltCon -> PmEquality)
-> (PmAltConApp -> PmAltCon) -> PmAltConApp -> PmEquality
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmAltConApp -> PmAltCon
paca_con) [PmAltConApp]
pos)
case (PmAltConApp -> Bool) -> [PmAltConApp] -> Maybe PmAltConApp
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((PmEquality -> PmEquality -> Bool
forall a. Eq a => a -> a -> Bool
== PmEquality
Equal) (PmEquality -> Bool)
-> (PmAltConApp -> PmEquality) -> PmAltConApp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon PmAltCon
alt (PmAltCon -> PmEquality)
-> (PmAltConApp -> PmAltCon) -> PmAltConApp -> PmEquality
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmAltConApp -> PmAltCon
paca_con) [PmAltConApp]
pos of
Just (PACA PmAltCon
_con [Id]
other_tvs [Id]
other_args) -> do
let ty_cts :: [PhiCt]
ty_cts = ThetaType -> ThetaType -> [PhiCt]
equateTys ((Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
mkTyVarTy [Id]
tvs) ((Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
mkTyVarTy [Id]
other_tvs)
nabla' <- IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a b. (a -> b) -> a -> b
$ Nabla -> PhiCts -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
addPhiCts Nabla
nabla ([PhiCt] -> PhiCts
forall a. [a] -> Bag a
listToBag [PhiCt]
ty_cts)
let add_var_ct Nabla
nabla (Id
a, Id
b) = Nabla -> Id -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addVarCt Nabla
nabla Id
a Id
b
foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args
Maybe PmAltConApp
Nothing -> do
let pos' :: [PmAltConApp]
pos' = PmAltCon -> [Id] -> [Id] -> PmAltConApp
PACA PmAltCon
alt [Id]
tvs [Id]
args PmAltConApp -> [PmAltConApp] -> [PmAltConApp]
forall a. a -> [a] -> [a]
: [PmAltConApp]
pos
let nabla_with :: BotInfo -> Nabla
nabla_with BotInfo
bot' =
Nabla
nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env x (vi{vi_pos = pos', vi_bot = bot'})} }
case (PmAltCon
alt, [Id]
args) of
(PmAltConLike (RealDataCon DataCon
dc), [Id
y]) | DataCon -> Bool
isNewDataCon DataCon
dc ->
case BotInfo
bot of
BotInfo
MaybeBot -> Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotInfo -> Nabla
nabla_with BotInfo
MaybeBot)
BotInfo
IsBot -> Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addBotCt (BotInfo -> Nabla
nabla_with BotInfo
MaybeBot) Id
y
BotInfo
IsNotBot -> Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotBotCt (BotInfo -> Nabla
nabla_with BotInfo
MaybeBot) Id
y
(PmAltCon, [Id])
_ -> Bool
-> (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> Nabla
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. HasCallStack => Bool -> a -> a
assert (PmAltCon -> Bool
isPmAltConMatchStrict PmAltCon
alt )
Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BotInfo -> Nabla
nabla_with BotInfo
IsNotBot)
equateTys :: [Type] -> [Type] -> [PhiCt]
equateTys :: ThetaType -> ThetaType -> [PhiCt]
equateTys ThetaType
ts ThetaType
us =
[ Type -> PhiCt
PhiTyCt (Type -> Type -> Type
mkNomEqPred Type
t Type
u)
| (Type
t, Type
u) <- String -> ThetaType -> ThetaType -> [(Type, Type)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"equateTys" ThetaType
ts ThetaType
us
, Bool -> Bool
not (HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
eqType Type
t Type
u)
]
addVarCt :: Nabla -> Id -> Id -> MaybeT DsM Nabla
addVarCt :: Nabla -> Id -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addVarCt nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts = UniqSDFM Id VarInfo
env } } Id
x Id
y =
case UniqSDFM Id VarInfo
-> Id -> Id -> (Maybe VarInfo, UniqSDFM Id VarInfo)
forall key ele.
Uniquable key =>
UniqSDFM key ele -> key -> key -> (Maybe ele, UniqSDFM key ele)
equateUSDFM UniqSDFM Id VarInfo
env Id
x Id
y of
(Maybe VarInfo
Nothing, UniqSDFM Id VarInfo
env') -> Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nabla
nabla{ nabla_tm_st = ts{ ts_facts = env' } })
(Just VarInfo
vi_x, UniqSDFM Id VarInfo
env') -> do
let nabla_equated :: Nabla
nabla_equated = Nabla
nabla{ nabla_tm_st = ts{ts_facts = env'} }
let add_pos :: Nabla
-> PmAltConApp -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
add_pos Nabla
nabla (PACA PmAltCon
cl [Id]
tvs [Id]
args) = Nabla
-> Id
-> PmAltCon
-> [Id]
-> [Id]
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addConCt Nabla
nabla Id
y PmAltCon
cl [Id]
tvs [Id]
args
nabla_pos <- (Nabla
-> PmAltConApp -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> Nabla
-> [PmAltConApp]
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Nabla
-> PmAltConApp -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
add_pos Nabla
nabla_equated (VarInfo -> [PmAltConApp]
vi_pos VarInfo
vi_x)
let add_neg Nabla
nabla PmAltCon
nalt = Nabla
-> Id -> PmAltCon -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotConCt Nabla
nabla Id
y PmAltCon
nalt
foldlM add_neg nabla_pos (pmAltConSetElems (vi_neg vi_x))
addCoreCt :: Nabla -> Id -> CoreExpr -> MaybeT DsM Nabla
addCoreCt :: Nabla
-> Id -> CoreExpr -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addCoreCt Nabla
nabla Id
x CoreExpr
e = do
simpl_opts <- DynFlags -> SimpleOpts
initSimpleOpts (DynFlags -> SimpleOpts)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) DynFlags
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) SimpleOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let e' = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
simpl_opts CoreExpr
e
execStateT (core_expr x e') nabla
where
core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()
core_expr :: Id
-> CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
core_expr Id
x (Cast CoreExpr
e Coercion
_co) = Id
-> CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
core_expr Id
x CoreExpr
e
core_expr Id
x (Tick CoreTickish
_t CoreExpr
e) = Id
-> CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
core_expr Id
x CoreExpr
e
core_expr Id
x CoreExpr
e
| Just (PmLit -> Maybe FastString
pmLitAsStringLit -> Just FastString
s) <- CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
e
, Type
expr_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
stringTy
= case FastString -> String
unpackFS FastString
s of
[] -> Id
-> InScopeSet
-> DataCon
-> [CoreExpr]
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
data_con_app Id
x InScopeSet
emptyInScopeSet DataCon
nilDataCon []
String
s' -> Id
-> CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
core_expr Id
x (Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
charTy ((Char -> CoreExpr) -> String -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Char -> CoreExpr
mkCharExpr String
s'))
| Just PmLit
lit <- CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
e
= Id
-> PmLit
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
pm_lit Id
x PmLit
lit
| Just (InScopeSet
in_scope, _empty_floats :: [FloatBind]
_empty_floats@[], DataCon
dc, ThetaType
_arg_tys, [CoreExpr]
args)
<- HasDebugCallStack =>
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, ThetaType, [CoreExpr])
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, ThetaType, [CoreExpr])
exprIsConApp_maybe InScopeEnv
in_scope_env CoreExpr
e
= Id
-> InScopeSet
-> DataCon
-> [CoreExpr]
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
data_con_app Id
x InScopeSet
in_scope DataCon
dc [CoreExpr]
args
| Var Id
y <- CoreExpr
e, Maybe DataCon
Nothing <- Id -> Maybe DataCon
isDataConId_maybe Id
x
= (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyT (\Nabla
nabla -> Nabla -> Id -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addVarCt Nabla
nabla Id
x Id
y)
| Bool
otherwise
= Id
-> CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
equate_with_similar_expr Id
x CoreExpr
e
where
expr_ty :: Type
expr_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
expr_in_scope :: InScopeSet
expr_in_scope = VarSet -> InScopeSet
mkInScopeSet (CoreExpr -> VarSet
exprFreeVars CoreExpr
e)
in_scope_env :: InScopeEnv
in_scope_env = InScopeSet -> IdUnfoldingFun -> InScopeEnv
ISE InScopeSet
expr_in_scope IdUnfoldingFun
noUnfoldingFun
equate_with_similar_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()
equate_with_similar_expr :: Id
-> CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
equate_with_similar_expr Id
x CoreExpr
e = do
rep <- (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Id, Nabla))
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) Id
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Id, Nabla))
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) Id)
-> (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Id, Nabla))
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) Id
forall a b. (a -> b) -> a -> b
$ \Nabla
nabla -> DsM (Id, Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Id, Nabla)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Nabla -> CoreExpr -> DsM (Id, Nabla)
representCoreExpr Nabla
nabla CoreExpr
e)
modifyT (\Nabla
nabla -> Nabla -> Id -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addVarCt Nabla
nabla Id
x Id
rep)
bind_expr :: CoreExpr -> StateT Nabla (MaybeT DsM) Id
bind_expr :: CoreExpr
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) Id
bind_expr CoreExpr
e = do
x <- MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Id
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) Id
forall (m :: * -> *) a. Monad m => m a -> StateT Nabla m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env DsGblEnv DsLclEnv) Id
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Id
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Type -> IOEnv (Env DsGblEnv DsLclEnv) Id
mkPmId (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)))
core_expr x e
pure x
data_con_app :: Id -> InScopeSet -> DataCon -> [CoreExpr] -> StateT Nabla (MaybeT DsM) ()
data_con_app :: Id
-> InScopeSet
-> DataCon
-> [CoreExpr]
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
data_con_app Id
x InScopeSet
in_scope DataCon
dc [CoreExpr]
args = do
let dc_ex_tvs :: [Id]
dc_ex_tvs = DataCon -> [Id]
dataConExTyCoVars DataCon
dc
arty :: Int
arty = DataCon -> Int
dataConSourceArity DataCon
dc
([CoreExpr]
ex_ty_args, [CoreExpr]
val_args) = [Id] -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Id]
dc_ex_tvs [CoreExpr]
args
ex_tys :: ThetaType
ex_tys = (CoreExpr -> Type) -> [CoreExpr] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprToType [CoreExpr]
ex_ty_args
vis_args :: [CoreExpr]
vis_args = [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a]
reverse ([CoreExpr] -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ Int -> [CoreExpr] -> [CoreExpr]
forall a. Int -> [a] -> [a]
take Int
arty ([CoreExpr] -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a]
reverse [CoreExpr]
val_args
uniq_supply <- MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) UniqSupply
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) UniqSupply
forall (m :: * -> *) a. Monad m => m a -> StateT Nabla m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) UniqSupply
-> StateT
Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) UniqSupply)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) UniqSupply
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) UniqSupply
forall a b. (a -> b) -> a -> b
$ DsM UniqSupply -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) UniqSupply
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DsM UniqSupply
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) UniqSupply)
-> DsM UniqSupply
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) UniqSupply
forall a b. (a -> b) -> a -> b
$ DsM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
let (_, ex_tvs) = cloneTyVarBndrs (mkEmptySubst in_scope) dc_ex_tvs uniq_supply
ty_cts = ThetaType -> ThetaType -> [PhiCt]
equateTys ((Id -> Type) -> [Id] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
mkTyVarTy [Id]
ex_tvs) ThetaType
ex_tys
when (not (isNewDataCon dc)) $
modifyT $ \Nabla
nabla -> Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotBotCt Nabla
nabla Id
x
modifyT $ \Nabla
nabla -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a b. (a -> b) -> a -> b
$ Nabla -> PhiCts -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
addPhiCts Nabla
nabla ([PhiCt] -> PhiCts
forall a. [a] -> Bag a
listToBag [PhiCt]
ty_cts)
arg_ids <- traverse bind_expr vis_args
pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids
pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) ()
pm_lit :: Id
-> PmLit
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
pm_lit Id
x PmLit
lit = do
(Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyT ((Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ())
-> (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
forall a b. (a -> b) -> a -> b
$ \Nabla
nabla -> Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotBotCt Nabla
nabla Id
x
Id
-> PmAltCon
-> [Id]
-> [Id]
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
pm_alt_con_app Id
x (PmLit -> PmAltCon
PmAltLit PmLit
lit) [] []
pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) ()
pm_alt_con_app :: Id
-> PmAltCon
-> [Id]
-> [Id]
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
pm_alt_con_app Id
x PmAltCon
con [Id]
tvs [Id]
args = (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyT ((Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ())
-> (Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> StateT Nabla (MaybeT (IOEnv (Env DsGblEnv DsLclEnv))) ()
forall a b. (a -> b) -> a -> b
$ \Nabla
nabla -> Nabla
-> Id
-> PmAltCon
-> [Id]
-> [Id]
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addConCt Nabla
nabla Id
x PmAltCon
con [Id]
tvs [Id]
args
modifyT :: Monad m => (s -> m s) -> StateT s m ()
modifyT :: forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyT s -> m s
f = (s -> m ((), s)) -> StateT s m ()
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m ((), s)) -> StateT s m ())
-> (s -> m ((), s)) -> StateT s m ()
forall a b. (a -> b) -> a -> b
$ (s -> ((), s)) -> m s -> m ((), s)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) ()) (m s -> m ((), s)) -> (s -> m s) -> s -> m ((), s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m s
f
representCoreExpr :: Nabla -> CoreExpr -> DsM (Id, Nabla)
representCoreExpr :: Nabla -> CoreExpr -> DsM (Id, Nabla)
representCoreExpr nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ ts_reps :: TmState -> CoreMap Id
ts_reps = CoreMap Id
reps } } CoreExpr
e
| Just Id
rep <- CoreMap Id -> CoreExpr -> Maybe Id
forall a. CoreMap a -> CoreExpr -> Maybe a
lookupCoreMap CoreMap Id
reps CoreExpr
key = (Id, Nabla) -> DsM (Id, Nabla)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
rep, Nabla
nabla)
| Bool
otherwise = do
rep <- Type -> IOEnv (Env DsGblEnv DsLclEnv) Id
mkPmId (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e)
let reps' = CoreMap Id -> CoreExpr -> Id -> CoreMap Id
forall a. CoreMap a -> CoreExpr -> a -> CoreMap a
extendCoreMap CoreMap Id
reps CoreExpr
key Id
rep
let nabla' = Nabla
nabla{ nabla_tm_st = ts{ ts_reps = reps' } }
pure (rep, nabla')
where
key :: CoreExpr
key = CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
e
makeDictsCoherent :: CoreExpr -> CoreExpr
makeDictsCoherent :: CoreExpr -> CoreExpr
makeDictsCoherent var :: CoreExpr
var@(Var Id
v)
| let ty :: Type
ty = Id -> Type
idType Id
v
, Type -> Bool
typeDeterminesValue Type
ty
= Type -> String -> CoreExpr
mkImpossibleExpr Type
ty String
"Solver.makeDictsCoherent"
| Bool
otherwise
= CoreExpr
var
makeDictsCoherent lit :: CoreExpr
lit@(Lit {})
= CoreExpr
lit
makeDictsCoherent (App CoreExpr
f CoreExpr
a)
= CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
f) (CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
a)
makeDictsCoherent (Lam Id
f CoreExpr
body)
= Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
f (CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
body)
makeDictsCoherent (Let Bind Id
bndr CoreExpr
body)
= Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let
(Bind Id -> Bind Id
go_bndr Bind Id
bndr)
(CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
body)
where
go_bndr :: Bind Id -> Bind Id
go_bndr (NonRec Id
bndr CoreExpr
expr) = Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
bndr (CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
expr)
go_bndr (Rec [(Id, CoreExpr)]
bndrs) = [(Id, CoreExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec (((Id, CoreExpr) -> (Id, CoreExpr))
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ( \(Id
b, CoreExpr
expr) -> (Id
b, CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
expr) ) [(Id, CoreExpr)]
bndrs)
makeDictsCoherent (Case CoreExpr
scrut Id
bndr Type
ty [Alt Id]
alts)
= CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
bndr Type
ty
[ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndr CoreExpr
expr'
| Alt AltCon
con [Id]
bndr CoreExpr
expr <- [Alt Id]
alts
, let expr' :: CoreExpr
expr' = CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
expr ]
makeDictsCoherent (Cast CoreExpr
expr Coercion
co)
= CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
expr) Coercion
co
makeDictsCoherent (Tick CoreTickish
tick CoreExpr
expr)
= CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tick (CoreExpr -> CoreExpr
makeDictsCoherent CoreExpr
expr)
makeDictsCoherent ty :: CoreExpr
ty@(Type {})
= CoreExpr
ty
makeDictsCoherent co :: CoreExpr
co@(Coercion {})
= CoreExpr
co
tyStateRefined :: TyState -> TyState -> Bool
tyStateRefined :: TyState -> TyState -> Bool
tyStateRefined TyState
a TyState
b = TyState -> Int
ty_st_n TyState
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= TyState -> Int
ty_st_n TyState
b
markDirty :: Id -> Nabla -> Nabla
markDirty :: Id -> Nabla -> Nabla
markDirty Id
x nabla :: Nabla
nabla@MkNabla{nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ts_dirty :: TmState -> DIdSet
ts_dirty = DIdSet
dirty} } =
Nabla
nabla{ nabla_tm_st = ts{ ts_dirty = extendDVarSet dirty x } }
traverseDirty :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState
traverseDirty :: forall (m :: * -> *).
Monad m =>
(VarInfo -> m VarInfo) -> TmState -> m TmState
traverseDirty VarInfo -> m VarInfo
f ts :: TmState
ts@TmSt{ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts = UniqSDFM Id VarInfo
env, ts_dirty :: TmState -> DIdSet
ts_dirty = DIdSet
dirty} =
[Id] -> UniqSDFM Id VarInfo -> m TmState
go (DIdSet -> [Id]
forall a. UniqDSet a -> [a]
uniqDSetToList DIdSet
dirty) UniqSDFM Id VarInfo
env
where
go :: [Id] -> UniqSDFM Id VarInfo -> m TmState
go [] UniqSDFM Id VarInfo
env = TmState -> m TmState
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TmState
ts{ts_facts=env}
go (Id
x:[Id]
xs) !UniqSDFM Id VarInfo
env = do
vi' <- VarInfo -> m VarInfo
f (TmState -> Id -> VarInfo
lookupVarInfo TmState
ts Id
x)
go xs (addToUSDFM env x vi')
traverseAll :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState
traverseAll :: forall (m :: * -> *).
Monad m =>
(VarInfo -> m VarInfo) -> TmState -> m TmState
traverseAll VarInfo -> m VarInfo
f ts :: TmState
ts@TmSt{ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts = UniqSDFM Id VarInfo
env} = do
env' <- (VarInfo -> m VarInfo)
-> UniqSDFM Id VarInfo -> m (UniqSDFM Id VarInfo)
forall key a b (f :: * -> *).
Applicative f =>
(a -> f b) -> UniqSDFM key a -> f (UniqSDFM key b)
traverseUSDFM VarInfo -> m VarInfo
f UniqSDFM Id VarInfo
env
pure ts{ts_facts = env'}
inhabitationTest :: Int -> TyState -> Nabla -> MaybeT DsM Nabla
inhabitationTest :: Int
-> TyState -> Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
inhabitationTest Int
0 TyState
_ Nabla
nabla = Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla
inhabitationTest Int
fuel TyState
old_ty_st nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = TmState
ts } = {-# SCC "inhabitationTest" #-} do
ts' <- if TyState -> TyState -> Bool
tyStateRefined TyState
old_ty_st (Nabla -> TyState
nabla_ty_st Nabla
nabla)
then (VarInfo -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo)
-> TmState -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) TmState
forall (m :: * -> *).
Monad m =>
(VarInfo -> m VarInfo) -> TmState -> m TmState
traverseAll VarInfo -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
test_one TmState
ts
else (VarInfo -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo)
-> TmState -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) TmState
forall (m :: * -> *).
Monad m =>
(VarInfo -> m VarInfo) -> TmState -> m TmState
traverseDirty VarInfo -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
test_one TmState
ts
pure nabla{ nabla_tm_st = ts'{ts_dirty=emptyDVarSet}}
where
nabla_not_dirty :: Nabla
nabla_not_dirty = Nabla
nabla{ nabla_tm_st = ts{ts_dirty=emptyDVarSet} }
test_one :: VarInfo -> MaybeT DsM VarInfo
test_one :: VarInfo -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
test_one VarInfo
vi =
DsM Bool -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TyState -> Nabla -> VarInfo -> DsM Bool
varNeedsTesting TyState
old_ty_st Nabla
nabla VarInfo
vi) MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Bool
-> (Bool -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
forall a b.
MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> (a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) b)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
Int
-> Nabla
-> VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
instantiate (Int
fuelInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Nabla
nabla_not_dirty VarInfo
vi
Bool
_ -> VarInfo -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VarInfo
vi
varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool
varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool
varNeedsTesting TyState
_ MkNabla{nabla_tm_st :: Nabla -> TmState
nabla_tm_st=TmState
tm_st} VarInfo
vi
| Id -> DIdSet -> Bool
elemDVarSet (VarInfo -> Id
vi_id VarInfo
vi) (TmState -> DIdSet
ts_dirty TmState
tm_st) = Bool -> DsM Bool
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
varNeedsTesting TyState
_ Nabla
_ VarInfo
vi
| [PmAltConApp] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull (VarInfo -> [PmAltConApp]
vi_pos VarInfo
vi) = Bool -> DsM Bool
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
varNeedsTesting TyState
old_ty_st MkNabla{nabla_ty_st :: Nabla -> TyState
nabla_ty_st=TyState
new_ty_st} VarInfo
_
| Bool -> Bool
not (TyState -> TyState -> Bool
tyStateRefined TyState
old_ty_st TyState
new_ty_st) = Bool -> DsM Bool
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
varNeedsTesting TyState
old_ty_st MkNabla{nabla_ty_st :: Nabla -> TyState
nabla_ty_st=TyState
new_ty_st} VarInfo
vi = do
(_, _, old_norm_ty) <- TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)
tntrGuts (TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type))
-> DsM TopNormaliseTypeResult
-> IOEnv
(Env DsGblEnv DsLclEnv) (Type, [(Type, DataCon, Type)], Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyState -> Type -> DsM TopNormaliseTypeResult
pmTopNormaliseType TyState
old_ty_st (Id -> Type
idType (Id -> Type) -> Id -> Type
forall a b. (a -> b) -> a -> b
$ VarInfo -> Id
vi_id VarInfo
vi)
(_, _, new_norm_ty) <- tntrGuts <$> pmTopNormaliseType new_ty_st (idType $ vi_id vi)
if old_norm_ty `eqType` new_norm_ty
then pure False
else pure True
instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo
instantiate :: Int
-> Nabla
-> VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
instantiate Int
fuel Nabla
nabla VarInfo
vi = {-# SCC "instantiate" #-}
(Int
-> Nabla
-> VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
instBot Int
fuel Nabla
nabla VarInfo
vi MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
forall a.
MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
-> Nabla
-> VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
instCompleteSets Int
fuel Nabla
nabla VarInfo
vi)
instBot :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo
instBot :: Int
-> Nabla
-> VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
instBot Int
_fuel Nabla
nabla VarInfo
vi = {-# SCC "instBot" #-} do
_nabla' <- Nabla -> Id -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addBotCt Nabla
nabla (VarInfo -> Id
vi_id VarInfo
vi)
pure vi
addNormalisedTypeMatches :: Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla)
addNormalisedTypeMatches :: Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla)
addNormalisedTypeMatches nabla :: Nabla
nabla@MkNabla{ nabla_ty_st :: Nabla -> TyState
nabla_ty_st = TyState
ty_st } Id
x
= (VarInfo
-> IOEnv
(Env DsGblEnv DsLclEnv) (ResidualCompleteMatches, VarInfo))
-> Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla)
forall (f :: * -> *) a.
Functor f =>
(VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)
trvVarInfo VarInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (ResidualCompleteMatches, VarInfo)
add_matches Nabla
nabla Id
x
where
add_matches :: VarInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (ResidualCompleteMatches, VarInfo)
add_matches vi :: VarInfo
vi@VI{ vi_rcm :: VarInfo -> ResidualCompleteMatches
vi_rcm = ResidualCompleteMatches
rcm }
| ResidualCompleteMatches -> Bool
isRcmInitialised ResidualCompleteMatches
rcm = (ResidualCompleteMatches, VarInfo)
-> IOEnv (Env DsGblEnv DsLclEnv) (ResidualCompleteMatches, VarInfo)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResidualCompleteMatches
rcm, VarInfo
vi)
add_matches vi :: VarInfo
vi@VI{ vi_rcm :: VarInfo -> ResidualCompleteMatches
vi_rcm = ResidualCompleteMatches
rcm } = do
norm_res_ty <- TyState -> Type -> DsM Type
normaliseSourceTypeWHNF TyState
ty_st (Id -> Type
idType Id
x)
env <- dsGetFamInstEnvs
rcm' <- case splitReprTyConApp_maybe env norm_res_ty of
Just (TyCon
rep_tc, ThetaType
_args, Coercion
_co) -> TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addTyConMatches TyCon
rep_tc ResidualCompleteMatches
rcm
Maybe (TyCon, ThetaType, Coercion)
Nothing -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addCompleteMatches ResidualCompleteMatches
rcm
pure (rcm', vi{ vi_rcm = rcm' })
splitReprTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
splitReprTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, ThetaType, Coercion)
splitReprTyConApp_maybe FamInstEnvs
env Type
ty =
(TyCon -> ThetaType -> (TyCon, ThetaType, Coercion))
-> (TyCon, ThetaType) -> (TyCon, ThetaType, Coercion)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (FamInstEnvs -> TyCon -> ThetaType -> (TyCon, ThetaType, Coercion)
tcLookupDataFamInst FamInstEnvs
env) ((TyCon, ThetaType) -> (TyCon, ThetaType, Coercion))
-> Maybe (TyCon, ThetaType) -> Maybe (TyCon, ThetaType, Coercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
splitTyConApp_maybe Type
ty
instCompleteSets :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo
instCompleteSets :: Int
-> Nabla
-> VarInfo
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) VarInfo
instCompleteSets Int
fuel Nabla
nabla VarInfo
vi = {-# SCC "instCompleteSets" #-} do
let x :: Id
x = VarInfo -> Id
vi_id VarInfo
vi
(rcm, nabla) <- DsM (ResidualCompleteMatches, Nabla)
-> MaybeT
(IOEnv (Env DsGblEnv DsLclEnv)) (ResidualCompleteMatches, Nabla)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla)
addNormalisedTypeMatches Nabla
nabla Id
x)
nabla <- foldM (\Nabla
nabla DsCompleteMatch
cls -> Int
-> Nabla
-> Id
-> DsCompleteMatch
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
instCompleteSet Int
fuel Nabla
nabla Id
x DsCompleteMatch
cls) nabla (getRcm rcm)
pure (lookupVarInfo (nabla_tm_st nabla) x)
anyConLikeSolution :: (ConLike -> Bool) -> [PmAltConApp] -> Bool
anyConLikeSolution :: (ConLike -> Bool) -> [PmAltConApp] -> Bool
anyConLikeSolution ConLike -> Bool
p = (PmAltConApp -> Bool) -> [PmAltConApp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (PmAltCon -> Bool
go (PmAltCon -> Bool)
-> (PmAltConApp -> PmAltCon) -> PmAltConApp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmAltConApp -> PmAltCon
paca_con)
where
go :: PmAltCon -> Bool
go (PmAltConLike ConLike
cl) = ConLike -> Bool
p ConLike
cl
go PmAltCon
_ = Bool
False
instCompleteSet :: Int -> Nabla -> Id -> DsCompleteMatch -> MaybeT DsM Nabla
instCompleteSet :: Int
-> Nabla
-> Id
-> DsCompleteMatch
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
instCompleteSet Int
fuel Nabla
nabla Id
x DsCompleteMatch
cs
| (ConLike -> Bool) -> [PmAltConApp] -> Bool
anyConLikeSolution (ConLike -> UniqDSet ConLike -> Bool
forall a. Uniquable a => a -> UniqDSet a -> Bool
`elementOfUniqDSet` (DsCompleteMatch -> UniqDSet ConLike
forall con. CompleteMatchX con -> UniqDSet con
cmConLikes DsCompleteMatch
cs)) (VarInfo -> [PmAltConApp]
vi_pos VarInfo
vi)
= Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla
| Bool -> Bool
not (Type -> DsCompleteMatch -> Bool
forall con. Type -> CompleteMatchX con -> Bool
completeMatchAppliesAtType (Id -> Type
varType Id
x) DsCompleteMatch
cs)
= Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla
| Bool
otherwise
= {-# SCC "instCompleteSet" #-} Nabla -> [ConLike] -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
go Nabla
nabla (DsCompleteMatch -> [ConLike]
sorted_candidates DsCompleteMatch
cs)
where
vi :: VarInfo
vi = TmState -> Id -> VarInfo
lookupVarInfo (Nabla -> TmState
nabla_tm_st Nabla
nabla) Id
x
sorted_candidates :: DsCompleteMatch -> [ConLike]
sorted_candidates :: DsCompleteMatch -> [ConLike]
sorted_candidates DsCompleteMatch
cm
| UniqDSet ConLike -> Int
forall a. UniqDSet a -> Int
sizeUniqDSet UniqDSet ConLike
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
5 = (ConLike -> ConLike -> Ordering) -> [ConLike] -> [ConLike]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ConLike -> ConLike -> Ordering
compareConLikeTestability (UniqDSet ConLike -> [ConLike]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet ConLike
cs)
| Bool
otherwise = UniqDSet ConLike -> [ConLike]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet ConLike
cs
where cs :: UniqDSet ConLike
cs = DsCompleteMatch -> UniqDSet ConLike
forall con. CompleteMatchX con -> UniqDSet con
cmConLikes DsCompleteMatch
cm
go :: Nabla -> [ConLike] -> MaybeT DsM Nabla
go :: Nabla -> [ConLike] -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
go Nabla
_ [] = MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
go Nabla
nabla (RealDataCon DataCon
dc:[ConLike]
_)
| DataCon -> Bool
isDataConTriviallyInhabited DataCon
dc
= Nabla -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nabla
nabla
go Nabla
nabla (ConLike
con:[ConLike]
cons) = do
let x :: Id
x = VarInfo -> Id
vi_id VarInfo
vi
let recur_not_con :: MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
recur_not_con = do
nabla' <- Nabla
-> Id -> PmAltCon -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
addNotConCt Nabla
nabla Id
x (ConLike -> PmAltCon
PmAltConLike ConLike
con)
go nabla' cons
(Nabla
nabla Nabla
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a b.
a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) b
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int
-> Nabla
-> Id
-> ConLike
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
instCon Int
fuel Nabla
nabla Id
x ConLike
con)
MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a.
MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
recur_not_con
isDataConTriviallyInhabited :: DataCon -> Bool
isDataConTriviallyInhabited :: DataCon -> Bool
isDataConTriviallyInhabited DataCon
dc
| TyCon -> Bool
isTyConTriviallyInhabited (DataCon -> TyCon
dataConTyCon DataCon
dc) = Bool
True
isDataConTriviallyInhabited DataCon
dc =
ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> ThetaType
dataConTheta DataCon
dc) Bool -> Bool -> Bool
&&
[HsImplBang] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [HsImplBang]
dataConImplBangs DataCon
dc) Bool -> Bool -> Bool
&&
ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> ThetaType
dataConMightBeUnliftedFieldTys DataCon
dc)
dataConMightBeUnliftedFieldTys :: DataCon -> [Type]
dataConMightBeUnliftedFieldTys :: DataCon -> ThetaType
dataConMightBeUnliftedFieldTys =
(Type -> Bool) -> ThetaType -> ThetaType
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
mightBeUnliftedType (ThetaType -> ThetaType)
-> (DataCon -> ThetaType) -> DataCon -> ThetaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> ThetaType)
-> (DataCon -> [Scaled Type]) -> DataCon -> ThetaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [Scaled Type]
dataConOrigArgTys
isTyConTriviallyInhabited :: TyCon -> Bool
isTyConTriviallyInhabited :: TyCon -> Bool
isTyConTriviallyInhabited TyCon
tc = Unique -> UniqueSet -> Bool
memberUniqueSet (TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc) UniqueSet
triviallyInhabitedTyConKeys
triviallyInhabitedTyConKeys :: UniqueSet
triviallyInhabitedTyConKeys :: UniqueSet
triviallyInhabitedTyConKeys = [Unique] -> UniqueSet
fromListUniqueSet [
Unique
charTyConKey, Unique
doubleTyConKey, Unique
floatTyConKey,
Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey, Unique
int32TyConKey, Unique
int64TyConKey,
Unique
intPrimTyConKey, Unique
int8PrimTyConKey, Unique
int16PrimTyConKey, Unique
int32PrimTyConKey, Unique
int64PrimTyConKey,
Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey, Unique
word32TyConKey, Unique
word64TyConKey,
Unique
wordPrimTyConKey, Unique
word8PrimTyConKey, Unique
word16PrimTyConKey, Unique
word32PrimTyConKey, Unique
word64PrimTyConKey,
Unique
trTyConTyConKey
]
compareConLikeTestability :: ConLike -> ConLike -> Ordering
compareConLikeTestability :: ConLike -> ConLike -> Ordering
compareConLikeTestability PatSynCon{} ConLike
_ = Ordering
GT
compareConLikeTestability ConLike
_ PatSynCon{} = Ordering
GT
compareConLikeTestability (RealDataCon DataCon
a) (RealDataCon DataCon
b) = [DataCon -> DataCon -> Ordering] -> DataCon -> DataCon -> Ordering
forall a. Monoid a => [a] -> a
mconcat
[ (DataCon -> Int) -> DataCon -> DataCon -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (ThetaType -> Int
forall a. [a] -> Int
fast_length (ThetaType -> Int) -> (DataCon -> ThetaType) -> DataCon -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> ThetaType
dataConTheta)
, (DataCon -> Int) -> DataCon -> DataCon -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing DataCon -> Int
unlifted_or_strict_fields
] DataCon
a DataCon
b
where
fast_length :: [a] -> Int
fast_length :: forall a. [a] -> Int
fast_length [a]
xs = ([a] -> Int) -> Int -> [a] -> Int -> Int
forall a b. ([a] -> b) -> b -> [a] -> Int -> b
atLength [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Int
6 [a]
xs Int
5
unlifted_or_strict_fields :: DataCon -> Int
unlifted_or_strict_fields :: DataCon -> Int
unlifted_or_strict_fields DataCon
dc = [HsImplBang] -> Int
forall a. [a] -> Int
fast_length (DataCon -> [HsImplBang]
dataConImplBangs DataCon
dc)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ThetaType -> Int
forall a. [a] -> Int
fast_length (DataCon -> ThetaType
dataConMightBeUnliftedFieldTys DataCon
dc)
instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla
instCon :: Int
-> Nabla
-> Id
-> ConLike
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
instCon Int
fuel nabla :: Nabla
nabla@MkNabla{nabla_ty_st :: Nabla -> TyState
nabla_ty_st = TyState
ty_st} Id
x ConLike
con = {-# SCC "instCon" #-} IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
forall a b. (a -> b) -> a -> b
$ do
let hdr :: String -> String
hdr String
what = String
"instCon " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fuel String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what
env <- DsM FamInstEnvs
dsGetFamInstEnvs
let match_ty = Id -> Type
idType Id
x
tracePm (hdr "{") $
ppr con <+> text "... <-" <+> ppr x <+> dcolon <+> ppr match_ty
norm_match_ty <- normaliseSourceTypeWHNF ty_st match_ty
mb_sigma_univ <- matchConLikeResTy env ty_st norm_match_ty con
case mb_sigma_univ of
Just Subst
sigma_univ -> do
let ([Id]
_univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec, ThetaType
thetas, ThetaType
_req_theta, [Scaled Type]
field_tys, Type
_con_res_ty)
= ConLike
-> ([Id], [Id], [EqSpec], ThetaType, ThetaType, [Scaled Type],
Type)
conLikeFullSig ConLike
con
(sigma_ex, _) <- Subst -> [Id] -> UniqSupply -> (Subst, [Id])
cloneTyVarBndrs Subst
sigma_univ [Id]
ex_tvs (UniqSupply -> (Subst, [Id]))
-> DsM UniqSupply -> IOEnv (Env DsGblEnv DsLclEnv) (Subst, [Id])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DsM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
let gammas = HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTheta Subst
sigma_ex ([EqSpec] -> ThetaType
eqSpecPreds [EqSpec]
eq_spec ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
thetas)
let field_tys' = HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTys Subst
sigma_ex (ThetaType -> ThetaType) -> ThetaType -> ThetaType
forall a b. (a -> b) -> a -> b
$ (Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
field_tys
arg_ids <- mapM mkPmId field_tys'
tracePm (hdr "(cts)") $ vcat
[ ppr x <+> dcolon <+> ppr match_ty
, text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty
, ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty
, ppr (map (\Id
tv -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'↦' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Subst -> Id -> Type
substTyVar Subst
sigma_univ Id
tv)) _univ_tvs)
, ppr gammas
, ppr (map (\Id
x -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
x)) arg_ids)
]
runMaybeT $ do
let alt = ConLike -> PmAltCon
PmAltConLike ConLike
con
let branching_factor = [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Id] -> Int) -> [Id] -> Int
forall a b. (a -> b) -> a -> b
$ PmAltCon -> [Id] -> [Id]
filterUnliftedFields PmAltCon
alt [Id]
arg_ids
let ct = Id -> PmAltCon -> [Id] -> ThetaType -> [Id] -> PhiCt
PhiConCt Id
x PmAltCon
alt [Id]
ex_tvs ThetaType
gammas [Id]
arg_ids
nabla1 <- traceWhenFailPm (hdr "(ct unsatisfiable) }") (ppr ct) $
addPhiTmCt nabla ct
let new_fuel
| Int
branching_factor Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = Int
fuel
| Bool
otherwise = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
fuel Int
2
lift $ tracePm (hdr "(ct satisfiable)") $ vcat
[ ppr ct
, ppr x <+> dcolon <+> ppr match_ty
, text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty
, ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty
, ppr (map (\Id
tv -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'↦' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Subst -> Id -> Type
substTyVar Subst
sigma_univ Id
tv)) _univ_tvs)
, ppr gammas
, ppr (map (\Id
x -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
x)) arg_ids)
, ppr branching_factor
, ppr new_fuel
]
nabla2 <- traceWhenFailPm (hdr "(inh test failed) }") (ppr nabla1) $
inhabitationTest new_fuel (nabla_ty_st nabla) nabla1
lift $ tracePm (hdr "(inh test succeeded) }") (ppr nabla2)
pure nabla2
Maybe Subst
Nothing -> do
String -> SDoc -> DsM ()
tracePm (String -> String
hdr String
"(match_ty not instance of res_ty) }") SDoc
forall doc. IsOutput doc => doc
empty
Maybe Nabla -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nabla -> Maybe Nabla
forall a. a -> Maybe a
Just Nabla
nabla)
matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe Subst)
matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe Subst)
matchConLikeResTy FamInstEnvs
env TyState
_ Type
ty (RealDataCon DataCon
dc) = Maybe Subst -> DsM (Maybe Subst)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Subst -> DsM (Maybe Subst))
-> Maybe Subst -> DsM (Maybe Subst)
forall a b. (a -> b) -> a -> b
$ do
(rep_tc, tc_args, _co) <- FamInstEnvs -> Type -> Maybe (TyCon, ThetaType, Coercion)
splitReprTyConApp_maybe FamInstEnvs
env Type
ty
if rep_tc == dataConTyCon dc
then Just (zipTCvSubst (dataConUnivTyVars dc) tc_args)
else Nothing
matchConLikeResTy FamInstEnvs
_ (TySt Int
_ InertSet
inert) Type
ty (PatSynCon PatSyn
ps) = {-# SCC "matchConLikeResTy" #-} MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Subst -> DsM (Maybe Subst)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Subst -> DsM (Maybe Subst))
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Subst
-> DsM (Maybe Subst)
forall a b. (a -> b) -> a -> b
$ do
let ([Id]
univ_tvs,ThetaType
req_theta,[Id]
_,ThetaType
_,[Scaled Type]
_,Type
con_res_ty) = PatSyn -> ([Id], ThetaType, [Id], ThetaType, [Scaled Type], Type)
patSynSig PatSyn
ps
subst <- DsM (Maybe Subst) -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Subst
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (DsM (Maybe Subst) -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Subst)
-> DsM (Maybe Subst)
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Subst
forall a b. (a -> b) -> a -> b
$ Maybe Subst -> DsM (Maybe Subst)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Subst -> DsM (Maybe Subst))
-> Maybe Subst -> DsM (Maybe Subst)
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Maybe Subst
tcMatchTy Type
con_res_ty Type
ty
guard $ all (`elemSubst` subst) univ_tvs
if null req_theta
then pure subst
else do
let req_theta' = HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTys Subst
subst ThetaType
req_theta
satisfiable <- lift $ initTcDsForSolver $ tcCheckWanteds inert req_theta'
if satisfiable
then pure subst
else mzero
data GenerateInhabitingPatternsMode
= CaseSplitTopLevel
| MinimalCover
deriving (GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool
(GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool)
-> (GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool)
-> Eq GenerateInhabitingPatternsMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool
== :: GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool
$c/= :: GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool
/= :: GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool
Eq, Int -> GenerateInhabitingPatternsMode -> String -> String
[GenerateInhabitingPatternsMode] -> String -> String
GenerateInhabitingPatternsMode -> String
(Int -> GenerateInhabitingPatternsMode -> String -> String)
-> (GenerateInhabitingPatternsMode -> String)
-> ([GenerateInhabitingPatternsMode] -> String -> String)
-> Show GenerateInhabitingPatternsMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GenerateInhabitingPatternsMode -> String -> String
showsPrec :: Int -> GenerateInhabitingPatternsMode -> String -> String
$cshow :: GenerateInhabitingPatternsMode -> String
show :: GenerateInhabitingPatternsMode -> String
$cshowList :: [GenerateInhabitingPatternsMode] -> String -> String
showList :: [GenerateInhabitingPatternsMode] -> String -> String
Show)
instance Outputable GenerateInhabitingPatternsMode where
ppr :: GenerateInhabitingPatternsMode -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (GenerateInhabitingPatternsMode -> String)
-> GenerateInhabitingPatternsMode
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenerateInhabitingPatternsMode -> String
forall a. Show a => a -> String
show
generateInhabitingPatterns :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns :: GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
_ [Id]
_ Int
0 Nabla
_ = [Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
generateInhabitingPatterns GenerateInhabitingPatternsMode
_ [] Int
_ Nabla
nabla = [Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Nabla
nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode (Id
x:[Id]
xs) Int
n Nabla
nabla = do
String -> SDoc -> DsM ()
tracePm String
"generateInhabitingPatterns" (GenerateInhabitingPatternsMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenerateInhabitingPatternsMode
mode SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id
xId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
xs) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Nabla -> SDoc
forall a. Outputable a => a -> SDoc
ppr Nabla
nabla)
let VI Id
_ [PmAltConApp]
pos PmAltConSet
neg BotInfo
_ ResidualCompleteMatches
_ = TmState -> Id -> VarInfo
lookupVarInfo (Nabla -> TmState
nabla_tm_st Nabla
nabla) Id
x
case [PmAltConApp]
pos of
PmAltConApp
_:[PmAltConApp]
_ -> do
let arg_vas :: [Id]
arg_vas = (PmAltConApp -> [Id]) -> [PmAltConApp] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PmAltConApp -> [Id]
paca_ids [PmAltConApp]
pos
GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode ([Id]
arg_vas [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
xs) Int
n Nabla
nabla
[]
| [PmLit] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [ PmLit
l | PmAltLit PmLit
l <- PmAltConSet -> [PmAltCon]
pmAltConSetElems PmAltConSet
neg ]
-> GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
xs Int
n Nabla
nabla
| Bool -> Bool
not (PmAltConSet -> Bool
isEmptyPmAltConSet PmAltConSet
neg) Bool -> Bool -> Bool
|| GenerateInhabitingPatternsMode
mode GenerateInhabitingPatternsMode
-> GenerateInhabitingPatternsMode -> Bool
forall a. Eq a => a -> a -> Bool
== GenerateInhabitingPatternsMode
CaseSplitTopLevel
-> Id -> [Id] -> Int -> Nabla -> DsM [Nabla]
try_instantiate Id
x [Id]
xs Int
n Nabla
nabla
| Bool
otherwise
-> GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
xs Int
n Nabla
nabla
where
try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]
try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]
try_instantiate Id
x [Id]
xs Int
n Nabla
nabla = do
(_src_ty, dcs, rep_ty) <- TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)
tntrGuts (TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type))
-> DsM TopNormaliseTypeResult
-> IOEnv
(Env DsGblEnv DsLclEnv) (Type, [(Type, DataCon, Type)], Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyState -> Type -> DsM TopNormaliseTypeResult
pmTopNormaliseType (Nabla -> TyState
nabla_ty_st Nabla
nabla) (Id -> Type
idType Id
x)
mb_stuff <- runMaybeT $ instantiate_newtype_chain x nabla dcs
case mb_stuff of
Maybe (Id, Nabla)
Nothing -> [Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just (Id
y, Nabla
newty_nabla) -> do
let vi :: VarInfo
vi = TmState -> Id -> VarInfo
lookupVarInfo (Nabla -> TmState
nabla_tm_st Nabla
newty_nabla) Id
y
env <- DsM FamInstEnvs
dsGetFamInstEnvs
rcm <- case splitReprTyConApp_maybe env rep_ty of
Just (TyCon
tc, ThetaType
_, Coercion
_) -> TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addTyConMatches TyCon
tc (VarInfo -> ResidualCompleteMatches
vi_rcm VarInfo
vi)
Maybe (TyCon, ThetaType, Coercion)
Nothing -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
addCompleteMatches (VarInfo -> ResidualCompleteMatches
vi_rcm VarInfo
vi)
clss <- pickApplicableCompleteSets (nabla_ty_st nabla) rep_ty rcm
case NE.nonEmpty (uniqDSetToList . cmConLikes <$> clss) of
Maybe (NonEmpty [ConLike])
Nothing ->
GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
xs Int
n Nabla
newty_nabla
Just NonEmpty [ConLike]
clss -> do
nablass' <- NonEmpty [ConLike]
-> ([ConLike]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Maybe ConLike, Nabla)])
-> IOEnv
(Env DsGblEnv DsLclEnv) (NonEmpty [(Maybe ConLike, Nabla)])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty [ConLike]
clss (Id
-> Type
-> [Id]
-> Int
-> Nabla
-> [ConLike]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Maybe ConLike, Nabla)]
instantiate_cons Id
y Type
rep_ty [Id]
xs Int
n Nabla
newty_nabla)
if any null nablass' && vi_bot vi /= IsNotBot
then generateInhabitingPatterns mode xs n newty_nabla
else do
DsGblEnv { ds_gbl_rdr_env = rdr_env } <- getGblEnv
let bestSet = ((Maybe ConLike, Nabla) -> Nabla)
-> [(Maybe ConLike, Nabla)] -> [Nabla]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe ConLike, Nabla) -> Nabla
forall a b. (a, b) -> b
snd ([(Maybe ConLike, Nabla)] -> [Nabla])
-> [(Maybe ConLike, Nabla)] -> [Nabla]
forall a b. (a -> b) -> a -> b
$ ([(Maybe ConLike, Nabla)] -> [(Maybe ConLike, Nabla)] -> Ordering)
-> NonEmpty [(Maybe ConLike, Nabla)] -> [(Maybe ConLike, Nabla)]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (([(Maybe ConLike, Nabla)] -> (Bool, Int, Int, Int))
-> [(Maybe ConLike, Nabla)] -> [(Maybe ConLike, Nabla)] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (([(Maybe ConLike, Nabla)] -> (Bool, Int, Int, Int))
-> [(Maybe ConLike, Nabla)]
-> [(Maybe ConLike, Nabla)]
-> Ordering)
-> ([(Maybe ConLike, Nabla)] -> (Bool, Int, Int, Int))
-> [(Maybe ConLike, Nabla)]
-> [(Maybe ConLike, Nabla)]
-> Ordering
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> [(Maybe ConLike, Nabla)] -> (Bool, Int, Int, Int)
forall a.
GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
completeSetCost GlobalRdrEnv
rdr_env) NonEmpty [(Maybe ConLike, Nabla)]
nablass'
pure bestSet
instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla)
instantiate_newtype_chain :: Id
-> Nabla
-> [(Type, DataCon, Type)]
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Id, Nabla)
instantiate_newtype_chain Id
x Nabla
nabla [] = (Id, Nabla) -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) (Id, Nabla)
forall a. a -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
x, Nabla
nabla)
instantiate_newtype_chain Id
x Nabla
nabla ((Type
_ty, DataCon
dc, Type
arg_ty):[(Type, DataCon, Type)]
dcs) = do
y <- IOEnv (Env DsGblEnv DsLclEnv) Id
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Id
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env DsGblEnv DsLclEnv) Id
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Id)
-> IOEnv (Env DsGblEnv DsLclEnv) Id
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Id
forall a b. (a -> b) -> a -> b
$ Type -> IOEnv (Env DsGblEnv DsLclEnv) Id
mkPmId Type
arg_ty
nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]
instantiate_newtype_chain y nabla' dcs
instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [(Maybe ConLike, Nabla)]
instantiate_cons :: Id
-> Type
-> [Id]
-> Int
-> Nabla
-> [ConLike]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Maybe ConLike, Nabla)]
instantiate_cons Id
_ Type
_ [Id]
_ Int
_ Nabla
_ [] = [(Maybe ConLike, Nabla)]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Maybe ConLike, Nabla)]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instantiate_cons Id
_ Type
_ [Id]
_ Int
0 Nabla
_ [ConLike]
_ = [(Maybe ConLike, Nabla)]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Maybe ConLike, Nabla)]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instantiate_cons Id
_ Type
ty [Id]
xs Int
n Nabla
nabla [ConLike]
_
| ((TyCon, ThetaType) -> Bool)
-> Maybe (TyCon, ThetaType) -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon -> Bool
isTyConTriviallyInhabited (TyCon -> Bool)
-> ((TyCon, ThetaType) -> TyCon) -> (TyCon, ThetaType) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCon, ThetaType) -> TyCon
forall a b. (a, b) -> a
fst) (HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
splitTyConApp_maybe Type
ty) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
= (Nabla -> (Maybe ConLike, Nabla))
-> [Nabla] -> [(Maybe ConLike, Nabla)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe ConLike
forall a. Maybe a
Nothing,) ([Nabla] -> [(Maybe ConLike, Nabla)])
-> DsM [Nabla]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Maybe ConLike, Nabla)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
xs Int
n Nabla
nabla
instantiate_cons Id
x Type
ty [Id]
xs Int
n Nabla
nabla (ConLike
cl:[ConLike]
cls) = do
mb_nabla <- MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla))
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Nabla)
forall a b. (a -> b) -> a -> b
$ Int
-> Nabla
-> Id
-> ConLike
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) Nabla
instCon Int
4 Nabla
nabla Id
x ConLike
cl
tracePm "instantiate_cons" (vcat [ ppr x <+> dcolon <+> ppr (idType x)
, ppr ty
, ppr cl
, ppr nabla
, ppr mb_nabla
, ppr n ])
con_nablas <- case mb_nabla of
Maybe Nabla
Nothing -> [Nabla] -> DsM [Nabla]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just Nabla
nabla' -> GenerateInhabitingPatternsMode
-> [Id] -> Int -> Nabla -> DsM [Nabla]
generateInhabitingPatterns GenerateInhabitingPatternsMode
mode [Id]
xs Int
n Nabla
nabla'
other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls
pure (map (Just cl,) con_nablas ++ other_cons_nablas)
completeSetCost :: GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
completeSetCost :: forall a.
GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
completeSetCost GlobalRdrEnv
_ [] = (Bool
False, Int
0, Int
0, Int
0)
completeSetCost GlobalRdrEnv
rdr_env ((Maybe ConLike
mb_con, a
_) : [(Maybe ConLike, a)]
cons) =
let con_out_of_scope :: Bool
con_out_of_scope
| Just ConLike
con <- Maybe ConLike
mb_con
= Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (GlobalRdrEltX GREInfo) -> Bool)
-> Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
rdr_env (ConLike -> Name
conLikeName ConLike
con)
| Bool
otherwise
= Bool
False
(Bool
any_out_of_scope, Int
nb_cons, Int
nb_triv, Int
nb_ps) = GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
forall a.
GlobalRdrEnv -> [(Maybe ConLike, a)] -> (Bool, Int, Int, Int)
completeSetCost GlobalRdrEnv
rdr_env [(Maybe ConLike, a)]
cons
in ( Bool
any_out_of_scope Bool -> Bool -> Bool
|| Bool
con_out_of_scope
, Int
nb_cons Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, Int
nb_triv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case Maybe ConLike
mb_con of { Maybe ConLike
Nothing -> Int
1; Maybe ConLike
_ -> Int
0 }
, Int
nb_ps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case Maybe ConLike
mb_con of { Just (PatSynCon {}) -> Int
1; Maybe ConLike
_ -> Int
0 }
)
pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM DsCompleteMatches
pickApplicableCompleteSets :: TyState
-> Type
-> ResidualCompleteMatches
-> IOEnv (Env DsGblEnv DsLclEnv) [DsCompleteMatch]
pickApplicableCompleteSets TyState
ty_st Type
ty ResidualCompleteMatches
rcm = do
let cl_res_ty_ok :: ConLike -> DsM Bool
cl_res_ty_ok :: ConLike -> DsM Bool
cl_res_ty_ok ConLike
cl = do
env <- DsM FamInstEnvs
dsGetFamInstEnvs
isJust <$> matchConLikeResTy env ty_st ty cl
let cm_applicable :: DsCompleteMatch -> DsM Bool
cm_applicable :: DsCompleteMatch -> DsM Bool
cm_applicable DsCompleteMatch
cm = do
cls_ok <- (ConLike -> DsM Bool) -> [ConLike] -> DsM Bool
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
(a -> m Bool) -> f a -> m Bool
allM ConLike -> DsM Bool
cl_res_ty_ok (UniqDSet ConLike -> [ConLike]
forall a. UniqDSet a -> [a]
uniqDSetToList (DsCompleteMatch -> UniqDSet ConLike
forall con. CompleteMatchX con -> UniqDSet con
cmConLikes DsCompleteMatch
cm))
let match_ty_ok = Type -> DsCompleteMatch -> Bool
forall con. Type -> CompleteMatchX con -> Bool
completeMatchAppliesAtType Type
ty DsCompleteMatch
cm
pure (cls_ok && match_ty_ok)
applicable_cms <- (DsCompleteMatch -> DsM Bool)
-> [DsCompleteMatch]
-> IOEnv (Env DsGblEnv DsLclEnv) [DsCompleteMatch]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM DsCompleteMatch -> DsM Bool
cm_applicable (ResidualCompleteMatches -> [DsCompleteMatch]
getRcm ResidualCompleteMatches
rcm)
tracePm "pickApplicableCompleteSets:" $
vcat
[ ppr ty
, ppr rcm
, ppr applicable_cms
]
return applicable_cms