#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
import Id ( Id )
+import Name ( isExternalName )
import TcType ( isTauTy )
import TcEnv ( checkWellStaged )
import HsSyn ( nlHsApp )
import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcPat ( badFieldCon )
-import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType, readMetaTyVar )
-import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..),
+import TcPat ( badFieldCon, refineTyVars )
+import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
+import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType,
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
tcSplitSigmaTy, tidyOpenType
import Name ( Name )
import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
tyConDataCons, tyConFields )
-import Type ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy )
+import Type ( zipTopTvSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import PrelNames ( enumFromName, enumFromThenName,
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
-import Maybes ( catMaybes )
import Outputable
import FastString
tc_expr (HsOverLit lit) res_ty
= zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' ->
+ -- Overloaded literals must have liftedTypeKind, because
+ -- we're instantiating an overloaded function here,
+ -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
newOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit_expr ->
returnM (unLoc lit_expr) -- ToDo: nasty unLoc
-- Check for missing fields
checkMissingFields data_con rbinds `thenM_`
- getSrcSpanM `thenM` \ loc ->
returnM (RecordConOut data_con (L loc con_expr) rbinds')
-- The main complication with RecordUpd is that we need to explicitly
Infer _ -> do -- Type check args first, then
-- refine result type, then do tcResult
{ the_app' <- tcArgs fun fun' args expected_arg_tys
- ; actual_res_ty' <- refineResultTy fun_tvs actual_res_ty
+ ; subst <- refineTyVars fun_tvs
+ ; let actual_res_ty' = substTy subst actual_res_ty
; co_fn <- tcResult fun args res_ty actual_res_ty'
; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app',
ppr actual_res_ty, ppr actual_res_ty'])
| otherwise = appCtxt fun args
in
returnM (env2, message)
-
-----------------
-refineResultTy :: [TcTyVar] -- Newly instantiated meta-tyvars of the function
- -> TcType -- Result type, instantiated with those tyvars
- -> TcM TcType -- Refined result type
--- De-wobblify the result type, by taking account what we learned
--- from type-checking the arguments. Just one level of de-wobblification
--- though. What a hack!
-refineResultTy tvs res_ty
- = do { mb_prs <- mapM mk_pr tvs
- ; let subst = mkTopTvSubst (catMaybes mb_prs)
- ; return (substTy subst res_ty) }
- where
- mk_pr tv = do { details <- readMetaTyVar tv
- ; case details of
- Indirect ty -> return (Just (tv,ty))
- other -> return Nothing
- }
\end{code}
-- Return the type variables at which the function
-- is instantiated, as well as the translated variable and its type
-tcId name -- Look up the Id and instantiate its type
- = tcLookup name `thenM` \ thing ->
+tcId id_name -- Look up the Id and instantiate its type
+ = tcLookup id_name `thenM` \ thing ->
case thing of {
- AGlobal (AnId id) -> instantiate id
- -- A global cannot possibly be ill-staged
- -- nor does it need the 'lifting' treatment
-
- ; AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too
+ AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too
-> do { (expr, tvs, tau) <- instantiate (dataConWrapId con)
; tcInstStupidTheta con (mkTyVarTys tvs)
-- Remember to chuck in the constraints from the "silly context"
; return (expr, tvs, tau) }
+ ; AGlobal (AnId id) -> instantiate id
+ -- A global cannot possibly be ill-staged
+ -- nor does it need the 'lifting' treatment
+
; ATcId id th_level proc_level
-> do { checkProcLevel id proc_level
; tc_local_id id th_level }
- ; other -> pprPanic "tcId" (ppr name $$ ppr thing)
+ ; other -> pprPanic "tcId" (ppr id_name $$ ppr thing)
}
where
case use_stage of
Brack use_lvl ps_var lie_var
| use_lvl > th_bind_lvl
- -> -- E.g. \x -> [| h x |]
- -- We must behave as if the reference to x was
- -- h $(lift x)
- -- We use 'x' itself as the splice proxy, used by
- -- the desugarer to stitch it all back together.
- -- If 'x' occurs many times we may get many identical
- -- bindings of the same splice proxy, but that doesn't
- -- matter, although it's a mite untidy.
- let
- id_ty = idType id
- in
- checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
- -- If x is polymorphic, its occurrence sites might
- -- have different instantiations, so we can't use plain
- -- 'x' as the splice proxy name. I don't know how to
- -- solve this, and it's probably unimportant, so I'm
- -- just going to flag an error for now
-
- setLIEVar lie_var (
- newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
- -- Put the 'lift' constraint into the right LIE
-
- -- Update the pending splices
- readMutVar ps_var `thenM` \ ps ->
- writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_`
-
- returnM (HsVar id, [], id_ty))
+ -> if isExternalName id_name then
+ -- Top-level identifiers in this module,
+ -- (which have External Names)
+ -- are just like the imported case:
+ -- no need for the 'lifting' treatment
+ -- E.g. this is fine:
+ -- f x = x
+ -- g y = [| f 3 |]
+ -- But we do need to put f into the keep-alive
+ -- set, because after desugaring the code will
+ -- only mention f's *name*, not f itself.
+ keepAliveTc id_name `thenM_`
+ instantiate id
+
+ else -- Nested identifiers, such as 'x' in
+ -- E.g. \x -> [| h x |]
+ -- We must behave as if the reference to x was
+ -- h $(lift x)
+ -- We use 'x' itself as the splice proxy, used by
+ -- the desugarer to stitch it all back together.
+ -- If 'x' occurs many times we may get many identical
+ -- bindings of the same splice proxy, but that doesn't
+ -- matter, although it's a mite untidy.
+ let
+ id_ty = idType id
+ in
+ checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
+ -- If x is polymorphic, its occurrence sites might
+ -- have different instantiations, so we can't use plain
+ -- 'x' as the splice proxy name. I don't know how to
+ -- solve this, and it's probably unimportant, so I'm
+ -- just going to flag an error for now
+
+ setLIEVar lie_var (
+ newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
+ -- Put the 'lift' constraint into the right LIE
+
+ -- Update the pending splices
+ readMutVar ps_var `thenM` \ ps ->
+ writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_`
+
+ returnM (HsVar id, [], id_ty))
other ->
checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
(_,[],_) -> False -- Not overloaded
(_,theta,_) -> not (any isLinearPred theta)
- orig = OccurrenceOf name
+ orig = OccurrenceOf id_name
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff