Add ad-hoc typing checks for tagToEnum#

The problem with tagToEnum# is that it is not overloaded (in the
Haskell sense) but you are only supposed to apply it to a TyCon
that is an enumeration (isEnumerationTyCon).

The Real Way to do this is to have some special kind of type constraint
for the purpose, but that is wild overkill. So this patch adds a small
rather ad-hoc check to TcExpr.instFun.  Crude, simple, but it works fine.

Fixes Trac #786
Test is tcfail164

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index ae26f84..8bdaeb3 100644 (file)
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -30,7 +30,7 @@ import Literal                ( Literal(..), mkMachInt, mkMachWord
                        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
                        , float2DoubleLit, double2FloatLit
                        )
-import PrimOp          ( PrimOp(..), primOpOcc )
+import PrimOp          ( PrimOp(..), primOpOcc, tagToEnumKey )
 import TysWiredIn      ( boolTy, trueDataConId, falseDataConId )
 import TyCon           ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
 import DataCon         ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
@@ -386,7 +386,7 @@ For dataToTag#, we can reduce if either
 
 \begin{code}
 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
-  | Just TagToEnumOp <- isPrimOpId_maybe tag_to_enum
+  | tag_to_enum `hasKey` tagToEnumKey
   , ty1 `coreEqType` ty2
   = Just tag   -- dataToTag (tagToEnum x)   ==>   x
 

diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index a650352..dae8bee 100644 (file)
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -9,6 +9,8 @@ module PrimOp (
        primOpType, primOpSig,
        primOpTag, maxPrimOpTag, primOpOcc,
 
+       tagToEnumKey,
+
        primOpOutOfLine, primOpNeedsWrapper, 
        primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
 
@@ -27,6 +29,7 @@ import TyCon          ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
 import Type            ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
                          typePrimRep )
 import BasicTypes      ( Arity, Boxity(..) )
+import Unique          ( Unique, mkPrimOpIdUnique )
 import Outputable
 import FastTypes
 \end{code}
@@ -84,6 +87,13 @@ allThePrimOps =
 #include "primop-list.hs-incl"
 \end{code}
 
+\begin{code}
+tagToEnumKey :: Unique
+tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp)
+\end{code}
+
+
+
 %************************************************************************
 %*                                                                     *
 \subsection[PrimOp-info]{The essential info about each @PrimOp@}

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index e897420..c26d74d 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -37,31 +37,34 @@ import TcArrows             ( tcProc )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
 import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
 import TcPat           ( tcOverloadedLit, badFieldCon )
-import TcMType         ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, 
-                         tcInstBoxyTyVar, tcInstTyVar )
+import TcMType         ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, zonkTcTypes )
 import TcType          ( TcType, TcSigmaType, TcRhoType, 
                          BoxySigmaType, BoxyRhoType, ThetaType,
-                         mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN, 
+                         mkTyVarTys, mkFunTys, 
+                         tcMultiSplitSigmaTy, tcSplitFunTysN, tcSplitTyConApp_maybe,
                          isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
-                         exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy, 
-                         zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar
+                         exactTyVarsOfType, exactTyVarsOfTypes, 
+                         zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
                        )
 import Kind            ( argTypeKind )
 
-import Id              ( idType, idName, recordSelectorFieldLabel, isRecordSelector, 
-                         isNaughtyRecordSelector, isDataConId_maybe )
+import Id              ( Id, idType, idName, recordSelectorFieldLabel, 
+                         isRecordSelector, isNaughtyRecordSelector, isDataConId_maybe )
 import DataCon         ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
                          dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
 import Name            ( Name )
-import TyCon           ( FieldLabel, tyConStupidTheta, tyConDataCons )
+import TyCon           ( FieldLabel, tyConStupidTheta, tyConDataCons, isEnumerationTyCon )
 import Type            ( substTheta, substTy )
 import Var             ( TyVar, tyVarKind )
 import VarSet          ( emptyVarSet, elemVarSet, unionVarSet )
 import TysWiredIn      ( boolTy, parrTyCon, tupleTyCon )
 import PrelNames       ( enumFromName, enumFromThenName, 
                          enumFromToName, enumFromThenToName,
-                         enumFromToPName, enumFromThenToPName, negateName
+                         enumFromToPName, enumFromThenToPName, negateName,
+                         hasKey
                        )
+import PrimOp          ( tagToEnumKey )
+
 import DynFlags
 import StaticFlags     ( opt_NoMethodSharing )
 import HscTypes                ( TyThing(..) )
@@ -252,6 +255,7 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
     tc_args arg1_ty' [arg1_ty, arg2_ty] 
        = do { boxyUnify arg1_ty' arg1_ty
             ; tcArg lop (arg2, arg2_ty, 2) }
+    tc_args arg1_ty' other = panic "tcExpr SectionR"
 \end{code}
 
 \begin{code}
@@ -761,7 +765,10 @@ instFun fun_id qtvs qtv_tys []
   = return (HsVar fun_id)      -- Common short cut
 
 instFun fun_id qtvs qtv_tys tv_theta_prs
-  = do         { let subst = zipOpenTvSubst qtvs qtv_tys
+  = do         {       -- Horrid check for tagToEnum; see Note [tagToEnum#]
+         checkBadTagToEnumCall fun_id qtv_tys
+
+       ; let subst = zipOpenTvSubst qtvs qtv_tys
              ty_theta_prs' = map subst_pr tv_theta_prs
              subst_pr (tvs, theta) = (map (substTyVar subst) tvs, 
                                       substTheta subst theta)
@@ -873,6 +880,44 @@ tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
 \end{code}
 
 
+Note [tagToEnum#]
+~~~~~~~~~~~~~~~~~
+Nasty check to ensure that tagToEnum# is applied to a type that is an
+enumeration TyCon.  Unification may refine the type later, but this
+check won't see that, alas.  It's crude but it works.
+
+Here's are two cases that should fail
+       f :: forall a. a
+       f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
+
+       g :: Int
+       g = tagToEnum# 0        -- Int is not an enumeration
+
+
+\begin{code}
+checkBadTagToEnumCall :: Id -> [TcType] -> TcM ()
+checkBadTagToEnumCall fun_id tys
+  | fun_id `hasKey` tagToEnumKey
+  = 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
+
+tagToEnumError tys
+  = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
+        2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
+                 ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
+  where
+    at_type | null tys = empty -- Probably never happens
+           | otherwise = ptext SLIT("at type") <+> ppr (head tys)
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection{@tcId@ typchecks an identifier occurrence}