X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=24dc515b084d7da59b154f54f6ddcb1d750029f5;hb=272807076575eb2d82ed3227be184e61c9e2a58e;hp=0ca5d6035ed330d9f3fe4844f9484d46aaa38d44;hpb=203a687fbdb9bf54592f907302d8e47e174bb549;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 0ca5d60..24dc515 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -27,6 +27,11 @@ module TcHsSyn (
 	mkHsTyLam, mkHsDictLam, mkHsLet,
 	hsLitType, hsPatType, 
 
+	-- Coercions
+	Coercion, ExprCoFn, PatCoFn, 
+	(<$>), (<.>), mkCoercion, 
+	idCoercion, isIdCoercion,
+
 	-- re-exported from TcMonad
 	TcId, TcIdSet,
 
@@ -65,6 +70,7 @@ import VarSet
 import VarEnv
 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
 import Maybes	  ( orElse )
+import Maybe  	  ( isNothing )
 import Unique	  ( Uniquable(..) )
 import SrcLoc	  ( noSrcLoc )
 import Bag
@@ -182,12 +188,37 @@ hsLitType (HsDoublePrim d) = doublePrimTy
 hsLitType (HsLitLit _ ty)  = ty
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Coercion functions}
+%*									*
+%************************************************************************
+
 \begin{code}
--- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> TcM TcId
-zonkId id
-  = zonkTcType (idType id) `thenM` \ ty' ->
-    returnM (setIdType id ty')
+type Coercion a = Maybe (a -> a)
+	-- Nothing => identity fn
+
+type ExprCoFn = Coercion TypecheckedHsExpr
+type PatCoFn  = Coercion TcPat
+
+(<.>) :: Coercion a -> Coercion a -> Coercion a	-- Composition
+Nothing <.> Nothing = Nothing
+Nothing <.> Just f  = Just f
+Just f  <.> Nothing = Just f
+Just f1 <.> Just f2 = Just (f1 . f2)
+
+(<$>) :: Coercion a -> a -> a
+Just f  <$> e = f e
+Nothing <$> e = e
+
+mkCoercion :: (a -> a) -> Coercion a
+mkCoercion f = Just f
+
+idCoercion :: Coercion a
+idCoercion = Nothing
+
+isIdCoercion :: Coercion a -> Bool
+isIdCoercion = isNothing
 \end{code}
 
 
@@ -197,7 +228,16 @@ zonkId id
 %*									*
 %************************************************************************
 
-This zonking pass runs over the bindings
+\begin{code}
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+  = zonkTcType (idType id) `thenM` \ ty' ->
+    returnM (setIdType id ty')
+\end{code}
+
+The rest of the zonking is done *after* typechecking.
+The main zonking pass runs over the bindings
 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
  b) convert unbound TcTyVar to Void
@@ -568,6 +608,11 @@ zonkExpr env (HsSCC lbl expr)
   = zonkExpr env expr	`thenM` \ new_expr ->
     returnM (HsSCC lbl new_expr)
 
+-- hdaume: core annotations
+zonkExpr env (HsCoreAnn lbl expr)
+  = zonkExpr env expr   `thenM` \ new_expr ->
+    returnM (HsCoreAnn lbl new_expr)
+
 zonkExpr env (TyLam tyvars expr)
   = mappM zonkTcTyVarToTyVar tyvars	`thenM` \ new_tyvars ->
 	-- No need to extend tyvar env; see AbsBinds
@@ -818,6 +863,8 @@ zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
    returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
+zonkForeignExport env for_imp 
+  = returnM for_imp	-- Foreign imports don't need zonking
 \end{code}
 
 \begin{code}