From: Tim Chevalier <chevalier@alum.wellesley.edu>
Date: Thu, 15 Jan 2009 00:26:12 +0000 (+0000)
Subject: External Core: re-add code I removed mistakenly in last commit
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ee69a45c027e2a9fefd9a97bfd64e78b49d0ecbe

External Core: re-add code I removed mistakenly in last commit
---

diff --git a/utils/ext-core/Language/Core/Check.hs b/utils/ext-core/Language/Core/Check.hs
index 9f7a276..3ae94e3 100644
--- a/utils/ext-core/Language/Core/Check.hs
+++ b/utils/ext-core/Language/Core/Check.hs
@@ -5,7 +5,7 @@ module Language.Core.Check(
   primCoercionError, 
   Menv, Venv, Tvenv, Envs(..),
   CheckRes(..), splitTy, substl,
-  mkTypeEnvsNoChecking) where
+  mkTypeEnvsNoChecking, NtEnv, mkNtEnv) where
 
 --import Debug.Trace
 
@@ -18,6 +18,7 @@ import Language.Core.Environments
 
 import Control.Monad.Reader
 import Data.List
+import qualified Data.Map as M
 import Data.Maybe
 
 {- Checking is done in a simple error monad.  In addition to
@@ -632,3 +633,17 @@ primCoercionError s = error $ "Bad coercion application: " ++ show s
 reportError :: Show a => a -> String -> b
 reportError e s = error $ ("Core type error: checkExpr failed with "
                    ++ s ++ " and " ++ show e)
+
+type NtEnv  = M.Map Tcon CoercionKind
+
+mkNtEnv :: Menv -> NtEnv
+mkNtEnv menv = 
+  foldl M.union M.empty $
+        map (\ (_,e) ->
+                 foldr (\ (_,thing) rest ->
+                            case thing of
+                              Kind _ -> rest
+                              Coercion d@(DefinedCoercion _ (lhs,_)) -> 
+                                  case splitTyConApp_maybe lhs of
+                                    Just ((_,tc1),_) -> M.insert tc1 d rest
+                                    _ -> rest) M.empty (etolist (tcenv_ e))) (etolist menv)
diff --git a/utils/ext-core/Language/Core/Prep.hs b/utils/ext-core/Language/Core/Prep.hs
index a557b80..1ce8fda 100644
--- a/utils/ext-core/Language/Core/Prep.hs
+++ b/utils/ext-core/Language/Core/Prep.hs
@@ -224,8 +224,6 @@ newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t =
   M.lookup tc ntEnv
 newtypeCoercion_maybe _ _ = Nothing
 
-type NtEnv  = M.Map Tcon CoercionKind
-
 mkTapp :: Ty -> [Ty] -> Ty
 mkTapp = foldl Tapp