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