{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE UndecidableInstances #-} 
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
module GHC.Tc.Gen.App
       ( tcApp
       , tcInferSigma
       , tcExprPrag ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
import GHC.Types.Basic ( Arity, ExprOrPat(Expression) )
import GHC.Types.Id ( idArity, idName, hasNoBinding )
import GHC.Types.Name ( isWiredInName )
import GHC.Types.Var
import GHC.Builtin.Types ( multiplicityTy )
import GHC.Core.ConLike  ( ConLike(..) )
import GHC.Core.DataCon ( dataConRepArity
                        , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon )
import GHC.Tc.Gen.Head
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCo.Subst (substTyWithInScope)
import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType )
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.PrimOps( tagToEnumKey )
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Types.Var.Env  ( emptyTidyEnv, mkInScopeSet )
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Function
import GHC.Prelude
tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcType
tcInferSigma Bool
inst (L SrcSpanAnn' (EpAnn AnnListItem)
loc HsExpr GhcRn
rn_expr)
  | (fun :: (HsExpr GhcRn, AppCtxt)
fun@(HsExpr GhcRn
rn_fun,AppCtxt
_), [HsExprArg 'TcpRn]
rn_args) <- HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
rn_expr
  = HsExpr GhcRn -> TcM TcType -> TcM TcType
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
rn_expr (TcM TcType -> TcM TcType) -> TcM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$
    SrcSpanAnn' (EpAnn AnnListItem) -> TcM TcType -> TcM TcType
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
loc     (TcM TcType -> TcM TcType) -> TcM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$
    do { Bool
do_ql <- HsExpr GhcRn -> TcM Bool
wantQuickLook HsExpr GhcRn
rn_fun
       ; (HsExpr GhcTc
_tc_fun, TcType
fun_sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead (HsExpr GhcRn, AppCtxt)
fun [HsExprArg 'TcpRn]
rn_args
       ; (Delta
_delta, [HsExprArg 'TcpInst]
inst_args, TcType
app_res_sigma) <- Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
inst (HsExpr GhcRn, AppCtxt)
fun TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
       ; [HsExprArg 'TcpTc]
_tc_args <- Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
do_ql [HsExprArg 'TcpInst]
inst_args
       ; TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
app_res_sigma }
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
rn_expr ExpRhoType
exp_res_ty
  | (fun :: (HsExpr GhcRn, AppCtxt)
fun@(HsExpr GhcRn
rn_fun, AppCtxt
fun_ctxt), [HsExprArg 'TcpRn]
rn_args) <- HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
rn_expr
  = do { (HsExpr GhcTc
tc_fun, TcType
fun_sigma) <- (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead (HsExpr GhcRn, AppCtxt)
fun [HsExprArg 'TcpRn]
rn_args
       
       ; Bool
do_ql <- HsExpr GhcRn -> TcM Bool
wantQuickLook HsExpr GhcRn
rn_fun
       ; (Delta
delta, [HsExprArg 'TcpInst]
inst_args, TcType
app_res_rho) <- Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
True (HsExpr GhcRn, AppCtxt)
fun TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
       
       
       
       
       
       
       
       
       
       ; String -> SDoc -> TcRn ()
traceTc String
"tcApp FRR" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat
             [ String -> SDoc
text String
"tc_fun =" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
tc_fun
             , String -> SDoc
text String
"inst_args =" SDoc -> SDoc -> SDoc
<+> [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
inst_args
             , String -> SDoc
text String
"app_res_rho =" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho ]
       ; [HsExprArg 'TcpInst] -> TcType -> HsExpr GhcTc -> TcRn ()
hasFixedRuntimeRep_remainingValArgs [HsExprArg 'TcpInst]
inst_args TcType
app_res_rho HsExpr GhcTc
tc_fun
       
       ; TcType
app_res_rho <- if Bool
do_ql
                        then Delta -> TcType -> ExpRhoType -> TcM TcType
quickLookResultType Delta
delta TcType
app_res_rho ExpRhoType
exp_res_ty
                        else TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
app_res_rho
       
       
       
       
       
       
       
       ; let  perhaps_add_res_ty_ctxt :: TcM HsWrapper -> TcM HsWrapper
perhaps_add_res_ty_ctxt TcM HsWrapper
thing_inside
                 | AppCtxt -> Bool
insideExpansion AppCtxt
fun_ctxt
                 = TcM HsWrapper
thing_inside
                 | Bool
otherwise
                 = HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcType
-> ExpRhoType
-> TcM HsWrapper
-> TcM HsWrapper
forall a.
HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt HsExpr GhcRn
rn_fun [HsExprArg 'TcpRn]
rn_args TcType
app_res_rho ExpRhoType
exp_res_ty (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
                   TcM HsWrapper
thing_inside
       ; HsWrapper
res_wrap <- TcM HsWrapper -> TcM HsWrapper
perhaps_add_res_ty_ctxt (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
                     CtOrigin
-> UserTypeCtxt
-> Maybe TypedThing
-> TcType
-> ExpRhoType
-> TcM HsWrapper
tcSubTypeNC (HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
rn_expr) UserTypeCtxt
GenSigCtxt (TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TypedThing -> Maybe TypedThing) -> TypedThing -> Maybe TypedThing
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> TypedThing
HsExprRnThing HsExpr GhcRn
rn_expr)
                                 TcType
app_res_rho ExpRhoType
exp_res_ty
                     
                     
                     
       ; DumpFlag -> TcRn () -> TcRn ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_tc_trace (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         do { [HsExprArg 'TcpInst]
inst_args <- (HsExprArg 'TcpInst
 -> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst))
-> [HsExprArg 'TcpInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [HsExprArg 'TcpInst]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
zonkArg [HsExprArg 'TcpInst]
inst_args  
            ; String -> SDoc -> TcRn ()
traceTc String
"tcApp" ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"rn_fun"       SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun
                               , String -> SDoc
text String
"inst_args"    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
brackets ((HsExprArg 'TcpInst -> SDoc) -> [HsExprArg 'TcpInst] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc [HsExprArg 'TcpInst]
inst_args)
                               , String -> SDoc
text String
"do_ql:  "     SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
do_ql
                               , String -> SDoc
text String
"fun_sigma:  " SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma
                               , String -> SDoc
text String
"delta:      " SDoc -> SDoc -> SDoc
<+> Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta
                               , String -> SDoc
text String
"app_res_rho:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho
                               , String -> SDoc
text String
"exp_res_ty:"  SDoc -> SDoc -> SDoc
<+> ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
exp_res_ty
                               , String -> SDoc
text String
"rn_expr:"     SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_expr ]) }
       
       ; [HsExprArg 'TcpTc]
tc_args <- Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
do_ql [HsExprArg 'TcpInst]
inst_args
       
       ; HsExpr GhcTc
tc_expr <-
          if HsExpr GhcRn -> Bool
isTagToEnum HsExpr GhcRn
rn_fun
          then HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
app_res_rho
          else do HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args)
       
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
res_wrap HsExpr GhcTc
tc_expr) }
hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM ()
hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcType -> HsExpr GhcTc -> TcRn ()
hasFixedRuntimeRep_remainingValArgs [HsExprArg 'TcpInst]
applied_args TcType
app_res_rho = \case
  HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ TcTyVar
fun_id)
    
    
    
    
    
    
    
    
    
    | TcTyVar -> Name
idName TcTyVar
fun_id Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeCoercePrimName
    -> TcTyVar -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
forall thing.
Outputable thing =>
thing -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
check_thing TcTyVar
fun_id Arity
1 (TcTyVar -> Arity -> FixedRuntimeRepContext
FRRNoBindingResArg TcTyVar
fun_id)
    
    
    
    | Name -> Bool
isWiredInName (TcTyVar -> Name
idName TcTyVar
fun_id) Bool -> Bool -> Bool
&& TcTyVar -> Bool
hasNoBinding TcTyVar
fun_id
    -> TcTyVar -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
forall thing.
Outputable thing =>
thing -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
check_thing TcTyVar
fun_id (TcTyVar -> Arity
idArity TcTyVar
fun_id) (TcTyVar -> Arity -> FixedRuntimeRepContext
FRRNoBindingResArg TcTyVar
fun_id)
       
       
       
       
       
       
  XExpr (ConLikeTc (RealDataCon DataCon
con) [TcTyVar]
_ [Scaled TcType]
_)
  
    | DataCon -> Bool
isNewDataCon DataCon
con
  
    Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
    Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con
    -> DataCon -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
forall thing.
Outputable thing =>
thing -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
check_thing DataCon
con (DataCon -> Arity
dataConRepArity DataCon
con) (ExprOrPat -> DataCon -> Arity -> FixedRuntimeRepContext
FRRDataConArg ExprOrPat
Expression DataCon
con)
  HsExpr GhcTc
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    nb_applied_vis_val_args :: Int
    nb_applied_vis_val_args :: Arity
nb_applied_vis_val_args = (HsExprArg 'TcpInst -> Bool) -> [HsExprArg 'TcpInst] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count HsExprArg 'TcpInst -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg [HsExprArg 'TcpInst]
applied_args
    nb_applied_val_args :: Int
    nb_applied_val_args :: Arity
nb_applied_val_args = [HsExprArg 'TcpInst] -> Arity
forall (id :: TcPass). [HsExprArg id] -> Arity
countVisAndInvisValArgs [HsExprArg 'TcpInst]
applied_args
    arg_tys :: [(Type,AnonArgFlag)]
    arg_tys :: [(TcType, AnonArgFlag)]
arg_tys = TcType -> [(TcType, AnonArgFlag)]
getRuntimeArgTys TcType
app_res_rho
    
    
    
    check_thing :: Outputable thing
                => thing
                -> Arity
                -> (Int -> FixedRuntimeRepContext)
                -> TcM ()
    check_thing :: forall thing.
Outputable thing =>
thing -> Arity -> (Arity -> FixedRuntimeRepContext) -> TcRn ()
check_thing thing
thing Arity
arity Arity -> FixedRuntimeRepContext
mk_frr_orig = do
      String -> SDoc -> TcRn ()
traceTc String
"tcApp remainingValArgs check_thing" (thing -> Arity -> SDoc
forall thing. Outputable thing => thing -> Arity -> SDoc
debug_msg thing
thing Arity
arity)
      Arity -> Arity -> [(TcType, AnonArgFlag)] -> TcRn ()
go (Arity
nb_applied_vis_val_args Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1) (Arity
nb_applied_val_args Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1) [(TcType, AnonArgFlag)]
arg_tys
      where
        go :: Int 
                  
           -> Int 
                  
           -> [(Type, AnonArgFlag)] 
           -> TcM ()
        go :: Arity -> Arity -> [(TcType, AnonArgFlag)] -> TcRn ()
go Arity
_ Arity
i_val [(TcType, AnonArgFlag)]
_
          | Arity
i_val Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
arity
          = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go Arity
_ Arity
_ []
          
          
          = String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"hasFixedRuntimeRep_remainingValArgs" (thing -> Arity -> SDoc
forall thing. Outputable thing => thing -> Arity -> SDoc
debug_msg thing
thing Arity
arity)
        go Arity
i_visval !Arity
i_val ((TcType
arg_ty, AnonArgFlag
af) : [(TcType, AnonArgFlag)]
tys)
          = case AnonArgFlag
af of
              AnonArgFlag
InvisArg ->
                Arity -> Arity -> [(TcType, AnonArgFlag)] -> TcRn ()
go Arity
i_visval (Arity
i_val Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1) [(TcType, AnonArgFlag)]
tys
              AnonArgFlag
VisArg   -> do
                (() :: Constraint) => FixedRuntimeRepContext -> TcType -> TcRn ()
FixedRuntimeRepContext -> TcType -> TcRn ()
hasFixedRuntimeRep_syntactic (Arity -> FixedRuntimeRepContext
mk_frr_orig Arity
i_visval) TcType
arg_ty
                Arity -> Arity -> [(TcType, AnonArgFlag)] -> TcRn ()
go (Arity
i_visval Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1) (Arity
i_val Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1) [(TcType, AnonArgFlag)]
tys
    
    
    debug_msg :: Outputable thing => thing -> Arity -> SDoc
    debug_msg :: forall thing. Outputable thing => thing -> Arity -> SDoc
debug_msg thing
thing Arity
arity =
      [SDoc] -> SDoc
vcat
        [ String -> SDoc
text String
"thing =" SDoc -> SDoc -> SDoc
<+> thing -> SDoc
forall a. Outputable a => a -> SDoc
ppr thing
thing
        , String -> SDoc
text String
"arity =" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
arity
        , String -> SDoc
text String
"applied_args =" SDoc -> SDoc -> SDoc
<+> [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
applied_args
        , String -> SDoc
text String
"nb_applied_val_args =" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
nb_applied_val_args
        , String -> SDoc
text String
"arg_tys =" SDoc -> SDoc -> SDoc
<+> [(TcType, AnonArgFlag)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(TcType, AnonArgFlag)]
arg_tys ]
wantQuickLook :: HsExpr GhcRn -> TcM Bool
wantQuickLook :: HsExpr GhcRn -> TcM Bool
wantQuickLook (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
f))
  | Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
f Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
quickLookKeys = Bool -> TcM Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
wantQuickLook HsExpr GhcRn
_                      = Extension -> TcM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
quickLookKeys :: [Unique]
quickLookKeys :: [Unique]
quickLookKeys = [Unique
dollarIdKey, Unique
leftSectionKey, Unique
rightSectionKey]
zonkQuickLook :: Bool -> TcType -> TcM TcType
zonkQuickLook :: Bool -> TcType -> TcM TcType
zonkQuickLook Bool
do_ql TcType
ty
  | Bool
do_ql     = TcType -> TcM TcType
zonkTcType TcType
ty
  | Bool
otherwise = TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
ty
zonkArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
zonkArg :: HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
zonkArg eva :: HsExprArg 'TcpInst
eva@(EValArg { eva_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty = Scaled TcType
m TcType
ty })
  = do { TcType
ty' <- TcType -> TcM TcType
zonkTcType TcType
ty
       ; HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExprArg 'TcpInst
eva { eva_arg_ty :: XEVAType 'TcpInst
eva_arg_ty = TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
m TcType
ty' }) }
zonkArg HsExprArg 'TcpInst
arg = HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExprArg 'TcpInst
arg
tcValArgs :: Bool                    
          -> [HsExprArg 'TcpInst]    
          -> TcM [HsExprArg 'TcpTc]  
tcValArgs :: Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
do_ql [HsExprArg 'TcpInst]
args
  = (HsExprArg 'TcpInst
 -> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc))
-> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
tc_arg [HsExprArg 'TcpInst]
args
  where
    tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)
    tc_arg :: HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
tc_arg (EPrag AppCtxt
l HsPragE (GhcPass (XPass 'TcpInst))
p)           = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCtxt -> HsPragE (GhcPass (XPass 'TcpTc)) -> HsExprArg 'TcpTc
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
l (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
HsPragE (GhcPass (XPass 'TcpInst))
p))
    tc_arg (EWrap EWrap
w)             = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EWrap -> HsExprArg 'TcpTc
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap EWrap
w)
    tc_arg (ETypeArg AppCtxt
l LHsWcType GhcRn
hs_ty XETAType 'TcpInst
ty) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCtxt -> LHsWcType GhcRn -> XETAType 'TcpTc -> HsExprArg 'TcpTc
forall (p :: TcPass).
AppCtxt -> LHsWcType GhcRn -> XETAType p -> HsExprArg p
ETypeArg AppCtxt
l LHsWcType GhcRn
hs_ty XETAType 'TcpInst
XETAType 'TcpTc
ty)
    tc_arg eva :: HsExprArg 'TcpInst
eva@(EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg 'TcpInst
arg, eva_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty = Scaled TcType
mult TcType
arg_ty
                        , eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt })
      = do { 
             
             
             
             
             
             
             
             
             TcType
arg_ty <- Bool -> TcType -> TcM TcType
zonkQuickLook Bool
do_ql TcType
arg_ty
             
           ; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
arg' <- TcType
-> TcM
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
mult (TcM (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
 -> TcM
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)))
-> TcM
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> TcM
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
                     do { String -> SDoc -> TcRn ()
traceTc String
"tcEValArg" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                          [SDoc] -> SDoc
vcat [ AppCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr AppCtxt
ctxt
                               , String -> SDoc
text String
"arg type:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
arg_ty
                               , String -> SDoc
text String
"arg:" SDoc -> SDoc -> SDoc
<+> EValArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
arg ]
                        ; AppCtxt -> EValArg 'TcpInst -> TcType -> TcM (LHsExpr GhcTc)
tcEValArg AppCtxt
ctxt EValArg 'TcpInst
arg TcType
arg_ty }
           ; HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExprArg 'TcpInst
eva { eva_arg :: EValArg 'TcpTc
eva_arg    = LHsExpr (GhcPass (XPass 'TcpTc)) -> EValArg 'TcpTc
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr (GhcPass (XPass 'TcpTc))
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
arg'
                         , eva_arg_ty :: XEVAType 'TcpTc
eva_arg_ty = TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
arg_ty }) }
tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc)
tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcType -> TcM (LHsExpr GhcTc)
tcEValArg AppCtxt
ctxt (ValArg larg :: LHsExpr (GhcPass (XPass 'TcpInst))
larg@(L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
arg)) TcType
exp_arg_sigma
  = AppCtxt
-> LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpInst))
larg (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do { HsExpr GhcTc
arg' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcPolyExpr HsExpr GhcRn
arg (TcType -> ExpRhoType
mkCheckExpType TcType
exp_arg_sigma)
       ; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcM
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcTc
arg') }
tcEValArg AppCtxt
ctxt (ValArgQL { va_expr :: EValArg 'TcpInst -> LHsExpr GhcRn
va_expr = larg :: LHsExpr GhcRn
larg@(L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
_)
                         , va_fun :: EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun = (HsExpr GhcTc
inner_fun, AppCtxt
fun_ctxt)
                         , va_args :: EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args = [HsExprArg 'TcpInst]
inner_args
                         , va_ty :: EValArg 'TcpInst -> TcType
va_ty = TcType
app_res_rho }) TcType
exp_arg_sigma
  = AppCtxt
-> LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr GhcRn
larg (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc String
"tcEValArgQL {" ([SDoc] -> SDoc
vcat [ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
inner_fun SDoc -> SDoc -> SDoc
<+> [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
inner_args ])
       ; [HsExprArg 'TcpTc]
tc_args <- Bool -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs Bool
True [HsExprArg 'TcpInst]
inner_args
       ; TcCoercionN
co      <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyType Maybe TypedThing
forall a. Maybe a
Nothing TcType
app_res_rho TcType
exp_arg_sigma
       ; let arg' :: HsExpr GhcTc
arg' = TcCoercionN -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionN
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps HsExpr GhcTc
inner_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args
       ; String -> SDoc -> TcRn ()
traceTc String
"tcEValArgQL }" SDoc
empty
       ; GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
-> TcM
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcTc
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcTc
arg') }
type Delta = TcTyVarSet   
                          
                          
                          
tcInstFun :: Bool   
          -> Bool   
                    
                    
                    
                    
                    
                    
                    
          -> (HsExpr GhcRn, AppCtxt)        
          -> TcSigmaType -> [HsExprArg 'TcpRn]
          -> TcM ( Delta
                 , [HsExprArg 'TcpInst]
                 , TcSigmaType )
tcInstFun :: Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
inst_final (HsExpr GhcRn
rn_fun, AppCtxt
fun_ctxt) TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcInstFun" ([SDoc] -> SDoc
vcat [ HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma
                                   , String -> SDoc
text String
"args:" SDoc -> SDoc -> SDoc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args
                                   , String -> SDoc
text String
"do_ql" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
do_ql ])
       ; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
emptyVarSet [] [] TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args }
  where
    fun_loc :: SrcSpan
fun_loc  = AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
fun_ctxt
    fun_orig :: CtOrigin
fun_orig = HsExpr GhcRn -> CtOrigin
exprCtOrigin (case AppCtxt
fun_ctxt of
                               VAExpansion HsExpr GhcRn
e SrcSpan
_ -> HsExpr GhcRn
e
                               VACall HsExpr GhcRn
e Arity
_ SrcSpan
_    -> HsExpr GhcRn
e)
    set_fun_ctxt :: TcRn ([TcTyVar], HsWrapper, TcType)
-> TcRn ([TcTyVar], HsWrapper, TcType)
set_fun_ctxt TcRn ([TcTyVar], HsWrapper, TcType)
thing_inside
      | Bool -> Bool
not (SrcSpan -> Bool
isGoodSrcSpan SrcSpan
fun_loc)   
      = TcRn ([TcTyVar], HsWrapper, TcType)
thing_inside                  
      | Bool
otherwise
      = SrcSpan
-> TcRn ([TcTyVar], HsWrapper, TcType)
-> TcRn ([TcTyVar], HsWrapper, TcType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
fun_loc (TcRn ([TcTyVar], HsWrapper, TcType)
 -> TcRn ([TcTyVar], HsWrapper, TcType))
-> TcRn ([TcTyVar], HsWrapper, TcType)
-> TcRn ([TcTyVar], HsWrapper, TcType)
forall a b. (a -> b) -> a -> b
$
        case AppCtxt
fun_ctxt of
          VAExpansion HsExpr GhcRn
orig SrcSpan
_ -> HsExpr GhcRn
-> TcRn ([TcTyVar], HsWrapper, TcType)
-> TcRn ([TcTyVar], HsWrapper, TcType)
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
orig TcRn ([TcTyVar], HsWrapper, TcType)
thing_inside
          VACall {}          -> TcRn ([TcTyVar], HsWrapper, TcType)
thing_inside
    
    
    
    n_val_args :: Arity
n_val_args = (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg [HsExprArg 'TcpRn]
rn_args
    fun_is_out_of_scope :: Bool
fun_is_out_of_scope  
      = case HsExpr GhcRn
rn_fun of
          HsUnboundVar {} -> Bool
True
          HsExpr GhcRn
_               -> Bool
False
    inst_all, inst_inferred, inst_none :: ArgFlag -> Bool
    inst_all :: ArgFlag -> Bool
inst_all (Invisible {}) = Bool
True
    inst_all ArgFlag
Required       = Bool
False
    inst_inferred :: ArgFlag -> Bool
inst_inferred (Invisible Specificity
InferredSpec)  = Bool
True
    inst_inferred (Invisible Specificity
SpecifiedSpec) = Bool
False
    inst_inferred ArgFlag
Required                  = Bool
False
    inst_none :: ArgFlag -> Bool
inst_none ArgFlag
_ = Bool
False
    inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool
    inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool
inst_fun [] | Bool
inst_final  = ArgFlag -> Bool
inst_all
                | Bool
otherwise   = ArgFlag -> Bool
inst_none
                
                
                
                
    inst_fun (EValArg {} : [HsExprArg 'TcpRn]
_) = ArgFlag -> Bool
inst_all
    inst_fun [HsExprArg 'TcpRn]
_                = ArgFlag -> Bool
inst_inferred
    
    go, go1 :: Delta
            -> [HsExprArg 'TcpInst]     
            -> [Scaled TcSigmaTypeFRR]  
            -> TcSigmaType -> [HsExprArg 'TcpRn]
            -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)
    
    go :: Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
      | Just TcTyVar
kappa <- TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
fun_ty
      , TcTyVar
kappa TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta
      = do { MetaDetails
cts <- TcTyVar -> TcM MetaDetails
readMetaTyVar TcTyVar
kappa
           ; case MetaDetails
cts of
                Indirect TcType
fun_ty' -> Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go  Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty' [HsExprArg 'TcpRn]
args
                MetaDetails
Flexi            -> Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty  [HsExprArg 'TcpRn]
args }
     | Bool
otherwise
     = Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
    
    
    
    
    go1 :: Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
      | ([TcTyVar]
tvs,   TcType
body1) <- (ArgFlag -> Bool) -> TcType -> ([TcTyVar], TcType)
tcSplitSomeForAllTyVars ([HsExprArg 'TcpRn] -> ArgFlag -> Bool
inst_fun [HsExprArg 'TcpRn]
args) TcType
fun_ty
      , (ThetaType
theta, TcType
body2) <- TcType -> (ThetaType, TcType)
tcSplitPhiTy TcType
body1
      , Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta)
      = do { ([TcTyVar]
inst_tvs, HsWrapper
wrap, TcType
fun_rho) <- TcRn ([TcTyVar], HsWrapper, TcType)
-> TcRn ([TcTyVar], HsWrapper, TcType)
set_fun_ctxt (TcRn ([TcTyVar], HsWrapper, TcType)
 -> TcRn ([TcTyVar], HsWrapper, TcType))
-> TcRn ([TcTyVar], HsWrapper, TcType)
-> TcRn ([TcTyVar], HsWrapper, TcType)
forall a b. (a -> b) -> a -> b
$
                                          CtOrigin
-> [TcTyVar]
-> ThetaType
-> TcType
-> TcRn ([TcTyVar], HsWrapper, TcType)
instantiateSigma CtOrigin
fun_orig [TcTyVar]
tvs ThetaType
theta TcType
body2
                 
                 
           ; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go (Delta
delta Delta -> [TcTyVar] -> Delta
`extendVarSetList` [TcTyVar]
inst_tvs)
                (HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
wrap [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
fun_rho [HsExprArg 'TcpRn]
args }
                
                
    
    go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
_ TcType
fun_ty []
       = do { String -> SDoc -> TcRn ()
traceTc String
"tcInstFun:ret" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_ty)
            ; (Delta, [HsExprArg 'TcpInst], TcType)
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta, [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. [a] -> [a]
reverse [HsExprArg 'TcpInst]
acc, TcType
fun_ty) }
    go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty (EWrap EWrap
w : [HsExprArg 'TcpRn]
args)
      = Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta (EWrap -> HsExprArg 'TcpInst
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap EWrap
w HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
    go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty (EPrag AppCtxt
sp HsPragE (GhcPass (XPass 'TcpRn))
prag : [HsExprArg 'TcpRn]
args)
      = Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go1 Delta
delta (AppCtxt -> HsPragE (GhcPass (XPass 'TcpInst)) -> HsExprArg 'TcpInst
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
sp HsPragE (GhcPass (XPass 'TcpRn))
HsPragE (GhcPass (XPass 'TcpInst))
prag HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
args
    
    go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty ( ETypeArg { eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty }
                                : [HsExprArg 'TcpRn]
rest_args )
      | Bool
fun_is_out_of_scope   
      = Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty [HsExprArg 'TcpRn]
rest_args
      | Bool
otherwise
      = do { (TcType
ty_arg, TcType
inst_ty) <- TcType -> LHsWcType GhcRn -> TcM (TcType, TcType)
tcVTA TcType
fun_ty LHsWcType GhcRn
hs_ty
           ; let arg' :: HsExprArg 'TcpInst
arg' = ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_hs_ty :: LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty, eva_ty :: XETAType 'TcpInst
eva_ty = TcType
XETAType 'TcpInst
ty_arg }
           ; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta (HsExprArg 'TcpInst
arg' HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) [Scaled TcType]
so_far TcType
inst_ty [HsExprArg 'TcpRn]
rest_args }
    
    go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty args :: [HsExprArg 'TcpRn]
args@(EValArg {} : [HsExprArg 'TcpRn]
_)
      | Just TcTyVar
kappa <- TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
fun_ty
      , TcTyVar
kappa TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta
      = 
        
        
        
        
        
        
        
        
        
        
        
        
        
        
        do { let valArgsCount :: Arity
valArgsCount = [HsExprArg 'TcpRn] -> Arity
forall (id :: TcPass). [HsExprArg id] -> Arity
countLeadingValArgs [HsExprArg 'TcpRn]
args
           ; [TcTyVar]
arg_nus <- Arity
-> IOEnv (Env TcGblEnv TcLclEnv) TcTyVar
-> IOEnv (Env TcGblEnv TcLclEnv) [TcTyVar]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
valArgsCount IOEnv (Env TcGblEnv TcLclEnv) TcTyVar
newOpenFlexiTyVar
             
             
           ; ThetaType
mults   <- Arity -> TcM TcType -> IOEnv (Env TcGblEnv TcLclEnv) ThetaType
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
valArgsCount (TcType -> TcM TcType
newFlexiTyVarTy TcType
multiplicityTy)
           ; TcTyVar
res_nu  <- IOEnv (Env TcGblEnv TcLclEnv) TcTyVar
newOpenFlexiTyVar
           ; TcCoercionN
kind_co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyKind Maybe TypedThing
forall a. Maybe a
Nothing TcType
liftedTypeKind (TcTyVar -> TcType
tyVarKind TcTyVar
kappa)
           ; let delta' :: Delta
delta'  = Delta
delta Delta -> [TcTyVar] -> Delta
`extendVarSetList` (TcTyVar
res_nuTcTyVar -> [TcTyVar] -> [TcTyVar]
forall a. a -> [a] -> [a]
:[TcTyVar]
arg_nus)
                 arg_tys :: ThetaType
arg_tys = [TcTyVar] -> ThetaType
mkTyVarTys [TcTyVar]
arg_nus
                 res_ty :: TcType
res_ty  = TcTyVar -> TcType
mkTyVarTy TcTyVar
res_nu
                 fun_ty' :: TcType
fun_ty' = [Scaled TcType] -> TcType -> TcType
mkVisFunTys (String
-> (TcType -> TcType -> Scaled TcType)
-> ThetaType
-> ThetaType
-> [Scaled TcType]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"tcInstFun" TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
mkScaled ThetaType
mults ThetaType
arg_tys) TcType
res_ty
                 co_wrap :: HsWrapper
co_wrap = TcCoercionN -> HsWrapper
mkWpCastN (Role -> TcType -> TcCoercionN -> TcCoercionN
mkTcGReflLeftCo Role
Nominal TcType
fun_ty' TcCoercionN
kind_co)
                 acc' :: [HsExprArg 'TcpInst]
acc'    = HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
co_wrap [HsExprArg 'TcpInst]
acc
                 
                 
                 
           ; (() :: Constraint) => TcTyVar -> TcType -> TcRn ()
TcTyVar -> TcType -> TcRn ()
writeMetaTyVar TcTyVar
kappa (TcType -> TcCoercionN -> TcType
mkCastTy TcType
fun_ty' TcCoercionN
kind_co)
                 
           ; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta' [HsExprArg 'TcpInst]
acc' [Scaled TcType]
so_far TcType
fun_ty' [HsExprArg 'TcpRn]
args }
    
    go1 Delta
delta [HsExprArg 'TcpInst]
acc [Scaled TcType]
so_far TcType
fun_ty
        (eva :: HsExprArg 'TcpRn
eva@(EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg LHsExpr (GhcPass (XPass 'TcpRn))
arg, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt }) : [HsExprArg 'TcpRn]
rest_args)
      = do { (HsWrapper
wrap, Scaled TcType
arg_ty, TcType
res_ty) <-
                ExpectedFunTyOrigin
-> Maybe TypedThing
-> (Arity, [Scaled TcType])
-> TcType
-> TcM (HsWrapper, Scaled TcType, TcType)
matchActualFunTySigma
                  (TypedThing -> HsExpr GhcRn -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg (HsExpr GhcRn -> TypedThing
HsExprRnThing HsExpr GhcRn
rn_fun) (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
-> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass (XPass 'TcpRn))
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
arg))
                  (TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TypedThing -> Maybe TypedThing) -> TypedThing -> Maybe TypedThing
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> TypedThing
HsExprRnThing HsExpr GhcRn
rn_fun)
                  (Arity
n_val_args, [Scaled TcType]
so_far) TcType
fun_ty
          ; (Delta
delta', EValArg 'TcpInst
arg') <- if Bool
do_ql
                              then AppCtxt
-> LHsExpr GhcRn
-> TcM (Delta, EValArg 'TcpInst)
-> TcM (Delta, EValArg 'TcpInst)
forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpRn))
arg (TcM (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst))
-> TcM (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a b. (a -> b) -> a -> b
$
                                   
                                   
                                   Delta
-> LHsExpr GhcRn -> Scaled TcType -> TcM (Delta, EValArg 'TcpInst)
quickLookArg Delta
delta LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpRn))
arg Scaled TcType
arg_ty
                              else (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta, LHsExpr (GhcPass (XPass 'TcpInst)) -> EValArg 'TcpInst
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr (GhcPass (XPass 'TcpRn))
LHsExpr (GhcPass (XPass 'TcpInst))
arg)
          ; let acc' :: [HsExprArg 'TcpInst]
acc' = HsExprArg 'TcpRn
eva { eva_arg :: EValArg 'TcpInst
eva_arg = EValArg 'TcpInst
arg', eva_arg_ty :: XEVAType 'TcpInst
eva_arg_ty = Scaled TcType
XEVAType 'TcpInst
arg_ty }
                       HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap HsWrapper
wrap [HsExprArg 'TcpInst]
acc
          ; Delta
-> [HsExprArg 'TcpInst]
-> [Scaled TcType]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
go Delta
delta' [HsExprArg 'TcpInst]
acc' (Scaled TcType
arg_tyScaled TcType -> [Scaled TcType] -> [Scaled TcType]
forall a. a -> [a] -> [a]
:[Scaled TcType]
so_far) TcType
res_ty [HsExprArg 'TcpRn]
rest_args }
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
           -> TcM a -> TcM a
addArgCtxt :: forall a. AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a
addArgCtxt (VACall HsExpr GhcRn
fun Arity
arg_no SrcSpan
_) (L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
arg) TcM a
thing_inside
  = SrcSpanAnn' (EpAnn AnnListItem) -> TcM a -> TcM a
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> HsExpr GhcRn -> Arity -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt HsExpr GhcRn
fun HsExpr GhcRn
arg Arity
arg_no) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TcM a
thing_inside
addArgCtxt (VAExpansion {}) (L SrcSpanAnn' (EpAnn AnnListItem)
arg_loc HsExpr GhcRn
arg) TcM a
thing_inside
  = SrcSpanAnn' (EpAnn AnnListItem) -> TcM a -> TcM a
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn AnnListItem)
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    HsExpr GhcRn -> TcM a -> TcM a
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
arg    (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$  
    TcM a
thing_inside
tcVTA :: TcType            
      -> LHsWcType GhcRn   
      -> TcM (TcType, TcType)
tcVTA :: TcType -> LHsWcType GhcRn -> TcM (TcType, TcType)
tcVTA TcType
fun_ty LHsWcType GhcRn
hs_ty
  | Just (TyVarBinder
tvb, TcType
inner_ty) <- TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTyVarBinder_maybe TcType
fun_ty
  , TyVarBinder -> ArgFlag
forall tv argf. VarBndr tv argf -> argf
binderArgFlag TyVarBinder
tvb ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
Specified
    
    
    
  = do { let tv :: TcTyVar
tv   = TyVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
tvb
             kind :: TcType
kind = TcTyVar -> TcType
tyVarKind TcTyVar
tv
       ; TcType
ty_arg <- LHsWcType GhcRn -> TcType -> TcM TcType
tcHsTypeApp LHsWcType GhcRn
hs_ty TcType
kind
       ; TcType
inner_ty <- TcType -> TcM TcType
zonkTcType TcType
inner_ty
             
       ; let in_scope :: InScopeSet
in_scope  = Delta -> InScopeSet
mkInScopeSet (ThetaType -> Delta
tyCoVarsOfTypes [TcType
fun_ty, TcType
ty_arg])
             insted_ty :: TcType
insted_ty = InScopeSet -> [TcTyVar] -> ThetaType -> TcType -> TcType
substTyWithInScope InScopeSet
in_scope [TcTyVar
tv] [TcType
ty_arg] TcType
inner_ty
                         
                         
       ; String -> SDoc -> TcRn ()
traceTc String
"VTA" ([SDoc] -> SDoc
vcat [TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv, TcType -> SDoc
debugPprType TcType
kind
                             , TcType -> SDoc
debugPprType TcType
ty_arg
                             , TcType -> SDoc
debugPprType ((() :: Constraint) => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty_arg)
                             , TcType -> SDoc
debugPprType TcType
inner_ty
                             , TcType -> SDoc
debugPprType TcType
insted_ty ])
       ; (TcType, TcType) -> TcM (TcType, TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType
ty_arg, TcType
insted_ty) }
  | Bool
otherwise
  = do { (TidyEnv
_, TcType
fun_ty) <- TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType TidyEnv
emptyTidyEnv TcType
fun_ty
       ; TcRnMessage -> TcM (TcType, TcType)
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> TcM (TcType, TcType))
-> TcRnMessage -> TcM (TcType, TcType)
forall a b. (a -> b) -> a -> b
$ TcType -> LHsWcType GhcRn -> TcRnMessage
TcRnInvalidTypeApplication TcType
fun_ty LHsWcType GhcRn
hs_ty }
quickLookArg :: Delta
             -> LHsExpr GhcRn          
             -> Scaled TcSigmaTypeFRR  
             -> TcM (Delta, EValArg 'TcpInst)
quickLookArg :: Delta
-> LHsExpr GhcRn -> Scaled TcType -> TcM (Delta, EValArg 'TcpInst)
quickLookArg Delta
delta LHsExpr GhcRn
larg (Scaled TcType
_ TcType
arg_ty)
  | Delta -> Bool
isEmptyVarSet Delta
delta  = Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg
  | Bool
otherwise            = TcType -> TcM (Delta, EValArg 'TcpInst)
go TcType
arg_ty
  where
    guarded :: Bool
guarded = TcType -> Bool
isGuardedTy TcType
arg_ty
      
      
      
    go :: TcType -> TcM (Delta, EValArg 'TcpInst)
go TcType
arg_ty | Bool -> Bool
not (TcType -> Bool
isRhoTy TcType
arg_ty)
              = Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg
              
              
              
              | Just TcTyVar
kappa <- TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
arg_ty
              , TcTyVar
kappa TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta
              = do { MetaDetails
info <- TcTyVar -> TcM MetaDetails
readMetaTyVar TcTyVar
kappa
                   ; case MetaDetails
info of
                       Indirect TcType
arg_ty' -> TcType -> TcM (Delta, EValArg 'TcpInst)
go TcType
arg_ty'
                       MetaDetails
Flexi            -> Bool
-> Delta
-> LHsExpr GhcRn
-> TcType
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 Bool
guarded Delta
delta LHsExpr GhcRn
larg TcType
arg_ty }
              | Bool
otherwise
              = Bool
-> Delta
-> LHsExpr GhcRn
-> TcType
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 Bool
guarded Delta
delta LHsExpr GhcRn
larg TcType
arg_ty
isGuardedTy :: TcType -> Bool
isGuardedTy :: TcType -> Bool
isGuardedTy TcType
ty
  | Just (TyCon
tc,ThetaType
_) <- HasCallStack => TcType -> Maybe (TyCon, ThetaType)
TcType -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe TcType
ty = TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal
  | Just {} <- TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty        = Bool
True
  | Bool
otherwise                               = Bool
False
quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR
              -> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 :: Bool
-> Delta
-> LHsExpr GhcRn
-> TcType
-> TcM (Delta, EValArg 'TcpInst)
quickLookArg1 Bool
guarded Delta
delta larg :: LHsExpr GhcRn
larg@(L SrcSpanAnn' (EpAnn AnnListItem)
_ HsExpr GhcRn
arg) TcType
arg_ty
  = do { let (fun :: (HsExpr GhcRn, AppCtxt)
fun@(HsExpr GhcRn
rn_fun, AppCtxt
fun_ctxt), [HsExprArg 'TcpRn]
rn_args) = HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
arg
       ; Maybe (HsExpr GhcTc, TcType)
mb_fun_ty <- HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcType))
tcInferAppHead_maybe HsExpr GhcRn
rn_fun [HsExprArg 'TcpRn]
rn_args
       ; String -> SDoc -> TcRn ()
traceTc String
"quickLookArg 1" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"arg:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg
              , String -> SDoc
text String
"head:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rn_fun SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Maybe (HsExpr GhcTc, TcType) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (HsExpr GhcTc, TcType)
mb_fun_ty
              , String -> SDoc
text String
"args:" SDoc -> SDoc -> SDoc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args ]
       ; case Maybe (HsExpr GhcTc, TcType)
mb_fun_ty of {
           Maybe (HsExpr GhcTc, TcType)
Nothing     -> 
                          Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg ;
           Just (HsExpr GhcTc
tc_fun, TcType
fun_sigma) ->
    do { let no_free_kappas :: Bool
no_free_kappas = TcType -> [HsExprArg 'TcpRn] -> Bool
findNoQuantVars TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
       ; String -> SDoc -> TcRn ()
traceTc String
"quickLookArg 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"no_free_kappas:" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
no_free_kappas
              , String -> SDoc
text String
"guarded:" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
guarded
              , String -> SDoc
text String
"tc_fun:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
tc_fun
              , String -> SDoc
text String
"fun_sigma:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma ]
       ; if Bool -> Bool
not (Bool
guarded Bool -> Bool -> Bool
|| Bool
no_free_kappas)
         then Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg
         else
    do { Bool
do_ql <- HsExpr GhcRn -> TcM Bool
wantQuickLook HsExpr GhcRn
rn_fun
       ; (Delta
delta_app, [HsExprArg 'TcpInst]
inst_args, TcType
app_res_rho) <- Bool
-> Bool
-> (HsExpr GhcRn, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM (Delta, [HsExprArg 'TcpInst], TcType)
tcInstFun Bool
do_ql Bool
True (HsExpr GhcRn, AppCtxt)
fun TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
       ; String -> SDoc -> TcRn ()
traceTc String
"quickLookArg 3" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"arg:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
arg
              , String -> SDoc
text String
"delta:" SDoc -> SDoc -> SDoc
<+> Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta
              , String -> SDoc
text String
"delta_app:" SDoc -> SDoc -> SDoc
<+> Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta_app
              , String -> SDoc
text String
"arg_ty:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
arg_ty
              , String -> SDoc
text String
"app_res_rho:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho ]
       
       
       ; let delta' :: Delta
delta' = Delta
delta Delta -> Delta -> Delta
`unionVarSet` Delta
delta_app
       ; Delta -> TcType -> TcType -> TcRn ()
qlUnify Delta
delta' TcType
arg_ty TcType
app_res_rho
       ; let ql_arg :: EValArg 'TcpInst
ql_arg = ValArgQL { va_expr :: LHsExpr GhcRn
va_expr  = LHsExpr GhcRn
larg
                               , va_fun :: (HsExpr GhcTc, AppCtxt)
va_fun   = (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt)
                               , va_args :: [HsExprArg 'TcpInst]
va_args  = [HsExprArg 'TcpInst]
inst_args
                               , va_ty :: TcType
va_ty    = TcType
app_res_rho }
       ; (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta', EValArg 'TcpInst
ql_arg) } } } }
skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
skipQuickLook Delta
delta LHsExpr GhcRn
larg = (Delta, EValArg 'TcpInst) -> TcM (Delta, EValArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Delta
delta, LHsExpr (GhcPass (XPass 'TcpInst)) -> EValArg 'TcpInst
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr GhcRn
LHsExpr (GhcPass (XPass 'TcpInst))
larg)
quickLookResultType :: Delta -> TcRhoType -> ExpRhoType -> TcM TcRhoType
quickLookResultType :: Delta -> TcType -> ExpRhoType -> TcM TcType
quickLookResultType Delta
delta TcType
app_res_rho (Check TcType
exp_rho)
  = 
    do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Delta -> Bool
isEmptyVarSet Delta
delta)  (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ 
         Delta -> TcType -> TcType -> TcRn ()
qlUnify Delta
delta TcType
app_res_rho TcType
exp_rho
       ; TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
app_res_rho }
quickLookResultType Delta
_ TcType
app_res_rho (Infer {})
  = TcType -> TcM TcType
zonkTcType TcType
app_res_rho
    
    
    
    
    
    
    
    
qlUnify :: Delta -> TcType -> TcType -> TcM ()
qlUnify :: Delta -> TcType -> TcType -> TcRn ()
qlUnify Delta
delta TcType
ty1 TcType
ty2
  = do { String -> SDoc -> TcRn ()
traceTc String
"qlUnify" (Delta -> SDoc
forall a. Outputable a => a -> SDoc
ppr Delta
delta SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty1 SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2)
       ; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta
emptyVarSet,Delta
emptyVarSet) TcType
ty1 TcType
ty2 }
  where
    go :: (TyVarSet, TcTyVarSet)
       -> TcType -> TcType
       -> TcM ()
    
    
    go :: (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs (TyVarTy TcTyVar
tv) TcType
ty2
      | TcTyVar
tv TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta = (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
go_kappa (Delta, Delta)
bvs TcTyVar
tv TcType
ty2
    go (Delta
bvs1, Delta
bvs2) TcType
ty1 (TyVarTy TcTyVar
tv)
      | TcTyVar
tv TcTyVar -> Delta -> Bool
`elemVarSet` Delta
delta = (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
go_kappa (Delta
bvs2,Delta
bvs1) TcTyVar
tv TcType
ty1
    go (Delta, Delta)
bvs (CastTy TcType
ty1 TcCoercionN
_) TcType
ty2 = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
ty1 TcType
ty2
    go (Delta, Delta)
bvs TcType
ty1 (CastTy TcType
ty2 TcCoercionN
_) = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
ty1 TcType
ty2
    go (Delta, Delta)
_ (TyConApp TyCon
tc1 []) (TyConApp TyCon
tc2 [])
      | TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2 
      = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  
    
    go (Delta, Delta)
bvs TcType
rho1 TcType
rho2
      | Just TcType
rho1 <- TcType -> Maybe TcType
tcView TcType
rho1 = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
rho1 TcType
rho2
      | Just TcType
rho2 <- TcType -> Maybe TcType
tcView TcType
rho2 = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
rho1 TcType
rho2
    go (Delta, Delta)
bvs (TyConApp TyCon
tc1 ThetaType
tys1) (TyConApp TyCon
tc2 ThetaType
tys2)
      | TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
      , Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc1)
      , ThetaType
tys1 ThetaType -> ThetaType -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` ThetaType
tys2
      = (TcType -> TcType -> TcRn ()) -> ThetaType -> ThetaType -> TcRn ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs) ThetaType
tys1 ThetaType
tys2
    
    
    
    
    
    go (Delta, Delta)
bvs (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
af1, ft_arg :: TcType -> TcType
ft_arg = TcType
arg1, ft_res :: TcType -> TcType
ft_res = TcType
res1, ft_mult :: TcType -> TcType
ft_mult = TcType
mult1 })
           (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
af2, ft_arg :: TcType -> TcType
ft_arg = TcType
arg2, ft_res :: TcType -> TcType
ft_res = TcType
res2, ft_mult :: TcType -> TcType
ft_mult = TcType
mult2 })
      | AnonArgFlag
af1 AnonArgFlag -> AnonArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== AnonArgFlag
af2
      = do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnonArgFlag
af1 AnonArgFlag -> AnonArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== AnonArgFlag
VisArg) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
             do { (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
arg1 TcType
arg2; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
mult1 TcType
mult2 }
           ; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
res1 TcType
res2 }
    
    
    
    go (Delta, Delta)
bvs (AppTy TcType
t1a TcType
t1b) TcType
ty2
      | Just (TcType
t2a, TcType
t2b) <- TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty2
      = do { (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1a TcType
t2a; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1b TcType
t2b }
    go (Delta, Delta)
bvs TcType
ty1 (AppTy TcType
t2a TcType
t2b)
      | Just (TcType
t1a, TcType
t1b) <- TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty1
      = do { (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1a TcType
t2a; (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
t1b TcType
t2b }
    go (Delta
bvs1, Delta
bvs2) (ForAllTy TyVarBinder
bv1 TcType
ty1) (ForAllTy TyVarBinder
bv2 TcType
ty2)
      = (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta
bvs1',Delta
bvs2') TcType
ty1 TcType
ty2
      where
       bvs1' :: Delta
bvs1' = Delta
bvs1 Delta -> TcTyVar -> Delta
`extendVarSet` TyVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
bv1
       bvs2' :: Delta
bvs2' = Delta
bvs2 Delta -> TcTyVar -> Delta
`extendVarSet` TyVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
bv2
    go (Delta, Delta)
_ TcType
_ TcType
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    
    go_kappa :: (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
go_kappa (Delta, Delta)
bvs TcTyVar
kappa TcType
ty2
      = Bool -> SDoc -> TcRn () -> TcRn ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TcTyVar -> Bool
isMetaTyVar TcTyVar
kappa) (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
kappa) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
        do { MetaDetails
info <- TcTyVar -> TcM MetaDetails
readMetaTyVar TcTyVar
kappa
           ; case MetaDetails
info of
               Indirect TcType
ty1 -> (Delta, Delta) -> TcType -> TcType -> TcRn ()
go (Delta, Delta)
bvs TcType
ty1 TcType
ty2
               MetaDetails
Flexi        -> do { TcType
ty2 <- TcType -> TcM TcType
zonkTcType TcType
ty2
                                  ; (Delta, Delta) -> TcTyVar -> TcType -> TcRn ()
forall {a}. (a, Delta) -> TcTyVar -> TcType -> TcRn ()
go_flexi (Delta, Delta)
bvs TcTyVar
kappa TcType
ty2 } }
    
    go_flexi :: (a, Delta) -> TcTyVar -> TcType -> TcRn ()
go_flexi (a
_,Delta
bvs2) TcTyVar
kappa TcType
ty2  
      | 
        let ty2_tvs :: Delta
ty2_tvs = TcType -> Delta
shallowTyCoVarsOfType TcType
ty2
      , Bool -> Bool
not (Delta
ty2_tvs Delta -> Delta -> Bool
`intersectsVarSet` Delta
bvs2)
          
      , Just TcType
ty2 <- [TcTyVar] -> TcType -> Maybe TcType
occCheckExpand [TcTyVar
kappa] TcType
ty2
          
      = do { let ty2_kind :: TcType
ty2_kind   = (() :: Constraint) => TcType -> TcType
TcType -> TcType
typeKind TcType
ty2
                 kappa_kind :: TcType
kappa_kind = TcTyVar -> TcType
tyVarKind TcTyVar
kappa
           ; TcCoercionN
co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyKind (TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TcType -> TypedThing
TypeThing TcType
ty2)) TcType
ty2_kind TcType
kappa_kind
                   
           ; String -> SDoc -> TcRn ()
traceTc String
"qlUnify:update" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
             [SDoc] -> SDoc
vcat [ SDoc -> Arity -> SDoc -> SDoc
hang (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
kappa SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
kappa_kind)
                       Arity
2 (String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2_kind)
                 , String -> SDoc
text String
"co:" SDoc -> SDoc -> SDoc
<+> TcCoercionN -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCoercionN
co ]
           ; (() :: Constraint) => TcTyVar -> TcType -> TcRn ()
TcTyVar -> TcType -> TcRn ()
writeMetaTyVar TcTyVar
kappa (TcType -> TcCoercionN -> TcType
mkCastTy TcType
ty2 TcCoercionN
co) }
      | Bool
otherwise
      = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()   
findNoQuantVars :: TcSigmaType -> [HsExprArg 'TcpRn] -> Bool
findNoQuantVars :: TcType -> [HsExprArg 'TcpRn] -> Bool
findNoQuantVars TcType
fun_ty [HsExprArg 'TcpRn]
args
  = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
emptyVarSet TcType
fun_ty [HsExprArg 'TcpRn]
args
  where
    need_instantiation :: [HsExprArg p] -> Bool
need_instantiation []               = Bool
True
    need_instantiation (EValArg {} : [HsExprArg p]
_) = Bool
True
    need_instantiation [HsExprArg p]
_                = Bool
False
    go :: TyVarSet -> TcSigmaType -> [HsExprArg 'TcpRn] -> Bool
    go :: Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
fun_ty [HsExprArg 'TcpRn]
args
      | [HsExprArg 'TcpRn] -> Bool
forall {p :: TcPass}. [HsExprArg p] -> Bool
need_instantiation [HsExprArg 'TcpRn]
args
      , ([TcTyVar]
tvs, ThetaType
theta, TcType
rho) <- TcType -> ([TcTyVar], ThetaType, TcType)
tcSplitSigmaTy TcType
fun_ty
      , Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta)
      = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go (Delta
bvs Delta -> [TcTyVar] -> Delta
`extendVarSetList` [TcTyVar]
tvs) TcType
rho [HsExprArg 'TcpRn]
args
    go Delta
bvs TcType
fun_ty [] =  TcType -> Delta
tyCoVarsOfType TcType
fun_ty Delta -> Delta -> Bool
`disjointVarSet` Delta
bvs
    go Delta
bvs TcType
fun_ty (EWrap {} : [HsExprArg 'TcpRn]
args) = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
fun_ty [HsExprArg 'TcpRn]
args
    go Delta
bvs TcType
fun_ty (EPrag {} : [HsExprArg 'TcpRn]
args) = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
fun_ty [HsExprArg 'TcpRn]
args
    go Delta
bvs TcType
fun_ty args :: [HsExprArg 'TcpRn]
args@(ETypeArg {} : [HsExprArg 'TcpRn]
rest_args)
      | ([TcTyVar]
tvs,  TcType
body1) <- (ArgFlag -> Bool) -> TcType -> ([TcTyVar], TcType)
tcSplitSomeForAllTyVars (ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
Inferred) TcType
fun_ty
      , (ThetaType
theta, TcType
body2) <- TcType -> (ThetaType, TcType)
tcSplitPhiTy TcType
body1
      , Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta)
      = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go (Delta
bvs Delta -> [TcTyVar] -> Delta
`extendVarSetList` [TcTyVar]
tvs) TcType
body2 [HsExprArg 'TcpRn]
args
      | Just (TyVarBinder
_tv, TcType
res_ty) <- TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTyVarBinder_maybe TcType
fun_ty
      = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
res_ty [HsExprArg 'TcpRn]
rest_args
      | Bool
otherwise
      = Bool
False  
    go Delta
bvs TcType
fun_ty (EValArg {} : [HsExprArg 'TcpRn]
rest_args)
      | Just (Scaled TcType
_, TcType
res_ty) <- TcType -> Maybe (Scaled TcType, TcType)
tcSplitFunTy_maybe TcType
fun_ty
      = Delta -> TcType -> [HsExprArg 'TcpRn] -> Bool
go Delta
bvs TcType
res_ty [HsExprArg 'TcpRn]
rest_args
      | Bool
otherwise
      = Bool
False  
isTagToEnum :: HsExpr GhcRn -> Bool
isTagToEnum :: HsExpr GhcRn -> Bool
isTagToEnum (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
fun_id)) = Name
fun_id Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
isTagToEnum HsExpr GhcRn
_ = Bool
False
tcTagToEnum :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]
            -> TcRhoType
            -> TcM (HsExpr GhcTc)
tcTagToEnum :: HsExpr GhcTc
-> AppCtxt -> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args TcType
res_ty
  | [HsExprArg 'TcpTc
val_arg] <- (HsExprArg 'TcpTc -> Bool)
-> [HsExprArg 'TcpTc] -> [HsExprArg 'TcpTc]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (HsExprArg 'TcpTc -> Bool) -> HsExprArg 'TcpTc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExprArg 'TcpTc -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg) [HsExprArg 'TcpTc]
tc_args
  = do { TcType
res_ty <- TcType -> TcM TcType
zonkTcType TcType
res_ty
       
       ; case HasCallStack => TcType -> Maybe (TyCon, ThetaType)
TcType -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe TcType
res_ty of {
           Maybe (TyCon, ThetaType)
Nothing -> do { TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumUnspecifiedResTy TcType
res_ty)
                         ; TcM (HsExpr GhcTc)
vanilla_result } ;
           Just (TyCon
tc, ThetaType
tc_args) ->
    do { 
       ; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; case FamInstEnvs
-> TyCon -> ThetaType -> Maybe (TyCon, ThetaType, TcCoercionN)
tcLookupDataFamInst_maybe FamInstEnvs
fam_envs TyCon
tc ThetaType
tc_args of {
           Maybe (TyCon, ThetaType, TcCoercionN)
Nothing -> do { TcType -> TyCon -> TcRn ()
check_enumeration TcType
res_ty TyCon
tc
                         ; TcM (HsExpr GhcTc)
vanilla_result } ;
           Just (TyCon
rep_tc, ThetaType
rep_args, TcCoercionN
coi) ->
    do { 
         TcType -> TyCon -> TcRn ()
check_enumeration TcType
res_ty TyCon
rep_tc
       ; let rep_ty :: TcType
rep_ty  = TyCon -> ThetaType -> TcType
mkTyConApp TyCon
rep_tc ThetaType
rep_args
             tc_fun' :: HsExpr GhcTc
tc_fun' = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (TcType -> HsWrapper
WpTyApp TcType
rep_ty) HsExpr GhcTc
tc_fun
             tc_expr :: HsExpr GhcTc
tc_expr = HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps HsExpr GhcTc
tc_fun' AppCtxt
fun_ctxt [HsExprArg 'TcpTc
val_arg]
             df_wrap :: HsWrapper
df_wrap = TcCoercionN -> HsWrapper
mkWpCastR (TcCoercionN -> TcCoercionN
mkTcSymCo TcCoercionN
coi)
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
df_wrap HsExpr GhcTc
tc_expr) }}}}}
  | Bool
otherwise
  = TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
TcRnTagToEnumMissingValArg
  where
    vanilla_result :: TcM (HsExpr GhcTc)
vanilla_result = HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps HsExpr GhcTc
tc_fun AppCtxt
fun_ctxt [HsExprArg 'TcpTc]
tc_args)
    check_enumeration :: TcType -> TyCon -> TcRn ()
check_enumeration TcType
ty' TyCon
tc
      | TyCon -> Bool
isEnumerationTyCon TyCon
tc = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise             = TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumResTyNotAnEnum TcType
ty')
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag (HsPragSCC XSCC GhcRn
x1 SourceText
src StringLiteral
ann) = XSCC GhcTc -> SourceText -> StringLiteral -> HsPragE GhcTc
forall p. XSCC p -> SourceText -> StringLiteral -> HsPragE p
HsPragSCC XSCC GhcRn
XSCC GhcTc
x1 SourceText
src StringLiteral
ann