{-# 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, mkDeclCCFlavour)
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_syntactic )
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.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity (checkValidType, checkEscapingKind)
import GHC.Core.Predicate
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class ( Class )
import GHC.Core.Coercion( mkSymCo )
import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Builtin.Types ( mkConstraintTupleTy )
import GHC.Builtin.Types.Prim
import GHC.Unit.Module
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, TyVarEnv, mkVarEnv, lookupVarEnv )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Utils.Error
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.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Bag
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
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 (HsBind GhcRn)))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [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
= specs ++ tcg_imp_specs tcg_env
, tcg_complete_matches
= complete_matches
++ tcg_complete_matches 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 SrcSpanAnnA
loc c :: Sig GhcRn
c@(CompleteMatchSig (EpAnn [AddEpAnn]
_ext, SourceText
_src_txt) (L SrcSpan
_ [GenLocated SrcSpanAnnN Name]
ns) Maybe (LIdP GhcRn)
mb_tc_nm))
= (CompleteMatch -> Maybe CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
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
forall doc. IsLine doc => String -> doc
text String
"In" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) ConLike)
-> [GenLocated SrcSpanAnnN Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [ConLike]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Name -> IOEnv (Env TcGblEnv TcLclEnv) ConLike)
-> GenLocated SrcSpanAnnN 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 SrcSpanAnnN Name]
ns
Maybe TyCon
mb_tc <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @Maybe GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupLocatedTyCon Maybe (LIdP GhcRn)
Maybe (GenLocated SrcSpanAnnN Name)
mb_tc_nm
CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 [TcId]
tcHsBootSigs [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs
= do { Bool -> TcRnMessage -> TcRn ()
checkTc ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds) TcRnMessage
TcRnIllegalHsBootFileDecl
; (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM [TcId])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcM [TcId]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((Sig GhcRn -> TcM [TcId])
-> GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM [TcId]
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Sig GhcRn -> TcM [TcId]
tc_boot_sig) ((GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
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 [TcId]
tc_boot_sig (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
lnames LHsSigWcType GhcRn
hs_ty) = (GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [GenLocated SrcSpanAnnN Name] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
f [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
lnames
where
f :: GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
f (L SrcSpanAnnN
_ Name
name)
= do { Kind
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Kind
tcHsSigWcType (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigWcType GhcRn
hs_ty
; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> TcId
mkVanillaGlobal Name
name Kind
sigma_ty) }
tc_boot_sig Sig GhcRn
s = String -> SDoc -> TcM [TcId]
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 :: forall thing.
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 GhcRn GhcRn
XEmptyLocalBinds GhcTc GhcTc
x, thing
thing) }
tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
x (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 GhcRn GhcRn
XHsValBinds GhcTc GhcTc
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. HasCallStack => 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
; ([TcId]
given_ips, [GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds') <-
(GenLocated SrcSpanAnnA (IPBind GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcId, GenLocated SrcSpanAnnA (IPBind GhcTc)))
-> [GenLocated SrcSpanAnnA (IPBind GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TcId], [GenLocated SrcSpanAnnA (IPBind GhcTc)])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((IPBind GhcRn -> TcM (TcId, IPBind GhcTc))
-> GenLocated SrcSpanAnnA (IPBind GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(TcId, 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 (TcId, IPBind GhcTc)
tc_ip_bind Class
ipClass)) [LIPBind GhcRn]
[GenLocated SrcSpanAnnA (IPBind GhcRn)]
ip_binds
; (TcEvBinds
ev_binds, thing
result) <- SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM thing -> TcM (TcEvBinds, thing)
forall result.
SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints ([HsIPName] -> SkolemInfoAnon
IPSkol [HsIPName]
ips)
[] [TcId]
given_ips TcM thing
thing_inside
; (HsLocalBinds GhcTc, thing) -> TcM (HsLocalBinds GhcTc, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 GhcRn GhcRn
XHsIPBinds GhcTc GhcTc
x (XIPBinds GhcTc -> [LIPBind GhcTc] -> HsIPBinds GhcTc
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds XIPBinds GhcTc
TcEvBinds
ev_binds [LIPBind GhcTc]
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds') , thing
result) }
where
ips :: [HsIPName]
ips = [HsIPName
ip | (L SrcSpanAnnA
_ (IPBind XCIPBind GhcRn
_ (L SrcAnn NoEpAnns
_ HsIPName
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 (TcId, IPBind GhcTc)
tc_ip_bind Class
ipClass (IPBind XCIPBind GhcRn
_ l_name :: XRec GhcRn HsIPName
l_name@(L SrcAnn NoEpAnns
_ HsIPName
ip) LHsExpr GhcRn
expr)
= do { Kind
ty <- TcM Kind
newOpenFlexiTyVarTy
; let p :: Kind
p = FastString -> Kind
mkStrLitTy (FastString -> Kind) -> FastString -> Kind
forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
ip
; TcId
ip_id <- Class -> TcThetaType -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newDict Class
ipClass [ Kind
p, Kind
ty ]
; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Kind -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Kind
ty
; let d :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
d = (HsExpr GhcTc -> HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Class -> Kind -> Kind -> HsExpr GhcTc -> HsExpr GhcTc
toDict Class
ipClass Kind
p Kind
ty) GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'
; (TcId, IPBind GhcTc) -> TcM (TcId, IPBind GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId
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
TcId
ip_id XRec GhcRn HsIPName
XRec GhcTc HsIPName
l_name LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
d)) }
toDict :: Class
-> Type
-> Type
-> HsExpr GhcTc
-> HsExpr GhcTc
toDict :: Class -> Kind -> Kind -> HsExpr GhcTc -> HsExpr GhcTc
toDict Class
ipClass Kind
x Kind
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
$
Kind -> TcCoercionR
wrapIP (Kind -> TcCoercionR) -> Kind -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> TcThetaType -> Kind
mkClassPred Class
ipClass [Kind
x,Kind
ty]
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds :: forall thing.
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 {
([TcId]
poly_ids, TcSigFun
sig_fn) <- [PatSynBind GhcRn GhcRn]
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a. [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders [PatSynBind GhcRn GhcRn]
patsyns (TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun))
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a b. (a -> b) -> a -> b
$
[LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs [LSig GhcRn]
sigs
; TopLevelFlag
-> [TcId]
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
-> TcM
([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
thing)
forall a. TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendSigIds TopLevelFlag
top_lvl [TcId]
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a. Bag a -> Bag a -> Bag a
unionBags (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a, b) -> b
snd) Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a. Bag a
emptyBag [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds)
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcBindGroups :: forall thing.
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a, b) -> b
snd (RecFlag, LHsBinds GhcRn)
(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 :: 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
NonRecursive, LHsBinds GhcRn
binds) IsGroupClosed
closed TcM thing
thing_inside
= do { let bind :: GenLocated SrcSpanAnnA (HsBind GhcRn)
bind = case Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds of
[GenLocated SrcSpanAnnA (HsBind GhcRn)
bind] -> GenLocated SrcSpanAnnA (HsBind GhcRn)
bind
[] -> String -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a. HasCallStack => String -> a
panic String
"tc_group: empty list of binds"
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
_ -> String -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a. HasCallStack => 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 (HsBind 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (HsBind GhcRn))
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
mbFirstPatSyn ((GenLocated SrcSpanAnnA (HsBind GhcRn) -> TcRn ()) -> TcRn ())
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (HsBind 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 (HsBind GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsBind 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (HsBind GhcRn))
mbFirstPatSyn = (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (HsBind GhcRn -> Bool
forall {idL} {idR}. HsBindLR idL idR -> Bool
isPatSyn (HsBind GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind 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 (HsBind GhcRn))]
-> [SCC (GenLocated SrcSpanAnnA (HsBind 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, [TcId]
ids1) <- SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> TcM (LHsBinds GhcTc, [TcId])
tc_scc SCC (LHsBind GhcRn)
SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
scc
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds2, thing
thing) <- TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [TcId]
-> 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 -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [TcId]
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (HsBind GhcRn))
-> TcM (LHsBinds GhcTc, [TcId])
tc_scc (AcyclicSCC GenLocated SrcSpanAnnA (HsBind GhcRn)
bind) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [TcId])
tc_sub_group RecFlag
NonRecursive [GenLocated SrcSpanAnnA (HsBind GhcRn)
bind]
tc_scc (CyclicSCC [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [TcId])
tc_sub_group RecFlag
Recursive [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds
tc_sub_group :: RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [TcId])
tc_sub_group RecFlag
rec_tc [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds = TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
RecFlag
Recursive RecFlag
rec_tc IsGroupClosed
closed [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds
recursivePatSynErr
:: SrcSpan
-> LHsBinds GhcRn
-> TcM a
recursivePatSynErr :: forall a. SrcSpan -> LHsBinds GhcRn -> TcM a
recursivePatSynErr SrcSpan
loc LHsBinds GhcRn
binds
= SrcSpan -> TcRnMessage -> TcRn a
forall a. SrcSpan -> TcRnMessage -> TcRn a
failAt SrcSpan
loc (TcRnMessage -> TcRn a) -> TcRnMessage -> TcRn 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 :: 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
(L SrcSpanAnnA
loc (PatSynBind XPatSynBind GhcRn GhcRn
_ PatSynBind GhcRn GhcRn
psb))
IsGroupClosed
_ TcM thing
thing_inside
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
aux_binds, TcGblEnv
tcg_env) <- LocatedA (PatSynBind GhcRn GhcRn)
-> TcSigFun -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl (SrcSpanAnnA
-> PatSynBind GhcRn GhcRn -> LocatedA (PatSynBind GhcRn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc PatSynBind GhcRn GhcRn
psb) TcSigFun
sig_fn 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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, [TcId]
ids) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
RecFlag
NonRecursive RecFlag
NonRecursive
IsGroupClosed
closed
[LHsBind GhcRn
lbind]
; thing
thing <- TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [TcId] -> TcM thing -> TcM thing
forall a.
TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [TcId]
ids TcM thing
thing_inside
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 (HsBind GhcRn)
-> BKey
-> [BKey]
-> Node BKey (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenLocated SrcSpanAnnA (HsBind GhcRn)
bind BKey
key [BKey
key | Name
n <- UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (HsBind GhcRn -> XFunBind GhcRn GhcRn
forall {idL} {idR}.
(XFunBind idL idR ~ UniqSet Name,
XPatBind idL idR ~ UniqSet Name) =>
HsBindLR idL idR -> XFunBind idL idR
bind_fvs (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBind 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 (HsBind GhcRn)
bind, BKey
key) <- [(GenLocated SrcSpanAnnA (HsBind GhcRn), BKey)]
keyd_binds
]
where
bind_fvs :: HsBindLR idL idR -> XFunBind idL idR
bind_fvs (FunBind { fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind idL idR
fvs }) = XFunBind idL idR
fvs
bind_fvs (PatBind { pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind idL idR
fvs }) = XPatBind idL idR
XFunBind idL idR
fvs
bind_fvs HsBindLR idL idR
_ = XFunBind 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 (HsBind GhcRn), BKey)]
keyd_binds = Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> [BKey] -> [(GenLocated SrcSpanAnnA (HsBind 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
_ HsBind GhcRn
bind, BKey
key) <- [(GenLocated SrcSpanAnnA (HsBind GhcRn), BKey)]
keyd_binds
, Name
bndr <- CollectFlag GhcRn -> HsBind GhcRn -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> HsBindLR p idR -> [IdP p]
collectHsBindBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsBind 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, [TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn RecFlag
rec_group RecFlag
rec_tc IsGroupClosed
closed [LHsBind GhcRn]
bind_list
= SrcSpan
-> TcM (LHsBinds GhcTc, [TcId]) -> TcM (LHsBinds GhcTc, [TcId])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsBinds GhcTc, [TcId]) -> TcM (LHsBinds GhcTc, [TcId]))
-> TcM (LHsBinds GhcTc, [TcId]) -> TcM (LHsBinds GhcTc, [TcId])
forall a b. (a -> b) -> a -> b
$
TcM (LHsBinds GhcTc, [TcId])
-> TcM (LHsBinds GhcTc, [TcId]) -> TcM (LHsBinds GhcTc, [TcId])
forall r. TcRn r -> TcRn r -> TcRn r
recoverM ([Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [TcId])
recoveryCode [IdP GhcRn]
[Name]
binder_names TcSigFun
sig_fn) (TcM (LHsBinds GhcTc, [TcId]) -> TcM (LHsBinds GhcTc, [TcId]))
-> TcM (LHsBinds GhcTc, [TcId]) -> TcM (LHsBinds GhcTc, [TcId])
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRn ()
traceTc String
"------------------------------------------------" SDoc
forall doc. IsOutput doc => doc
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)), [TcId])
result@(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
_, [TcId]
poly_ids) <- case GeneralisationPlan
plan of
GeneralisationPlan
NoGen -> RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn [LHsBind GhcRn]
bind_list
GeneralisationPlan
InferGen -> RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn [LHsBind GhcRn]
bind_list
CheckGen LHsBind GhcRn
lbind TcIdSigInfo
sig -> TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck TcPragEnv
prag_fn TcIdSigInfo
sig LHsBind GhcRn
lbind
; (TcId -> TcRn ()) -> [TcId] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ TcId
poly_id ->
(() :: Constraint) => FixedRuntimeRepContext -> Kind -> TcRn ()
FixedRuntimeRepContext -> Kind -> TcRn ()
hasFixedRuntimeRep_syntactic (Name -> FixedRuntimeRepContext
FRRBinder (Name -> FixedRuntimeRepContext) -> Name -> FixedRuntimeRepContext
forall a b. (a -> b) -> a -> b
$ TcId -> Name
idName TcId
poly_id) (TcId -> Kind
idType TcId
poly_id))
[TcId]
poly_ids
; String -> SDoc -> TcRn ()
traceTc String
"} End of bindings for" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => [doc] -> doc
vcat [TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id) | TcId
id <- [TcId]
poly_ids]
])
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
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 a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan)
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpanAnnA)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc) [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
bind_list)
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id])
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [TcId])
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 :: [TcId]
poly_ids = (Name -> TcId) -> [Name] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TcId
mk_dummy [Name]
binder_names
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, [TcId]
poly_ids) }
where
mk_dummy :: Name -> TcId
mk_dummy Name
name
| Just TcSigInfo
sig <- TcSigFun
sig_fn Name
name
, Just TcId
poly_id <- TcSigInfo -> Maybe TcId
completeSigPolyId_maybe TcSigInfo
sig
= TcId
poly_id
| Bool
otherwise
= (() :: Constraint) => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
name Kind
ManyTy Kind
forall_a_a
forall_a_a :: TcType
forall_a_a :: Kind
forall_a_a = [TcId] -> Kind -> Kind
mkSpecForAllTys [TcId
alphaTyVar] Kind
alphaTy
tcPolyNoGen
:: RecFlag
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyNoGen :: RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
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
; [TcId]
mono_ids' <- (MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [MonoBindInfo] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tc_mono_info [MonoBindInfo]
mono_infos
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [TcId]
mono_ids') }
where
tc_mono_info :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tc_mono_info (MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
name, mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id = TcId
mono_id })
= do { [LTcSpecPrag]
_specs <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
mono_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name)
; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
mono_id }
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo
-> LHsBind GhcRn
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo -> LHsBind GhcRn -> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck TcPragEnv
prag_fn
(CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id
, sig_ctxt :: TcIdSigInfo -> UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
sig_loc })
(L SrcSpanAnnA
bind_loc (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
nm_loc Name
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matches }))
= do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyCheck" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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) (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
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
-> Kind
-> (Kind
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall result.
UserTypeCtxt
-> Kind -> (Kind -> TcM result) -> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ctxt (TcId -> Kind
idType TcId
poly_id) ((Kind
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> (Kind
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcRn
(HsWrapper,
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ \Kind
rho_ty ->
let mono_id :: TcId
mono_id = (() :: Constraint) => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
mono_name (TcId -> Kind
varMult TcId
poly_id) Kind
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 [TcId -> TopLevelFlag -> TcBinder
TcIdBndr TcId
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
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
bind_loc (TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nm_loc (TcId -> Name
idName TcId
mono_id)) MatchGroup GhcRn (LHsExpr GhcRn)
matches
(Kind -> ExpSigmaType
mkCheckExpType Kind
rho_ty)
; let prag_sigs :: [LSig GhcRn]
prag_sigs = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name
poly_id2 :: TcId
poly_id2 = (() :: Constraint) => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
mono_name (TcId -> Kind
idMult TcId
poly_id) (TcId -> Kind
idType TcId
poly_id)
; [LTcSpecPrag]
spec_prags <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
poly_id [LSig GhcRn]
prag_sigs
; TcId
poly_id <- TcId -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id [LSig GhcRn]
prag_sigs
; Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; [CoreTickish]
tick <- SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish]
funBindTicks (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
nm_loc) TcId
poly_id Module
mod [LSig GhcRn]
prag_sigs
; let bind' :: HsBindLR GhcTc GhcTc
bind' = FunBind { fun_id :: LIdP GhcTc
fun_id = SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nm_loc TcId
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, [CoreTickish]
tick)
}
export :: ABExport
export = ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: TcId
abe_poly = TcId
poly_id
, abe_mono :: TcId
abe_mono = TcId
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 { abs_tvs :: [TcId]
abs_tvs = []
, abs_ev_vars :: [TcId]
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)), [TcId])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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, [TcId
poly_id]) }
tcPolyCheck TcPragEnv
_prag_fn TcIdSigInfo
sig LHsBind GhcRn
bind
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcPolyCheck" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsBind GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
bind)
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-> TcM [CoreTickish]
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish]
funBindTicks SrcSpan
loc TcId
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
_ 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 (TcId -> Name
Var.varName TcId
fun_id)
cc_name :: FastString
cc_name = [FastString] -> FastString
concatFS [ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod), String -> FastString
fsLit String
".", FastString
cc_str]
= do
CCFlavour
flavour <- CostCentreIndex -> CCFlavour
mkDeclCCFlavour (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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcPolyInfer
:: RecFlag
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyInfer :: RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn [LHsBind GhcRn]
bind_list
= do { (TcLevel
tclvl, WantedConstraints
wanted, (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [MonoBindInfo]
mono_infos))
<- TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM
(TcLevel, WantedConstraints, (LHsBinds GhcTc, [MonoBindInfo]))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM
(TcLevel, WantedConstraints, (LHsBinds GhcTc, [MonoBindInfo])))
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM
(TcLevel, WantedConstraints, (LHsBinds 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
; Bool
apply_mr <- [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
checkMonomorphismRestriction [MonoBindInfo]
mono_infos [LHsBind GhcRn]
bind_list
; String -> SDoc -> TcRn ()
traceTc String
"tcPolyInfer" (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
apply_mr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Maybe TcIdSigInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((MonoBindInfo -> Maybe TcIdSigInst)
-> [MonoBindInfo] -> [Maybe TcIdSigInst]
forall a b. (a -> b) -> [a] -> [b]
map MonoBindInfo -> Maybe TcIdSigInst
mbi_sig [MonoBindInfo]
mono_infos))
; let name_taus :: [(Name, Kind)]
name_taus = [ (MonoBindInfo -> Name
mbi_poly_name MonoBindInfo
info, TcId -> Kind
idType (MonoBindInfo -> TcId
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
apply_mr then InferMode
ApplyMR else InferMode
NoRestrictions
; String -> SDoc -> TcRn ()
traceTc String
"simplifyInfer call" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [(Name, Kind)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, Kind)]
name_taus SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)
; (([TcId]
qtvs, [TcId]
givens, TcEvBinds
ev_binds, Bool
insoluble), WantedConstraints
residual)
<- TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints))
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Kind)]
-> WantedConstraints
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst]
sigs [(Name, Kind)]
name_taus WantedConstraints
wanted
; let inferred_theta :: TcThetaType
inferred_theta = (TcId -> Kind) -> [TcId] -> TcThetaType
forall a b. (a -> b) -> [a] -> [b]
map TcId -> Kind
evVarPred [TcId]
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcPragEnv
-> WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) ABExport
mkExport TcPragEnv
prag_fn WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
inferred_theta) [MonoBindInfo]
mono_infos
; WantedConstraints -> TcRn ()
emitConstraints WantedConstraints
residual
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; let poly_ids :: [TcId]
poly_ids = (ABExport -> TcId) -> [ABExport] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map ABExport -> TcId
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 { abs_tvs :: [TcId]
abs_tvs = [TcId]
qtvs
, abs_ev_vars :: [TcId]
abs_ev_vars = [TcId]
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:" ([(TcId, Kind)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TcId]
poly_ids [TcId] -> TcThetaType -> [(TcId, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (TcId -> Kind) -> [TcId] -> TcThetaType
forall a b. (a -> b) -> [a] -> [b]
map TcId -> Kind
idType [TcId]
poly_ids))
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), [TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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, [TcId]
poly_ids) }
checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
checkMonomorphismRestriction [MonoBindInfo]
mbis [LHsBind GhcRn]
lbinds
| [TcIdSigInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcIdSigInst]
partial_sigs
= do { Bool
mr_on <- Extension -> TcM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.MonomorphismRestriction
; let mr_applies :: Bool
mr_applies = Bool
mr_on Bool -> Bool -> Bool
&& (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsBind GhcRn -> Bool
forall {idL} {l} {id :: Pass}.
(IdP idL ~ Name, XRec idL Name ~ GenLocated l Name,
Outputable (HsBindLR idL (GhcPass id))) =>
HsBindLR idL (GhcPass id) -> Bool
restricted (HsBind GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc) [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
lbinds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mr_applies (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ (TcIdSigInst -> TcRn ()) -> [TcIdSigInst] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TcIdSigInst -> TcRn ()
checkOverloadedSig [TcIdSigInst]
sigs
; Bool -> TcM Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
mr_applies }
| Bool
otherwise
= Bool -> TcM Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TcIdSigInst -> Bool) -> [TcIdSigInst] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcIdSigInst -> Bool
is_mono_psig [TcIdSigInst]
partial_sigs)
where
sigs, partial_sigs :: [TcIdSigInst]
sigs :: [TcIdSigInst]
sigs = [TcIdSigInst
sig | MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig } <- [MonoBindInfo]
mbis]
partial_sigs :: [TcIdSigInst]
partial_sigs = [TcIdSigInst
sig | sig :: TcIdSigInst
sig@(TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = PartialSig {} }) <- [TcIdSigInst]
sigs]
complete_sig_bndrs :: NameSet
complete_sig_bndrs :: UniqSet Name
complete_sig_bndrs
= [Name] -> UniqSet Name
mkNameSet [ TcId -> Name
idName TcId
bndr
| TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
bndr }} <- [TcIdSigInst]
sigs ]
is_mono_psig :: TcIdSigInst -> Bool
is_mono_psig (TISI { sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
theta, sig_inst_wcx :: TcIdSigInst -> Maybe Kind
sig_inst_wcx = Maybe Kind
mb_extra_constraints })
= TcThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TcThetaType
theta Bool -> Bool -> Bool
&& Maybe Kind -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Kind
mb_extra_constraints
restricted :: HsBindLR idL (GhcPass id) -> Bool
restricted (PatBind {}) = Bool
True
restricted (VarBind { var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP idL
v }) = Name -> Bool
no_sig IdP idL
Name
v
restricted (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP idL
v, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup (GhcPass id) (LHsExpr (GhcPass id))
m }) = MatchGroup
(GhcPass id) (GenLocated SrcSpanAnnA (HsExpr (GhcPass id)))
-> Bool
forall {id :: Pass} {body}. MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup (GhcPass id) (LHsExpr (GhcPass id))
MatchGroup
(GhcPass id) (GenLocated SrcSpanAnnA (HsExpr (GhcPass id)))
m
Bool -> Bool -> Bool
&& Name -> Bool
no_sig (GenLocated l Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP idL
GenLocated l Name
v)
restricted HsBindLR idL (GhcPass id)
b = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isRestrictedGroup/unrestricted" (HsBindLR idL (GhcPass id) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR idL (GhcPass id)
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
nm = Bool -> Bool
not (Name
nm Name -> UniqSet Name -> Bool
`elemNameSet` UniqSet Name
complete_sig_bndrs)
checkOverloadedSig :: TcIdSigInst -> TcM ()
checkOverloadedSig :: TcIdSigInst -> TcRn ()
checkOverloadedSig TcIdSigInst
sig
| Bool -> Bool
not (TcThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> TcThetaType
sig_inst_theta TcIdSigInst
sig))
, 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkExport :: TcPragEnv
-> WantedConstraints
-> Bool
-> [TyVar] -> TcThetaType
-> MonoBindInfo
-> TcM ABExport
mkExport :: TcPragEnv
-> WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) ABExport
mkExport TcPragEnv
prag_fn WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
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 -> TcId
mbi_mono_id = TcId
mono_id })
= do { Kind
mono_ty <- Kind -> TcM Kind
zonkTcType (TcId -> Kind
idType TcId
mono_id)
; TcId
poly_id <- WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> Name
-> Maybe TcIdSigInst
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
mkInferredPolyId WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
theta Name
poly_name Maybe TcIdSigInst
mb_sig Kind
mono_ty
; TcId
poly_id <- TcId -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id [LSig GhcRn]
prag_sigs
; [LTcSpecPrag]
spec_prags <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
poly_id [LSig GhcRn]
prag_sigs
; let poly_ty :: Kind
poly_ty = TcId -> Kind
idType TcId
poly_id
sel_poly_ty :: Kind
sel_poly_ty = [TcId] -> TcThetaType -> Kind -> Kind
(() :: Constraint) => [TcId] -> TcThetaType -> Kind -> Kind
mkInfSigmaTy [TcId]
qtvs TcThetaType
theta Kind
mono_ty
; String -> SDoc -> TcRn ()
traceTc String
"mkExport" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
poly_ty
, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
sel_poly_ty ])
; HsWrapper
wrap <- if Kind
sel_poly_ty Kind -> Kind -> Bool
`eqType` Kind
poly_ty
then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
else CtOrigin
-> UserTypeCtxt
-> Kind
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma CtOrigin
GhcBug20076
UserTypeCtxt
sig_ctxt Kind
sel_poly_ty Kind
poly_ty
; TcId -> Maybe TcIdSigInst -> TcRn ()
localSigWarn TcId
poly_id Maybe TcIdSigInst
mb_sig
; ABExport -> IOEnv (Env TcGblEnv TcLclEnv) ABExport
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
wrap
, abe_poly :: TcId
abe_poly = TcId
poly_id
, abe_mono :: TcId
abe_mono = TcId
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
-> [TcId]
-> TcThetaType
-> Name
-> Maybe TcIdSigInst
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
mkInferredPolyId WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
inferred_theta Name
poly_name Maybe TcIdSigInst
mb_sig_inst Kind
mono_ty
| Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = TcIdSigInfo
sig }) <- Maybe TcIdSigInst
mb_sig_inst
, CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id } <- TcIdSigInfo
sig
= TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
poly_id
| Bool
otherwise
= IOEnv (Env TcGblEnv TcLclEnv) TcId
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall r. TcM r -> TcM r
checkNoErrs (IOEnv (Env TcGblEnv TcLclEnv) TcId
-> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a b. (a -> b) -> a -> b
$
do { FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let mono_ty' :: Kind
mono_ty' = Reduction -> Kind
reductionReducedType (Reduction -> Kind) -> Reduction -> Kind
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> Role -> Kind -> Reduction
normaliseType FamInstEnvs
fam_envs Role
Nominal Kind
mono_ty
; ([VarBndr TcId Specificity]
binders, TcThetaType
theta') <- WantedConstraints
-> TcThetaType
-> VarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([VarBndr TcId Specificity], TcThetaType)
chooseInferredQuantifiers WantedConstraints
residual TcThetaType
inferred_theta
(Kind -> VarSet
tyCoVarsOfType Kind
mono_ty') [TcId]
qtvs Maybe TcIdSigInst
mb_sig_inst
; let inferred_poly_ty :: Kind
inferred_poly_ty = [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
binders (TcThetaType -> Kind -> Kind
(() :: Constraint) => TcThetaType -> Kind -> Kind
mkPhiTy TcThetaType
theta' Kind
mono_ty')
; String -> SDoc -> TcRn ()
traceTc String
"mkInferredPolyId" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
poly_name, [TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
qtvs, TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
theta'
, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
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 -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
inferred_poly_ty) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { Kind -> TcRn ()
checkEscapingKind Kind
inferred_poly_ty
; UserTypeCtxt -> Kind -> TcRn ()
checkValidType (Name -> UserTypeCtxt
InfSigCtxt Name
poly_name) Kind
inferred_poly_ty }
; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((() :: Constraint) => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
poly_name Kind
ManyTy Kind
inferred_poly_ty) }
chooseInferredQuantifiers :: WantedConstraints
-> TcThetaType
-> TcTyVarSet
-> [TcTyVar]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], TcThetaType)
chooseInferredQuantifiers :: WantedConstraints
-> TcThetaType
-> VarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([VarBndr TcId Specificity], TcThetaType)
chooseInferredQuantifiers WantedConstraints
_residual TcThetaType
inferred_theta VarSet
tau_tvs [TcId]
qtvs Maybe TcIdSigInst
Nothing
=
do { let free_tvs :: VarSet
free_tvs = VarSet -> VarSet
closeOverKinds (TcThetaType -> VarSet -> VarSet
growThetaTyVars TcThetaType
inferred_theta VarSet
tau_tvs)
my_theta :: TcThetaType
my_theta = VarSet -> TcThetaType -> TcThetaType
pickCapturedPreds VarSet
free_tvs TcThetaType
inferred_theta
binders :: [VarBndr TcId Specificity]
binders = [ Specificity -> TcId -> VarBndr TcId Specificity
forall vis. vis -> TcId -> VarBndr TcId vis
mkTyVarBinder Specificity
InferredSpec TcId
tv
| TcId
tv <- [TcId]
qtvs
, TcId
tv TcId -> VarSet -> Bool
`elemVarSet` VarSet
free_tvs ]
; ([VarBndr TcId Specificity], TcThetaType)
-> TcM ([VarBndr TcId Specificity], TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TcId Specificity]
binders, TcThetaType
my_theta) }
chooseInferredQuantifiers WantedConstraints
residual TcThetaType
inferred_theta VarSet
tau_tvs [TcId]
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 Kind
sig_inst_wcx = Maybe Kind
wcx
, sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
annotated_theta
, sig_inst_skols :: TcIdSigInst -> [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
annotated_tvs }))
=
do { let ([Name]
psig_qtv_nms, [VarBndr TcId Specificity]
psig_qtv_bndrs) = [(Name, VarBndr TcId Specificity)]
-> ([Name], [VarBndr TcId Specificity])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, VarBndr TcId Specificity)]
annotated_tvs
; [VarBndr TcId Specificity]
psig_qtv_bndrs <- (VarBndr TcId Specificity
-> IOEnv (Env TcGblEnv TcLclEnv) (VarBndr TcId Specificity))
-> [VarBndr TcId Specificity]
-> IOEnv (Env TcGblEnv TcLclEnv) [VarBndr TcId Specificity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarBndr TcId Specificity
-> IOEnv (Env TcGblEnv TcLclEnv) (VarBndr TcId Specificity)
forall spec. VarBndr TcId spec -> TcM (VarBndr TcId spec)
zonkInvisTVBinder [VarBndr TcId Specificity]
psig_qtv_bndrs
; let psig_qtvs :: [TcId]
psig_qtvs = (VarBndr TcId Specificity -> TcId)
-> [VarBndr TcId Specificity] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar [VarBndr TcId Specificity]
psig_qtv_bndrs
psig_qtv_set :: VarSet
psig_qtv_set = [TcId] -> VarSet
mkVarSet [TcId]
psig_qtvs
psig_qtv_prs :: [(Name, TcId)]
psig_qtv_prs = [Name]
psig_qtv_nms [Name] -> [TcId] -> [(Name, TcId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcId]
psig_qtvs
psig_bndr_map :: TyVarEnv InvisTVBinder
psig_bndr_map :: TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map = [(TcId, VarBndr TcId Specificity)]
-> TyVarEnv (VarBndr TcId Specificity)
forall a. [(TcId, a)] -> VarEnv a
mkVarEnv [ (VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr TcId Specificity
tvb, VarBndr TcId Specificity
tvb) | VarBndr TcId Specificity
tvb <- [VarBndr TcId Specificity]
psig_qtv_bndrs ]
; ((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, TcId)] -> [(Name, Name)]
findDupTyVarTvs [(Name, TcId)]
psig_qtv_prs)
; ((Name, TcId) -> TcRn ()) -> [(Name, TcId)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, TcId) -> TcRn ()
report_mono_sig_tv_err [ (Name, TcId)
pr | pr :: (Name, TcId)
pr@(Name
_,TcId
tv) <- [(Name, TcId)]
psig_qtv_prs
, Bool -> Bool
not (TcId
tv TcId -> [TcId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TcId]
qtvs) ]
; TcThetaType
annotated_theta <- TcThetaType -> TcM TcThetaType
zonkTcTypes TcThetaType
annotated_theta
; (VarSet
free_tvs, TcThetaType
my_theta) <- VarSet -> TcThetaType -> Maybe Kind -> TcM (VarSet, TcThetaType)
choose_psig_context VarSet
psig_qtv_set TcThetaType
annotated_theta Maybe Kind
wcx
; let (VarSet
_,[VarBndr TcId Specificity]
final_qtvs) = (TcId
-> (VarSet, [VarBndr TcId Specificity])
-> (VarSet, [VarBndr TcId Specificity]))
-> (VarSet, [VarBndr TcId Specificity])
-> [TcId]
-> (VarSet, [VarBndr TcId Specificity])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TyVarEnv (VarBndr TcId Specificity)
-> TcId
-> (VarSet, [VarBndr TcId Specificity])
-> (VarSet, [VarBndr TcId Specificity])
choose_qtv TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map) (VarSet
free_tvs, []) [TcId]
qtvs
; String -> SDoc -> TcRn ()
traceTc String
"chooseInferredQuantifiers" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"qtvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TcId] -> SDoc
pprTyVars [TcId]
qtvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"psig_qtv_bndrs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [VarBndr TcId Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr TcId Specificity]
psig_qtv_bndrs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"free_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
free_tvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"final_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [VarBndr TcId Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr TcId Specificity]
final_qtvs ]
; ([VarBndr TcId Specificity], TcThetaType)
-> TcM ([VarBndr TcId Specificity], TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TcId Specificity]
final_qtvs, TcThetaType
my_theta) }
where
choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar
-> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder])
choose_qtv :: TyVarEnv (VarBndr TcId Specificity)
-> TcId
-> (VarSet, [VarBndr TcId Specificity])
-> (VarSet, [VarBndr TcId Specificity])
choose_qtv TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map TcId
tv (VarSet
free_tvs, [VarBndr TcId Specificity]
qtvs)
| Just VarBndr TcId Specificity
psig_bndr <- TyVarEnv (VarBndr TcId Specificity)
-> TcId -> Maybe (VarBndr TcId Specificity)
forall a. VarEnv a -> TcId -> Maybe a
lookupVarEnv TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map TcId
tv
= (VarSet
free_tvs', VarBndr TcId Specificity
psig_bndr VarBndr TcId Specificity
-> [VarBndr TcId Specificity] -> [VarBndr TcId Specificity]
forall a. a -> [a] -> [a]
: [VarBndr TcId Specificity]
qtvs)
| TcId
tv TcId -> VarSet -> Bool
`elemVarSet` VarSet
free_tvs
= (VarSet
free_tvs', Specificity -> TcId -> VarBndr TcId Specificity
forall vis. vis -> TcId -> VarBndr TcId vis
mkTyVarBinder Specificity
InferredSpec TcId
tv VarBndr TcId Specificity
-> [VarBndr TcId Specificity] -> [VarBndr TcId Specificity]
forall a. a -> [a] -> [a]
: [VarBndr TcId Specificity]
qtvs)
| Bool
otherwise
= (VarSet
free_tvs, [VarBndr TcId Specificity]
qtvs)
where
free_tvs' :: VarSet
free_tvs' = VarSet
free_tvs VarSet -> VarSet -> VarSet
`unionVarSet` Kind -> VarSet
tyCoVarsOfType (TcId -> Kind
tyVarKind TcId
tv)
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
choose_psig_context :: VarSet -> TcThetaType -> Maybe Kind -> TcM (VarSet, TcThetaType)
choose_psig_context VarSet
_ TcThetaType
annotated_theta Maybe Kind
Nothing
= do { let free_tvs :: VarSet
free_tvs = VarSet -> VarSet
closeOverKinds (TcThetaType -> VarSet
tyCoVarsOfTypes TcThetaType
annotated_theta
VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
tau_tvs)
; (VarSet, TcThetaType) -> TcM (VarSet, TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
free_tvs, TcThetaType
annotated_theta) }
choose_psig_context VarSet
psig_qtvs TcThetaType
annotated_theta (Just Kind
wc_var_ty)
= do { let free_tvs :: VarSet
free_tvs = VarSet -> VarSet
closeOverKinds (TcThetaType -> VarSet -> VarSet
growThetaTyVars TcThetaType
inferred_theta VarSet
seed_tvs)
seed_tvs :: VarSet
seed_tvs = TcThetaType -> VarSet
tyCoVarsOfTypes TcThetaType
annotated_theta
VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
tau_tvs
; let keep_me :: VarSet
keep_me = VarSet
psig_qtvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
free_tvs
my_theta :: TcThetaType
my_theta = VarSet -> TcThetaType -> TcThetaType
pickCapturedPreds VarSet
keep_me TcThetaType
inferred_theta
; TcThetaType
diff_theta <- TcThetaType -> TcThetaType -> TcM TcThetaType
findInferredDiff TcThetaType
annotated_theta TcThetaType
my_theta
; case Kind -> Maybe (TcId, TcCoercionR)
getCastedTyVar_maybe Kind
wc_var_ty of
Just (TcId
wc_var, TcCoercionR
wc_co) -> (() :: Constraint) => TcId -> Kind -> TcRn ()
TcId -> Kind -> TcRn ()
writeMetaTyVar TcId
wc_var (TcThetaType -> Kind
mkConstraintTupleTy TcThetaType
diff_theta
Kind -> TcCoercionR -> Kind
`mkCastTy` TcCoercionR -> TcCoercionR
mkSymCo TcCoercionR
wc_co)
Maybe (TcId, TcCoercionR)
Nothing -> String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers 1" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
wc_var_ty)
; String -> SDoc -> TcRn ()
traceTc String
"completeTheta" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"annotated_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
annotated_theta
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inferred_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
inferred_theta
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"my_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
my_theta
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"diff_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
diff_theta ]
; (VarSet, TcThetaType) -> TcM (VarSet, TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
free_tvs, TcThetaType
annotated_theta TcThetaType -> TcThetaType -> TcThetaType
forall a. [a] -> [a] -> [a]
++ TcThetaType
diff_theta) }
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, TcId) -> TcRn ()
report_mono_sig_tv_err (Name
n,TcId
tv)
= TcRnMessage -> TcRn ()
addErrTc (Name -> Name -> Maybe Kind -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigBadQuantifier Name
n Name
fn_name Maybe Kind
m_unif_ty LHsSigWcType GhcRn
hs_ty)
where
m_unif_ty :: Maybe Kind
m_unif_ty = TcThetaType -> Maybe Kind
forall a. [a] -> Maybe a
listToMaybe
[ Kind
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 :: Kind
residual_pred = Ct -> Kind
ctPred Ct
residual_ct
, Just (Role
Nominal, Kind
lhs, Kind
rhs) <- [ Kind -> Maybe (Role, Kind, Kind)
getEqPredTys_maybe Kind
residual_pred ]
, Just TcId
lhs_tv <- [ Kind -> Maybe TcId
getTyVar_maybe Kind
lhs ]
, TcId
lhs_tv TcId -> TcId -> Bool
forall a. Eq a => a -> a -> Bool
== TcId
tv ]
chooseInferredQuantifiers WantedConstraints
_ TcThetaType
_ VarSet
_ [TcId]
_ (Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = sig :: TcIdSigInfo
sig@(CompleteSig {}) }))
= String -> SDoc -> TcM ([VarBndr TcId Specificity], TcThetaType)
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 -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
poly_ty TidyEnv
tidy_env
= do { (TidyEnv
tidy_env1, Kind
poly_ty) <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
tidy_env Kind
poly_ty
; let msg :: SDoc
msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
poly_ty ]
; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env1, SDoc
msg) }
localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()
localSigWarn :: TcId -> Maybe TcIdSigInst -> TcRn ()
localSigWarn TcId
id Maybe TcIdSigInst
mb_sig
| Just TcIdSigInst
_ <- Maybe TcIdSigInst
mb_sig = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool -> Bool
not (Kind -> Bool
isSigmaTy (TcId -> Kind
idType TcId
id)) = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = TcId -> TcRn ()
warnMissingSignatures TcId
id
warnMissingSignatures :: Id -> TcM ()
warnMissingSignatures :: TcId -> TcRn ()
warnMissingSignatures TcId
id
= do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
; let (TidyEnv
env1, Kind
tidy_ty) = TidyEnv -> Kind -> (TidyEnv, Kind)
tidyOpenType TidyEnv
env0 (TcId -> Kind
idType TcId
id)
; let dia :: TcRnMessage
dia = Name -> Kind -> TcRnMessage
TcRnPolymorphicBinderMissingSig (TcId -> Name
idName TcId
id) Kind
tidy_ty
; (TidyEnv, TcRnMessage) -> TcRn ()
addDiagnosticTcM (TidyEnv
env1, TcRnMessage
dia) }
data MonoBindInfo = MBI { MonoBindInfo -> Name
mbi_poly_name :: Name
, MonoBindInfo -> Maybe TcIdSigInst
mbi_sig :: Maybe TcIdSigInst
, MonoBindInfo -> TcId
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 SrcSpanAnnA
b_loc (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
nm_loc Name
name
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matches })]
| RecFlag
NonRecursive <- RecFlag
is_rec
, Maybe TcSigInfo
Nothing <- TcSigFun
sig_fn Name
name
= SrcSpanAnnA
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
b_loc (TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo]))
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
do { ((HsWrapper
co_fn, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'), Kind
rhs_ty')
<- FixedRuntimeRepContext
-> (ExpSigmaType
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Kind)
forall a.
FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInferFRR (Name -> FixedRuntimeRepContext
FRRBinder Name
name) ((ExpSigmaType
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Kind))
-> (ExpSigmaType
-> TcM
(HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
((HsWrapper,
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
[TcBinder]
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Name -> ExpSigmaType -> TopLevelFlag -> TcBinder
TcIdBndr_ExpType Name
name ExpSigmaType
exp_ty TopLevelFlag
NotTopLevel] (TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nm_loc Name
name) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
exp_ty
; TcId
mono_id <- LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
name Kind
ManyTy Kind
rhs_ty'
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[MonoBindInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 { fun_id :: LIdP GhcTc
fun_id = SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nm_loc TcId
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
co_fn, []) },
[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 :: TcId
mbi_mono_id = TcId
mono_id }]) }
tcMonoBinds RecFlag
is_rec TcSigFun
sig_fn LetBndrSpec
no_gen
[L SrcSpanAnnA
b_loc (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 })]
| 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
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds 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) (TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo]))
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
do { (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss', Kind
pat_ty) <- FixedRuntimeRepContext
-> (ExpSigmaType
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Kind)
forall a.
FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInferFRR FixedRuntimeRepContext
FRRPatBind ((ExpSigmaType
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Kind))
-> (ExpSigmaType
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Kind)
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 (Kind -> ExpSigmaType
mkCheckExpType Kind
pat_ty)
; (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', [MonoBindInfo]
mbis) <- (Name -> Maybe TcId)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe TcId)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat (Maybe TcId -> Name -> Maybe TcId
forall a b. a -> b -> a
const Maybe TcId
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 { 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 = (Kind
pat_ty, ([],[])) }
, [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 (HsBind GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA TcMonoBind))
-> [GenLocated SrcSpanAnnA (HsBind 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((HsBind GhcRn -> TcM TcMonoBind)
-> GenLocated SrcSpanAnnA (HsBind 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 -> HsBind GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen)) [LHsBind GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds
; let mono_infos :: [MonoBindInfo]
mono_infos = [GenLocated SrcSpanAnnA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
rhs_id_env :: [(Name, TcId)]
rhs_id_env = [ (Name
name, TcId
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 -> TcId
mbi_mono_id = TcId
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
forall doc. IsDoc doc => [doc] -> doc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id)
| (Name
n,TcId
id) <- [(Name, TcId)]
rhs_id_env]
; [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds' <- [(Name, TcId)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds [(Name, TcId)]
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 -> HsBind GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
nm_loc Name
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan -> MatchGroup GhcRn (LHsExpr GhcRn) -> TcMonoBind
TcFunBind MonoBindInfo
mono_info (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
nm_loc) MatchGroup GhcRn (LHsExpr GhcRn)
matches) }
| Bool
otherwise
= do { Kind
mono_ty <- TcM Kind
newOpenFlexiTyVarTy
; TcId
mono_id <- LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
name Kind
ManyTy Kind
mono_ty
; let mono_info :: MonoBindInfo
mono_info = 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 :: TcId
mbi_mono_id = TcId
mono_id }
; TcMonoBind -> TcM TcMonoBind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan -> MatchGroup GhcRn (LHsExpr GhcRn) -> TcMonoBind
TcFunBind MonoBindInfo
mono_info (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (LetBndrSpec
-> (Name, TcIdSigInfo)
-> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen) [(Name, TcIdSigInfo)]
sig_names
; let inst_sig_fun :: Name -> Maybe TcId
inst_sig_fun = NameEnv TcId -> Name -> Maybe TcId
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (NameEnv TcId -> Name -> Maybe TcId)
-> NameEnv TcId -> Name -> Maybe TcId
forall a b. (a -> b) -> a -> b
$ [(Name, TcId)] -> NameEnv TcId
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, TcId)] -> NameEnv TcId) -> [(Name, TcId)] -> NameEnv TcId
forall a b. (a -> b) -> a -> b
$
[ (MonoBindInfo -> Name
mbi_poly_name MonoBindInfo
mbi, MonoBindInfo -> TcId
mbi_mono_id MonoBindInfo
mbi)
| MonoBindInfo
mbi <- [MonoBindInfo]
sig_mbis ]
; ((GenLocated SrcSpanAnnA (Pat GhcTc)
pat', [MonoBindInfo]
nosig_mbis), Kind
pat_ty)
<- SDoc
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
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]), Kind)
-> TcM
((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a b. (a -> b) -> a -> b
$
FixedRuntimeRepContext
-> (ExpSigmaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a.
FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInferFRR FixedRuntimeRepContext
FRRPatBind ((ExpSigmaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM
((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind))
-> (ExpSigmaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
(Name -> Maybe TcId)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe TcId)
-> LetBndrSpec
-> LPat GhcRn
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat Name -> Maybe TcId
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id)
| MonoBindInfo
mbi <- [MonoBindInfo]
mbis, let id :: TcId
id = MonoBindInfo -> TcId
mbi_mono_id MonoBindInfo
mbi ]
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ LetBndrSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr LetBndrSpec
no_gen)
; TcMonoBind -> TcM TcMonoBind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([MonoBindInfo]
-> LPat GhcTc -> GRHSs GhcRn (LHsExpr GhcRn) -> Kind -> TcMonoBind
TcPatBind [MonoBindInfo]
mbis LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' GRHSs GhcRn (LHsExpr GhcRn)
grhss Kind
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
_ HsBind GhcRn
other_bind = String -> SDoc -> TcM TcMonoBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLhs" (HsBind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
other_bind)
lookupMBI :: Name -> TcM MonoBindInfo
lookupMBI :: Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI Name
name
= do { TcId
mono_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tcLookupId Name
name
; MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: TcId
mbi_mono_id = TcId
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
; TcId
mono_id <- LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newSigLetBndr LetBndrSpec
no_gen Name
name TcIdSigInst
inst_sig
; MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: TcId
mbi_mono_id = TcId
mono_id }) }
newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
newSigLetBndr :: LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newSigLetBndr (LetGblBndr TcPragEnv
prags) Name
name (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = TcIdSigInfo
id_sig })
| CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id } <- TcIdSigInfo
id_sig
= TcId -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prags Name
name)
newSigLetBndr LetBndrSpec
no_gen Name
name (TISI { sig_inst_tau :: TcIdSigInst -> Kind
sig_inst_tau = Kind
tau })
= LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
name Kind
ManyTy Kind
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 -> TcId
mbi_mono_id = TcId
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" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
mono_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
mono_id))
; (HsWrapper
co_fn, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') <- GenLocated SrcSpanAnnN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchesFun (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (TcId -> Name
idName TcId
mono_id))
MatchGroup GhcRn (LHsExpr GhcRn)
matches (Kind -> ExpSigmaType
mkCheckExpType (Kind -> ExpSigmaType) -> Kind -> ExpSigmaType
forall a b. (a -> b) -> a -> b
$ TcId -> Kind
idType TcId
mono_id)
; HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( FunBind { fun_id :: LIdP GhcTc
fun_id = SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) TcId
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
co_fn, [])
} ) }
tcRhs (TcPatBind [MonoBindInfo]
infos LPat GhcTc
pat' GRHSs GhcRn (LHsExpr GhcRn)
grhss Kind
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty)
; GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss' <- SDoc
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr 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 (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat GRHSs GhcRn (LHsExpr GhcRn)
grhss (Kind -> ExpSigmaType
mkCheckExpType Kind
pat_ty)
; HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( 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 = (Kind
pat_ty, ([],[])) } )}
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs :: forall a. 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 :: forall a. TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig TcIdSigInst
sig_inst TcM a
thing_inside
| TISI { sig_inst_skols :: TcIdSigInst -> [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
skol_prs, sig_inst_wcs :: TcIdSigInst -> [(Name, TcId)]
sig_inst_wcs = [(Name, TcId)]
wcs } <- TcIdSigInst
sig_inst
= [(Name, TcId)] -> TcM a -> TcM a
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendNameTyVarEnv [(Name, TcId)]
wcs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
[(Name, TcId)] -> TcM a -> TcM a
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendNameTyVarEnv ((VarBndr TcId Specificity -> TcId)
-> [(Name, VarBndr TcId Specificity)] -> [(Name, TcId)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar [(Name, VarBndr TcId Specificity)]
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 :: forall a. [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 [ TcId -> TopLevelFlag -> TcBinder
TcIdBndr TcId
mono_id TopLevelFlag
NotTopLevel
| MBI { mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id = TcId
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 a b. (a -> b -> b) -> b -> [a] -> b
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)
_ Kind
_) [MonoBindInfo]
rest = [MonoBindInfo]
infos [MonoBindInfo] -> [MonoBindInfo] -> [MonoBindInfo]
forall a. [a] -> [a] -> [a]
++ [MonoBindInfo]
rest
data GeneralisationPlan
= NoGen
| InferGen
| CheckGen
(LHsBind GhcRn)
TcIdSigInfo
instance Outputable GeneralisationPlan where
ppr :: GeneralisationPlan -> SDoc
ppr GeneralisationPlan
NoGen = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NoGen"
ppr GeneralisationPlan
InferGen = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"InferGen"
ppr (CheckGen LHsBind GhcRn
_ TcIdSigInfo
s) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CheckGen" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
| Just (GenLocated SrcSpanAnnA (HsBind GhcRn)
bind, TcIdSigInfo
sig) <- Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcIdSigInfo)
one_funbind_with_sig = LHsBind GhcRn -> TcIdSigInfo -> GeneralisationPlan
CheckGen LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
bind TcIdSigInfo
sig
| Bool
generalise_binds = GeneralisationPlan
InferGen
| Bool
otherwise = GeneralisationPlan
NoGen
where
generalise_binds :: Bool
generalise_binds
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Bool
True
| IsGroupClosed NameEnv (UniqSet Name)
_ Bool
True <- IsGroupClosed
closed = Bool
True
| Bool
has_partial_sigs = Bool
True
| Bool
otherwise = Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonoLocalBinds DynFlags
dflags)
one_funbind_with_sig :: Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcIdSigInfo)
one_funbind_with_sig
| [lbind :: LHsBind GhcRn
lbind@(L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
v }))] <- [LHsBind GhcRn]
lbinds
, Just (TcIdSig sig :: TcIdSigInfo
sig@(CompleteSig {})) <- TcSigFun
sig_fn (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
v)
= (GenLocated SrcSpanAnnA (HsBind GhcRn), TcIdSigInfo)
-> Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcIdSigInfo)
forall a. a -> Maybe a
Just (LHsBind GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
lbind, TcIdSigInfo
sig)
| Bool
otherwise
= Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcIdSigInfo)
forall a. Maybe a
Nothing
binders :: [IdP GhcRn]
binders = 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
has_partial_sigs :: Bool
has_partial_sigs = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
has_partial_sig [IdP GhcRn]
[Name]
binders
has_partial_sig :: Name -> Bool
has_partial_sig Name
nm = case TcSigFun
sig_fn Name
nm of
Just (TcIdSig (PartialSig {})) -> Bool
True
Maybe TcSigInfo
_ -> Bool
False
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 (HsBind GhcRn) -> [(Name, UniqSet Name)])
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [(Name, UniqSet Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBind GhcRn -> [(Name, UniqSet Name)]
bindFvs (HsBind GhcRn -> [(Name, UniqSet Name)])
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> [(Name, UniqSet Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds
bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
bindFvs :: HsBind GhcRn -> [(Name, UniqSet Name)]
bindFvs (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
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 HsBind 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 :: forall (p :: Pass).
OutputableBndrId p =>
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
forall doc. IsLine doc => String -> doc
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)