remove spurious commas in imports

[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index e897420..0da370b 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -26,7 +26,7 @@ import HsSyn          ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
 import TcHsSyn         ( hsLitType )
 import TcRnMonad
 import TcUnify         ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
-                         boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,, 
+                         boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
                          unBox )
 import BasicTypes      ( Arity, isMarkedStrict )
 import Inst            ( newMethodFromName, newIPDict, instToId,
@@ -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(..) )
@@ -187,7 +190,7 @@ tcExpr (HsApp e1 e2) res_ty
     go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
     go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
     go lfun@(L loc fun) args
-       = do { (fun', args') <- addErrCtxt (callCtxt lfun args) $
+       = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
                                tcApp fun (length args) (tcArgs lfun args) res_ty
             ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
 
@@ -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}