{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Bind
( tcLocalBinds
, tcTopBinds
, tcValBinds
, tcHsBootSigs
, tcPolyCheck
, chooseInferredQuantifiers
)
where
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr )
import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
import GHC.Types.Tickish (CoreTickish, GenTickish (..))
import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC))
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Sig
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Unify
import GHC.Tc.Solver
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Core.Class ( Class )
import GHC.Tc.Utils.TcType
import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
import GHC.Builtin.Types ( mkBoxedTupleTy )
import GHC.Builtin.Types.Prim
import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.Var as Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env( TidyEnv )
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Utils.Error
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Types.Basic
import GHC.Types.CompleteMatch
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names( ipClassName )
import GHC.Tc.Validity (checkValidType)
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Foldable (find)
tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM (TcGblEnv, TcLclEnv)
tcTopBinds :: [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn] -> TcM (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs
= do {
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds', (TcGblEnv
tcg_env, TcLclEnv
tcl_env)) <- TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM (TcGblEnv, TcLclEnv)
-> TcM ([(RecFlag, LHsBinds GhcTc)], (TcGblEnv, TcLclEnv))
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs TcM (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
; [LTcSpecPrag]
specs <- [LSig GhcRn] -> TcM [LTcSpecPrag]
tcImpPrags [LSig GhcRn]
sigs
; [CompleteMatch]
complete_matches <- (TcGblEnv, TcLclEnv)
-> TcRn [CompleteMatch] -> TcRn [CompleteMatch]
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRn [CompleteMatch] -> TcRn [CompleteMatch])
-> TcRn [CompleteMatch] -> TcRn [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [LSig GhcRn] -> TcRn [CompleteMatch]
tcCompleteSigs [LSig GhcRn]
sigs
; String -> SDoc -> TcRn ()
traceTc String
"complete_matches" ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
binds SDoc -> SDoc -> SDoc
$$ [GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs)
; String -> SDoc -> TcRn ()
traceTc String
"complete_matches" ([CompleteMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CompleteMatch]
complete_matches)
; let { tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env { tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs
= [LTcSpecPrag]
specs [LTcSpecPrag] -> [LTcSpecPrag] -> [LTcSpecPrag]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [LTcSpecPrag]
tcg_imp_specs TcGblEnv
tcg_env
, tcg_complete_matches :: [CompleteMatch]
tcg_complete_matches
= [CompleteMatch]
complete_matches
[CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env }
TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a, b) -> b
snd [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds' }
; (TcGblEnv, TcLclEnv) -> TcM (TcGblEnv, TcLclEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', TcLclEnv
tcl_env) }
tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs :: [LSig GhcRn] -> TcRn [CompleteMatch]
tcCompleteSigs [LSig GhcRn]
sigs =
let
doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)
doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)
doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm))
= (CompleteMatch -> Maybe CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompleteMatch -> Maybe CompleteMatch
forall a. a -> Maybe a
Just (IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch))
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
c) (IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ do
UniqDSet ConLike
cls <- [ConLike] -> UniqDSet ConLike
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([ConLike] -> UniqDSet ConLike)
-> IOEnv (Env TcGblEnv TcLclEnv) [ConLike]
-> IOEnv (Env TcGblEnv TcLclEnv) (UniqDSet ConLike)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) ConLike)
-> [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [ConLike]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name -> IOEnv (Env TcGblEnv TcLclEnv) ConLike)
-> GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) ConLike
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Name -> IOEnv (Env TcGblEnv TcLclEnv) ConLike
tcLookupConLike) [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name]
ns
Maybe TyCon
mb_tc <- (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> Maybe (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TyCon)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @Maybe GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupLocatedTyCon Maybe (LIdP GhcRn)
Maybe (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name)
mb_tc_nm
CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompleteMatch :: UniqDSet ConLike -> Maybe TyCon -> CompleteMatch
CompleteMatch { cmConLikes :: UniqDSet ConLike
cmConLikes = UniqDSet ConLike
cls, cmResultTyCon :: Maybe TyCon
cmResultTyCon = Maybe TyCon
mb_tc }
doOne LSig GhcRn
_ = Maybe CompleteMatch -> TcM (Maybe CompleteMatch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CompleteMatch
forall a. Maybe a
Nothing
in (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM (Maybe CompleteMatch))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [CompleteMatch]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM LSig GhcRn -> TcM (Maybe CompleteMatch)
GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM (Maybe CompleteMatch)
doOne ([GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [CompleteMatch])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. [a] -> [a]
reverse [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs
= do { Bool -> TcRnMessage -> TcRn ()
checkTc ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
binds) TcRnMessage
TcRnIllegalHsBootFileDecl
; (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM [Id])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcM [Id]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((Sig GhcRn -> TcM [Id])
-> GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM [Id]
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Sig GhcRn -> TcM [Id]
tc_boot_sig) ((GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
isTypeLSig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs) }
where
tc_boot_sig :: Sig GhcRn -> TcM [Id]
tc_boot_sig (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
lnames LHsSigWcType GhcRn
hs_ty) = (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> [GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) Id
f [LIdP GhcRn]
[GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name]
lnames
where
f :: GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
-> IOEnv (Env TcGblEnv TcLclEnv) Id
f (L SrcSpanAnn' (EpAnn NameAnn)
_ Name
name)
= do { Type
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigWcType GhcRn
hs_ty
; Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> Id
mkVanillaGlobal Name
name Type
sigma_ty) }
tc_boot_sig Sig GhcRn
s = String -> SDoc -> TcM [Id]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcHsBootSigs/tc_boot_sig" (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
s)
tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
-> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
x) TcM thing
thing_inside
= do { thing
thing <- TcM thing
thing_inside
; (HsLocalBinds GhcTc, thing) -> TcM (HsLocalBinds GhcTc, thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
XEmptyLocalBinds GhcRn GhcRn
x, thing
thing) }
tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
x (XValBindsLR (NValBinds binds sigs))) TcM thing
thing_inside
= do { ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds', thing
thing) <- TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
NotTopLevel [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs TcM thing
thing_inside
; (HsLocalBinds GhcTc, thing) -> TcM (HsLocalBinds GhcTc, thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds GhcTc GhcTc
-> HsValBindsLR GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcTc GhcTc
XHsValBinds GhcRn GhcRn
x (XXValBindsLR GhcTc GhcTc -> HsValBindsLR GhcTc GhcTc
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR ([(RecFlag, LHsBinds GhcTc)] -> [LSig GhcRn] -> NHsValBindsLR GhcTc
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds' [LSig GhcRn]
sigs)), thing
thing) }
tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
_ (ValBinds {})) TcM thing
_ = String -> TcM (HsLocalBinds GhcTc, thing)
forall a. String -> a
panic String
"tcLocalBinds"
tcLocalBinds (HsIPBinds XHsIPBinds GhcRn GhcRn
x (IPBinds XIPBinds GhcRn
_ [LIPBind GhcRn]
ip_binds)) TcM thing
thing_inside
= do { Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; ([Id]
given_ips, [GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds') <-
(GenLocated SrcSpanAnnA (IPBind GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (IPBind GhcTc)))
-> [GenLocated SrcSpanAnnA (IPBind GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([Id], [GenLocated SrcSpanAnnA (IPBind GhcTc)])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((IPBind GhcRn -> TcM (Id, IPBind GhcTc))
-> GenLocated SrcSpanAnnA (IPBind GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Id, GenLocated SrcSpanAnnA (IPBind GhcTc))
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (b, GenLocated (SrcSpanAnn' ann) c)
wrapLocSndMA (Class -> IPBind GhcRn -> TcM (Id, IPBind GhcTc)
tc_ip_bind Class
ipClass)) [LIPBind GhcRn]
[GenLocated SrcSpanAnnA (IPBind GhcRn)]
ip_binds
; (TcEvBinds
ev_binds, thing
result) <- SkolemInfoAnon
-> [Id] -> [Id] -> TcM thing -> TcM (TcEvBinds, thing)
forall result.
SkolemInfoAnon
-> [Id] -> [Id] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints ([HsIPName] -> SkolemInfoAnon
IPSkol [HsIPName]
ips)
[] [Id]
given_ips TcM thing
thing_inside
; (HsLocalBinds GhcTc, thing) -> TcM (HsLocalBinds GhcTc, thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsIPBinds GhcTc GhcTc -> HsIPBinds GhcTc -> HsLocalBinds GhcTc
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcTc GhcTc
XHsIPBinds GhcRn GhcRn
x (XIPBinds GhcTc -> [LIPBind GhcTc] -> HsIPBinds GhcTc
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds TcEvBinds
XIPBinds GhcTc
ev_binds [LIPBind GhcTc]
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds') , thing
result) }
where
ips :: [HsIPName]
ips = [HsIPName
ip | (L SrcSpanAnnA
_ (IPBind XCIPBind GhcRn
_ (L _ ip) LHsExpr GhcRn
_)) <- [LIPBind GhcRn]
[GenLocated SrcSpanAnnA (IPBind GhcRn)]
ip_binds]
tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)
tc_ip_bind :: Class -> IPBind GhcRn -> TcM (Id, IPBind GhcTc)
tc_ip_bind Class
ipClass (IPBind XCIPBind GhcRn
_ l_name :: XRec GhcRn HsIPName
l_name@(L _ ip) LHsExpr GhcRn
expr)
= do { Type
ty <- TcM Type
newOpenFlexiTyVarTy
; let p :: Type
p = FastString -> Type
mkStrLitTy (FastString -> Type) -> FastString -> Type
forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
ip
; Id
ip_id <- Class -> [Type] -> IOEnv (Env TcGblEnv TcLclEnv) Id
newDict Class
ipClass [ Type
p, Type
ty ]
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Type
ty
; let d :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
d = (HsExpr GhcTc -> HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
toDict Class
ipClass Type
p Type
ty) GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'
; (Id, IPBind GhcTc) -> TcM (Id, IPBind GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
ip_id, (XCIPBind GhcTc
-> XRec GhcTc HsIPName -> LHsExpr GhcTc -> IPBind GhcTc
forall id.
XCIPBind id -> XRec id HsIPName -> LHsExpr id -> IPBind id
IPBind XCIPBind GhcTc
Id
ip_id XRec GhcTc HsIPName
XRec GhcRn HsIPName
l_name LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
d)) }
toDict :: Class
-> Type
-> Type
-> HsExpr GhcTc
-> HsExpr GhcTc
toDict :: Class -> Type -> Type -> HsExpr GhcTc -> HsExpr GhcTc
toDict Class
ipClass Type
x Type
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
Type -> TcCoercionR
wrapIP (Type -> TcCoercionR) -> Type -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
x,Type
ty]
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
top_lvl [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs TcM thing
thing_inside
= do {
([Id]
poly_ids, TcSigFun
sig_fn) <- [PatSynBind GhcRn GhcRn]
-> TcM ([Id], TcSigFun) -> TcM ([Id], TcSigFun)
forall a. [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders [PatSynBind GhcRn GhcRn]
patsyns (TcM ([Id], TcSigFun) -> TcM ([Id], TcSigFun))
-> TcM ([Id], TcSigFun) -> TcM ([Id], TcSigFun)
forall a b. (a -> b) -> a -> b
$
[LSig GhcRn] -> TcM ([Id], TcSigFun)
tcTySigs [LSig GhcRn]
sigs
; TopLevelFlag
-> [Id]
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall a. TopLevelFlag -> [Id] -> TcM a -> TcM a
tcExtendSigIds TopLevelFlag
top_lvl [Id]
poly_ids (TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing))
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall a b. (a -> b) -> a -> b
$
do { ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds', ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds', thing
thing))
<- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, LHsBinds GhcTc)],
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing))
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn [(RecFlag, LHsBinds GhcRn)]
binds (TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, LHsBinds GhcTc)],
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)))
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, LHsBinds GhcTc)],
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
do { thing
thing <- TcM thing
thing_inside
; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
patsyn_builders <- (PatSynBind GhcRn GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [PatSynBind GhcRn GhcRn]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcPragEnv -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind TcPragEnv
prag_fn) [PatSynBind GhcRn GhcRn]
patsyns
; let extra_binds :: [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds = [ (RecFlag
NonRecursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder)
| Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder <- [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
patsyn_builders ]
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds, thing
thing) }
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds' [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds', thing
thing) }}
where
patsyns :: [PatSynBind GhcRn GhcRn]
patsyns = [(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn]
forall id.
UnXRec id =>
[(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds GhcRn)]
binds
prag_fn :: TcPragEnv
prag_fn = [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs (((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall a. Bag a -> Bag a -> Bag a
unionBags (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall a b. (a, b) -> b
snd) Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall a. Bag a
emptyBag [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))]
binds)
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcBindGroups :: TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcBindGroups TopLevelFlag
_ TcSigFun
_ TcPragEnv
_ [] TcM thing
thing_inside
= do { thing
thing <- TcM thing
thing_inside
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn ((RecFlag, LHsBinds GhcRn)
group : [(RecFlag, LHsBinds GhcRn)]
groups) TcM thing
thing_inside
= do {
TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
; let closed :: IsGroupClosed
closed = TcTypeEnv -> LHsBinds GhcRn -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall a b. (a, b) -> b
snd (RecFlag, LHsBinds GhcRn)
(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)))
group)
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
group', ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
groups', thing
thing))
<- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds GhcRn)
-> IsGroupClosed
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, LHsBinds GhcTc)],
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing))
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds GhcRn)
-> IsGroupClosed
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag, LHsBinds GhcRn)
group IsGroupClosed
closed (IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, LHsBinds GhcTc)],
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, LHsBinds GhcTc)],
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing))
forall a b. (a -> b) -> a -> b
$
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn [(RecFlag, LHsBinds GhcRn)]
groups TcM thing
thing_inside
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
group' [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
groups', thing
thing) }
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tc_group :: TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds GhcRn)
-> IsGroupClosed
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag
NonRecursive, LHsBinds GhcRn
binds) IsGroupClosed
closed TcM thing
thing_inside
= do { let bind :: GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind = case Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds of
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind] -> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind
[] -> String -> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
forall a. String -> a
panic String
"tc_group: empty list of binds"
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
_ -> String -> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
forall a. String -> a
panic String
"tc_group: NonRecursive binds is not a singleton bag"
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bind', thing
thing) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBind GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBind GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, thing)
tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind IsGroupClosed
closed
TcM thing
thing_inside
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(RecFlag
NonRecursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bind')], thing
thing) }
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag
Recursive, LHsBinds GhcRn
binds) IsGroupClosed
closed TcM thing
thing_inside
=
do { String -> SDoc -> TcRn ()
traceTc String
"tc_group rec" (LHsBinds GhcRn -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds LHsBinds GhcRn
binds)
; Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbFirstPatSyn ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ())
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> TcRn ())
-> TcRn ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
lpat_syn ->
SrcSpan -> LHsBinds GhcRn -> TcRn ()
forall a. SrcSpan -> LHsBinds GhcRn -> TcM a
recursivePatSynErr (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan) -> SrcSpanAnnA -> SrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
lpat_syn) LHsBinds GhcRn
binds
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, thing
thing) <- [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go [SCC (LHsBind GhcRn)]
sccs
; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag
Recursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1)], thing
thing) }
where
mbFirstPatSyn :: Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
mbFirstPatSyn = (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (HsBindLR GhcRn GhcRn -> Bool
forall idL idR. HsBindLR idL idR -> Bool
isPatSyn (HsBindLR GhcRn GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn)
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds
isPatSyn :: HsBindLR idL idR -> Bool
isPatSyn PatSynBind{} = Bool
True
isPatSyn HsBindLR idL idR
_ = Bool
False
sccs :: [SCC (LHsBind GhcRn)]
sccs :: [SCC (LHsBind GhcRn)]
sccs = [Node BKey (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))]
-> [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq (TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
mkEdges TcSigFun
sig_fn LHsBinds GhcRn
binds)
go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go (SCC (LHsBind GhcRn)
scc:[SCC (LHsBind GhcRn)]
sccs) = do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, [Id]
ids1) <- SCC (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
tc_scc SCC (LHsBind GhcRn)
SCC (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
scc
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds2, thing
thing) <- TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [Id]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
forall a.
TopLevelFlag -> TcSigFun -> IsGroupClosed -> [Id] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [Id]
ids1
([SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go [SCC (LHsBind GhcRn)]
sccs)
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1 Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds2, thing
thing) }
go [] = do { thing
thing <- TcM thing
thing_inside; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, thing
thing) }
tc_scc :: SCC (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
tc_scc (AcyclicSCC GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> TcM (LHsBinds GhcTc, [Id])
tc_sub_group RecFlag
NonRecursive [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind]
tc_scc (CyclicSCC [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
binds) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> TcM (LHsBinds GhcTc, [Id])
tc_sub_group RecFlag
Recursive [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
binds
tc_sub_group :: RecFlag
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> TcM (LHsBinds GhcTc, [Id])
tc_sub_group RecFlag
rec_tc [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
binds = TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
RecFlag
Recursive RecFlag
rec_tc IsGroupClosed
closed [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
binds
recursivePatSynErr
:: SrcSpan
-> LHsBinds GhcRn
-> TcM a
recursivePatSynErr :: SrcSpan -> LHsBinds GhcRn -> TcM a
recursivePatSynErr SrcSpan
loc LHsBinds GhcRn
binds
= SrcSpan -> TcRnMessage -> TcM a
forall a. SrcSpan -> TcRnMessage -> TcRn a
failAt SrcSpan
loc (TcRnMessage -> TcM a) -> TcRnMessage -> TcM a
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcRn -> TcRnMessage
TcRnRecursivePatternSynonym LHsBinds GhcRn
binds
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind GhcRn -> IsGroupClosed -> TcM thing
-> TcM (LHsBinds GhcTc, thing)
tc_single :: TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBind GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, thing)
tc_single TopLevelFlag
_top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
(L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
IsGroupClosed
_ TcM thing
thing_inside
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
aux_binds, TcGblEnv
tcg_env) <- PatSynBind GhcRn GhcRn
-> Maybe TcSigInfo -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl PatSynBind GhcRn GhcRn
psb (TcSigFun
sig_fn Name
name) TcPragEnv
prag_fn
; thing
thing <- TcGblEnv -> TcM thing -> TcM thing
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcM thing
thing_inside
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
aux_binds, thing
thing)
}
tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBind GhcRn
lbind IsGroupClosed
closed TcM thing
thing_inside
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, [Id]
ids) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
RecFlag
NonRecursive RecFlag
NonRecursive
IsGroupClosed
closed
[LHsBind GhcRn
lbind]
; thing
thing <- TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [Id] -> TcM thing -> TcM thing
forall a.
TopLevelFlag -> TcSigFun -> IsGroupClosed -> [Id] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [Id]
ids TcM thing
thing_inside
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, thing
thing) }
type BKey = Int
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
mkEdges TcSigFun
sig_fn LHsBinds GhcRn
binds
= [ GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> BKey
-> [BKey]
-> Node BKey (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind BKey
key [BKey
key | Name
n <- UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (HsBindLR GhcRn GhcRn -> UniqSet Name
forall idL idR.
(XFunBind idL idR ~ UniqSet Name,
XPatBind idL idR ~ UniqSet Name) =>
HsBindLR idL idR -> UniqSet Name
bind_fvs (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind)),
Just BKey
key <- [NameEnv BKey -> Name -> Maybe BKey
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv BKey
key_map Name
n], Name -> Bool
no_sig Name
n ]
| (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind, BKey
key) <- [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), BKey)]
keyd_binds
]
where
bind_fvs :: HsBindLR idL idR -> UniqSet Name
bind_fvs (FunBind { fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind idL idR
fvs }) = XFunBind idL idR
UniqSet Name
fvs
bind_fvs (PatBind { pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind idL idR
fvs }) = XPatBind idL idR
UniqSet Name
fvs
bind_fvs HsBindLR idL idR
_ = UniqSet Name
emptyNameSet
no_sig :: Name -> Bool
no_sig :: Name -> Bool
no_sig Name
n = Bool -> Bool
not (TcSigFun -> Name -> Bool
hasCompleteSig TcSigFun
sig_fn Name
n)
keyd_binds :: [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), BKey)]
keyd_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> [BKey]
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), BKey)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [BKey
0::BKey ..]
key_map :: NameEnv BKey
key_map :: NameEnv BKey
key_map = [(Name, BKey)] -> NameEnv BKey
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
bndr, BKey
key) | (L SrcSpanAnnA
_ HsBindLR GhcRn GhcRn
bind, BKey
key) <- [(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), BKey)]
keyd_binds
, Name
bndr <- CollectFlag GhcRn -> HsBindLR GhcRn GhcRn -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> HsBindLR p idR -> [IdP p]
collectHsBindBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsBindLR GhcRn GhcRn
bind ]
tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyBinds :: TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn RecFlag
rec_group RecFlag
rec_tc IsGroupClosed
closed [LHsBind GhcRn]
bind_list
= SrcSpan
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall a b. (a -> b) -> a -> b
$
IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall r. TcRn r -> TcRn r -> TcRn r
recoverM ([Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id])
recoveryCode [IdP GhcRn]
[Name]
binder_names TcSigFun
sig_fn) (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRn ()
traceTc String
"------------------------------------------------" SDoc
Outputable.empty
; String -> SDoc -> TcRn ()
traceTc String
"Bindings for {" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
[Name]
binder_names)
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let plan :: GeneralisationPlan
plan = DynFlags
-> TopLevelFlag
-> IsGroupClosed
-> TcSigFun
-> [LHsBind GhcRn]
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags TopLevelFlag
top_lvl IsGroupClosed
closed TcSigFun
sig_fn [LHsBind GhcRn]
bind_list
; String -> SDoc -> TcRn ()
traceTc String
"Generalisation plan" (GeneralisationPlan -> SDoc
forall a. Outputable a => a -> SDoc
ppr GeneralisationPlan
plan)
; result :: (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
result@(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
_, [Id]
poly_ids) <- case GeneralisationPlan
plan of
GeneralisationPlan
NoGen -> RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn [LHsBind GhcRn]
bind_list
InferGen Bool
mn -> RecFlag
-> TcPragEnv
-> TcSigFun
-> Bool
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn Bool
mn [LHsBind GhcRn]
bind_list
CheckGen LHsBind GhcRn
lbind TcIdSigInfo
sig -> TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck TcPragEnv
prag_fn TcIdSigInfo
sig LHsBind GhcRn
lbind
; (Id -> TcRn ()) -> [Id] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ Id
poly_id ->
FRROrigin -> Type -> TcRn ()
hasFixedRuntimeRep_MustBeRefl (Name -> FRROrigin
FRRBinder (Name -> FRROrigin) -> Name -> FRROrigin
forall a b. (a -> b) -> a -> b
$ Id -> Name
idName Id
poly_id) (Id -> Type
idType Id
poly_id))
[Id]
poly_ids
; String -> SDoc -> TcRn ()
traceTc String
"} End of bindings for" ([SDoc] -> SDoc
vcat [ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
[Name]
binder_names, RecFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecFlag
rec_group
, [SDoc] -> SDoc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id) | Id
id <- [Id]
poly_ids]
])
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
result }
where
binder_names :: [IdP GhcRn]
binder_names = CollectFlag GhcRn -> [LHsBind GhcRn] -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders [LHsBind GhcRn]
bind_list
loc :: SrcSpan
loc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> SrcSpanAnnA)
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc) [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
bind_list)
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id])
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id])
recoveryCode [Name]
binder_names TcSigFun
sig_fn
= do { String -> SDoc -> TcRn ()
traceTc String
"tcBindsWithSigs: error recovery" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
binder_names)
; let poly_ids :: [Id]
poly_ids = (Name -> Id) -> [Name] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Id
mk_dummy [Name]
binder_names
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, [Id]
poly_ids) }
where
mk_dummy :: Name -> Id
mk_dummy Name
name
| Just TcSigInfo
sig <- TcSigFun
sig_fn Name
name
, Just Id
poly_id <- TcSigInfo -> Maybe Id
completeSigPolyId_maybe TcSigInfo
sig
= Id
poly_id
| Bool
otherwise
= HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
name Type
Many Type
forall_a_a
forall_a_a :: TcType
forall_a_a :: Type
forall_a_a = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] Type
alphaTy
tcPolyNoGen
:: RecFlag
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyNoGen :: RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn [LHsBind GhcRn]
bind_list
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [MonoBindInfo]
mono_infos) <- RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn
(TcPragEnv -> LetBndrSpec
LetGblBndr TcPragEnv
prag_fn)
[LHsBind GhcRn]
bind_list
; [Id]
mono_ids' <- (MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> [MonoBindInfo] -> TcM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) Id
tc_mono_info [MonoBindInfo]
mono_infos
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [Id]
mono_ids') }
where
tc_mono_info :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) Id
tc_mono_info (MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
name, mbi_mono_id :: MonoBindInfo -> Id
mbi_mono_id = Id
mono_id })
= do { [LTcSpecPrag]
_specs <- Id -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags Id
mono_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name)
; Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
mono_id }
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo
-> LHsBind GhcRn
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [Id])
tcPolyCheck TcPragEnv
prag_fn
(CompleteSig { sig_bndr :: TcIdSigInfo -> Id
sig_bndr = Id
poly_id
, sig_ctxt :: TcIdSigInfo -> UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
sig_loc })
(L bind_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches }))
= do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyCheck" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id SDoc -> SDoc -> SDoc
$$ SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
sig_loc)
; Name
mono_name <- OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
nameOccName Name
name) (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NameAnn)
nm_loc)
; (HsWrapper
wrap_gen, (HsWrapper
wrap_res, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'))
<- SrcSpan
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
sig_loc (TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt
-> Type
-> (Type
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall result.
UserTypeCtxt
-> Type -> (Type -> TcM result) -> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ctxt (Id -> Type
idType Id
poly_id) ((Type
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> (Type
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ \Type
rho_ty ->
let mono_id :: Id
mono_id = HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
mono_name (Id -> Type
varMult Id
poly_id) Type
rho_ty in
[TcBinder]
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
mono_id TopLevelFlag
NotTopLevel] (TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
bind_loc (TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
LocatedN Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun (SrcSpanAnn' (EpAnn NameAnn) -> Id -> LocatedN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
nm_loc Id
mono_id) MatchGroup GhcRn (LHsExpr GhcRn)
matches
(Type -> ExpSigmaType
mkCheckExpType Type
rho_ty)
; let prag_sigs :: [LSig GhcRn]
prag_sigs = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name
poly_id2 :: Id
poly_id2 = HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
mono_name (Id -> Type
idMult Id
poly_id) (Id -> Type
idType Id
poly_id)
; [LTcSpecPrag]
spec_prags <- Id -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags Id
poly_id [LSig GhcRn]
prag_sigs
; Id
poly_id <- Id -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
addInlinePrags Id
poly_id [LSig GhcRn]
prag_sigs
; Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; [CoreTickish]
tick <- SrcSpan -> Id -> Module -> [LSig GhcRn] -> TcM [CoreTickish]
funBindTicks (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NameAnn)
nm_loc) Id
poly_id Module
mod [LSig GhcRn]
prag_sigs
; let bind' :: HsBindLR GhcTc GhcTc
bind' = FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [CoreTickish]
-> HsBindLR idL idR
FunBind { fun_id :: LIdP GhcTc
fun_id = SrcSpanAnn' (EpAnn NameAnn) -> Id -> LocatedN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
nm_loc Id
poly_id2
, fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'
, fun_ext :: XFunBind GhcTc GhcTc
fun_ext = HsWrapper
wrap_gen HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_res
, fun_tick :: [CoreTickish]
fun_tick = [CoreTickish]
tick }
export :: ABExport
export = ABE :: Id -> Id -> HsWrapper -> TcSpecPrags -> ABExport
ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: Id
abe_poly = Id
poly_id
, abe_mono :: Id
abe_mono = Id
poly_id2
, abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_prags }
abs_bind :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind = SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
AbsBinds :: [Id]
-> [Id]
-> [ABExport]
-> [TcEvBinds]
-> LHsBinds GhcTc
-> Bool
-> AbsBinds
AbsBinds { abs_tvs :: [Id]
abs_tvs = []
, abs_ev_vars :: [Id]
abs_ev_vars = []
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_binds :: LHsBinds GhcTc
abs_binds = GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
bind')
, abs_sig :: Bool
abs_sig = Bool
True }
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind, [Id
poly_id]) }
tcPolyCheck TcPragEnv
_prag_fn TcIdSigInfo
sig LHsBind GhcRn
bind
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcPolyCheck" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig SDoc -> SDoc -> SDoc
$$ GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind)
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-> TcM [CoreTickish]
funBindTicks :: SrcSpan -> Id -> Module -> [LSig GhcRn] -> TcM [CoreTickish]
funBindTicks SrcSpan
loc Id
fun_id Module
mod [LSig GhcRn]
sigs
| (Maybe (GenLocated (SrcAnn NoEpAnns) StringLiteral)
mb_cc_str : [Maybe (GenLocated (SrcAnn NoEpAnns) StringLiteral)]
_) <- [ Maybe (XRec GhcRn StringLiteral)
Maybe (GenLocated (SrcAnn NoEpAnns) StringLiteral)
cc_name | L SrcSpanAnnA
_ (SCCFunSig XSCCFunSig GhcRn
_ SourceText
_ LIdP GhcRn
_ Maybe (XRec GhcRn StringLiteral)
cc_name) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs ]
, let cc_str :: FastString
cc_str
| Just GenLocated (SrcAnn NoEpAnns) StringLiteral
cc_str <- Maybe (GenLocated (SrcAnn NoEpAnns) StringLiteral)
mb_cc_str
= StringLiteral -> FastString
sl_fs (StringLiteral -> FastString) -> StringLiteral -> FastString
forall a b. (a -> b) -> a -> b
$ GenLocated (SrcAnn NoEpAnns) StringLiteral -> StringLiteral
forall l e. GenLocated l e -> e
unLoc GenLocated (SrcAnn NoEpAnns) StringLiteral
cc_str
| Bool
otherwise
= Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS (Id -> Name
Var.varName Id
fun_id)
cc_name :: FastString
cc_name = ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) FastString -> FastString -> FastString
`appendFS` Char -> FastString -> FastString
consFS Char
'.' FastString
cc_str
= do
CCFlavour
flavour <- CostCentreIndex -> CCFlavour
DeclCC (CostCentreIndex -> CCFlavour)
-> IOEnv (Env TcGblEnv TcLclEnv) CostCentreIndex
-> IOEnv (Env TcGblEnv TcLclEnv) CCFlavour
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> IOEnv (Env TcGblEnv TcLclEnv) CostCentreIndex
getCCIndexTcM FastString
cc_name
let cc :: CostCentre
cc = FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
cc_name Module
mod SrcSpan
loc CCFlavour
flavour
[CoreTickish] -> TcM [CoreTickish]
forall (m :: * -> *) a. Monad m => a -> m a
return [CostCentre -> Bool -> Bool -> CoreTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
True Bool
True]
| Bool
otherwise
= [CoreTickish] -> TcM [CoreTickish]
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcPolyInfer
:: RecFlag
-> TcPragEnv -> TcSigFun
-> Bool
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyInfer :: RecFlag
-> TcPragEnv
-> TcSigFun
-> Bool
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Id])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn Bool
mono [LHsBind GhcRn]
bind_list
= do { (TcLevel
tclvl, WantedConstraints
wanted, (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [MonoBindInfo]
mono_infos))
<- IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> TcM
(TcLevel, WantedConstraints,
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo]))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> TcM
(TcLevel, WantedConstraints,
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> TcM
(TcLevel, WantedConstraints,
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo]))
forall a b. (a -> b) -> a -> b
$
RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn LetBndrSpec
LetLclBndr [LHsBind GhcRn]
bind_list
; let name_taus :: [(Name, Type)]
name_taus = [ (MonoBindInfo -> Name
mbi_poly_name MonoBindInfo
info, Id -> Type
idType (MonoBindInfo -> Id
mbi_mono_id MonoBindInfo
info))
| MonoBindInfo
info <- [MonoBindInfo]
mono_infos ]
sigs :: [TcIdSigInst]
sigs = [ TcIdSigInst
sig | MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig } <- [MonoBindInfo]
mono_infos ]
infer_mode :: InferMode
infer_mode = if Bool
mono then InferMode
ApplyMR else InferMode
NoRestrictions
; (TcIdSigInst -> TcRn ()) -> [TcIdSigInst] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> TcIdSigInst -> TcRn ()
checkOverloadedSig Bool
mono) [TcIdSigInst]
sigs
; String -> SDoc -> TcRn ()
traceTc String
"simplifyInfer call" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl SDoc -> SDoc -> SDoc
$$ [(Name, Type)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, Type)]
name_taus SDoc -> SDoc -> SDoc
$$ WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)
; (([Id]
qtvs, [Id]
givens, TcEvBinds
ev_binds, Bool
insoluble), WantedConstraints
residual)
<- TcM ([Id], [Id], TcEvBinds, Bool)
-> TcM (([Id], [Id], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([Id], [Id], TcEvBinds, Bool)
-> TcM (([Id], [Id], TcEvBinds, Bool), WantedConstraints))
-> TcM ([Id], [Id], TcEvBinds, Bool)
-> TcM (([Id], [Id], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Type)]
-> WantedConstraints
-> TcM ([Id], [Id], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst]
sigs [(Name, Type)]
name_taus WantedConstraints
wanted
; let inferred_theta :: [Type]
inferred_theta = (Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
evVarPred [Id]
givens
; [ABExport]
exports <- TcM [ABExport] -> TcM [ABExport]
forall r. TcM r -> TcM r
checkNoErrs (TcM [ABExport] -> TcM [ABExport])
-> TcM [ABExport] -> TcM [ABExport]
forall a b. (a -> b) -> a -> b
$
(MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) ABExport)
-> [MonoBindInfo] -> TcM [ABExport]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcPragEnv
-> WantedConstraints
-> Bool
-> [Id]
-> [Type]
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) ABExport
mkExport TcPragEnv
prag_fn WantedConstraints
residual Bool
insoluble [Id]
qtvs [Type]
inferred_theta) [MonoBindInfo]
mono_infos
; WantedConstraints -> TcRn ()
emitConstraints WantedConstraints
residual
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; let poly_ids :: [Id]
poly_ids = (ABExport -> Id) -> [ABExport] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ABExport -> Id
abe_poly [ABExport]
exports
abs_bind :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind = SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
AbsBinds :: [Id]
-> [Id]
-> [ABExport]
-> [TcEvBinds]
-> LHsBinds GhcTc
-> Bool
-> AbsBinds
AbsBinds { abs_tvs :: [Id]
abs_tvs = [Id]
qtvs
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
givens, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
ev_binds]
, abs_exports :: [ABExport]
abs_exports = [ABExport]
exports, abs_binds :: LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds'
, abs_sig :: Bool
abs_sig = Bool
False }
; String -> SDoc -> TcRn ()
traceTc String
"Binding:" ([(Id, Type)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Id]
poly_ids [Id] -> [Type] -> [(Id, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
poly_ids))
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind, [Id]
poly_ids) }
mkExport :: TcPragEnv
-> WantedConstraints
-> Bool
-> [TyVar] -> TcThetaType
-> MonoBindInfo
-> TcM ABExport
mkExport :: TcPragEnv
-> WantedConstraints
-> Bool
-> [Id]
-> [Type]
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) ABExport
mkExport TcPragEnv
prag_fn WantedConstraints
residual Bool
insoluble [Id]
qtvs [Type]
theta
(MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
poly_name
, mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
mb_sig
, mbi_mono_id :: MonoBindInfo -> Id
mbi_mono_id = Id
mono_id })
= do { Type
mono_ty <- Type -> TcM Type
zonkTcType (Id -> Type
idType Id
mono_id)
; Id
poly_id <- WantedConstraints
-> Bool
-> [Id]
-> [Type]
-> Name
-> Maybe TcIdSigInst
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) Id
mkInferredPolyId WantedConstraints
residual Bool
insoluble [Id]
qtvs [Type]
theta Name
poly_name Maybe TcIdSigInst
mb_sig Type
mono_ty
; Id
poly_id <- Id -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
addInlinePrags Id
poly_id [LSig GhcRn]
prag_sigs
; [LTcSpecPrag]
spec_prags <- Id -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags Id
poly_id [LSig GhcRn]
prag_sigs
; let poly_ty :: Type
poly_ty = Id -> Type
idType Id
poly_id
sel_poly_ty :: Type
sel_poly_ty = [Id] -> [Type] -> Type -> Type
mkInfSigmaTy [Id]
qtvs [Type]
theta Type
mono_ty
; String -> SDoc -> TcRn ()
traceTc String
"mkExport" ([SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
poly_ty
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sel_poly_ty ])
; HsWrapper
wrap <- if Type
sel_poly_ty Type -> Type -> Bool
`eqType` Type
poly_ty
then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
else CtOrigin
-> UserTypeCtxt
-> Type
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma CtOrigin
GhcBug20076
UserTypeCtxt
sig_ctxt Type
sel_poly_ty Type
poly_ty
; Id -> Maybe TcIdSigInst -> TcRn ()
localSigWarn Id
poly_id Maybe TcIdSigInst
mb_sig
; ABExport -> IOEnv (Env TcGblEnv TcLclEnv) ABExport
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE :: Id -> Id -> HsWrapper -> TcSpecPrags -> ABExport
ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
wrap
, abe_poly :: Id
abe_poly = Id
poly_id
, abe_mono :: Id
abe_mono = Id
mono_id
, abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_prags }) }
where
prag_sigs :: [LSig GhcRn]
prag_sigs = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
poly_name
sig_ctxt :: UserTypeCtxt
sig_ctxt = Name -> UserTypeCtxt
InfSigCtxt Name
poly_name
mkInferredPolyId :: WantedConstraints
-> Bool
-> [TyVar] -> TcThetaType
-> Name -> Maybe TcIdSigInst -> TcType
-> TcM TcId
mkInferredPolyId :: WantedConstraints
-> Bool
-> [Id]
-> [Type]
-> Name
-> Maybe TcIdSigInst
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) Id
mkInferredPolyId WantedConstraints
residual Bool
insoluble [Id]
qtvs [Type]
inferred_theta Name
poly_name Maybe TcIdSigInst
mb_sig_inst Type
mono_ty
| Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = TcIdSigInfo
sig }) <- Maybe TcIdSigInst
mb_sig_inst
, CompleteSig { sig_bndr :: TcIdSigInfo -> Id
sig_bndr = Id
poly_id } <- TcIdSigInfo
sig
= Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
poly_id
| Bool
otherwise
= IOEnv (Env TcGblEnv TcLclEnv) Id
-> IOEnv (Env TcGblEnv TcLclEnv) Id
forall r. TcM r -> TcM r
checkNoErrs (IOEnv (Env TcGblEnv TcLclEnv) Id
-> IOEnv (Env TcGblEnv TcLclEnv) Id)
-> IOEnv (Env TcGblEnv TcLclEnv) Id
-> IOEnv (Env TcGblEnv TcLclEnv) Id
forall a b. (a -> b) -> a -> b
$
do { FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let mono_ty' :: Type
mono_ty' = Reduction -> Type
reductionReducedType (Reduction -> Type) -> Reduction -> Type
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> Role -> Type -> Reduction
normaliseType FamInstEnvs
fam_envs Role
Nominal Type
mono_ty
; ([InvisTVBinder]
binders, [Type]
theta') <- WantedConstraints
-> [Type]
-> TcTyVarSet
-> [Id]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], [Type])
chooseInferredQuantifiers WantedConstraints
residual [Type]
inferred_theta
(Type -> TcTyVarSet
tyCoVarsOfType Type
mono_ty') [Id]
qtvs Maybe TcIdSigInst
mb_sig_inst
; let inferred_poly_ty :: Type
inferred_poly_ty = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
binders ([Type] -> Type -> Type
mkPhiTy [Type]
theta' Type
mono_ty')
; String -> SDoc -> TcRn ()
traceTc String
"mkInferredPolyId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
poly_name, [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
qtvs, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta'
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inferred_poly_ty])
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
insoluble (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(TidyEnv -> TcM (TidyEnv, SDoc)) -> TcRn () -> TcRn ()
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (Name -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Type
inferred_poly_ty) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt -> Type -> TcRn ()
checkValidType (Name -> UserTypeCtxt
InfSigCtxt Name
poly_name) Type
inferred_poly_ty
; Id -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
poly_name Type
Many Type
inferred_poly_ty) }
chooseInferredQuantifiers :: WantedConstraints
-> TcThetaType
-> TcTyVarSet
-> [TcTyVar]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], TcThetaType)
chooseInferredQuantifiers :: WantedConstraints
-> [Type]
-> TcTyVarSet
-> [Id]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], [Type])
chooseInferredQuantifiers WantedConstraints
_residual [Type]
inferred_theta TcTyVarSet
tau_tvs [Id]
qtvs Maybe TcIdSigInst
Nothing
=
do { let free_tvs :: TcTyVarSet
free_tvs = TcTyVarSet -> TcTyVarSet
closeOverKinds ([Type] -> TcTyVarSet -> TcTyVarSet
growThetaTyVars [Type]
inferred_theta TcTyVarSet
tau_tvs)
my_theta :: [Type]
my_theta = TcTyVarSet -> [Type] -> [Type]
pickCapturedPreds TcTyVarSet
free_tvs [Type]
inferred_theta
binders :: [InvisTVBinder]
binders = [ Specificity -> Id -> InvisTVBinder
forall vis. vis -> Id -> VarBndr Id vis
mkTyVarBinder Specificity
InferredSpec Id
tv
| Id
tv <- [Id]
qtvs
, Id
tv Id -> TcTyVarSet -> Bool
`elemVarSet` TcTyVarSet
free_tvs ]
; ([InvisTVBinder], [Type]) -> TcM ([InvisTVBinder], [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvisTVBinder]
binders, [Type]
my_theta) }
chooseInferredQuantifiers WantedConstraints
residual [Type]
inferred_theta TcTyVarSet
tau_tvs [Id]
qtvs
(Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
fn_name, psig_hs_ty :: TcIdSigInfo -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty })
, sig_inst_wcx :: TcIdSigInst -> Maybe Type
sig_inst_wcx = Maybe Type
wcx
, sig_inst_theta :: TcIdSigInst -> [Type]
sig_inst_theta = [Type]
annotated_theta
, sig_inst_skols :: TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols = [(Name, InvisTVBinder)]
annotated_tvs }))
=
do { let ([Name]
psig_qtv_nms, [InvisTVBinder]
psig_qtv_bndrs) = [(Name, InvisTVBinder)] -> ([Name], [InvisTVBinder])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, InvisTVBinder)]
annotated_tvs
; [InvisTVBinder]
psig_qtv_bndrs <- (InvisTVBinder -> IOEnv (Env TcGblEnv TcLclEnv) InvisTVBinder)
-> [InvisTVBinder] -> IOEnv (Env TcGblEnv TcLclEnv) [InvisTVBinder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InvisTVBinder -> IOEnv (Env TcGblEnv TcLclEnv) InvisTVBinder
forall spec. VarBndr Id spec -> TcM (VarBndr Id spec)
zonkInvisTVBinder [InvisTVBinder]
psig_qtv_bndrs
; let psig_qtvs :: [Id]
psig_qtvs = (InvisTVBinder -> Id) -> [InvisTVBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map InvisTVBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [InvisTVBinder]
psig_qtv_bndrs
psig_qtv_set :: TcTyVarSet
psig_qtv_set = [Id] -> TcTyVarSet
mkVarSet [Id]
psig_qtvs
psig_qtv_prs :: [(Name, Id)]
psig_qtv_prs = [Name]
psig_qtv_nms [Name] -> [Id] -> [(Name, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
psig_qtvs
; ((Name, Name) -> TcRn ()) -> [(Name, Name)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Name) -> TcRn ()
report_dup_tyvar_tv_err ([(Name, Id)] -> [(Name, Name)]
findDupTyVarTvs [(Name, Id)]
psig_qtv_prs)
; ((Name, Id) -> TcRn ()) -> [(Name, Id)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Id) -> TcRn ()
report_mono_sig_tv_err [ (Name, Id)
pr | pr :: (Name, Id)
pr@(Name
_,Id
tv) <- [(Name, Id)]
psig_qtv_prs
, Bool -> Bool
not (Id
tv Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
qtvs) ]
; [Type]
annotated_theta <- [Type] -> TcM [Type]
zonkTcTypes [Type]
annotated_theta
; (TcTyVarSet
free_tvs, [Type]
my_theta) <- TcTyVarSet -> [Type] -> Maybe Type -> TcM (TcTyVarSet, [Type])
choose_psig_context TcTyVarSet
psig_qtv_set [Type]
annotated_theta Maybe Type
wcx
; let keep_me :: TcTyVarSet
keep_me = TcTyVarSet
free_tvs TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
psig_qtv_set
final_qtvs :: [InvisTVBinder]
final_qtvs = [ Specificity -> Id -> InvisTVBinder
forall vis. vis -> Id -> VarBndr Id vis
mkTyVarBinder Specificity
vis Id
tv
| Id
tv <- [Id]
qtvs
, Id
tv Id -> TcTyVarSet -> Bool
`elemVarSet` TcTyVarSet
keep_me
, let vis :: Specificity
vis = case Id -> [InvisTVBinder] -> Maybe Specificity
forall var flag. Eq var => var -> [VarBndr var flag] -> Maybe flag
lookupVarBndr Id
tv [InvisTVBinder]
psig_qtv_bndrs of
Just Specificity
spec -> Specificity
spec
Maybe Specificity
Nothing -> Specificity
InferredSpec ]
; ([InvisTVBinder], [Type]) -> TcM ([InvisTVBinder], [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvisTVBinder]
final_qtvs, [Type]
my_theta) }
where
report_dup_tyvar_tv_err :: (Name, Name) -> TcRn ()
report_dup_tyvar_tv_err (Name
n1,Name
n2)
= TcRnMessage -> TcRn ()
addErrTc (Name -> Name -> Name -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigTyVarMismatch Name
n1 Name
n2 Name
fn_name LHsSigWcType GhcRn
hs_ty)
report_mono_sig_tv_err :: (Name, Id) -> TcRn ()
report_mono_sig_tv_err (Name
n,Id
tv)
= TcRnMessage -> TcRn ()
addErrTc (Name -> Name -> Maybe Type -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigBadQuantifier Name
n Name
fn_name Maybe Type
m_unif_ty LHsSigWcType GhcRn
hs_ty)
where
m_unif_ty :: Maybe Type
m_unif_ty = [Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe
[ Type
rhs
| Implication
residual_implic <- Bag Implication -> [Implication]
forall a. Bag a -> [a]
bagToList (Bag Implication -> [Implication])
-> Bag Implication -> [Implication]
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> Bag Implication
wc_impl WantedConstraints
residual
, Ct
residual_ct <- Bag Ct -> [Ct]
forall a. Bag a -> [a]
bagToList (Bag Ct -> [Ct]) -> Bag Ct -> [Ct]
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> Bag Ct
wc_simple (Implication -> WantedConstraints
ic_wanted Implication
residual_implic)
, let residual_pred :: Type
residual_pred = Ct -> Type
ctPred Ct
residual_ct
, Just (Role
Nominal, Type
lhs, Type
rhs) <- [ Type -> Maybe (Role, Type, Type)
getEqPredTys_maybe Type
residual_pred ]
, Just Id
lhs_tv <- [ Type -> Maybe Id
tcGetTyVar_maybe Type
lhs ]
, Id
lhs_tv Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
tv ]
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
choose_psig_context :: TcTyVarSet -> [Type] -> Maybe Type -> TcM (TcTyVarSet, [Type])
choose_psig_context TcTyVarSet
_ [Type]
annotated_theta Maybe Type
Nothing
= do { let free_tvs :: TcTyVarSet
free_tvs = TcTyVarSet -> TcTyVarSet
closeOverKinds ([Type] -> TcTyVarSet
tyCoVarsOfTypes [Type]
annotated_theta
TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
tau_tvs)
; (TcTyVarSet, [Type]) -> TcM (TcTyVarSet, [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVarSet
free_tvs, [Type]
annotated_theta) }
choose_psig_context TcTyVarSet
psig_qtvs [Type]
annotated_theta (Just Type
wc_var_ty)
= do { let free_tvs :: TcTyVarSet
free_tvs = TcTyVarSet -> TcTyVarSet
closeOverKinds ([Type] -> TcTyVarSet -> TcTyVarSet
growThetaTyVars [Type]
inferred_theta TcTyVarSet
seed_tvs)
seed_tvs :: TcTyVarSet
seed_tvs = [Type] -> TcTyVarSet
tyCoVarsOfTypes [Type]
annotated_theta
TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
tau_tvs
; let keep_me :: TcTyVarSet
keep_me = TcTyVarSet
psig_qtvs TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
free_tvs
my_theta :: [Type]
my_theta = TcTyVarSet -> [Type] -> [Type]
pickCapturedPreds TcTyVarSet
keep_me [Type]
inferred_theta
; [Type]
diff_theta <- [Type] -> [Type] -> TcM [Type]
findInferredDiff [Type]
annotated_theta [Type]
my_theta
; case Type -> Maybe (Id, TcCoercionR)
tcGetCastedTyVar_maybe Type
wc_var_ty of
Just (Id
wc_var, TcCoercionR
wc_co) -> Id -> Type -> TcRn ()
writeMetaTyVar Id
wc_var ([Type] -> Type
mk_ctuple [Type]
diff_theta
Type -> TcCoercionR -> Type
`mkCastTy` TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
wc_co)
Maybe (Id, TcCoercionR)
Nothing -> String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers 1" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wc_var_ty)
; String -> SDoc -> TcRn ()
traceTc String
"completeTheta" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig
, String -> SDoc
text String
"annotated_theta:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
annotated_theta
, String -> SDoc
text String
"inferred_theta:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inferred_theta
, String -> SDoc
text String
"my_theta:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
my_theta
, String -> SDoc
text String
"diff_theta:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
diff_theta ]
; (TcTyVarSet, [Type]) -> TcM (TcTyVarSet, [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVarSet
free_tvs, [Type]
annotated_theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
diff_theta) }
mk_ctuple :: [Type] -> Type
mk_ctuple [Type]
preds = [Type] -> Type
mkBoxedTupleTy [Type]
preds
chooseInferredQuantifiers WantedConstraints
_ [Type]
_ TcTyVarSet
_ [Id]
_ (Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = sig :: TcIdSigInfo
sig@(CompleteSig {}) }))
= String -> SDoc -> TcM ([InvisTVBinder], [Type])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig)
mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg :: Name -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Type
poly_ty TidyEnv
tidy_env
= do { (TidyEnv
tidy_env1, Type
poly_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
poly_ty
; let msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"When checking the inferred type"
, BKey -> SDoc -> SDoc
nest BKey
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
poly_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
poly_ty ]
; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env1, SDoc
msg) }
localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()
localSigWarn :: Id -> Maybe TcIdSigInst -> TcRn ()
localSigWarn Id
id Maybe TcIdSigInst
mb_sig
| Just TcIdSigInst
_ <- Maybe TcIdSigInst
mb_sig = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool -> Bool
not (Type -> Bool
isSigmaTy (Id -> Type
idType Id
id)) = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = Id -> TcRn ()
warnMissingSignatures Id
id
warnMissingSignatures :: Id -> TcM ()
warnMissingSignatures :: Id -> TcRn ()
warnMissingSignatures Id
id
= do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
; let (TidyEnv
env1, Type
tidy_ty) = TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType TidyEnv
env0 (Id -> Type
idType Id
id)
; let dia :: TcRnMessage
dia = Name -> Type -> TcRnMessage
TcRnPolymorphicBinderMissingSig (Id -> Name
idName Id
id) Type
tidy_ty
; (TidyEnv, TcRnMessage) -> TcRn ()
addDiagnosticTcM (TidyEnv
env1, TcRnMessage
dia) }
checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
checkOverloadedSig :: Bool -> TcIdSigInst -> TcRn ()
checkOverloadedSig Bool
monomorphism_restriction_applies TcIdSigInst
sig
| Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [Type]
sig_inst_theta TcIdSigInst
sig))
, Bool
monomorphism_restriction_applies
, let orig_sig :: TcIdSigInfo
orig_sig = TcIdSigInst -> TcIdSigInfo
sig_inst_sig TcIdSigInst
sig
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TcIdSigInfo -> SrcSpan
sig_loc TcIdSigInfo
orig_sig) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcIdSigInfo -> TcRnMessage
TcRnOverloadedSig TcIdSigInfo
orig_sig
| Bool
otherwise
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
data MonoBindInfo = MBI { MonoBindInfo -> Name
mbi_poly_name :: Name
, MonoBindInfo -> Maybe TcIdSigInst
mbi_sig :: Maybe TcIdSigInst
, MonoBindInfo -> Id
mbi_mono_id :: TcId }
tcMonoBinds :: RecFlag
-> TcSigFun -> LetBndrSpec
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds :: RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
is_rec TcSigFun
sig_fn LetBndrSpec
no_gen
[ L b_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches })]
| RecFlag
NonRecursive <- RecFlag
is_rec
, Maybe TcSigInfo
Nothing <- TcSigFun
sig_fn Name
name
= SrcSpanAnnA
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
b_loc (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
do { ((HsWrapper
co_fn, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'), Id
mono_id, Type
_) <- (((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type))
-> (((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
forall a b. (a -> b) -> a -> b
$ \ ~((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
_, Id
_, Type
rhs_ty) ->
do { Id
mono_id <- LetBndrSpec
-> Name -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
newLetBndr LetBndrSpec
no_gen Name
name Type
Many Type
rhs_ty
; ((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
matches', Type
rhs_ty')
<- (ExpSigmaType
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Type)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, Type)
tcInfer ((ExpSigmaType
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Type))
-> (ExpSigmaType
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Type)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
[TcBinder]
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Name -> ExpSigmaType -> TopLevelFlag -> TcBinder
TcIdBndr_ExpType Name
name ExpSigmaType
exp_ty TopLevelFlag
NotTopLevel] (TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
LocatedN Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun (SrcSpanAnn' (EpAnn NameAnn) -> Id -> LocatedN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
nm_loc Id
mono_id) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
exp_ty
; ((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
-> IOEnv
(Env TcGblEnv TcLclEnv)
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Id, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
matches', Id
mono_id, Type
rhs_ty')
}
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
b_loc (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [CoreTickish]
-> HsBindLR idL idR
FunBind { fun_id :: LIdP GhcTc
fun_id = SrcSpanAnn' (EpAnn NameAnn) -> Id -> LocatedN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
nm_loc Id
mono_id,
fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches',
fun_ext :: XFunBind GhcTc GhcTc
fun_ext = HsWrapper
XFunBind GhcTc GhcTc
co_fn, fun_tick :: [CoreTickish]
fun_tick = [] },
[MBI :: Name -> Maybe TcIdSigInst -> Id -> MonoBindInfo
MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
, mbi_sig :: Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
forall a. Maybe a
Nothing
, mbi_mono_id :: Id
mbi_mono_id = Id
mono_id }]) }
tcMonoBinds RecFlag
is_rec TcSigFun
sig_fn LetBndrSpec
no_gen
[L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]
| RecFlag
NonRecursive <- RecFlag
is_rec
, (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe TcSigInfo -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe TcSigInfo -> Bool) -> TcSigFun -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigFun
sig_fn) [IdP GhcRn]
[Name]
bndrs
= SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LPat GhcRn -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt LPat GhcRn
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss) (IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
do { (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss', Type
pat_ty) <- (ExpSigmaType
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Type)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, Type)
tcInfer ((ExpSigmaType
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Type))
-> (ExpSigmaType
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Type)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpSigmaType
exp_ty
; let exp_pat_ty :: Scaled ExpSigmaTypeFRR
exp_pat_ty :: Scaled ExpSigmaType
exp_pat_ty = ExpSigmaType -> Scaled ExpSigmaType
forall a. a -> Scaled a
unrestricted (Type -> ExpSigmaType
mkCheckExpType Type
pat_ty)
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', [MonoBindInfo]
mbis) <- (Name -> Maybe Id)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe Id)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat (Maybe Id -> Name -> Maybe Id
forall a b. a -> b -> a
const Maybe Id
forall a. Maybe a
Nothing) LetBndrSpec
no_gen LPat GhcRn
pat Scaled ExpSigmaType
exp_pat_ty (TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo]))
-> TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
(Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [Name] -> TcM [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI [IdP GhcRn]
[Name]
bndrs
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ( GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
b_loc (HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
PatBind :: forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([CoreTickish], [[CoreTickish]])
-> HsBindLR idL idR
PatBind { pat_lhs :: LPat GhcTc
pat_lhs = LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat', pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss'
, pat_ext :: XPatBind GhcTc GhcTc
pat_ext = XPatBind GhcTc GhcTc
Type
pat_ty, pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_ticks = ([],[]) }
, [MonoBindInfo]
mbis ) }
where
bndrs :: [IdP GhcRn]
bndrs = CollectFlag GhcRn -> LPat GhcRn -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat
tcMonoBinds RecFlag
_ TcSigFun
sig_fn LetBndrSpec
no_gen [LHsBind GhcRn]
binds
= do { [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds <- (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA TcMonoBind))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA TcMonoBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((HsBindLR GhcRn GhcRn -> TcM TcMonoBind)
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA TcMonoBind)
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (TcSigFun -> LetBndrSpec -> HsBindLR GhcRn GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen)) [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
binds
; let mono_infos :: [MonoBindInfo]
mono_infos = [GenLocated SrcSpanAnnA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
rhs_id_env :: [(Name, Id)]
rhs_id_env = [ (Name
name, Id
mono_id)
| MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
name
, mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
mb_sig
, mbi_mono_id :: MonoBindInfo -> Id
mbi_mono_id = Id
mono_id } <- [MonoBindInfo]
mono_infos
, case Maybe TcIdSigInst
mb_sig of
Just TcIdSigInst
sig -> TcIdSigInst -> Bool
isPartialSig TcIdSigInst
sig
Maybe TcIdSigInst
Nothing -> Bool
True ]
; String -> SDoc -> TcRn ()
traceTc String
"tcMonoBinds" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id)
| (Name
n,Id
id) <- [(Name, Id)]
rhs_id_env]
; [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds' <- [(Name, Id)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. [(Name, Id)] -> TcM a -> TcM a
tcExtendRecIds [(Name, Id)]
rhs_id_env (TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA TcMonoBind
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> [GenLocated SrcSpanAnnA TcMonoBind]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TcMonoBind -> TcM (HsBindLR GhcTc GhcTc))
-> GenLocated SrcSpanAnnA TcMonoBind
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA TcMonoBind -> TcM (HsBindLR GhcTc GhcTc)
tcRhs) [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds', [MonoBindInfo]
mono_infos) }
data TcMonoBind
= TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
| TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn))
TcSigmaTypeFRR
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
tcLhs :: TcSigFun -> LetBndrSpec -> HsBindLR GhcRn GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L nm_loc name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matches })
| Just (TcIdSig TcIdSigInfo
sig) <- TcSigFun
sig_fn Name
name
=
do { MonoBindInfo
mono_info <- LetBndrSpec
-> (Name, TcIdSigInfo)
-> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSigInfo
sig)
; TcMonoBind -> TcM TcMonoBind
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan -> MatchGroup GhcRn (LHsExpr GhcRn) -> TcMonoBind
TcFunBind MonoBindInfo
mono_info (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NameAnn)
nm_loc) MatchGroup GhcRn (LHsExpr GhcRn)
matches) }
| Bool
otherwise
= do { Type
mono_ty <- TcM Type
newOpenFlexiTyVarTy
; Id
mono_id <- LetBndrSpec
-> Name -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
newLetBndr LetBndrSpec
no_gen Name
name Type
Many Type
mono_ty
; let mono_info :: MonoBindInfo
mono_info = MBI :: Name -> Maybe TcIdSigInst -> Id -> MonoBindInfo
MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
, mbi_sig :: Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
forall a. Maybe a
Nothing
, mbi_mono_id :: Id
mbi_mono_id = Id
mono_id }
; TcMonoBind -> TcM TcMonoBind
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan -> MatchGroup GhcRn (LHsExpr GhcRn) -> TcMonoBind
TcFunBind MonoBindInfo
mono_info (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn NameAnn)
nm_loc) MatchGroup GhcRn (LHsExpr GhcRn)
matches) }
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcRn
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcRn (LHsExpr GhcRn)
grhss })
=
do { [MonoBindInfo]
sig_mbis <- ((Name, TcIdSigInfo) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [(Name, TcIdSigInfo)] -> TcM [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LetBndrSpec
-> (Name, TcIdSigInfo)
-> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen) [(Name, TcIdSigInfo)]
sig_names
; let inst_sig_fun :: Name -> Maybe Id
inst_sig_fun = NameEnv Id -> Name -> Maybe Id
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (NameEnv Id -> Name -> Maybe Id) -> NameEnv Id -> Name -> Maybe Id
forall a b. (a -> b) -> a -> b
$ [(Name, Id)] -> NameEnv Id
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, Id)] -> NameEnv Id) -> [(Name, Id)] -> NameEnv Id
forall a b. (a -> b) -> a -> b
$
[ (MonoBindInfo -> Name
mbi_poly_name MonoBindInfo
mbi, MonoBindInfo -> Id
mbi_mono_id MonoBindInfo
mbi)
| MonoBindInfo
mbi <- [MonoBindInfo]
sig_mbis ]
; ((GenLocated SrcSpanAnnA (Pat GhcTc)
pat', [MonoBindInfo]
nosig_mbis), Type
pat_ty)
<- SDoc
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LPat GhcRn -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt LPat GhcRn
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss) (TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
-> TcM
((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
forall a b. (a -> b) -> a -> b
$
(ExpSigmaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, Type)
tcInfer ((ExpSigmaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM
((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type))
-> (ExpSigmaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Type)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
(Name -> Maybe Id)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe Id)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat Name -> Maybe Id
inst_sig_fun LetBndrSpec
no_gen LPat GhcRn
pat (ExpSigmaType -> Scaled ExpSigmaType
forall a. a -> Scaled a
unrestricted ExpSigmaType
exp_ty) (TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo]))
-> TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
(Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [Name] -> TcM [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI [Name]
nosig_names
; let mbis :: [MonoBindInfo]
mbis = [MonoBindInfo]
sig_mbis [MonoBindInfo] -> [MonoBindInfo] -> [MonoBindInfo]
forall a. [a] -> [a] -> [a]
++ [MonoBindInfo]
nosig_mbis
; String -> SDoc -> TcRn ()
traceTc String
"tcLhs" ([SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id)
| MonoBindInfo
mbi <- [MonoBindInfo]
mbis, let id :: Id
id = MonoBindInfo -> Id
mbi_mono_id MonoBindInfo
mbi ]
SDoc -> SDoc -> SDoc
$$ LetBndrSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr LetBndrSpec
no_gen)
; TcMonoBind -> TcM TcMonoBind
forall (m :: * -> *) a. Monad m => a -> m a
return ([MonoBindInfo]
-> LPat GhcTc -> GRHSs GhcRn (LHsExpr GhcRn) -> Type -> TcMonoBind
TcPatBind [MonoBindInfo]
mbis LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GRHSs GhcRn (LHsExpr GhcRn)
grhss Type
pat_ty) }
where
bndr_names :: [IdP GhcRn]
bndr_names = CollectFlag GhcRn -> LPat GhcRn -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat
([Name]
nosig_names, [(Name, TcIdSigInfo)]
sig_names) = (Name -> Either Name (Name, TcIdSigInfo))
-> [Name] -> ([Name], [(Name, TcIdSigInfo)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Name -> Either Name (Name, TcIdSigInfo)
find_sig [IdP GhcRn]
[Name]
bndr_names
find_sig :: Name -> Either Name (Name, TcIdSigInfo)
find_sig :: Name -> Either Name (Name, TcIdSigInfo)
find_sig Name
name = case TcSigFun
sig_fn Name
name of
Just (TcIdSig TcIdSigInfo
sig) -> (Name, TcIdSigInfo) -> Either Name (Name, TcIdSigInfo)
forall a b. b -> Either a b
Right (Name
name, TcIdSigInfo
sig)
Maybe TcSigInfo
_ -> Name -> Either Name (Name, TcIdSigInfo)
forall a b. a -> Either a b
Left Name
name
tcLhs TcSigFun
_ LetBndrSpec
_ HsBindLR GhcRn GhcRn
other_bind = String -> SDoc -> TcM TcMonoBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLhs" (HsBindLR GhcRn GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcRn GhcRn
other_bind)
lookupMBI :: Name -> TcM MonoBindInfo
lookupMBI :: Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI Name
name
= do { Id
mono_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
tcLookupId Name
name
; MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (MBI :: Name -> Maybe TcIdSigInst -> Id -> MonoBindInfo
MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
, mbi_sig :: Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
forall a. Maybe a
Nothing
, mbi_mono_id :: Id
mbi_mono_id = Id
mono_id }) }
tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
tcLhsSigId :: LetBndrSpec
-> (Name, TcIdSigInfo)
-> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSigInfo
sig)
= do { TcIdSigInst
inst_sig <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
; Id
mono_id <- LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) Id
newSigLetBndr LetBndrSpec
no_gen Name
name TcIdSigInst
inst_sig
; MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (MBI :: Name -> Maybe TcIdSigInst -> Id -> MonoBindInfo
MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
, mbi_sig :: Maybe TcIdSigInst
mbi_sig = TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
inst_sig
, mbi_mono_id :: Id
mbi_mono_id = Id
mono_id }) }
newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
newSigLetBndr :: LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) Id
newSigLetBndr (LetGblBndr TcPragEnv
prags) Name
name (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = TcIdSigInfo
id_sig })
| CompleteSig { sig_bndr :: TcIdSigInfo -> Id
sig_bndr = Id
poly_id } <- TcIdSigInfo
id_sig
= Id -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) Id
addInlinePrags Id
poly_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prags Name
name)
newSigLetBndr LetBndrSpec
no_gen Name
name (TISI { sig_inst_tau :: TcIdSigInst -> Type
sig_inst_tau = Type
tau })
= LetBndrSpec
-> Name -> Type -> Type -> IOEnv (Env TcGblEnv TcLclEnv) Id
newLetBndr LetBndrSpec
no_gen Name
name Type
Many Type
tau
tcRhs :: TcMonoBind -> TcM (HsBind GhcTc)
tcRhs :: TcMonoBind -> TcM (HsBindLR GhcTc GhcTc)
tcRhs (TcFunBind info :: MonoBindInfo
info@(MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
mb_sig, mbi_mono_id :: MonoBindInfo -> Id
mbi_mono_id = Id
mono_id })
SrcSpan
loc MatchGroup GhcRn (LHsExpr GhcRn)
matches)
= [MonoBindInfo]
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo
info] (TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc))
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
Maybe TcIdSigInst
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a. Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Maybe TcIdSigInst
mb_sig (TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc))
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcRhs: fun bind" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
mono_id SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
mono_id))
; (HsWrapper
co_fn, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') <- LocatedN Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun (SrcSpanAnn' (EpAnn NameAnn) -> Id -> LocatedN Id
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) Id
mono_id)
MatchGroup GhcRn (LHsExpr GhcRn)
matches (Type -> ExpSigmaType
mkCheckExpType (Type -> ExpSigmaType) -> Type -> ExpSigmaType
forall a b. (a -> b) -> a -> b
$ Id -> Type
idType Id
mono_id)
; HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ( FunBind :: forall idL idR.
XFunBind idL idR
-> LIdP idL
-> MatchGroup idR (LHsExpr idR)
-> [CoreTickish]
-> HsBindLR idL idR
FunBind { fun_id :: LIdP GhcTc
fun_id = SrcSpanAnn' (EpAnn NameAnn) -> Id -> LocatedN Id
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) Id
mono_id
, fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'
, fun_ext :: XFunBind GhcTc GhcTc
fun_ext = HsWrapper
XFunBind GhcTc GhcTc
co_fn
, fun_tick :: [CoreTickish]
fun_tick = [] } ) }
tcRhs (TcPatBind [MonoBindInfo]
infos LPat GhcTc
pat' GRHSs GhcRn (LHsExpr GhcRn)
grhss Type
pat_ty)
=
[MonoBindInfo]
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo]
infos (TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc))
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcRhs: pat bind" (GenLocated SrcSpanAnnA (Pat GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pat_ty)
; GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss' <- SDoc
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LPat GhcTc -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt LPat GhcTc
pat' GRHSs GhcRn (LHsExpr GhcRn)
grhss) (TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss (Type -> ExpSigmaType
mkCheckExpType Type
pat_ty)
; HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ( PatBind :: forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([CoreTickish], [[CoreTickish]])
-> HsBindLR idL idR
PatBind { pat_lhs :: LPat GhcTc
pat_lhs = LPat GhcTc
pat', pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss'
, pat_ext :: XPatBind GhcTc GhcTc
pat_ext = XPatBind GhcTc GhcTc
Type
pat_ty
, pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_ticks = ([],[]) } )}
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Maybe TcIdSigInst
Nothing TcM a
thing_inside
= TcM a
thing_inside
tcExtendTyVarEnvForRhs (Just TcIdSigInst
sig) TcM a
thing_inside
= TcIdSigInst -> TcM a -> TcM a
forall a. TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig TcIdSigInst
sig TcM a
thing_inside
tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig TcIdSigInst
sig_inst TcM a
thing_inside
| TISI { sig_inst_skols :: TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols = [(Name, InvisTVBinder)]
skol_prs, sig_inst_wcs :: TcIdSigInst -> [(Name, Id)]
sig_inst_wcs = [(Name, Id)]
wcs } <- TcIdSigInst
sig_inst
= [(Name, Id)] -> TcM a -> TcM a
forall a. [(Name, Id)] -> TcM a -> TcM a
tcExtendNameTyVarEnv [(Name, Id)]
wcs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
[(Name, Id)] -> TcM a -> TcM a
forall a. [(Name, Id)] -> TcM a -> TcM a
tcExtendNameTyVarEnv ((InvisTVBinder -> Id) -> [(Name, InvisTVBinder)] -> [(Name, Id)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd InvisTVBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [(Name, InvisTVBinder)]
skol_prs) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo]
infos TcM a
thing_inside
= [TcBinder] -> TcM a -> TcM a
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [ Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
mono_id TopLevelFlag
NotTopLevel
| MBI { mbi_mono_id :: MonoBindInfo -> Id
mbi_mono_id = Id
mono_id } <- [MonoBindInfo]
infos ]
TcM a
thing_inside
getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo :: [GenLocated SrcSpanAnnA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
= (GenLocated SrcSpanAnnA TcMonoBind
-> [MonoBindInfo] -> [MonoBindInfo])
-> [MonoBindInfo]
-> [GenLocated SrcSpanAnnA TcMonoBind]
-> [MonoBindInfo]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo]
get_info (TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo])
-> (GenLocated SrcSpanAnnA TcMonoBind -> TcMonoBind)
-> GenLocated SrcSpanAnnA TcMonoBind
-> [MonoBindInfo]
-> [MonoBindInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA TcMonoBind -> TcMonoBind
forall l e. GenLocated l e -> e
unLoc) [] [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
where
get_info :: TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo]
get_info (TcFunBind MonoBindInfo
info SrcSpan
_ MatchGroup GhcRn (LHsExpr GhcRn)
_) [MonoBindInfo]
rest = MonoBindInfo
info MonoBindInfo -> [MonoBindInfo] -> [MonoBindInfo]
forall a. a -> [a] -> [a]
: [MonoBindInfo]
rest
get_info (TcPatBind [MonoBindInfo]
infos LPat GhcTc
_ GRHSs GhcRn (LHsExpr GhcRn)
_ Type
_) [MonoBindInfo]
rest = [MonoBindInfo]
infos [MonoBindInfo] -> [MonoBindInfo] -> [MonoBindInfo]
forall a. [a] -> [a] -> [a]
++ [MonoBindInfo]
rest
data GeneralisationPlan
= NoGen
| InferGen
Bool
| CheckGen (LHsBind GhcRn) TcIdSigInfo
instance Outputable GeneralisationPlan where
ppr :: GeneralisationPlan -> SDoc
ppr GeneralisationPlan
NoGen = String -> SDoc
text String
"NoGen"
ppr (InferGen Bool
b) = String -> SDoc
text String
"InferGen" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b
ppr (CheckGen LHsBind GhcRn
_ TcIdSigInfo
s) = String -> SDoc
text String
"CheckGen" SDoc -> SDoc -> SDoc
<+> TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
s
decideGeneralisationPlan
:: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun
-> [LHsBind GhcRn] -> GeneralisationPlan
decideGeneralisationPlan :: DynFlags
-> TopLevelFlag
-> IsGroupClosed
-> TcSigFun
-> [LHsBind GhcRn]
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags TopLevelFlag
top_lvl IsGroupClosed
closed TcSigFun
sig_fn [LHsBind GhcRn]
lbinds
| Bool
has_partial_sigs = Bool -> GeneralisationPlan
InferGen ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
partial_sig_mrs)
| Just (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind, TcIdSigInfo
sig) <- Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), TcIdSigInfo)
one_funbind_with_sig = LHsBind GhcRn -> TcIdSigInfo -> GeneralisationPlan
CheckGen LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
bind TcIdSigInfo
sig
| Bool
do_not_generalise = GeneralisationPlan
NoGen
| Bool
otherwise = Bool -> GeneralisationPlan
InferGen Bool
mono_restriction
where
binds :: [HsBindLR GhcRn GhcRn]
binds = (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
-> [HsBindLR GhcRn GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn
forall l e. GenLocated l e -> e
unLoc [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
lbinds
partial_sig_mrs :: [Bool]
partial_sig_mrs :: [Bool]
partial_sig_mrs
= [ [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (LHsContext GhcRn) -> HsContext GhcRn
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
mtheta
| TcIdSig (PartialSig { psig_hs_ty :: TcIdSigInfo -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty })
<- TcSigFun -> [Name] -> [TcSigInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcSigFun
sig_fn (CollectFlag GhcRn -> [LHsBind GhcRn] -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders [LHsBind GhcRn]
lbinds)
, let (Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
mtheta, GenLocated SrcSpanAnnA (HsType GhcRn)
_) = LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy (LHsSigWcType GhcRn -> LHsType GhcRn
forall p. UnXRec p => LHsSigWcType p -> LHsType p
hsSigWcType LHsSigWcType GhcRn
hs_ty) ]
has_partial_sigs :: Bool
has_partial_sigs = Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
partial_sig_mrs)
mono_restriction :: Bool
mono_restriction = Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonomorphismRestriction DynFlags
dflags
Bool -> Bool -> Bool
&& (HsBindLR GhcRn GhcRn -> Bool) -> [HsBindLR GhcRn GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsBindLR GhcRn GhcRn -> Bool
restricted [HsBindLR GhcRn GhcRn]
binds
do_not_generalise :: Bool
do_not_generalise
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Bool
False
| IsGroupClosed NameEnv (UniqSet Name)
_ Bool
True <- IsGroupClosed
closed = Bool
False
| Bool
otherwise = Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonoLocalBinds DynFlags
dflags
one_funbind_with_sig :: Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), TcIdSigInfo)
one_funbind_with_sig
| [lbind :: LHsBind GhcRn
lbind@(L _ (FunBind { fun_id = v }))] <- [LHsBind GhcRn]
lbinds
, Just (TcIdSig TcIdSigInfo
sig) <- TcSigFun
sig_fn (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
v)
= (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), TcIdSigInfo)
-> Maybe
(GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), TcIdSigInfo)
forall a. a -> Maybe a
Just (LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
lbind, TcIdSigInfo
sig)
| Bool
otherwise
= Maybe (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn), TcIdSigInfo)
forall a. Maybe a
Nothing
restricted :: HsBindLR GhcRn GhcRn -> Bool
restricted (PatBind {}) = Bool
True
restricted (VarBind { var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP GhcRn
v }) = Name -> Bool
no_sig IdP GhcRn
Name
v
restricted (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
v, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
m }) = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> Bool
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
m
Bool -> Bool -> Bool
&& Name -> Bool
no_sig (GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
v)
restricted HsBindLR GhcRn GhcRn
b = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isRestrictedGroup/unrestricted" (HsBindLR GhcRn GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcRn GhcRn
b)
restricted_match :: MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup (GhcPass id) body
mg = MatchGroup (GhcPass id) body -> BKey
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> BKey
matchGroupArity MatchGroup (GhcPass id) body
mg BKey -> BKey -> Bool
forall a. Eq a => a -> a -> Bool
== BKey
0
no_sig :: Name -> Bool
no_sig Name
n = Bool -> Bool
not (TcSigFun -> Name -> Bool
hasCompleteSig TcSigFun
sig_fn Name
n)
isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
isClosedBndrGroup :: TcTypeEnv -> LHsBinds GhcRn -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env LHsBinds GhcRn
binds
= NameEnv (UniqSet Name) -> Bool -> IsGroupClosed
IsGroupClosed NameEnv (UniqSet Name)
fv_env Bool
type_closed
where
type_closed :: Bool
type_closed = (UniqSet Name -> Bool) -> NameEnv (UniqSet Name) -> Bool
forall elt key. (elt -> Bool) -> UniqFM key elt -> Bool
allUFM ((Name -> Bool) -> UniqSet Name -> Bool
nameSetAll Name -> Bool
is_closed_type_id) NameEnv (UniqSet Name)
fv_env
fv_env :: NameEnv NameSet
fv_env :: NameEnv (UniqSet Name)
fv_env = [(Name, UniqSet Name)] -> NameEnv (UniqSet Name)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, UniqSet Name)] -> NameEnv (UniqSet Name))
-> [(Name, UniqSet Name)] -> NameEnv (UniqSet Name)
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> [(Name, UniqSet Name)])
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> [(Name, UniqSet Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBindLR GhcRn GhcRn -> [(Name, UniqSet Name)]
bindFvs (HsBindLR GhcRn GhcRn -> [(Name, UniqSet Name)])
-> (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn)
-> GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> [(Name, UniqSet Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> HsBindLR GhcRn GhcRn
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds
bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, UniqSet Name)]
bindFvs (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L _ f
, fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcRn GhcRn
fvs })
= let open_fvs :: UniqSet Name
open_fvs = UniqSet Name -> UniqSet Name
get_open_fvs XFunBind GhcRn GhcRn
UniqSet Name
fvs
in [(Name
f, UniqSet Name
open_fvs)]
bindFvs (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcRn
pat, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind GhcRn GhcRn
fvs })
= let open_fvs :: UniqSet Name
open_fvs = UniqSet Name -> UniqSet Name
get_open_fvs XPatBind GhcRn GhcRn
UniqSet Name
fvs
in [(Name
b, UniqSet Name
open_fvs) | Name
b <- CollectFlag GhcRn -> LPat GhcRn -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat]
bindFvs HsBindLR GhcRn GhcRn
_
= []
get_open_fvs :: UniqSet Name -> UniqSet Name
get_open_fvs UniqSet Name
fvs = (Name -> Bool) -> UniqSet Name -> UniqSet Name
filterNameSet (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
is_closed) UniqSet Name
fvs
is_closed :: Name -> ClosedTypeId
is_closed :: Name -> Bool
is_closed Name
name
| Just TcTyThing
thing <- TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
name
= case TcTyThing
thing of
AGlobal {} -> Bool
True
ATcId { tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
ClosedLet } -> Bool
True
TcTyThing
_ -> Bool
False
| Bool
otherwise
= Bool
True
is_closed_type_id :: Name -> Bool
is_closed_type_id :: Name -> Bool
is_closed_type_id Name
name
| Just TcTyThing
thing <- TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
name
= case TcTyThing
thing of
ATcId { tct_info :: TcTyThing -> IdBindingInfo
tct_info = NonClosedLet UniqSet Name
_ Bool
cl } -> Bool
cl
ATcId { tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
NotLetBound } -> Bool
False
ATyVar {} -> Bool
False
TcTyThing
_ -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"is_closed_id" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
| Bool
otherwise
= Bool
True
patMonoBindsCtxt :: (OutputableBndrId p)
=> LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt :: LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt LPat (GhcPass p)
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss
= SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"In a pattern binding:") BKey
2 (LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (bndr :: Pass) (p :: Pass).
(OutputableBndrId bndr, OutputableBndrId p) =>
LPat (GhcPass bndr)
-> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc
pprPatBind LPat (GhcPass p)
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss)