-\begin{code}
-tcDoStmts do_or_lc stmts src_loc res_ty
- = -- get the Monad and MonadZero classes
- -- create type consisting of a fresh monad tyvar
- ASSERT( not (null stmts) )
- tcAddSrcLoc src_loc $
-
- -- If it's a comprehension we're dealing with,
- -- force it to be a list comprehension.
- -- (as of Haskell 98, monad comprehensions are no more.)
- (case do_or_lc of
- ListComp -> unifyListTy res_ty `thenTc` \ elt_ty ->
- returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
-
- _ -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
- newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
- returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
- ) `thenNF_Tc` \ (tc_ty, m_ty) ->
-
- tcStmts (DoCtxt do_or_lc) m_ty stmts `thenTc` \ (stmts', stmts_lie) ->
-
- -- Build the then and zero methods in case we need them
- -- It's important that "then" and "return" appear just once in the final LIE,
- -- not only for typechecker efficiency, but also because otherwise during
- -- simplification we end up with silly stuff like
- -- then = case d of (t,r) -> t
- -- then = then
- -- where the second "then" sees that it already exists in the "available" stuff.
- --
- tcLookupGlobalId returnMName `thenNF_Tc` \ return_sel_id ->
- tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id ->
- tcLookupGlobalId failMName `thenNF_Tc` \ fail_sel_id ->
- newMethod DoOrigin return_sel_id [tc_ty] `thenNF_Tc` \ return_inst ->
- newMethod DoOrigin then_sel_id [tc_ty] `thenNF_Tc` \ then_inst ->
- newMethod DoOrigin fail_sel_id [tc_ty] `thenNF_Tc` \ fail_inst ->
- let
- monad_lie = mkLIE [return_inst, then_inst, fail_inst]
- in
- returnTc (HsDoOut do_or_lc stmts'
- (instToId return_inst) (instToId then_inst) (instToId fail_inst)
- res_ty src_loc,
- stmts_lie `plusLIE` monad_lie)
+#ifndef GHCI
+ tc_local_id id th_bind_lvl -- Non-TH case
+ = instantiate id
+
+#else /* GHCI and TH is on */
+ tc_local_id id th_bind_lvl -- TH case
+ = -- Check for cross-stage lifting
+ getStage `thenM` \ use_stage ->
+ 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))
+
+ other ->
+ checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
+ instantiate id
+#endif /* GHCI */
+
+ instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
+ instantiate fun_id = loop (HsVar fun_id) [] (idType fun_id)
+
+ loop (HsVar fun_id) tvs fun_ty
+ | want_method_inst fun_ty
+ = tcInstType fun_ty `thenM` \ (tyvars, theta, tau) ->
+ newMethodWithGivenTy orig fun_id
+ (mkTyVarTys tyvars) theta tau `thenM` \ meth_id ->
+ loop (HsVar meth_id) (tvs ++ tyvars) tau
+
+ loop fun tvs fun_ty
+ | isSigmaTy fun_ty
+ = tcInstCall orig fun_ty `thenM` \ (inst_fn, new_tvs, tau) ->
+ loop (inst_fn <$> fun) (tvs ++ new_tvs) tau
+
+ | otherwise
+ = returnM (fun, tvs, fun_ty)
+
+ -- Hack Alert (want_method_inst)!
+ -- If f :: (%x :: T) => Int -> Int
+ -- Then if we have two separate calls, (f 3, f 4), we cannot
+ -- make a method constraint that then gets shared, thus:
+ -- let m = f %x in (m 3, m 4)
+ -- because that loses the linearity of the constraint.
+ -- The simplest thing to do is never to construct a method constraint
+ -- in the first place that has a linear implicit parameter in it.
+ want_method_inst fun_ty
+ | opt_NoMethodSharing = False
+ | otherwise = case tcSplitSigmaTy fun_ty of
+ (_,[],_) -> False -- Not overloaded
+ (_,theta,_) -> not (any isLinearPred theta)
+
+ orig = OccurrenceOf name