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