[project @ 2002-05-27 15:28:07 by simonpj]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsTypes.lhs

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 837dc91..738ab16 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module HsTypes (
-         HsType(..), HsTyVarBndr(..),
+         HsType(..), HsTyVarBndr(..), HsTyOp(..),
        , HsContext, HsPred(..)
        , HsTupCon(..), hsTupParens, mkHsTupCon,
         , hsUsOnce, hsUsMany
@@ -102,9 +102,9 @@ data HsType name
 
   | HsTupleTy          (HsTupCon name)
                        [HsType name]   -- Element types (length gives arity)
-  -- Generics
-  | HsOpTy             (HsType name) name (HsType name)
-  | HsNumTy             Integer
+
+  | HsOpTy             (HsType name) (HsTyOp name) (HsType name)
+  | HsNumTy             Integer                -- Generics only
 
   -- these next two are only used in interfaces
   | HsPredTy           (HsPred name)
@@ -113,6 +113,11 @@ data HsType name
                        Kind            -- A type with a kind signature
 
 
+data HsTyOp name = HsArrow | HsTyOp name
+       -- Function arrows from *source* get read in as HsOpTy t1 HsArrow t2
+       -- But when we generate or parse interface files, we use HsFunTy.
+       -- This keeps interfaces a bit smaller, because there are a lot of arrows
+
 -----------------------
 hsUsOnce, hsUsMany :: HsType RdrName
 hsUsOnce = HsTyVar (mkUnqual tvName FSLIT("."))  -- deep magic
@@ -209,6 +214,10 @@ NB: these types get printed into interface files, so
 instance (Outputable name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
+instance (Outputable name) => Outputable (HsTyOp name) where
+    ppr HsArrow    = ftext FSLIT("->")
+    ppr (HsTyOp n) = ppr n
+
 instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name)       = ppr name
     ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
@@ -475,11 +484,15 @@ eq_hsType env (HsPredTy p1) (HsPredTy p2)
   = eq_hsPred env p1 p2
 
 eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
-  = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
+  = eq_hsOp env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
 
 eq_hsType env ty1 ty2 = False
 
 
+eq_hsOp env (HsTyOp n1) (HsTyOp n2) = eq_hsVar env n1 n2
+eq_hsOp env HsArrow     HsArrow     = True
+eq_hsOp env op1                op2         = False
+
 -------------------
 eq_hsContext env a b = eqListBy (eq_hsPred env) a b