X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcContext.lhs;fp=ghc%2Fcompiler%2Ftypecheck%2FTcContext.lhs;h=fc79ae35ddbadac22d262aed5f8f70d4409617f8;hb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;hp=0000000000000000000000000000000000000000;hpb=e48474bff05e6cfb506660420f025f694c870d38;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcContext.lhs b/ghc/compiler/typecheck/TcContext.lhs
new file mode 100644
index 0000000..fc79ae3
--- /dev/null
+++ b/ghc/compiler/typecheck/TcContext.lhs
@@ -0,0 +1,55 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[TcContext]{Typecheck a type-class context}
+
+\begin{code}
+module TcContext ( tcContext ) where
+
+#include "HsVersions.h"
+
+import TcMonad		-- typechecking monadic machinery
+import AbsSyn		-- the stuff being typechecked
+
+import CE		( lookupCE, CE(..) )
+import Errors		( naughtyCCallContextErr )
+import TCE		( TCE(..), UniqFM )
+import TVE		( TVE(..) )
+import TcMonoType	( tcMonoType )
+import Unique		( cCallableClassKey, cReturnableClassKey )
+import Util
+
+tcContext :: CE -> TCE -> TVE -> RenamedContext -> Baby_TcM ThetaType
+
+tcContext ce tce tve context
+  = mapB_Tc (tcClassAssertion ce tce tve) context
+
+tcClassAssertion ce tce tve (class_name, tyname)
+  | canBeUsedInContext class_name
+  = tcMonoType ce tce tve (MonoTyVar tyname) `thenB_Tc` \ ty ->
+    returnB_Tc (lookupCE ce class_name, ty)
+
+  | otherwise
+  = getSrcLocB_Tc `thenB_Tc` \ locn ->
+    failB_Tc (naughtyCCallContextErr class_name locn)
+\end{code}
+
+HACK warning: Someone discovered that @_CCallable_@ and @_CReturnable@
+could be used in contexts such as:
+\begin{verbatim}
+foo :: _CCallable a => a -> PrimIO Int
+\end{verbatim}
+
+Doing this utterly wrecks the whole point of introducing these
+classes so we specifically check that this isn't being done.
+
+\begin{code}
+canBeUsedInContext :: Name -> Bool
+
+canBeUsedInContext class_name
+  = class_name /= cCallableClass && class_name /= cReturnableClass
+ where
+  cCallableClass   = PreludeClass cCallableClassKey   bottom
+  cReturnableClass = PreludeClass cReturnableClassKey bottom
+  bottom	   = panic "canBeUsedInContext"
+\end{code}