[project @ 2000-10-24 09:44:18 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 86a1467..956b02f 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -26,22 +26,21 @@ module HsTypes (
 #include "HsVersions.h"
 
 import Class           ( FunDep )
-import Type            ( Type, Kind, PredType(..), UsageAnn(..), ClassContext,
-                         getTyVar_maybe, splitSigmaTy, unUsgTy, boxedTypeKind
+import Type            ( Type, Kind, PredType(..), ClassContext,
+                         splitSigmaTy, unUsgTy, boxedTypeKind
                        )
 import TypeRep         ( Type(..), TyNote(..) )        -- toHsType sees the representation
-import TyCon           ( isTupleTyCon, tupleTyConBoxity, tyConArity, tyConClass_maybe )
-import PrelInfo         ( mkTupConRdrName )
+import TyCon           ( isTupleTyCon, tupleTyConBoxity, tyConArity )
 import RdrName         ( RdrName )
-import Name            ( toRdrName )
+import Name            ( Name, getName )
 import OccName         ( NameSpace )
 import Var             ( TyVar, tyVarKind )
 import PprType         ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes      ( Arity, Boxity(..), tupleParens )
-import Unique          ( hasKey, listTyConKey, Uniquable(..) )
-import Maybes          ( maybeToBool )
+import BasicTypes      ( Boxity(..), tupleParens )
+import PrelNames       ( mkTupConRdrName, listTyConKey, hasKey )
 import FiniteMap
 import Outputable
+
 \end{code}
 
 This is the syntax for types as seen in type signatures.
@@ -57,7 +56,7 @@ data HsType name
                (HsContext name)
                (HsType name)
 
-  | HsTyVar            name            -- Type variable
+  | HsTyVar            name            -- Type variable or type constructor
 
   | HsAppTy            (HsType name)
                        (HsType name)
@@ -69,7 +68,9 @@ data HsType name
 
   | HsTupleTy          (HsTupCon name)
                        [HsType name]   -- Element types (length gives arity)
-
+  -- Generics
+  | HsOpTy             (HsType name) name (HsType name)
+  | HsNumTy             Integer
   -- these next two are only used in interfaces
   | HsPredTy           (HsPred name)
 
@@ -254,6 +255,9 @@ ppr_mono_ty ctxt_prec (HsUsgTy u ty)
               HsUsOnce   -> ptext SLIT("-")
               HsUsMany   -> ptext SLIT("!")
               HsUsVar uv -> ppr uv
+-- Generics
+ppr_mono_ty ctxt_prec (HsNumTy n) = integer  n
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2
 \end{code}
 
 
@@ -268,37 +272,34 @@ user-friendly as possible.  Notably, it uses synonyms where possible, and
 expresses overloaded functions using the '=>' context part of a HsForAllTy.
 
 \begin{code}
-toHsTyVar :: TyVar -> HsTyVarBndr RdrName
-toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv)
+toHsTyVar :: TyVar -> HsTyVarBndr Name
+toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv)
 
 toHsTyVars tvs = map toHsTyVar tvs
 
-toHsType :: Type -> HsType RdrName
+toHsType :: Type -> HsType Name
 toHsType ty = toHsType' (unUsgTy ty)
        -- For now we just discard the usage
---  = case splitUsgTy ty of
---     (usg, tau) -> HsUsgTy (toHsUsg usg) (toHsType' tau)
        
-toHsType' :: Type -> HsType RdrName
+toHsType' :: Type -> HsType Name
 -- Called after the usage is stripped off
 -- This function knows the representation of types
-toHsType' (TyVarTy tv)    = HsTyVar (toRdrName tv)
+toHsType' (TyVarTy tv)    = HsTyVar (getName tv)
 toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
 toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) 
 
 toHsType' (NoteTy (SynNote ty) _) = toHsType ty                -- Use synonyms if possible!!
 toHsType' (NoteTy _ ty)                  = toHsType ty
 
+toHsType' (PredTy p)             = HsPredTy (toHsPred p)
+
 toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
   | not saturated           = generic_case
-  | isTupleTyCon tc         = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys'
+  | isTupleTyCon tc         = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys'
   | tc `hasKey` listTyConKey = HsListTy (head tys')
-  | maybeToBool maybe_class  = HsPredTy (HsPClass (toRdrName clas) tys')
   | otherwise               = generic_case
   where
-     generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys'
-     maybe_class  = tyConClass_maybe tc
-     Just clas    = maybe_class
+     generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
      tys'         = map toHsType tys
      saturated    = length tys == tyConArity tc
 
@@ -308,18 +309,14 @@ toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of
                                                                (toHsType tau)
 
 
-toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys)
-toHsPred (IParam n ty)  = HsPIParam (toRdrName n)  (toHsType ty)
+toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys)
+toHsPred (IParam n ty)  = HsPIParam (getName n)  (toHsType ty)
 
-toHsContext :: ClassContext -> HsContext RdrName
-toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt]
+toHsContext :: ClassContext -> HsContext Name
+toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt]
 
-toHsUsg UsOnce    = HsUsOnce
-toHsUsg UsMany    = HsUsMany
-toHsUsg (UsVar v) = HsUsVar (toRdrName v)
-
-toHsFDs :: [FunDep TyVar] -> [FunDep RdrName]
-toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds]
+toHsFDs :: [FunDep TyVar] -> [FunDep Name]
+toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
 \end{code}
 
 
@@ -413,6 +410,9 @@ eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2)
 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_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2)
   = eqUsg u1 u2 && eq_hsType env ty1 ty2