X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=e64c34ae34d5082235942374d1847e67a7e44a24;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=9c29e8111790f9d471ee3a2d011449dd5750ea53;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 9c29e81..e64c34a 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsTypes]{Abstract syntax: user-defined types}
 
@@ -8,258 +8,217 @@ If compiled without \tr{#define COMPILING_GHC}, you get
 you get part of GHC.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsTypes (
-	PolyType(..), MonoType(..),
-	Context(..), ClassAssertion(..)
-
-#ifdef COMPILING_GHC
-	, pprParendMonoType, pprContext
-	, extractMonoTyNames, extractCtxtTyNames
-	, cmpPolyType, cmpMonoType, cmpContext
-#endif
+	HsType(..), HsTyVar(..),
+	Context, ClassAssertion
+
+	, mkHsForAllTy
+	, getTyVarName, replaceTyVarName
+	, pprParendHsType
+	, pprForAll, pprContext, pprClassAssertion
+	, cmpHsType, cmpHsTypes, cmpContext
     ) where
 
-#ifdef COMPILING_GHC
-import Ubiq
+#include "HsVersions.h"
 
-import Outputable	( interppSP, ifnotPprForUser )
-import Pretty
 import Type		( Kind )
-import Util		( thenCmp, cmpList, isIn, panic# )
-
-#endif {- COMPILING_GHC -}
+import PprType		( {- instance Outputable Kind -} )
+import Outputable
+import Util		( thenCmp, cmpList, panic )
 \end{code}
 
 This is the syntax for types as seen in type signatures.
 
 \begin{code}
-data PolyType name
-  = HsPreForAllTy	(Context name)
-			(MonoType name)
+type Context name = [ClassAssertion name]
 
-	-- The renamer turns HsPreForAllTys into HsForAllTys when they
-	-- occur in signatures, to make the binding of variables
-	-- explicit.  This distinction is made visible for
-	-- non-COMPILING_GHC code, because you probably want to do the
-	-- same thing.
+type ClassAssertion name = (name, [HsType name])
+	-- The type is usually a type variable, but it
+	-- doesn't have to be when reading interface files
 
-  | HsForAllTy		[name]
+data HsType name
+  = HsForAllTy		[HsTyVar name]
 			(Context name)
-			(MonoType name)
+			(HsType name)
 
-type Context name = [ClassAssertion name]
-
-type ClassAssertion name = (name, name)
+  | MonoTyVar		name		-- Type variable
 
-data MonoType name
-  = MonoTyVar		name		-- Type variable
+  | MonoTyApp		(HsType name)
+			(HsType name)
 
-  | MonoTyApp		name		-- Type constructor or variable
-			[MonoType name]
+  | MonoFunTy		(HsType name) -- function type
+			(HsType name)
 
-    -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []"
-    -- (for efficiency, what?)  WDP 96/02/18
+  | MonoListTy		(HsType name)	-- Element type
 
-  | MonoFunTy		(MonoType name) -- function type
-			(MonoType name)
+  | MonoTupleTy		[HsType name]	-- Element types (length gives arity)
+			Bool		-- boxed?
 
-  | MonoListTy		(MonoType name) -- list type
-  | MonoTupleTy		[MonoType name] -- tuple type (length gives arity)
-
-#ifdef COMPILING_GHC
   -- these next two are only used in unfoldings in interfaces
   | MonoDictTy		name	-- Class
-			(MonoType name)
+			[HsType name]
+
+mkHsForAllTy []  []   ty = ty
+mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
 
-  | MonoForAllTy	[(name, Kind)]
-			(MonoType name)
+data HsTyVar name
+  = UserTyVar name
+  | IfaceTyVar name Kind
 	-- *** NOTA BENE *** A "monotype" in a pragma can have
 	-- for-alls in it, (mostly to do with dictionaries).  These
 	-- must be explicitly Kinded.
 
-#endif {- COMPILING_GHC -}
-\end{code}
+getTyVarName (UserTyVar n)    = n
+getTyVarName (IfaceTyVar n _) = n
 
-This is used in various places:
-\begin{code}
-#ifdef COMPILING_GHC
-pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
-
-pprContext sty []	    = ppNil
-pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
-pprContext sty context
-  = ppBesides [ppLparen,
-	   ppInterleave ppComma (map pp_assert context),
-	   ppRparen, ppStr " =>"]
-  where
-    pp_assert (clas, ty)
-      = ppCat [ppr sty clas, ppr sty ty]
+replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
+replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
+replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Pretty printing}
+%*									*
+%************************************************************************
+
 \begin{code}
-instance (Outputable name) => Outputable (PolyType name) where
-    ppr sty (HsPreForAllTy ctxt ty)
-      = print_it sty ppNil ctxt ty
-    ppr sty (HsForAllTy tvs ctxt ty)
-      = print_it sty
-	    (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
-	    ctxt ty
 
-print_it sty pp_forall ctxt ty
-  = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
-	   pprContext sty ctxt, ppr sty ty]
+instance (Outputable name) => Outputable (HsType name) where
+    ppr ty = pprHsType ty
+
+instance (Outputable name) => Outputable (HsTyVar name) where
+    ppr (UserTyVar name)       = ppr name
+    ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
 
-instance (Outputable name) => Outputable (MonoType name) where
-    ppr = pprMonoType
+pprForAll []  = empty
+pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
 
+pprContext :: (Outputable name) => Context name -> SDoc
+pprContext []	   = empty
+pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
+
+pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
+pprClassAssertion (clas, tys) 
+  = ppr clas <+> hsep (map ppr tys)
+\end{code}
+
+\begin{code}
 pREC_TOP = (0 :: Int)
 pREC_FUN = (1 :: Int)
 pREC_CON = (2 :: Int)
 
+maybeParen :: Bool -> SDoc -> SDoc
+maybeParen True  p = parens p
+maybeParen False p = p
+	
 -- printing works more-or-less as for Types
 
-pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
+pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
 
-pprMonoType sty ty  	 = ppr_mono_ty sty pREC_TOP ty
-pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
+pprHsType ty       = ppr_mono_ty pREC_TOP ty
+pprParendHsType ty = ppr_mono_ty pREC_CON ty
 
-ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
+  = maybeParen (ctxt_prec >= pREC_FUN) $
+    sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
 
-ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
-  = let p1 = ppr_mono_ty sty pREC_FUN ty1
-	p2 = ppr_mono_ty sty pREC_TOP ty2
-    in
-    if ctxt_prec < pREC_FUN then -- no parens needed
-	ppSep [p1, ppBeside (ppStr "-> ") p2]
-    else
-	ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
-
-ppr_mono_ty sty ctxt_prec (MonoTupleTy tys)
- = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
-
-ppr_mono_ty sty ctxt_prec (MonoListTy ty)
- = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
-
-ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys)
-  = let pp_tycon = ppr sty tycon in
-    if null tys then
-	pp_tycon
-    else if ctxt_prec < pREC_CON then -- no parens needed
-	ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
-    else
-	ppBesides [ ppLparen, pp_tycon, ppSP,
-	       ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
-
--- unfoldings only
-ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
-  = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
-
-#endif {- COMPILING_GHC -}
-\end{code}
+ppr_mono_ty ctxt_prec (MonoTyVar name)
+  = ppr name
 
-\begin{code}
-#ifdef COMPILING_GHC
+ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
+  = let p1 = ppr_mono_ty pREC_FUN ty1
+	p2 = ppr_mono_ty pREC_TOP ty2
+    in
+    maybeParen (ctxt_prec >= pREC_FUN)
+	       (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 
-extractCtxtTyNames :: Eq name => Context  name -> [name]
-extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name]
+ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
+ = parens (sep (punctuate comma (map ppr tys)))
+ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
+ = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
 
-extractCtxtTyNames ctxt
-  = foldr get [] ctxt
-  where
-    get (clas, tv) acc
-      | tv `is_elem` acc = acc
-      | otherwise        = tv : acc
+ppr_mono_ty ctxt_prec (MonoListTy ty)
+ = brackets (ppr_mono_ty pREC_TOP ty)
 
-    is_elem = isIn "extractCtxtTyNames"
+ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
+  = maybeParen (ctxt_prec >= pREC_CON)
+	       (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
 
-extractMonoTyNames is_tyvar_name ty
-  = get ty []
-  where
-    get (MonoTyApp con tys) acc = let
-				     rest = foldr get acc tys
-				  in
-				  if is_tyvar_name con && not (con `is_elem` rest)
-				  then con : rest
-				  else rest
-    get (MonoListTy ty)	    acc = get ty acc
-    get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
-    get (MonoDictTy _ ty)   acc = get ty acc
-    get (MonoTupleTy tys)   acc = foldr get acc tys
-    get (MonoTyVar tv)      acc
-      | tv `is_elem` acc	= acc
-      | otherwise		= tv : acc
-
-    is_elem = isIn "extractMonoTyNames"
-
-#endif {- COMPILING_GHC -}
+ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
+  = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Comparison}
+%*									*
+%************************************************************************
+
 We do define a specialised equality for these \tr{*Type} types; used
 in checking interfaces.  Most any other use is likely to be {\em
 wrong}, so be careful!
+
 \begin{code}
-#ifdef COMPILING_GHC
+cmpHsTyVar  :: (a -> a -> Ordering) -> HsTyVar a  -> HsTyVar a  -> Ordering
+cmpHsType   :: (a -> a -> Ordering) -> HsType a   -> HsType a   -> Ordering
+cmpHsTypes  :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
+cmpContext  :: (a -> a -> Ordering) -> Context  a -> Context  a -> Ordering
 
-cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
-cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
-cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
+cmpHsTyVar cmp (UserTyVar v1)    (UserTyVar v2)    = v1 `cmp` v2
+cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
+cmpHsTyVar cmp (UserTyVar _)	 other		   = LT
+cmpHsTyVar cmp other1	 	 other2		   = GT
 
--- We assume that HsPreForAllTys have been smashed by now.
-# ifdef DEBUG
-cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
-cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
-# endif
 
-cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
-  = thenCmp (cmp_tvs tvs1 tvs2)
-	    (thenCmp (cmpContext cmp c1 c2) (cmpMonoType cmp t1 t2))
-  where
-    cmp_tvs [] [] = EQ_
-    cmp_tvs [] _  = LT_
-    cmp_tvs _  [] = GT_
-    cmp_tvs (a:as) (b:bs)
-      = thenCmp (cmp a b) (cmp_tvs as bs)
-    cmp_tvs _ _ = panic# "cmp_tvs"
-
------------
-cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
+cmpHsTypes cmp [] []   = EQ
+cmpHsTypes cmp [] tys2 = LT
+cmpHsTypes cmp tys1 [] = GT
+cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
+
+cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+  = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
+    cmpContext cmp c1 c2    		`thenCmp`
+    cmpHsType cmp t1 t2
+
+cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
   = cmp n1 n2
 
-cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
-  = cmpList (cmpMonoType cmp) tys1 tys2
-cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
-  = cmpMonoType cmp ty1 ty2
+cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
+  = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
 
-cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
-  = thenCmp (cmp tc1 tc2) (cmpList (cmpMonoType cmp) tys1 tys2)
+cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
+  = cmpHsType cmp ty1 ty2
 
-cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
-  = thenCmp (cmpMonoType cmp a1 a2) (cmpMonoType cmp b1 b2)
+cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
+  = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
 
-cmpMonoType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
-  = thenCmp (cmp c1 c2) (cmpMonoType cmp ty1 ty2)
+cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+  = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
 
-cmpMonoType cmp ty1 ty2 -- tags must be different
+cmpHsType cmp (MonoDictTy c1 tys1)   (MonoDictTy c2 tys2)
+  = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+
+cmpHsType cmp ty1 ty2 -- tags must be different
   = let tag1 = tag ty1
 	tag2 = tag ty2
     in
-    if tag1 _LT_ tag2 then LT_ else GT_
+    if tag1 _LT_ tag2 then LT else GT
   where
-    tag (MonoTyVar n1)		= (ILIT(1) :: FAST_INT)
-    tag (MonoTupleTy tys1)	= ILIT(2)
-    tag (MonoListTy ty1)	= ILIT(3)
-    tag (MonoTyApp tc1 tys1)	= ILIT(4)
-    tag (MonoFunTy a1 b1)	= ILIT(5)
-    tag (MonoDictTy c1 ty1)	= ILIT(7)
+    tag (MonoTyVar n1)			= (ILIT(1) :: FAST_INT)
+    tag (MonoTupleTy tys1 _)		= ILIT(2)
+    tag (MonoListTy ty1)		= ILIT(3)
+    tag (MonoTyApp tc1 tys1)		= ILIT(4)
+    tag (MonoFunTy a1 b1)		= ILIT(5)
+    tag (MonoDictTy c1 tys1)		= ILIT(7)
+    tag (HsForAllTy _ _ _)		= ILIT(8)
 
 -------------------
 cmpContext cmp a b
   = cmpList cmp_ctxt a b
   where
-    cmp_ctxt (c1, tv1) (c2, tv2)
-      = thenCmp (cmp c1 c2) (cmp tv1 tv2)
-
-#endif {- COMPILING_GHC -}
+    cmp_ctxt (c1, tys1) (c2, tys2)
+      = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 \end{code}