Refactor TcRnDriver, and check exports on hi-boot files

[ghc-hetmet.git] / compiler / coreSyn / CoreUtils.lhs

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 362fb52..a43be02 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -13,7 +13,7 @@ module CoreUtils (
        mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
        -- Taking expressions apart
-       findDefault, findAlt, isDefaultAlt, mergeAlts,
+       findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
 
        -- Properties of expressions
        exprType, coreAltType,
@@ -314,6 +314,18 @@ mergeAlts (a1:as1) (a2:as2)
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
+
+
+---------------------------------
+trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
+-- Given       case (C a b x y) of
+--                C b x y -> ...
+-- we want to drop the leading type argument of the scrutinee
+-- leaving the arguments to match agains the pattern
+
+trimConArgs DEFAULT      args = ASSERT( null args ) []
+trimConArgs (LitAlt lit) args = ASSERT( null args ) []
+trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 \end{code}
 
 
@@ -606,8 +618,8 @@ Because `seq` on such things completes immediately
 
 For unlifted argument types, we have to be careful:
                C (f x :: Int#)
-Suppose (f x) diverges; then C (f x) is not a value.  True, but
-this form is illegal (see the invariants in CoreSyn).  Args of unboxed
+Suppose (f x) diverges; then C (f x) is not a value.  However this can't 
+happen: see CoreSyn Note [CoreSyn let/app invariant].  Args of unboxed
 type must be ok-for-speculation (or trivial).
 
 \begin{code}
@@ -633,22 +645,12 @@ exprIsHNF other              = False
 
 -- There is at least one value argument
 app_is_value (Var fun) args
-  |  isDataConWorkId fun               -- Constructor apps are values
-  || idArity fun > valArgCount args    -- Under-applied function
-  = check_args (idType fun) args
-app_is_value (App f a) as = app_is_value f (a:as)
-app_is_value other     as = False
-
-       -- 'check_args' checks that unlifted-type args
-       -- are in fact guaranteed non-divergent
-check_args fun_ty []             = True
-check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
-                                     Just (_, ty) -> check_args ty args
-check_args fun_ty (arg : args)
-  | isUnLiftedType arg_ty = exprOkForSpeculation arg
-  | otherwise            = check_args res_ty args
-  where
-    (arg_ty, res_ty) = splitFunTy fun_ty
+  = idArity fun > valArgCount args     -- Under-applied function
+    ||  isDataConWorkId fun            --  or data constructor
+app_is_value (Note n f) as = app_is_value f as
+app_is_value (Cast f _) as = app_is_value f as
+app_is_value (App f a)  as = app_is_value f (a:as)
+app_is_value other      as = False
 \end{code}
 
 \begin{code}