#include "HsVersions.h"
#ifdef GHCI /* Only if bootstrapped */
-import {-# SOURCE #-} TcSplice( tcSpliceExpr )
-import TcEnv ( bracketOK, tcMetaTy )
+import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
+import HsSyn ( HsReify(..), ReifyFlavour(..) )
+import TcEnv ( bracketOK, tcMetaTy, tcLookupGlobal,
+ wellStaged, metaLevel )
import TcSimplify ( tcSimplifyBracket )
-import PrelNames ( exprTyConName )
-import HsSyn ( HsBracket(..) )
+import Name ( isExternalName )
+import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
+import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
mkMonoBind, recBindFields
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
- tcLookupTyCon, tcLookupDataCon, tcLookupId,
- wellStaged, metaLevel
+ tcLookupTyCon, tcLookupDataCon, tcLookupId
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
- isSigmaTy, isTauTy, mkFunTy, mkFunTys,
+ isSigmaTy, mkFunTy, mkFunTys,
mkTyConApp, mkClassPred, tcFunArgTy,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind,
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks )
-import Name ( Name, isExternalName )
+import Name ( Name )
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- ioTyConName, liftName
+ ioTyConName
)
import ListSetOps ( minusList )
import CmdLineOpts
#ifdef GHCI /* Only if bootstrapped */
-- Rename excludes these cases otherwise
-tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
+tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
-tcMonoExpr (HsBracket (ExpBr expr)) res_ty
- = getStage `thenM` \ level ->
+tcMonoExpr (HsBracket brack loc) res_ty
+ = addSrcLoc loc $
+ getStage `thenM` \ level ->
case bracketOK level of {
Nothing -> failWithTc (illegalBracket level) ;
Just next_level ->
-- it again when we actually use it.
newMutVar [] `thenM` \ pending_splices ->
getLIEVar `thenM` \ lie_var ->
- newTyVarTy openTypeKind `thenM` \ any_ty ->
setStage (Brack next_level pending_splices lie_var) (
- getLIE (tcMonoExpr expr any_ty)
- ) `thenM` \ (expr', lie) ->
- tcSimplifyBracket lie `thenM_`
+ getLIE (tcBracket brack)
+ ) `thenM` \ (meta_ty, lie) ->
+ tcSimplifyBracket lie `thenM_`
- tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
- unifyTauTy res_ty meta_exp_ty `thenM_`
+ unifyTauTy res_ty meta_ty `thenM_`
-- Return the original expression, not the type-decorated one
readMutVar pending_splices `thenM` \ pendings ->
- returnM (HsBracketOut (ExpBr expr) pendings)
+ returnM (HsBracketOut brack pendings)
}
+
+tcMonoExpr (HsReify (Reify flavour name)) res_ty
+ = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
+ tcMetaTy tycon_name `thenM` \ reify_ty ->
+ unifyTauTy res_ty reify_ty `thenM_`
+ returnM (HsReify (ReifyOut flavour name))
+ where
+ tycon_name = case flavour of
+ ReifyDecl -> DsMeta.decTyConName
+ ReifyType -> DsMeta.typTyConName
+ ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
#endif GHCI
\end{code}
= tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
-- Check for cross-stage lifting
+#ifdef GHCI
getStage `thenM` \ use_stage ->
case use_stage of
Brack use_lvl ps_var lie_var
-- just going to flag an error for now
setLIEVar lie_var (
- newMethodFromName orig id_ty liftName `thenM` \ lift ->
+ newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
-- Put the 'lift' constraint into the right LIE
-- Update the pending splices
in
checkTc (wellStaged bind_lvl use_lvl)
(badStageErr id bind_lvl use_lvl) `thenM_`
-
+#endif
+ -- This is the bit that handles the no-Template-Haskell case
case isDataConWrapId_maybe id of
Nothing -> loop (HsVar id) (idType id)
Just data_con -> inst_data_con id data_con
| want_method_inst fun_ty
= tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
newMethodWithGivenTy orig fun_id
- (mkTyVarTys tyvars) theta tau `thenM` \ meth ->
- loop (HsVar (instToId meth)) tau
+ (mkTyVarTys tyvars) theta tau `thenM` \ meth_id ->
+ loop (HsVar meth_id) tau
loop fun fun_ty
| isSigmaTy fun_ty
| otherwise = colon <+> pprWithCommas ppr fields
header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
- ptext SLIT("does not have the required strict fields")
+ ptext SLIT("does not have the required strict field(s)")
missingFields :: DataCon -> [FieldLabel] -> SDoc