X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=61edc1cbf0d05a5fedc5ea0fffed733df5886549;hb=f53483a24f46fb3aa09052d8c00c0fc5d7d9dcca;hp=6bf8c3202334066abdbcc5cc1331e426a73157e4;hpb=b2d205e39c0e2cdb054c53c6a3f14c9489f6b9b5;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 6bf8c32..61edc1c 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,14 +9,14 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
 #include "HsVersions.h"
 
 #ifdef GHCI 	/* Only if bootstrapped */
-import {-# SOURCE #-}	TcSplice( tcSpliceExpr )
+import {-# SOURCE #-}	TcSplice( tcSpliceExpr, tcBracket )
+import HsSyn		( HsReify(..), ReifyFlavour(..) )
 import TcEnv		( bracketOK, tcMetaTy )
 import TcSimplify	( tcSimplifyBracket )
-import PrelNames	( exprTyConName )
-import HsSyn		( HsBracket(..) )
+import qualified DsMeta
 #endif
 
-import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
+import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..),
 			  mkMonoBind, recBindFields
 			)
 import RnHsSyn		( RenamedHsExpr, RenamedRecordBinds )
@@ -33,7 +33,7 @@ import Inst		( InstOrigin(..),
 			)
 import TcBinds		( tcBindsAndThen )
 import TcEnv		( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
-			  tcLookupTyCon, tcLookupDataCon, tcLookupId,
+			  tcLookupTyCon, tcLookupDataCon, tcLookupId, tcLookupGlobal,
 			  wellStaged, metaLevel
 			)
 import TcMatches	( tcMatchesCase, tcMatchLambda, tcDoStmts )
@@ -44,7 +44,7 @@ import TcMType		( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
 			  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, 
@@ -54,7 +54,7 @@ import TcType		( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
 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 )
@@ -63,7 +63,7 @@ import PrelNames	( cCallableClassName, cReturnableClassName,
 			  enumFromName, enumFromThenName, 
 			  enumFromToName, enumFromThenToName,
 			  enumFromToPName, enumFromThenToPName,
-			  ioTyConName, liftName
+			  ioTyConName
 			)
 import ListSetOps	( minusList )
 import CmdLineOpts
@@ -622,10 +622,11 @@ tcMonoExpr (PArrSeqIn _) _
 #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 ->
@@ -635,20 +636,29 @@ tcMonoExpr (HsBracket (ExpBr expr)) res_ty
 	-- 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}
 
@@ -812,6 +822,7 @@ tcId name	-- Look up the Id and instantiate its type
   = 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
@@ -835,7 +846,7 @@ tcId name	-- Look up the Id and instantiate its type
 		    -- 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
@@ -850,7 +861,8 @@ tcId name	-- Look up the Id and instantiate its type
 	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
@@ -862,8 +874,8 @@ tcId name	-- Look up the Id and instantiate its type
 	| 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
@@ -1136,7 +1148,7 @@ missingStrictFields con fields
 	 | 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