X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=8dccc72b376341e9afbe39ac11d2ed83ae92c4d8;hb=37a6a52facd1c3999ce4472c50b0030568be1e04;hp=c39b713f9fc57ed2ebe6b08996b8b4cce6d56ebd;hpb=9a81ddfb43b96cfeae2236c9616ca3552250b235;p=ghc-hetmet.git

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index c39b713..8dccc72 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -871,20 +871,32 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
      ty' <- tcIfaceType ty
      return (Case scrut' case_bndr' ty' alts')
 
-tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = do
-    rhs' <- tcIfaceExpr rhs
-    id   <- tcIfaceLetBndr bndr
-    body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
-    return (Let (NonRec id rhs') body')
-
-tcIfaceExpr (IfaceLet (IfaceRec pairs) body) = do
-    ids <- mapM tcIfaceLetBndr bndrs
-    extendIfaceIdEnv ids $ do
-     rhss' <- mapM tcIfaceExpr rhss
-     body' <- tcIfaceExpr body
-     return (Let (Rec (ids `zip` rhss')) body')
-  where
-    (bndrs, rhss) = unzip pairs
+tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
+  = do	{ name 	  <- newIfaceName (mkVarOccFS fs)
+	; ty'  	  <- tcIfaceType ty
+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                              name ty' info
+	; let id = mkLocalIdWithInfo name ty' id_info
+        ; rhs' <- tcIfaceExpr rhs
+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+        ; return (Let (NonRec id rhs') body') }
+
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
+  = do { ids <- mapM tc_rec_bndr (map fst pairs)
+       ; extendIfaceIdEnv ids $ do
+       { pairs' <- zipWithM tc_pair pairs ids
+       ; body' <- tcIfaceExpr body
+       ; return (Let (Rec pairs') body') } }
+ where
+   tc_rec_bndr (IfLetBndr fs ty _) 
+     = do { name <- newIfaceName (mkVarOccFS fs)  
+          ; ty'  <- tcIfaceType ty
+          ; return (mkLocalId name ty') }
+   tc_pair (IfLetBndr _ _ info, rhs) id
+     = do { rhs' <- tcIfaceExpr rhs
+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                                (idName id) (idType id) info
+          ; return (setIdInfo id id_info, rhs') }
 
 tcIfaceExpr (IfaceCast expr co) = do
     expr' <- tcIfaceExpr expr
@@ -974,10 +986,10 @@ do_one (IfaceRec pairs) thing_inside
 \begin{code}
 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
 tcIdDetails _  IfVanillaId = return VanillaId
-tcIdDetails ty IfDFunId
-  = return (DFunId (isNewTyCon (classTyCon cls)))
+tcIdDetails ty (IfDFunId ns)
+  = return (DFunId ns (isNewTyCon (classTyCon cls)))
   where
-    (_, cls, _) = tcSplitDFunTy ty
+    (_, _, cls, _) = tcSplitDFunTy ty
 
 tcIdDetails _ (IfRecSelId tc naughty)
   = do { tc' <- tcIfaceTyCon tc
@@ -1039,12 +1051,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
     }
 
 tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
-  = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+  = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
        ; return (case mb_ops1 of
        	 	    Nothing   -> noUnfolding
                     Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
   where
     doc = text "Class ops for dfun" <+> ppr name
+    tc_arg (DFunPolyArg  e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
+    tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
+    tc_arg (DFunLamArg i)   = return (DFunLamArg i)
 
 tcUnfolding name ty info (IfExtWrapper arity wkr)
   = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
@@ -1091,7 +1106,9 @@ tcPragExpr name expr
           Just fail_msg -> do { mod <- getIfModule 
                               ; pprPanic "Iface Lint failure" 
                                   (vcat [ ptext (sLit "In interface for") <+> ppr mod
-                                        , hang doc 2 fail_msg ]) }
+                                        , hang doc 2 fail_msg
+                                        , ppr name <+> equals <+> ppr core_expr'
+                                        , ptext (sLit "Iface expr =") <+> ppr expr ]) }
     return core_expr'
   where
     doc = text "Unfolding of" <+> ppr name
@@ -1099,14 +1116,14 @@ tcPragExpr name expr
     get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
     get_in_scope 	
 	= do { (gbl_env, lcl_env) <- getEnvs
-             ; setLclEnv () $ do
-	     { case if_rec_types gbl_env of {
-		  Nothing -> return [] ;
-		  Just (_, get_env) -> do
-	     { type_env <- get_env
+             ; rec_ids <- case if_rec_types gbl_env of
+                            Nothing -> return []
+                            Just (_, get_env) -> do
+                               { type_env <- setLclEnv () get_env
+                               ; return (typeEnvIds type_env) }
              ; return (varEnvElts (if_tv_env lcl_env) ++
                        varEnvElts (if_id_env lcl_env) ++
-                       typeEnvIds type_env) }}}}
+                       rec_ids) }
 \end{code}
 
 
@@ -1236,16 +1253,6 @@ bindIfaceBndrs (b:bs) thing_inside
     bindIfaceBndrs bs	$ \ bs' ->
     thing_inside (b':bs')
 
-
------------------------
-tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
-tcIfaceLetBndr (IfLetBndr fs ty info)
-  = do	{ name <- newIfaceName (mkVarOccFS fs)
-	; ty' <- tcIfaceType ty
-        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
-                              name ty' info
-	; return (mkLocalIdWithInfo name ty' id_info) } 
-
 -----------------------
 newExtCoreBndr :: IfaceLetBndr -> IfL Id
 newExtCoreBndr (IfLetBndr var ty _)    -- Ignoring IdInfo for now