[project @ 2005-01-31 13:25:33 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreTidy.lhs
index 9c03072..a2a56c6 100644 (file)
@@ -17,14 +17,16 @@ module CoreTidy (
 
 import CoreSyn
 import CoreUtils       ( exprArity )
+import Unify           ( coreRefineTys )
 import PprCore         ( pprIdRules )
+import DataCon         ( DataCon, isVanillaDataCon )
 import Id              ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
-                         idType, idCoreRules )
+                         idType, setIdType, idCoreRules )
 import IdInfo          ( setArityInfo, vanillaIdInfo,
                          newStrictnessInfo, setAllStrictnessInfo,
                          newDemandInfo, setNewDemandInfo )
-import Type            ( tidyType, tidyTyVarBndr )
-import Var             ( Var )
+import Type            ( Type, tidyType, tidyTyVarBndr, substTy, mkTvSubst )
+import Var             ( Var, TyVar )
 import VarEnv
 import Name            ( getOccName )
 import OccName         ( tidyOccName )
@@ -71,21 +73,52 @@ tidyExpr env (Let b e)
   = tidyBind env b     =: \ (env', b') ->
     Let b' (tidyExpr env' e)
 
--- gaw 2004
 tidyExpr env (Case e b ty alts)
   = tidyBndr env b     =: \ (env', b) ->
--- gaw 2004
-    Case (tidyExpr env e) b (tidyType env ty) (map (tidyAlt env') alts)
+    Case (tidyExpr env e) b (tidyType env ty) 
+        (map (tidyAlt b env') alts)
 
 tidyExpr env (Lam b e)
   = tidyBndr env b     =: \ (env', b) ->
     Lam b (tidyExpr env' e)
 
 ------------  Case alternatives  --------------
-tidyAlt env (con, vs, rhs)
+tidyAlt case_bndr env (DataAlt con, vs, rhs)
+  | not (isVanillaDataCon con) -- GADT case
+  = tidyBndrs env tvs          =: \ (env1, tvs') ->
+    let 
+       env2 = refineTidyEnv env con tvs' scrut_ty
+    in
+    tidyBndrs env2 ids         =: \ (env3, ids') ->
+    (DataAlt con, tvs' ++ ids', tidyExpr env3 rhs)
+  where 
+    (tvs, ids) = span isTyVar vs
+    scrut_ty = idType case_bndr
+
+tidyAlt case_bndr env (con, vs, rhs)
   = tidyBndrs env vs   =: \ (env', vs) ->
     (con, vs, tidyExpr env' rhs)
 
+refineTidyEnv :: TidyEnv -> DataCon -> [TyVar] -> Type -> TidyEnv
+-- Refine the TidyEnv in the light of the type refinement from coreRefineTys
+refineTidyEnv tidy_env@(occ_env, var_env)  con tvs scrut_ty
+  = case coreRefineTys in_scope con tvs scrut_ty of
+       Nothing -> tidy_env
+       Just (tv_subst, all_bound_here)
+           | all_bound_here    -- Local type refinement only
+           -> tidy_env
+           | otherwise         -- Apply the refining subst to the tidy env
+                               -- This ensures that occurences have the most refined type
+                               -- And that means that exprType will work right everywhere
+           -> (occ_env, mapVarEnv (refine subst) var_env)
+           where
+             subst = mkTvSubst in_scope tv_subst
+  where
+    refine subst var | isId var  = setIdType var (substTy subst (idType var)) 
+                    | otherwise = var
+
+    in_scope = mkInScopeSet var_env    -- Seldom used
+
 ------------  Notes  --------------
 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 tidyNote env note            = note
@@ -94,10 +127,10 @@ tidyNote env note            = note
 ------------  Rules  --------------
 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
 tidyIdRules env [] = []
-tidyIdRules env ((fn,rule) : rules)
+tidyIdRules env (IdCoreRule fn is_orph rule : rules)
   = tidyRule env rule                  =: \ rule ->
     tidyIdRules env rules      =: \ rules ->
-     ((tidyVarOcc env fn, rule) : rules)
+    (IdCoreRule (tidyVarOcc env fn) is_orph rule : rules)
 
 tidyRule :: TidyEnv -> CoreRule -> CoreRule
 tidyRule env rule@(BuiltinRule _ _) = rule