{-# 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, tcFunBindMatches )
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.DynFlags
import GHC.Data.FastString
import GHC.Hs
import GHC.Rename.Bind ( rejectBootDecls )
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.Core.Predicate
import GHC.Core.UsageEnv ( bottomUE )
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.Tc.Zonk.TcType
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, tidyOpenTypeX, mkCastTy)
import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy )
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.SourceFile
import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Types.Basic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names( ipClassName )
import GHC.Types.Unique.FM
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, traverse_)
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 {
(binds', (tcg_env, 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
; specs <- tcImpPrags sigs
; let { tcg_env' = TcGblEnv
tcg_env { tcg_imp_specs
= specs ++ tcg_imp_specs tcg_env }
TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` ((RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
-> [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a, b) -> b
snd [(RecFlag, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])]
binds' }
; return (tcg_env', tcl_env) }
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
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])]
binds) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
HsBootOrSig
-> (NonEmpty (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> BadBootDecls)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
rejectBootDecls HsBootOrSig
HsBoot NonEmpty (LHsBindLR GhcRn GhcRn) -> BadBootDecls
NonEmpty (GenLocated SrcSpanAnnA (HsBind GhcRn)) -> BadBootDecls
BootBindsRn (((RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [(RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])]
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])]
binds)
; (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 t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM 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 { sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Kind
tcHsSigWcType (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigWcType GhcRn
hs_ty
; return (mkVanillaGlobal name 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 <- TcM thing
thing_inside
; return (EmptyLocalBinds x, thing) }
tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
x (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs))) TcM thing
thing_inside
= do { (binds', 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
; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
_ (ValBinds {})) TcM thing
_ = String -> IOEnv (Env TcGblEnv TcLclEnv) (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 { ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; (given_ips, ip_binds') <-
mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds
; (ev_binds, result) <- checkConstraints (IPSkol ips)
[] given_ips thing_inside
; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
where
ips :: [HsIPName]
ips = [HsIPName
ip | (L SrcSpanAnnA
_ (IPBind XCIPBind GhcRn
_ (L EpAnnCO
_ 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 EpAnnCO
_ HsIPName
ip) LHsExpr GhcRn
expr)
= do { ty <- Kind -> TcM Kind
newFlexiTyVarTy Kind
liftedTypeKind
; let p = FastString -> Kind
mkStrLitTy (FastString -> Kind) -> FastString -> Kind
forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcCheckMonoExpr expr ty
; let 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'
; return (ip_id, (IPBind ip_id l_name 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 {
(poly_ids, 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
; tcExtendSigIds top_lvl poly_ids $
do { (binds', (extra_binds', thing))
<- tcBindGroups top_lvl sig_fn prag_fn binds $
do { thing <- thing_inside
; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
; let extra_binds = [ (RecFlag
NonRecursive, [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
builder)
| [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
builder <- [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', 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, [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [(RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])]
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, [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 <- TcM thing
thing_inside
; return ([], thing) }
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn ((RecFlag, LHsBinds GhcRn)
group : [(RecFlag, LHsBinds GhcRn)]
groups) TcM thing
thing_inside
= do {
type_env <- TcM TcTypeEnv
getLclTypeEnv
; let closed = TcTypeEnv -> LHsBinds GhcRn -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env ((RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a b. (a, b) -> b
snd (RecFlag, LHsBinds GhcRn)
(RecFlag, [GenLocated SrcSpanAnnA (HsBind GhcRn)])
group)
; (group', (groups', thing))
<- tc_group top_lvl sig_fn prag_fn group closed $
tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', 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 :: LHsBindLR GhcRn GhcRn
bind = case LHsBinds GhcRn
binds of
[LHsBindLR GhcRn GhcRn
bind] -> LHsBindLR GhcRn GhcRn
bind
[] -> String -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a. HasCallStack => String -> a
panic String
"tc_group: empty list of binds"
LHsBinds GhcRn
_ -> String -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a. HasCallStack => String -> a
panic String
"tc_group: NonRecursive binds is not a singleton bag"
; (bind', thing) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBindLR GhcRn GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBindLR GhcRn GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, thing)
tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBindLR GhcRn GhcRn
bind IsGroupClosed
closed
TcM thing
thing_inside
; return ( [(NonRecursive, bind')], 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
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)
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
mbFirstPatSyn ((GenLocated SrcSpanAnnA (HsBind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (GenLocated SrcSpanAnnA (HsBind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (HsBind GhcRn)
lpat_syn ->
SrcSpan -> LHsBinds GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> LHsBinds GhcRn -> TcM a
recursivePatSynErr (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => 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
; (binds1, thing) <- [SCC (LHsBindLR GhcRn GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go [SCC (LHsBindLR GhcRn GhcRn)]
sccs
; return ([(Recursive, binds1)], thing) }
where
mbFirstPatSyn :: Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
mbFirstPatSyn = (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> [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
[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 (LHsBindLR GhcRn 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 (LHsBindLR GhcRn GhcRn)]
mkEdges TcSigFun
sig_fn LHsBinds GhcRn
binds)
go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go :: [SCC (LHsBindLR GhcRn GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go (SCC (LHsBindLR GhcRn GhcRn)
scc:[SCC (LHsBindLR GhcRn GhcRn)]
sccs) = do { (binds1, ids1) <- SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_scc SCC (LHsBindLR GhcRn GhcRn)
SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
scc
; (binds2, thing) <-
tcExtendLetEnv top_lvl sig_fn closed ids1
(go sccs)
; return (binds1 ++ binds2, thing) }
go [] = do { thing <- TcM thing
thing_inside; return ([], thing) }
tc_scc :: SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_scc (AcyclicSCC GenLocated SrcSpanAnnA (HsBind GhcRn)
bind) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [Scaled 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, [Scaled TcId])
tc_sub_group RecFlag
Recursive [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds
tc_sub_group :: RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_sub_group RecFlag
rec_tc [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds = TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
RecFlag
Recursive RecFlag
rec_tc IsGroupClosed
closed LHsBinds 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
-> LHsBindLR GhcRn 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 { (aux_binds, 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 <- setGblEnv tcg_env thing_inside
; return (aux_binds, thing)
}
tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBindLR GhcRn GhcRn
lbind IsGroupClosed
closed TcM thing
thing_inside
= do { (binds1, ids) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
RecFlag
NonRecursive RecFlag
NonRecursive
IsGroupClosed
closed
[LHsBindLR GhcRn GhcRn
lbind]
; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
; return (binds1, thing) }
type BKey = Int
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBindLR GhcRn 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 <- NameSet -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (HsBind GhcRn -> XFunBind GhcRn GhcRn
forall {idL} {idR}.
(XPatBind idL idR ~ XFunBind idL idR,
XFunBind idL idR ~ NameSet) =>
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
NameSet
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 = LHsBinds GhcRn
[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, [Scaled TcId])
tcPolyBinds :: TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn RecFlag
rec_group RecFlag
rec_tc IsGroupClosed
closed LHsBinds GhcRn
bind_list
= SrcSpan
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId]))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall a b. (a -> b) -> a -> b
$
TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall r. TcRn r -> TcRn r -> TcRn r
recoverM ([Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled TcId])
recoveryCode [IdP GhcRn]
[Name]
binder_names TcSigFun
sig_fn) (TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId]))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"------------------------------------------------" SDoc
forall doc. IsOutput doc => doc
Outputable.empty
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Bindings for {" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
[Name]
binder_names)
; dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let plan = DynFlags
-> TopLevelFlag
-> IsGroupClosed
-> TcSigFun
-> LHsBinds GhcRn
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags TopLevelFlag
top_lvl IsGroupClosed
closed TcSigFun
sig_fn LHsBinds GhcRn
bind_list
; traceTc "Generalisation plan" (ppr plan)
; result@(_, scaled_poly_ids) <- case plan of
GeneralisationPlan
NoGen -> RecFlag
-> TcPragEnv
-> TcSigFun
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn LHsBinds GhcRn
bind_list
GeneralisationPlan
InferGen -> TopLevelFlag
-> RecFlag
-> TcPragEnv
-> TcSigFun
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyInfer TopLevelFlag
top_lvl RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn LHsBinds GhcRn
bind_list
CheckGen LHsBindLR GhcRn GhcRn
lbind TcCompleteSig
sig -> TcPragEnv
-> TcCompleteSig
-> LHsBindLR GhcRn GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyCheck TcPragEnv
prag_fn TcCompleteSig
sig LHsBindLR GhcRn GhcRn
lbind
; let poly_ids = (Scaled TcId -> TcId) -> [Scaled TcId] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcId -> TcId
forall a. Scaled a -> a
scaledThing [Scaled TcId]
scaled_poly_ids
; mapM_ (\ TcId
poly_id ->
HasDebugCallStack =>
FixedRuntimeRepContext -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
FixedRuntimeRepContext -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
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))
poly_ids
; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
, vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
])
; return result }
where
binder_names :: [IdP GhcRn]
binder_names = CollectFlag GhcRn -> LHsBinds GhcRn -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LHsBinds 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. HasLoc a => 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) LHsBinds GhcRn
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
bind_list)
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled Id])
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled TcId])
recoveryCode [Name]
binder_names TcSigFun
sig_fn
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcBindsWithSigs: error recovery" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
binder_names)
; let poly_ids :: [Scaled TcId]
poly_ids = (TcId -> Scaled TcId) -> [TcId] -> [Scaled TcId]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> TcId -> Scaled TcId
forall a. Kind -> a -> Scaled a
Scaled Kind
ManyTy) ([TcId] -> [Scaled TcId]) -> [TcId] -> [Scaled TcId]
forall a b. (a -> b) -> a -> b
$ (Name -> TcId) -> [Name] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TcId
mk_dummy [Name]
binder_names
; ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [Scaled TcId])
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [Scaled TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Scaled 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
= HasDebugCallStack => 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, [Scaled TcId])
tcPolyNoGen :: RecFlag
-> TcPragEnv
-> TcSigFun
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn LHsBinds GhcRn
bind_list
= do { (binds', mono_infos) <- RecFlag
-> TcSigFun
-> LetBndrSpec
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn
(TcPragEnv -> LetBndrSpec
LetGblBndr TcPragEnv
prag_fn)
LHsBinds GhcRn
bind_list
; mono_ids' <- mapM tc_mono_info mono_infos
; return (binds', mono_ids') }
where
tc_mono_info :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled 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, mbi_mono_mult :: MonoBindInfo -> Kind
mbi_mono_mult = Kind
mult })
= do { _specs <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
mono_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name)
; return $ Scaled mult mono_id }
tcPolyCheck :: TcPragEnv
-> TcCompleteSig
-> LHsBind GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyCheck :: TcPragEnv
-> TcCompleteSig
-> LHsBindLR GhcRn GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyCheck TcPragEnv
prag_fn
sig :: TcCompleteSig
sig@(CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id, sig_ctxt :: TcCompleteSig -> UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt })
(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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPolyCheck" (TcCompleteSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCompleteSig
sig)
; mono_name <- OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
nameOccName Name
name) (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
nm_loc)
; mult <- tcMultAnn (HsNoMultAnn noExtField)
; (wrap_gen, (wrap_res, matches'))
<- tcSkolemiseCompleteSig sig $ \[ExpPatType]
invis_pat_tys Kind
rho_ty ->
let mono_id :: TcId
mono_id = HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
mono_name (HasDebugCallStack => TcId -> Kind
TcId -> Kind
idMult TcId
poly_id) Kind
rho_ty in
[TcBinder]
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcId -> TopLevelFlag -> TcBinder
TcIdBndr TcId
mono_id TopLevelFlag
NotTopLevel] (TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
bind_loc (TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt
-> Name
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches UserTypeCtxt
ctxt Name
mono_name Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
invis_pat_tys (Kind -> ExpSigmaType
mkCheckExpType Kind
rho_ty)
; let prag_sigs = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name
poly_id2 = HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
mono_name (HasDebugCallStack => TcId -> Kind
TcId -> Kind
idMult TcId
poly_id) (TcId -> Kind
idType TcId
poly_id)
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule
; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs
; let 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 = 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 = 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 = [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 }
; return ([abs_bind], [Scaled mult poly_id]) }
tcPolyCheck TcPragEnv
_prag_fn TcCompleteSig
sig LHsBindLR GhcRn GhcRn
bind
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)], [Scaled TcId])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcPolyCheck" (TcCompleteSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCompleteSig
sig SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsBind GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBindLR GhcRn 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 EpAnnCO StringLiteral)
mb_cc_str : [Maybe (GenLocated EpAnnCO StringLiteral)]
_) <- [ Maybe (XRec GhcRn StringLiteral)
Maybe (GenLocated EpAnnCO 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 EpAnnCO StringLiteral
cc_str <- Maybe (GenLocated EpAnnCO StringLiteral)
mb_cc_str
= StringLiteral -> FastString
sl_fs (StringLiteral -> FastString) -> StringLiteral -> FastString
forall a b. (a -> b) -> a -> b
$ GenLocated EpAnnCO StringLiteral -> StringLiteral
forall l e. GenLocated l e -> e
unLoc GenLocated EpAnnCO 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
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 = FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
cc_name Module
mod SrcSpan
loc CCFlavour
flavour
return [ProfNote cc True True]
| Bool
otherwise
= [CoreTickish] -> TcM [CoreTickish]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcPolyInfer
:: TopLevelFlag
-> RecFlag
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyInfer :: TopLevelFlag
-> RecFlag
-> TcPragEnv
-> TcSigFun
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyInfer TopLevelFlag
top_lvl RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn LHsBinds GhcRn
bind_list
= do { (tclvl, wanted, (binds', 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
-> LHsBinds GhcRn
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn LetBndrSpec
LetLclBndr LHsBinds GhcRn
bind_list
; apply_mr <- checkMonomorphismRestriction mono_infos bind_list
; manyIfPats binds'
; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos))
; let 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
sig | MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig } <- [MonoBindInfo]
mono_infos ]
infer_mode = if Bool
apply_mr then InferMode
ApplyMR else InferMode
NoRestrictions
; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
; ((qtvs, givens, ev_binds, insoluble), residual)
<- captureConstraints $ simplifyInfer top_lvl tclvl infer_mode sigs name_taus wanted
; let inferred_theta = (TcId -> Kind) -> [TcId] -> TcThetaType
forall a b. (a -> b) -> [a] -> [b]
map TcId -> Kind
evVarPred [TcId]
givens
; scaled_exports <- checkNoErrs $
mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos
; let exports = (Scaled ABExport -> ABExport) -> [Scaled ABExport] -> [ABExport]
forall a b. (a -> b) -> [a] -> [b]
map Scaled ABExport -> ABExport
forall a. Scaled a -> a
scaledThing [Scaled ABExport]
scaled_exports
; emitConstraints residual
; loc <- getSrcSpanM
; let scaled_poly_ids = [ Kind -> TcId -> Scaled TcId
forall a. Kind -> a -> Scaled a
Scaled Kind
p (ABExport -> TcId
abe_poly ABExport
export) | Scaled Kind
p ABExport
export <- [Scaled ABExport]
scaled_exports]
poly_ids = (Scaled TcId -> TcId) -> [Scaled TcId] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcId -> TcId
forall a. Scaled a -> a
scaledThing [Scaled TcId]
scaled_poly_ids
abs_bind = SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
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
binds'
, abs_sig :: Bool
abs_sig = Bool
False }
; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
; return ([abs_bind], scaled_poly_ids) }
where
manyIfPat :: GenLocated l (HsBindLR GhcTc idR)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
manyIfPat (L l
_ (PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs=(L SrcSpanAnnA
_ (VarPat{}))}))
= () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
manyIfPat (L l
_ (PatBind {pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult=HsMultAnn GhcTc
mult_ann}))
= CtOrigin -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcSubMult (NonLinearPatternReason -> XRec GhcRn (Pat GhcRn) -> CtOrigin
NonLinearPatternOrigin NonLinearPatternReason
GeneralisedPatternReason XRec GhcRn (Pat GhcRn)
nlWildPatName) Kind
ManyTy (HsMultAnn GhcTc -> Kind
getTcMultAnn HsMultAnn GhcTc
mult_ann)
manyIfPat GenLocated l (HsBindLR GhcTc idR)
_ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
manyIfPats :: t (GenLocated l (HsBindLR GhcTc idR))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
manyIfPats t (GenLocated l (HsBindLR GhcTc idR))
binds' = (GenLocated l (HsBindLR GhcTc idR)
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> t (GenLocated l (HsBindLR GhcTc idR))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ GenLocated l (HsBindLR GhcTc idR)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall {l} {idR}.
GenLocated l (HsBindLR GhcTc idR)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
manyIfPat t (GenLocated l (HsBindLR GhcTc idR))
binds'
checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
checkMonomorphismRestriction :: [MonoBindInfo] -> LHsBinds GhcRn -> TcM Bool
checkMonomorphismRestriction [MonoBindInfo]
mbis LHsBinds GhcRn
lbinds
= do { mr_on <- Extension -> TcM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.MonomorphismRestriction
; let 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
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) LHsBinds GhcRn
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
lbinds
; when mr_applies $ mapM_ checkOverloadedSig mbis
; return mr_applies }
where
no_mr_bndrs :: NameSet
no_mr_bndrs :: NameSet
no_mr_bndrs = [Name] -> NameSet
mkNameSet ((MonoBindInfo -> Maybe Name) -> [MonoBindInfo] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MonoBindInfo -> Maybe Name
no_mr_name [MonoBindInfo]
mbis)
no_mr_name :: MonoBindInfo -> Maybe Name
no_mr_name :: MonoBindInfo -> Maybe Name
no_mr_name (MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig })
| TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
info, sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
theta, sig_inst_wcx :: TcIdSigInst -> Maybe Kind
sig_inst_wcx = Maybe Kind
wcx } <- TcIdSigInst
sig
= case TcIdSig
info of
TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
bndr }) -> Name -> Maybe Name
forall a. a -> Maybe a
Just (TcId -> Name
idName TcId
bndr)
TcPartialSig (PSig { psig_name :: TcPartialSig -> Name
psig_name = Name
nm })
| TcThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TcThetaType
theta, Maybe Kind -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Kind
wcx -> Maybe Name
forall a. Maybe a
Nothing
| Bool
otherwise -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
nm
no_mr_name MonoBindInfo
_ = Maybe Name
forall a. Maybe a
Nothing
restricted :: HsBindLR GhcRn GhcRn -> Bool
restricted :: HsBind GhcRn -> Bool
restricted (PatBind {}) = Bool
True
restricted (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
v, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
m }) = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> Bool
forall {id :: Pass} {body}. MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
m
Bool -> Bool -> Bool
&& Name -> Bool
mr_needed_for (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
v)
restricted (VarBind { var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_ext = XVarBind GhcRn GhcRn
x }) = DataConCantHappen -> Bool
forall a. DataConCantHappen -> a
dataConCantHappen XVarBind GhcRn GhcRn
DataConCantHappen
x
restricted b :: HsBind GhcRn
b@(PatSynBind {}) = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isRestrictedGroup/unrestricted" (HsBind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
b)
restricted_match :: MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup (GhcPass id) body
mg = MatchGroup (GhcPass id) body -> BKey
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> BKey
matchGroupArity MatchGroup (GhcPass id) body
mg BKey -> BKey -> Bool
forall a. Eq a => a -> a -> Bool
== BKey
0
mr_needed_for :: Name -> Bool
mr_needed_for Name
nm = Bool -> Bool
not (Name
nm Name -> NameSet -> Bool
`elemNameSet` NameSet
no_mr_bndrs)
checkOverloadedSig :: MonoBindInfo -> TcM ()
checkOverloadedSig :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkOverloadedSig (MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig })
| TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
orig_sig, sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
theta, sig_inst_wcx :: TcIdSigInst -> Maybe Kind
sig_inst_wcx = Maybe Kind
wcx } <- TcIdSigInst
sig
, Bool -> Bool
not (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
wcx)
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TcIdSig -> SrcSpan
tcIdSigLoc TcIdSig
orig_sig) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ TcIdSig -> TcRnMessage
TcRnOverloadedSig TcIdSig
orig_sig
checkOverloadedSig MonoBindInfo
_ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
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 (Scaled ABExport)
mkExport :: TcPragEnv
-> WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled 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
, mbi_mono_mult :: MonoBindInfo -> Kind
mbi_mono_mult = Kind
mono_mult })
= do { mono_ty <- ZonkM Kind -> TcM Kind
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM Kind -> TcM Kind) -> ZonkM Kind -> TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkM Kind
zonkTcType (TcId -> Kind
idType TcId
mono_id)
; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty
; poly_id <- addInlinePrags poly_id prag_sigs
; spec_prags <- tcSpecPrags poly_id prag_sigs
; let poly_ty = TcId -> Kind
idType TcId
poly_id
sel_poly_ty = [TcId] -> TcThetaType -> Kind -> Kind
HasDebugCallStack => [TcId] -> TcThetaType -> Kind -> Kind
mkInfSigmaTy [TcId]
qtvs TcThetaType
theta Kind
mono_ty
; traceTc "mkExport" (vcat [ ppr poly_id <+> dcolon <+> ppr poly_ty
, ppr sel_poly_ty ])
; wrap <- if sel_poly_ty `eqType` poly_ty
then return idHsWrapper
else tcSubTypeSigma (ImpedanceMatching poly_id)
sig_ctxt sel_poly_ty poly_ty
; localSigWarn poly_id mb_sig
; return (Scaled mono_mult $
ABE { abe_wrap = wrap
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags 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 -> TcIdSig
sig_inst_sig = TcIdSig
sig }) <- Maybe TcIdSigInst
mb_sig_inst
, TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id }) <- TcIdSig
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 { fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let 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
; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta
(tyCoVarsOfType mono_ty') qtvs mb_sig_inst
; let inferred_poly_ty = [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
binders (TcThetaType -> Kind -> Kind
HasDebugCallStack => TcThetaType -> Kind -> Kind
mkPhiTy TcThetaType
theta' Kind
mono_ty')
; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
, ppr inferred_poly_ty
, text "insoluble" <+> ppr insoluble ])
; unless insoluble $
addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
do { checkEscapingKind inferred_poly_ty
; checkValidType (InfSigCtxt poly_name) inferred_poly_ty }
; return (mkLocalId poly_name ManyTy 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 -> TcIdSig
sig_inst_sig = TcIdSig
sig, 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 }))
| TcPartialSig (PSig { psig_name :: TcPartialSig -> Name
psig_name = Name
fn_name, psig_hs_ty :: TcPartialSig -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty }) <- TcIdSig
sig
=
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
; psig_qtv_bndrs <- ZonkM [VarBndr TcId Specificity] -> TcM [VarBndr TcId Specificity]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [VarBndr TcId Specificity]
-> TcM [VarBndr TcId Specificity])
-> ZonkM [VarBndr TcId Specificity]
-> TcM [VarBndr TcId Specificity]
forall a b. (a -> b) -> a -> b
$ (VarBndr TcId Specificity -> ZonkM (VarBndr TcId Specificity))
-> [VarBndr TcId Specificity] -> ZonkM [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 -> ZonkM (VarBndr TcId Specificity)
forall spec. VarBndr TcId spec -> ZonkM (VarBndr TcId spec)
zonkInvisTVBinder [VarBndr TcId Specificity]
psig_qtv_bndrs
; let 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 = [TcId] -> VarSet
mkVarSet [TcId]
psig_qtvs
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 = [(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 ]
; mapM_ (report_dup_tyvar_tv_err fn_name hs_ty) $
findDupTyVarTvs psig_qtv_prs
; mapM_ (report_mono_sig_tv_err fn_name hs_ty)
[ pr | pr@(_,tv) <- psig_qtv_prs, not (tv `elem` qtvs) ]
; annotated_theta <- liftZonkM $ zonkTcTypes annotated_theta
; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx
; let (_,final_qtvs) = foldr (choose_qtv psig_bndr_map) (free_tvs, []) qtvs
; traceTc "chooseInferredQuantifiers" $
vcat [ text "qtvs" <+> pprTyVars qtvs
, text "psig_qtv_bndrs" <+> ppr psig_qtv_bndrs
, text "free_tvs" <+> ppr free_tvs
, text "final_tvs" <+> ppr final_qtvs ]
; return (final_qtvs, 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
; diff_theta <- TcThetaType -> TcThetaType -> TcM TcThetaType
findInferredDiff TcThetaType
annotated_theta TcThetaType
my_theta
; case getCastedTyVar_maybe wc_var_ty of
Just (TcId
wc_var, TcCoercionR
wc_co) -> ZonkM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ZonkM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => TcId -> Kind -> ZonkM ()
TcId -> Kind -> ZonkM ()
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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers 1" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
wc_var_ty)
; traceTc "completeTheta" $
vcat [ ppr sig
, text "annotated_theta:" <+> ppr annotated_theta
, text "inferred_theta:" <+> ppr inferred_theta
, text "my_theta:" <+> ppr my_theta
, text "diff_theta:" <+> ppr diff_theta ]
; return (free_tvs, annotated_theta ++ diff_theta) }
report_dup_tyvar_tv_err :: Name
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> (Name, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
report_dup_tyvar_tv_err Name
fn_name HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty (Name
n1,Name
n2)
= TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Name -> Name -> Name -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigTyVarMismatch Name
n1 Name
n2 Name
fn_name LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty)
report_mono_sig_tv_err :: Name
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> (Name, TcId)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
report_mono_sig_tv_err Name
fn_name HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty (Name
n,TcId
tv)
= TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Name -> Name -> Maybe Kind -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigBadQuantifier Name
n Name
fn_name Maybe Kind
m_unif_ty LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType 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 TcIdSigInst
sig)
= String -> SDoc -> TcM ([VarBndr TcId Specificity], TcThetaType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers" (TcIdSigInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInst
sig)
mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
mk_inf_msg :: Name -> Kind -> TidyEnv -> ZonkM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
poly_ty TidyEnv
tidy_env
= do { (tidy_env1, poly_ty) <- TidyEnv -> Kind -> ZonkM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
tidy_env Kind
poly_ty
; let 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 ]
; return (tidy_env1, msg) }
localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()
localSigWarn :: TcId -> Maybe TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) ()
localSigWarn TcId
id Maybe TcIdSigInst
mb_sig
| Just TcIdSigInst
_ <- Maybe TcIdSigInst
mb_sig = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
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)) = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = TcId -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMissingSignatures TcId
id
warnMissingSignatures :: Id -> TcM ()
warnMissingSignatures :: TcId -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMissingSignatures TcId
id
= do { env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TidyEnv -> TcM TidyEnv) -> ZonkM TidyEnv -> TcM TidyEnv
forall a b. (a -> b) -> a -> b
$ ZonkM TidyEnv
tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenTypeX env0 (idType id)
; let dia = Name -> Kind -> TcRnMessage
TcRnPolymorphicBinderMissingSig (TcId -> Name
idName TcId
id) Kind
tidy_ty
; addDiagnosticTcM (env1, dia) }
data MonoBindInfo = MBI { MonoBindInfo -> Name
mbi_poly_name :: Name
, MonoBindInfo -> Maybe TcIdSigInst
mbi_sig :: Maybe TcIdSigInst
, MonoBindInfo -> TcId
mbi_mono_id :: TcId
, MonoBindInfo -> Kind
mbi_mono_mult :: Mult }
tcMonoBinds :: RecFlag
-> TcSigFun -> LetBndrSpec
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds :: RecFlag
-> TcSigFun
-> LetBndrSpec
-> LHsBinds 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. EpAnn 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 { mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn (XNoMultAnn GhcRn -> HsMultAnn GhcRn
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcRn
noExtField)
; ((co_fn, matches'), rhs_ty')
<- tcInferFRR (FRRBinder name) $ \ ExpSigmaType
exp_ty ->
[TcBinder]
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (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] (TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt
-> Name
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches (Name -> UserTypeCtxt
InfSigCtxt Name
name) Name
name Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches [] ExpSigmaType
exp_ty
; mono_id <- newLetBndr no_gen name mult rhs_ty'
; return (singleton $ L b_loc $
FunBind { fun_id = L nm_loc mono_id,
fun_matches = matches',
fun_ext = (co_fn, []) },
[MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id
, mbi_mono_mult = mult }]) }
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 = XRec GhcRn (Pat GhcRn)
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcRn (LHsExpr GhcRn)
grhss, pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcRn
mult_ann })]
| 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 (XRec GhcRn (Pat GhcRn) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt XRec GhcRn (Pat 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 { mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn HsMultAnn GhcRn
mult_ann
; (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ ExpSigmaType
exp_ty ->
Kind
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat Kind
mult GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpSigmaType
exp_ty
; let exp_pat_ty :: Scaled ExpSigmaTypeFRR
exp_pat_ty = Kind -> ExpSigmaType -> Scaled ExpSigmaType
forall a. Kind -> a -> Scaled a
Scaled Kind
mult (Kind -> ExpSigmaType
mkCheckExpType Kind
pat_ty)
; (_, (pat', mbis)) <- tcCollectingUsage $
tcLetPat (const Nothing) no_gen pat exp_pat_ty $ do
tcEmitBindingUsage bottomUE
mapM lookupMBI bndrs
; return ( singleton $ L b_loc $
PatBind { pat_lhs = pat', pat_rhs = grhss'
, pat_ext = (pat_ty, ([],[]))
, pat_mult = setTcMultAnn mult mult_ann }
, mbis ) }
where
bndrs :: [IdP GhcRn]
bndrs = CollectFlag GhcRn -> XRec GhcRn (Pat GhcRn) -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders XRec GhcRn (Pat GhcRn)
pat
tcMonoBinds RecFlag
_ TcSigFun
sig_fn LetBndrSpec
no_gen LHsBinds GhcRn
binds
= do { 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 (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA (TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen)) LHsBinds GhcRn
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds
; let mono_infos = [GenLocated SrcSpanAnnA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
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 ]
; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env]
; binds' <- tcExtendRecIds rhs_id_env $
mapM (wrapLocMA tcRhs) tc_binds
; return (binds', mono_infos) }
data TcMonoBind
= TcFunBind MonoBindInfo SrcSpan Mult (MatchGroup GhcRn (LHsExpr GhcRn))
| TcPatBind [MonoBindInfo] (LPat GhcTc) Mult (HsMultAnn GhcRn) (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 TcIdSig
sig) <- TcSigFun
sig_fn Name
name
=
do { mono_info <- LetBndrSpec
-> (Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSig
sig)
; mult <- tcMultAnn (HsNoMultAnn noExtField)
; return (TcFunBind mono_info (locA nm_loc) mult matches) }
| Bool
otherwise
= do { mono_ty <- TcM Kind
newOpenFlexiTyVarTy
; mult <- tcMultAnn (HsNoMultAnn noExtField)
; mono_id <- newLetBndr no_gen name mult mono_ty
; let 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
, mbi_mono_mult :: Kind
mbi_mono_mult = Kind
mult}
; return (TcFunBind mono_info (locA nm_loc) mult matches) }
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec GhcRn (Pat GhcRn)
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcRn (LHsExpr GhcRn)
grhss, pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcRn
mult_ann })
=
do { sig_mbis <- ((Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [(Name, TcIdSig)] -> 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, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen) [(Name, TcIdSig)]
sig_names
; let 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 ]
; mult <- tcMultAnn mult_ann
; ((pat', nosig_mbis), pat_ty)
<- addErrCtxt (patMonoBindsCtxt pat grhss) $
tcInferFRR FRRPatBind $ \ ExpSigmaType
exp_ty ->
(Name -> Maybe TcId)
-> LetBndrSpec
-> XRec GhcRn (Pat GhcRn)
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe TcId)
-> LetBndrSpec
-> XRec GhcRn (Pat GhcRn)
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat Name -> Maybe TcId
inst_sig_fun LetBndrSpec
no_gen XRec GhcRn (Pat GhcRn)
pat (Kind -> ExpSigmaType -> Scaled ExpSigmaType
forall a. Kind -> a -> Scaled a
Scaled Kind
mult 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]
sig_mbis [MonoBindInfo] -> [MonoBindInfo] -> [MonoBindInfo]
forall a. [a] -> [a] -> [a]
++ [MonoBindInfo]
nosig_mbis
; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
| mbi <- mbis, let id = MonoBindInfo -> TcId
mbi_mono_id MonoBindInfo
mbi ]
$$ ppr no_gen)
; return (TcPatBind mbis pat' mult mult_ann grhss pat_ty) }
where
bndr_names :: [IdP GhcRn]
bndr_names = CollectFlag GhcRn -> XRec GhcRn (Pat GhcRn) -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders XRec GhcRn (Pat GhcRn)
pat
([Name]
nosig_names, [(Name, TcIdSig)]
sig_names) = (Name -> Either Name (Name, TcIdSig))
-> [Name] -> ([Name], [(Name, TcIdSig)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Name -> Either Name (Name, TcIdSig)
find_sig [IdP GhcRn]
[Name]
bndr_names
find_sig :: Name -> Either Name (Name, TcIdSig)
find_sig :: Name -> Either Name (Name, TcIdSig)
find_sig Name
name = case TcSigFun
sig_fn Name
name of
Just (TcIdSig TcIdSig
sig) -> (Name, TcIdSig) -> Either Name (Name, TcIdSig)
forall a b. b -> Either a b
Right (Name
name, TcIdSig
sig)
Maybe TcSigInfo
_ -> Name -> Either Name (Name, TcIdSig)
forall a b. a -> Either a b
Left Name
name
tcLhs TcSigFun
_ LetBndrSpec
_ b :: HsBind GhcRn
b@(PatSynBind {}) = String -> SDoc -> TcM TcMonoBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLhs: PatSynBind" (HsBind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
b)
tcLhs TcSigFun
_ LetBndrSpec
_ (VarBind { var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_ext = XVarBind GhcRn GhcRn
x }) = DataConCantHappen -> TcM TcMonoBind
forall a. DataConCantHappen -> a
dataConCantHappen XVarBind GhcRn GhcRn
DataConCantHappen
x
lookupMBI :: Name -> TcM MonoBindInfo
lookupMBI :: Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI Name
name
= do { mono_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tcLookupId Name
name
; return (MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id
, mbi_mono_mult = idMult mono_id }) }
tcLhsSigId :: LetBndrSpec -> (Name, TcIdSig) -> TcM MonoBindInfo
tcLhsSigId :: LetBndrSpec
-> (Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSig
sig)
= do { inst_sig <- TcIdSig -> TcM TcIdSigInst
tcInstSig TcIdSig
sig
; mono_id <- newSigLetBndr no_gen name inst_sig
; return (MBI { mbi_poly_name = name
, mbi_sig = Just inst_sig
, mbi_mono_id = mono_id
, mbi_mono_mult = idMult 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 -> TcIdSig
sig_inst_sig = TcIdSig
id_sig })
| TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id }) <- TcIdSig
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 Kind
mult 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 { let mono_ty :: Kind
mono_ty = TcId -> Kind
idType TcId
mono_id
mono_name :: Name
mono_name = TcId -> Name
idName TcId
mono_id
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
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 Kind
mono_ty)
; (co_fn, matches') <- UserTypeCtxt
-> Name
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches (Name -> UserTypeCtxt
InfSigCtxt Name
mono_name) Name
mono_name Kind
mult
MatchGroup GhcRn (LHsExpr GhcRn)
matches [] (Kind -> ExpSigmaType
mkCheckExpType Kind
mono_ty)
; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
, fun_matches = matches'
, fun_ext = (co_fn, [])
} ) }
tcRhs (TcPatBind [MonoBindInfo]
infos LPat GhcTc
pat' Kind
mult HsMultAnn GhcRn
mult_ann 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 -> IOEnv (Env TcGblEnv TcLclEnv) ()
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' <- 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
$
Kind
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat Kind
mult GRHSs GhcRn (LHsExpr GhcRn)
grhss (Kind -> ExpSigmaType
mkCheckExpType Kind
pat_ty)
; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
, pat_ext = (pat_ty, ([],[]))
, pat_mult = setTcMultAnn mult mult_ann } )}
tcMultAnn :: HsMultAnn GhcRn -> TcM Mult
tcMultAnn :: HsMultAnn GhcRn -> TcM Kind
tcMultAnn (HsPct1Ann XPct1Ann GhcRn
_) = Kind -> TcM Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
oneDataConTy
tcMultAnn (HsMultAnn XMultAnn GhcRn
_ LHsType (NoGhcTc GhcRn)
p) = LHsType GhcRn -> ContextKind -> TcM Kind
tcCheckLHsTypeInContext LHsType (NoGhcTc GhcRn)
LHsType GhcRn
p (Kind -> ContextKind
TheKind Kind
multiplicityTy)
tcMultAnn (HsNoMultAnn XNoMultAnn GhcRn
_) = Kind -> TcM Kind
newFlexiTyVarTy Kind
multiplicityTy
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
_ Kind
_ 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
_ Kind
_ HsMultAnn GhcRn
_ 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)
TcCompleteSig
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 LHsBindLR GhcRn GhcRn
_ TcCompleteSig
s) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CheckGen" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcCompleteSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCompleteSig
s
decideGeneralisationPlan
:: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun
-> [LHsBind GhcRn] -> GeneralisationPlan
decideGeneralisationPlan :: DynFlags
-> TopLevelFlag
-> IsGroupClosed
-> TcSigFun
-> LHsBinds GhcRn
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags TopLevelFlag
top_lvl IsGroupClosed
closed TcSigFun
sig_fn LHsBinds GhcRn
lbinds
| Just (GenLocated SrcSpanAnnA (HsBind GhcRn)
bind, TcCompleteSig
sig) <- Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
one_funbind_with_sig = LHsBindLR GhcRn GhcRn -> TcCompleteSig -> GeneralisationPlan
CheckGen LHsBindLR GhcRn GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
bind TcCompleteSig
sig
| Bool
generalise_binds = GeneralisationPlan
InferGen
| Bool
otherwise = GeneralisationPlan
NoGen
where
generalise_binds :: Bool
generalise_binds
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Bool
True
| Bool
has_mult_anns_and_pats = Bool
False
| IsGroupClosed NameEnv NameSet
_ 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), TcCompleteSig)
one_funbind_with_sig
| [lbind :: LHsBindLR GhcRn GhcRn
lbind@(L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
v }))] <- LHsBinds GhcRn
lbinds
, Just (TcIdSig (TcCompleteSig TcCompleteSig
sig)) <- 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), TcCompleteSig)
-> Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
forall a. a -> Maybe a
Just (LHsBindLR GhcRn GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
lbind, TcCompleteSig
sig)
| Bool
otherwise
= Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
forall a. Maybe a
Nothing
binders :: [IdP GhcRn]
binders = CollectFlag GhcRn -> LHsBinds GhcRn -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LHsBinds 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 (TcPartialSig {})) -> Bool
True
Maybe TcSigInfo
_ -> Bool
False
has_mult_anns_and_pats :: Bool
has_mult_anns_and_pats = (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool
forall {idL} {l} {l} {idR}.
(XRec idL (Pat idL) ~ GenLocated l (Pat idL)) =>
GenLocated l (HsBindLR idL idR) -> Bool
has_mult_ann_and_pat LHsBinds GhcRn
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
lbinds
has_mult_ann_and_pat :: GenLocated l (HsBindLR idL idR) -> Bool
has_mult_ann_and_pat (L l
_ (PatBind{pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult=HsNoMultAnn{}})) = Bool
False
has_mult_ann_and_pat (L l
_ (PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs=(L l
_ (VarPat{}))})) = Bool
False
has_mult_ann_and_pat (L l
_ (PatBind{})) = Bool
True
has_mult_ann_and_pat GenLocated l (HsBindLR idL idR)
_ = Bool
False
isClosedBndrGroup :: TcTypeEnv -> [(LHsBind GhcRn)] -> IsGroupClosed
isClosedBndrGroup :: TcTypeEnv -> LHsBinds GhcRn -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env LHsBinds GhcRn
binds
= NameEnv NameSet -> Bool -> IsGroupClosed
IsGroupClosed NameEnv NameSet
fv_env Bool
type_closed
where
type_closed :: Bool
type_closed = (NameSet -> Bool) -> NameEnv NameSet -> Bool
forall {k} elt (key :: k). (elt -> Bool) -> UniqFM key elt -> Bool
allUFM ((Name -> Bool) -> NameSet -> Bool
nameSetAll Name -> Bool
is_closed_type_id) NameEnv NameSet
fv_env
fv_env :: NameEnv NameSet
fv_env :: NameEnv NameSet
fv_env = [(Name, NameSet)] -> NameEnv NameSet
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, NameSet)] -> NameEnv NameSet)
-> [(Name, NameSet)] -> NameEnv NameSet
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsBind GhcRn) -> [(Name, NameSet)])
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> [(Name, NameSet)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBind GhcRn -> [(Name, NameSet)]
bindFvs (HsBind GhcRn -> [(Name, NameSet)])
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> [(Name, NameSet)]
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
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds
bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
bindFvs :: HsBind GhcRn -> [(Name, NameSet)]
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 :: NameSet
open_fvs = NameSet -> NameSet
get_open_fvs XFunBind GhcRn GhcRn
NameSet
fvs
in [(Name
f, NameSet
open_fvs)]
bindFvs (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec GhcRn (Pat GhcRn)
pat, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind GhcRn GhcRn
fvs })
= let open_fvs :: NameSet
open_fvs = NameSet -> NameSet
get_open_fvs XPatBind GhcRn GhcRn
NameSet
fvs
in [(Name
b, NameSet
open_fvs) | Name
b <- CollectFlag GhcRn -> XRec GhcRn (Pat GhcRn) -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders XRec GhcRn (Pat GhcRn)
pat]
bindFvs HsBind GhcRn
_
= []
get_open_fvs :: NameSet -> NameSet
get_open_fvs NameSet
fvs = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
is_closed) NameSet
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 NameSet
_ 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)