import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName )
import RnTypes ( rnLHsType )
-import TcExpr ( tcCheckRho, tcMonoExpr )
+import TcExpr ( tcMonoExpr )
import TcHsSyn ( mkHsDictLet, zonkTopLExpr )
import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
-import TcUnify ( Expected, zapExpectedTo, zapExpectedType )
-import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
+import TcUnify ( boxyUnify, unBox )
+import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
+import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
import TcHsType ( tcHsSigType, kcHsType )
import TcIface ( tcImportDecl )
import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
import TcRnMonad
import IfaceEnv ( lookupOrig )
import Class ( Class, classExtraBigSig )
-import TyCon ( TyCon, tyConTyVars, getSynTyConDefn,
+import TyCon ( TyCon, tyConTyVars, synTyConDefn,
isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon,
tyConArity, tyConStupidTheta, isUnLiftedTyCon )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
\begin{code}
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceExpr :: HsSplice Name -> Expected TcType -> TcM (HsExpr TcId)
+tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
#ifndef GHCI
%************************************************************************
\begin{code}
-tcBracket :: HsBracket Name -> Expected TcType -> TcM (LHsExpr Id)
+tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr Id)
tcBracket brack res_ty
= getStage `thenM` \ level ->
case bracketOK level of {
tcSimplifyBracket lie `thenM_`
-- Make the expected type have the right shape
- zapExpectedTo res_ty meta_ty `thenM_`
+ boxyUnify meta_ty res_ty `thenM_`
-- Return the original expression, not the type-decorated one
readMutVar pending_splices `thenM` \ pendings ->
= tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
tc_bracket (ExpBr expr)
- = newTyFlexiVarTy liftedTypeKind `thenM` \ any_ty ->
- tcCheckRho expr any_ty `thenM_`
+ = newFlexiTyVarTy liftedTypeKind `thenM` \ any_ty ->
+ tcMonoExpr expr any_ty `thenM_`
tcMetaTy expQTyConName
-- Result type is Expr (= Q Exp)
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
- zapExpectedType res_ty liftedTypeKind `thenM_`
+ unBox res_ty `thenM_`
tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
setStage (Splice next_level) (
setLIEVar lie_var $
- tcCheckRho expr meta_exp_ty
+ tcMonoExpr expr meta_exp_ty
) `thenM` \ expr' ->
-- Write the pending splice into the bucket
-- The recursive call to tcMonoExpr will simply expand the
-- inner escape before dealing with the outer one
-tcTopSplice :: LHsExpr Name -> Expected TcType -> TcM (LHsExpr Id)
+tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
tcTopSplice expr res_ty
= tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
do { recordThUse -- Record that TH is used (for pkg depdendency)
-- Typecheck the expression
- ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty)
+ ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
-- Solve the constraints
; const_binds <- tcSimplifyTop lie
; meta_ty <- tcMetaTy typeQTyConName
; expr' <- setStage (Splice next_level) $
setLIEVar lie_var $
- tcCheckRho hs_expr meta_ty
+ tcMonoExpr hs_expr meta_ty
-- Write the pending splice into the bucket
; ps <- readMutVar ps_var
; fix <- reifyFixity name
; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
-reifyThing (ATcId id _)
+reifyThing (ATcId id _ _)
= do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
-- though it may be incomplete
; ty2 <- reifyType ty1
| isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
| isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
| isSynTyCon tc
- = do { let (tvs, rhs) = getSynTyConDefn tc
+ = do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }