X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=3d6c49107db863d4011dbb51f9962c2f6f847313;hb=cd450d41e84c2bf09bb9c3a646c7408eb2c2d772;hp=46b8c04dfd2308bdaa062a6f249d18661b89cf3d;hpb=e8fa04cf0d656c4a2ff737278b8cea9fce3b5a2b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 46b8c04..3d6c491 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -82,7 +82,6 @@ hsPatType :: Pat Id -> Type
 hsPatType (ParPat pat)                = hsLPatType pat
 hsPatType (WildPat ty)                = ty
 hsPatType (VarPat var)                = idType var
-hsPatType (VarPatOut var _)           = idType var
 hsPatType (BangPat pat)               = hsLPatType pat
 hsPatType (LazyPat pat)               = hsLPatType pat
 hsPatType (LitPat lit)                = hsLitType lit
@@ -270,13 +269,14 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
 zonkTopDecls :: Bag EvBind 
              -> LHsBinds TcId -> NameSet
-             -> [LRuleDecl TcId] -> [LForeignDecl TcId]
+             -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
 	     -> TcM ([Id], 
 	             Bag EvBind,
 		     Bag (LHsBind  Id),
 		     [LForeignDecl Id],
+		     [LTcSpecPrag],
 		     [LRuleDecl    Id])
-zonkTopDecls ev_binds binds sig_ns rules fords
+zonkTopDecls ev_binds binds sig_ns rules imp_specs fords
   = do	{ (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
 
 	 -- Warn about missing signatures
@@ -288,8 +288,9 @@ zonkTopDecls ev_binds binds sig_ns rules fords
         ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
 			-- Top level is implicitly recursive
 	; rules' <- zonkRules env2 rules
+        ; specs' <- zonkLTcSpecPrags env2 imp_specs
 	; fords' <- zonkForeignExports env2 fords
-	; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
+	; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
@@ -430,12 +431,16 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
 
 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
 zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
-zonkSpecPrags env (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps
+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
                                        ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+  = mapM zonk_prag ps
   where
-    zonk_prag (L loc (SpecPrag co_fn inl))
+    zonk_prag (L loc (SpecPrag id co_fn inl))
 	= do { (_, co_fn') <- zonkCoFn env co_fn
-	     ; return (L loc (SpecPrag co_fn' inl)) }
+	     ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
 \end{code}
 
 %************************************************************************
@@ -559,11 +564,12 @@ zonkExpr env (HsCase expr ms)
     zonkMatchGroup env ms	`thenM` \ new_ms ->
     returnM (HsCase new_expr new_ms)
 
-zonkExpr env (HsIf e1 e2 e3)
-  = zonkLExpr env e1	`thenM` \ new_e1 ->
-    zonkLExpr env e2	`thenM` \ new_e2 ->
-    zonkLExpr env e3	`thenM` \ new_e3 ->
-    returnM (HsIf new_e1 new_e2 new_e3)
+zonkExpr env (HsIf e0 e1 e2 e3)
+  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
+       ; new_e1 <- zonkLExpr env e1
+       ; new_e2 <- zonkLExpr env e2
+       ; new_e3 <- zonkLExpr env e3
+       ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
 
 zonkExpr env (HsLet binds expr)
   = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
@@ -845,11 +851,6 @@ zonk_pat env (VarPat v)
   = do	{ v' <- zonkIdBndr env v
 	; return (extendZonkEnv1 env v', VarPat v') }
 
-zonk_pat env (VarPatOut v binds)
-  = do	{ v' <- zonkIdBndr env v
-	; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
-  	; returnM (env', VarPatOut v' binds') }
-
 zonk_pat env (LazyPat pat)
   = do	{ (env', pat') <- zonkPat env pat
 	; return (env',  LazyPat pat') }
@@ -902,10 +903,7 @@ zonk_pat env (SigPatOut pat ty)
 
 zonk_pat env (NPat lit mb_neg eq_expr)
   = do	{ lit' <- zonkOverLit env lit
- 	; mb_neg' <- case mb_neg of
-			Nothing  -> return Nothing
-			Just neg -> do { neg' <- zonkExpr env neg
-				       ; return (Just neg') }
+ 	; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
  	; eq_expr' <- zonkExpr env eq_expr
 	; return (env, NPat lit' mb_neg' eq_expr') }
 
@@ -1070,7 +1068,7 @@ zonkEvBind env (EvBind var term)
 
 %************************************************************************
 %*									*
-\subsection[BackSubst-Foreign]{Foreign exports}
+                         Zonking types
 %*									*
 %************************************************************************