External Core lib: lots of cleanup

[ghc-hetmet.git] / utils / ext-core / Language / Core / Prep.hs

diff --git a/utils/ext-core/Language/Core/Prep.hs b/utils/ext-core/Language/Core/Prep.hs
index 86b0155..a557b80 100644 (file)
--- a/utils/ext-core/Language/Core/Prep.hs
+++ b/utils/ext-core/Language/Core/Prep.hs
@@ -13,6 +13,8 @@ After these preprocessing steps, Core can be interpreted (or given an operationa
 
 module Language.Core.Prep where
 
+--import Debug.Trace
+
 import Control.Monad.State
 import Data.Either
 import Data.List
@@ -20,6 +22,7 @@ import Data.Generics
 import qualified Data.Map as M
 
 import Language.Core.Core
+import Language.Core.CoreUtils
 import Language.Core.Env
 import Language.Core.Check
 import Language.Core.Environments
@@ -97,8 +100,6 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
     prepAlt env (Alit l e) = (liftM (Alit l)) (prepExp env e)
     prepAlt env (Adefault e) = (liftM Adefault) (prepExp env e)
 
-    ntEnv = mkNtEnv globalEnv
-
     unwindApp :: (Venv, Tvenv) -> Exp -> [Either Exp Ty] -> PrepM Exp
     unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
     unwindApp env (Appt e t) as  = unwindApp env e (Right t:as)
@@ -110,41 +111,9 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
              atys = map (substl (map fst tbs) ts) atys0
              ts = [t | Right t <- as]
               n = length [e | Left e <- as]
-    unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv = do
+    unwindApp env (op@(Var qv)) as | isPrimVar qv = do
         e' <- rewindApp env op as
-       (liftM k) $ etaExpand (snd (unzip extraTbs)) (drop n atys) (k1 e')
-        where -- TODO: avoid copying code. these two cases are the same
-
-              -- etaExpand needs to add the type arguments too! Bah!
-              primEnv = case elookup globalEnv primMname of
-                              Just es -> venv_ es
-                              _       -> error "eek"
-              (_, _, resTy') = (maybe (error "unwindApp") splitTy (elookup primEnv p))
-              (tbs, atys0, _resTy) = (maybe (error "unwindApp") (splitTy . (substNewtys ntEnv)) (elookup primEnv p))
-              -- The magic here is so we know to eta-expand applications of
-              -- primops whose return types are newtypes.
-              -- There are no actual GHC primops that have this property, but
-              -- a back-end tool writer (for example: me) might want to add
-              -- such a primop.
-              -- If this code wasn't here, and we had a primop 
-              -- foo# :: Int -> IO (),
-              -- we would see (foo# 5) and think it was fully applied, when 
-              -- actually we need to rewrite it as:
-              -- (\ (s::State# RealWorld#) -> foo# 5 s)
-              -- (This code may be a very good case against introducing such
-              -- primops.)
-                  -- tim 10/29/2008: I think this is no longer necessary.
-                  -- hPutChar now has a (#wub,blub#) return type.
-              (k,k1) = case newtypeCoercion_maybe ntEnv resTy' of
-                         Just co -> case splitTyConApp_maybe resTy' of
-                                      Just (_, args) -> ((\ e -> Cast e (SymCoercion (mkTapp co args))), (\ e1 -> Cast e1 (mkTapp co args)))
-                                      _ -> ((\ e -> Cast e (SymCoercion co)), (\ e1 -> Cast e1 co))
-                         _       -> (id,id) 
-              n_args = length ts
-              (appliedTbs, extraTbs) = (take n_args tbs, drop n_args tbs)
-              atys = map (substl (map fst appliedTbs) ts) atys0
-              ts = [t | Right t <- as]
-              n = length [e | Left e <- as]
+        etaExpand [] [] e'
     unwindApp env (op@(External _ t)) as = do
         e' <- rewindApp env op as
         etaExpand [] (drop n atys) e'
@@ -241,36 +210,21 @@ boundVarsAlt (Acon _ _ vbs e) = (map fst vbs) `union` (boundVars e)
 boundVarsAlt (Alit _ e) = boundVars e
 boundVarsAlt (Adefault e) = boundVars e
 
-mkNtEnv :: Menv -> NtEnv
-mkNtEnv menv = 
-  foldl M.union M.empty $
-        map (\ (mn,e) ->
-                 foldr (\ (key,thing) rest ->
-                            case thing of
-                              Kind _ -> rest
-                              Coercion (DefinedCoercion _ (lhs,rhs)) -> 
-                                  case splitTyConApp_maybe lhs of
-                                    Just ((_,tc1),_) -> M.insert tc1 (rhs,Tcon (Just mn, key)) rest
-                                    _ -> rest) M.empty (etolist (tcenv_ e))) (etolist menv)
-
 substNewtys :: NtEnv -> Ty -> Ty
 substNewtys ntEnv = everywhere'Except (mkT go)
-                 where go t | Just ((_,tc),_) <- splitTyConApp_maybe t =
+                 where go t | Just ((_,tc),args) <- splitTyConApp_maybe t =
                          case M.lookup tc ntEnv of
-                           Just (rhs,_) -> rhs
+                           Just d -> -- trace ("applying newtype: " ++ show t) $
+                                       (snd (applyNewtype d args))
                            Nothing  -> t
                        go t = t
 
-newtypeCoercion_maybe :: NtEnv -> Ty -> Maybe Ty
-newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t = 
-  case M.lookup tc ntEnv of
-    Just (_, coercion) -> Just coercion
-    Nothing               -> Nothing
+newtypeCoercion_maybe :: NtEnv -> Ty -> Maybe CoercionKind
+newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t =
+  M.lookup tc ntEnv
 newtypeCoercion_maybe _ _ = Nothing
 
--- first element: rep type
--- second element: coercion tcon
-type NtEnv  = M.Map Tcon (Ty, Ty)
+type NtEnv  = M.Map Tcon CoercionKind
 
 mkTapp :: Ty -> [Ty] -> Ty
 mkTapp = foldl Tapp