[project @ 2001-12-06 10:45:42 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 04a6192..b8aa290 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -12,6 +12,10 @@ module HsTypes (
 
        , mkHsForAllTy, mkHsDictTy, mkHsIParamTy
        , hsTyVarName, hsTyVarNames, replaceTyVarName
+       , getHsInstHead
+       
+       -- Type place holder
+       , PostTcType, placeHolderType,
 
        -- Printing
        , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
@@ -27,7 +31,7 @@ module HsTypes (
 #include "HsVersions.h"
 
 import Class           ( FunDep )
-import TcType          ( Type, Kind, ThetaType, SourceType(..), PredType, 
+import TcType          ( Type, Kind, ThetaType, SourceType(..), 
                          tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType
                        )
 import TypeRep         ( Type(..), TyNote(..) )        -- toHsType sees the representation
@@ -36,24 +40,48 @@ import RdrName              ( RdrName, mkUnqual )
 import Name            ( Name, getName )
 import OccName         ( NameSpace, tvName )
 import Var             ( TyVar, tyVarKind )
-import Subst           ( mkTyVarSubst, substTy )
+import Subst           ( substTyWith )
 import PprType         ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes      ( Boxity(..), Arity, tupleParens )
+import BasicTypes      ( Boxity(..), Arity, IPName, tupleParens )
 import PrelNames       ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
                          usOnceTyConName, usManyTyConName
                        )
 import FiniteMap
+import Util            ( eqListBy, lengthIs )
 import Outputable
+\end{code}
 
+
+%************************************************************************
+%*                                                                     *
+\subsection{Annotating the syntax}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+type PostTcType = Type         -- Used for slots in the abstract syntax
+                               -- where we want to keep slot for a type
+                               -- to be added by the type checker...but
+                               -- before typechecking it's just bogus
+
+placeHolderType :: PostTcType  -- Used before typechecking
+placeHolderType  = panic "Evaluated the place holder for a PostTcType"
 \end{code}
 
+
+%************************************************************************
+%*                                                                     *
+\subsection{Data types}
+%*                                                                     *
+%************************************************************************
+
 This is the syntax for types as seen in type signatures.
 
 \begin{code}
 type HsContext name = [HsPred name]
 
 data HsPred name = HsClassP name [HsType name]
-                | HsIParam name (HsType name)
+                | HsIParam (IPName name) (HsType name)
 
 data HsType name
   = HsForAllTy (Maybe [HsTyVarBndr name])      -- Nothing for implicitly quantified signatures
@@ -75,6 +103,7 @@ data HsType name
   -- Generics
   | HsOpTy             (HsType name) name (HsType name)
   | HsNumTy             Integer
+
   -- these next two are only used in interfaces
   | HsPredTy           (HsPred name)
   
@@ -144,6 +173,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
 \end{code}
 
 
+\begin{code}
+getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name]))
+       -- Split up an instance decl type, returning the 'head' part
+
+-- In interface fiels, the type of the decl is held like this:
+--     forall a. Foo a -> Baz (T a)
+-- so we have to strip off function argument types,
+-- as well as the bit before the '=>' (which is always 
+-- empty in interface files)
+--
+-- The parser ensures the type will have the right shape.
+-- (e.g. see ParseUtil.checkInstType)
+
+getHsInstHead  (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau)
+getHsInstHead  tau                          = ([],  get_head1 tau)
+
+get_head1 (HsFunTy _ ty)               = get_head1 ty
+get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
+\end{code}
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{Pretty printing}
@@ -163,7 +213,7 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where
 
 instance Outputable name => Outputable (HsPred name) where
     ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
-    ppr (HsIParam n ty)    = hsep [char '?' <> ppr n, text "::", ppr ty]
+    ppr (HsIParam n ty)    = hsep [ppr n, dcolon, ppr ty]
 
 pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
 pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
@@ -285,7 +335,7 @@ toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty)
   where
     syn_matches      = ty_from_syn `tcEqType` real_ty
     (tyvars,syn_ty)  = getSynTyConDefn tycon
-    ty_from_syn      = substTy (mkTyVarSubst tyvars tyargs) syn_ty
+    ty_from_syn      = substTyWith tyvars tyargs syn_ty
 
     -- We only use the type synonym in the file if this doesn't cause
     -- us to lose important information.  This matters for usage
@@ -313,7 +363,7 @@ toHsType ty@(TyConApp tc tys)       -- Must be saturated because toHsType's arg is of
   where
      generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
      tys'         = map toHsType tys
-     saturated    = length tys == tyConArity tc
+     saturated    = tys `lengthIs` tyConArity tc
 
 toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of
                                (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
@@ -325,7 +375,7 @@ toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty)
 
 
 toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
-toHsPred (IParam n ty)   = HsIParam (getName n)  (toHsType ty)
+toHsPred (IParam n ty)    = HsIParam n            (toHsType ty)
 
 toHsContext :: ThetaType -> HsContext Name
 toHsContext theta = map toHsPred theta
@@ -443,10 +493,4 @@ eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2)
 eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2)
   = n1 == n2 && eq_hsType env ty1 ty2
 eq_hsPred env _ _ = False
-
--------------------
-eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
-eqListBy eq []     []     = True
-eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
-eqListBy eq xs     ys     = False
 \end{code}