X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=6354499976914e339ad14f6e7f92d6aff7975168;hb=54c309c0135eaa656f16d3abada41e5392a1fae0;hp=d6099816bf03709193dcda649464740d28f45677;hpb=c455d9a46cbe9b7fa0013a7bcadaa5c738944604;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index d609981..6354499 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -772,14 +772,10 @@ instFun orig fun subst []
   = return fun		-- Common short cut
 
 instFun orig fun subst tv_theta_prs
-  = do 	{-- !!!SPJ: 	-- Horrid check for tagToEnum; see Note [tagToEnum#]
-	 -- !!!SPJ: checkBadTagToEnumCall fun_id qtv_tys
+  = do 	{ let ty_theta_prs' = map subst_pr tv_theta_prs
 
-	; let ty_theta_prs' = map subst_pr tv_theta_prs
-
-  		-- First, chuck in the constraints from 
-		-- the "stupid theta" of a data constructor (sigh)
-	; inst_stupid fun ty_theta_prs'
+                -- Make two ad-hoc checks 
+	; doStupidChecks orig fun ty_theta_prs'
 
 		-- Now do normal instantiation
 	; go True fun ty_theta_prs' }
@@ -787,11 +783,6 @@ instFun orig fun subst tv_theta_prs
     subst_pr (tvs, theta) 
 	= (map (substTyVar subst) tvs, substTheta subst theta)
 
-    inst_stupid (HsVar fun_id) ((tys,_):_)
-	| Just con <- isDataConId_maybe fun_id 
-	= addDataConStupidTheta orig con tys
-    inst_stupid _ _ = return ()
-
     go _ fun [] = return fun
 
     go True (HsVar fun_id) ((tys,theta) : prs)
@@ -900,20 +891,33 @@ Here's are two cases that should fail
 
 
 \begin{code}
-checkBadTagToEnumCall :: Id -> [TcType] -> TcM ()
-checkBadTagToEnumCall fun_id tys
-  | fun_id `hasKey` tagToEnumKey
+doStupidChecks :: InstOrigin
+	       -> HsExpr TcId
+	       -> [([TcType], ThetaType)]
+	       -> TcM ()
+-- Check two tiresome and ad-hoc cases
+-- (a) the "stupid theta" for a data con; add the constraints
+--     from the "stupid theta" of a data constructor (sigh)
+-- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
+
+doStupidChecks orig (HsVar fun_id) ((tys,_):_)
+  | Just con <- isDataConId_maybe fun_id   -- (a)
+  = addDataConStupidTheta orig con tys
+
+  | fun_id `hasKey` tagToEnumKey           -- (b)
   = do	{ tys' <- zonkTcTypes tys
 	; checkTc (ok tys') (tagToEnumError tys')
 	}
-  | otherwise    -- Vastly common case
-  = return ()
   where
     ok [] 	= False
     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
 			Just (tc,_) -> isEnumerationTyCon tc
 			Nothing     -> False
 
+doStupidChecks orig fun tv_theta_prs
+  = return () -- The common case
+				      
+
 tagToEnumError tys
   = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
 	 2 (vcat [ptext SLIT("Specify the type by giving a type signature"),