X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=b83f4b8fcd4e2fe5bd090f0c5ed961299aab7aba;hb=9c26739695219d8343505a88457cb55c76b65449;hp=884ee9f8bef644e0663343f8b4647760886eae95;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 884ee9f..b83f4b8 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -11,34 +11,38 @@ you get part of GHC.
 #include "HsVersions.h"
 
 module HsTypes (
-	PolyType(..), MonoType(..),
-	Context(..), ClassAssertion(..)
-
-#ifdef COMPILING_GHC
-	, pprParendPolyType
-	, pprParendMonoType, pprContext
-	, extractMonoTyNames, extractCtxtTyNames
-	, cmpPolyType, cmpMonoType, cmpContext
-#endif
+	HsType(..), HsTyVar(..),
+	SYN_IE(Context), SYN_IE(ClassAssertion)
+
+	, mkHsForAllTy
+	, getTyVarName, replaceTyVarName
+	, pprParendHsType
+	, pprContext
+	, cmpHsType, cmpContext
     ) where
 
-#ifdef COMPILING_GHC
-import Ubiq
+IMP_Ubiq()
 
-import Outputable	( interppSP, ifnotPprForUser )
+import CmdLineOpts      ( opt_PprUserLength )
+import Outputable	( Outputable(..), PprStyle(..), pprQuote, interppSP )
+import Kind		( Kind {- instance Outputable -} )
+import Name		( nameOccName )
 import Pretty
-import Type		( Kind )
 import Util		( thenCmp, cmpList, isIn, panic# )
-
-#endif {- COMPILING_GHC -}
 \end{code}
 
 This is the syntax for types as seen in type signatures.
 
 \begin{code}
-data PolyType name
+type Context name = [ClassAssertion name]
+
+type ClassAssertion name = (name, HsType name)
+	-- The type is usually a type variable, but it
+	-- doesn't have to be when reading interface files
+
+data HsType name
   = HsPreForAllTy	(Context name)
-			(MonoType name)
+			(HsType name)
 
 	-- The renamer turns HsPreForAllTys into HsForAllTys when they
 	-- occur in signatures, to make the binding of variables
@@ -46,90 +50,97 @@ data PolyType name
 	-- non-COMPILING_GHC code, because you probably want to do the
 	-- same thing.
 
-  | HsForAllTy		[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		name		-- The list TyCon name
+			(HsType name)	-- Element type
 
-  | MonoFunTy		(MonoType name) -- function type
-			(MonoType name)
+  | MonoTupleTy		name		-- The tuple TyCon name
+			[HsType name]	-- Element types (length gives arity)
 
-  | 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 -}
+getTyVarName (UserTyVar n)    = n
+getTyVarName (IfaceTyVar n _) = n
+
+replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
+replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
+replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
 \end{code}
 
-This is used in various places:
+
+%************************************************************************
+%*									*
+\subsection{Pretty printing}
+%*									*
+%************************************************************************
+
 \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 "=>"]
+instance (Outputable name) => Outputable (HsType name) where
+    ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty
+
+instance (Outputable name) => Outputable (HsTyVar name) where
+    ppr sty (UserTyVar name)       = ppr sty name
+    ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty ->
+				     hsep [ppr sty name, ptext SLIT("::"), ppr sty kind]
+
+ppr_forall sty ctxt_prec [] [] ty
+   = ppr_mono_ty sty ctxt_prec ty
+ppr_forall sty ctxt_prec tvs ctxt ty
+   = maybeParen (ctxt_prec >= pREC_FUN) $
+     sep [ptext SLIT("_forall_"), brackets (interppSP sty tvs),
+	    pprContext sty ctxt,  ptext SLIT("=>"),
+	    pprHsType sty ty]
+
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc
+pprContext sty []	        = empty
 pprContext sty context
-  = ppBesides [ppLparen,
-	   ppInterleave ppComma (map pp_assert context),
-	   ppRparen, ppStr " =>"]
+  = hsep [braces (hsep (punctuate comma (map ppr_assert context)))]
   where
-    pp_assert (clas, ty)
-      = ppCat [ppr sty clas, ppr sty ty]
+    ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty]
 \end{code}
 
 \begin{code}
-instance (Outputable name) => Outputable (PolyType name) where
-    ppr sty (HsPreForAllTy ctxt ty)
-      = print_it sty ppNil ctxt ty
-    ppr sty (HsForAllTy [] 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]
-
-pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty
-pprParendPolyType sty ty = ppr sty ty -- ToDo: more later
-
-instance (Outputable name) => Outputable (MonoType name) where
-    ppr = pprMonoType
-
 pREC_TOP = (0 :: Int)
 pREC_FUN = (1 :: Int)
 pREC_CON = (2 :: Int)
 
+maybeParen :: Bool -> Doc -> Doc
+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) => PprStyle -> HsType name -> Doc
 
-pprMonoType sty ty  	 = ppr_mono_ty sty pREC_TOP ty
-pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
+pprHsType sty ty       = ppr_mono_ty sty pREC_TOP ty
+pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
+
+ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty)     = ppr_forall sty ctxt_prec [] ctxt ty
+ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty)    = ppr_forall sty ctxt_prec tvs ctxt ty
 
 ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
 
@@ -137,135 +148,92 @@ 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 "}}"]
+    maybeParen (ctxt_prec >= pREC_FUN)
+	       (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 
-#endif {- COMPILING_GHC -}
-\end{code}
+ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
+ = parens (sep (punctuate comma (map (ppr sty) tys)))
 
-\begin{code}
-#ifdef COMPILING_GHC
+ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
+ = brackets (ppr_mono_ty sty pREC_TOP ty)
 
-extractCtxtTyNames :: Eq name => Context  name -> [name]
-extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name]
+ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty)
+  = maybeParen (ctxt_prec >= pREC_CON)
+	       (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
 
-extractCtxtTyNames ctxt
-  = foldr get [] ctxt
-  where
-    get (clas, tv) acc
-      | tv `is_elem` acc = acc
-      | otherwise        = tv : acc
+ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
+  = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty]
+\end{code}
 
-    is_elem = isIn "extractCtxtTyNames"
 
-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 -}
-\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 -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_
+--cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType 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_
 
-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_
 
 -- 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"
+cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg"
+cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType: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)
+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) (MonoTupleTy _ tys2)
+  = cmpList (cmpHsType cmp) tys1 tys2
+cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
+  = cmpHsType cmp ty1 ty2
 
-cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
-  = thenCmp (cmp tc1 tc2) (cmpList (cmpMonoType cmp) tys1 tys2)
+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 (MonoFunTy a1 b1) (MonoFunTy a2 b2)
-  = thenCmp (cmpMonoType cmp a1 a2) (cmpMonoType cmp b1 b2)
+cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+  = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
 
-cmpMonoType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
-  = thenCmp (cmp c1 c2) (cmpMonoType cmp ty1 ty2)
+cmpHsType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
+  = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
 
-cmpMonoType cmp ty1 ty2 -- tags must be different
+cmpHsType cmp ty1 ty2 -- tags must be different
   = let tag1 = tag ty1
 	tag2 = tag ty2
     in
     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 (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 (HsForAllTy _ _ _)	= ILIT(8)
+    tag (HsPreForAllTy _ _)	= ILIT(9)
 
 -------------------
 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, ty1) (c2, ty2)
+      = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
 \end{code}