X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=590819443cd8450c2819a474c6b1456a1e9e23b9;hb=40b82d31494eabb51ef2eb47d6e6191e0db764fd;hp=cf38146eb10d59b2c7b16691d72fdd35dba5fab0;hpb=1ae354e107715a9e3fd4e2d67b61f868c090e4ae;p=ghc-hetmet.git

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index cf38146..5908194 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -41,7 +41,7 @@ module Type (
 	applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
 	
 	-- (Newtypes)
-	newTyConInstRhs,
+	newTyConInstRhs, carefullySplitNewType_maybe,
 	
 	-- (Type families)
         tyFamInsts, predFamInsts,
@@ -87,7 +87,7 @@ module Type (
 
 	-- * Type free variables
 	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-	typeKind,
+	typeKind, expandTypeSynonyms,
 
 	-- * Tidying type related things up for printing
 	tidyType,      tidyTypes,
@@ -281,6 +281,29 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
 tcView _                 = Nothing
 
 -----------------------------------------------
+expandTypeSynonyms :: Type -> Type
+-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out
+-- just the ones that discard type variables (e.g.  type Funny a = Int)
+-- But we don't know which those are currently, so we just expand all.
+expandTypeSynonyms ty 
+  = go ty
+  where
+    go (TyConApp tc tys)
+      | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys 
+      = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
+      | otherwise
+      = TyConApp tc (map go tys)
+    go (TyVarTy tv)    = TyVarTy tv
+    go (AppTy t1 t2)   = AppTy (go t1) (go t2)
+    go (FunTy t1 t2)   = FunTy (go t1) (go t2)
+    go (ForAllTy tv t) = ForAllTy tv (go t)
+    go (PredTy p)      = PredTy (go_pred p)
+
+    go_pred (ClassP c ts)  = ClassP c (map go ts)
+    go_pred (IParam ip t)  = IParam ip (go t)
+    go_pred (EqPred t1 t2) = EqPred (go t1) (go t2)
+
+-----------------------------------------------
 {-# INLINE kindView #-}
 kindView :: Kind -> Maybe Kind
 -- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
@@ -534,7 +557,7 @@ splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitTyConApp_maybe _                 = Nothing
 
 newTyConInstRhs :: TyCon -> [Type] -> Type
--- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an 
+-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an 
 -- eta-reduced version of the @newtype@ if possible
 newTyConInstRhs tycon tys 
     = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
@@ -596,14 +619,9 @@ newtype at outermost level; and bale out if we see it again.
 -- | Looks through:
 --
 --	1. For-alls
---
 --	2. Synonyms
---
 --	3. Predicates
---
---	4. Usage annotations
---
---	5. All newtypes, including recursive ones, but not newtype families
+--	4. All newtypes, including recursive ones, but not newtype families
 --
 -- It's useful in the back end of the compiler.
 repType :: Type -> Type
@@ -618,19 +636,25 @@ repType ty
     go rec_nts (ForAllTy _ ty)			-- Look through foralls
 	= go rec_nts ty
 
-    go rec_nts ty@(TyConApp tc tys)		-- Expand newtypes
-	| Just _co_con <- newTyConCo_maybe tc	-- See Note [Expanding newtypes]
-	= if tc `elem` rec_nts 			--  in Type.lhs
-	  then ty
-	  else go rec_nts' nt_rhs
-	where
-	  nt_rhs = newTyConInstRhs tc tys
-	  rec_nts' | isRecursiveTyCon tc = tc:rec_nts
-		   | otherwise		 = rec_nts
+    go rec_nts (TyConApp tc tys)		-- Expand newtypes
+      | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
+      = go rec_nts' ty'
 
     go _ ty = ty
 
 
+carefullySplitNewType_maybe :: [TyCon] -> TyCon -> [Type] -> Maybe ([TyCon],Type)
+-- Return the representation of a newtype, unless 
+-- we've seen it already: see Note [Expanding newtypes]
+carefullySplitNewType_maybe rec_nts tc tys
+  | isNewTyCon tc
+  , not (tc `elem` rec_nts)  = Just (rec_nts', newTyConInstRhs tc tys)
+  | otherwise	   	     = Nothing
+  where
+    rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+	     | otherwise	   = rec_nts
+
+
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 -- of inspecting the type directly.
 
@@ -657,7 +681,7 @@ typePrimRep ty = case repType ty of
 \begin{code}
 mkForAllTy :: TyVar -> Type -> Type
 mkForAllTy tyvar ty
-  = mkForAllTys [tyvar] ty
+  = ForAllTy tyvar ty
 
 -- | Wraps foralls over the type using the provided 'TyVar's from left to right
 mkForAllTys :: [TyVar] -> Type -> Type
@@ -739,8 +763,8 @@ applyTysD doc orig_fun_ty arg_tys
 		(mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise		-- Too many type args
   = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty )	-- Zero case gives infnite loop!
-    applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
-	     (drop n_tvs arg_tys)
+    applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty)
+	          (drop n_tvs arg_tys)
   where
     (tvs, rho_ty) = splitForAllTys orig_fun_ty 
     n_tvs = length tvs