Reorganisation of the source tree

[ghc-hetmet.git] / compiler / types / Class.lhs

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
new file mode 100644 (file)
index 0000000..016ce1b
--- /dev/null
+++ b/compiler/types/Class.lhs
@@ -0,0 +1,164 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Class]{The @Class@ datatype}
+
+\begin{code}
+module Class (
+       Class, ClassOpItem, FunDep,
+       DefMeth (..),
+
+       mkClass, classTyVars, classArity,
+       classKey, className, classSelIds, classTyCon, classMethods,
+       classBigSig, classExtraBigSig, classTvsFds, classSCTheta
+    ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} TyCon    ( TyCon )
+import {-# SOURCE #-} TypeRep  ( PredType )
+
+import Var             ( Id, TyVar )
+import Name            ( NamedThing(..), Name )
+import BasicTypes      ( Arity )
+import Unique          ( Unique, Uniquable(..) )
+import Outputable
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection[Class-basic]{@Class@: basic definition}
+%*                                                                     *
+%************************************************************************
+
+A @Class@ corresponds to a Greek kappa in the static semantics:
+
+\begin{code}
+data Class
+  = Class {
+       classKey  :: Unique,                    -- Key for fast comparison
+       className :: Name,
+       
+       classTyVars  :: [TyVar],                -- The class type variables
+       classFunDeps :: [FunDep TyVar],         -- The functional dependencies
+
+       classSCTheta :: [PredType],             -- Immediate superclasses, and the
+       classSCSels  :: [Id],                   -- corresponding selector functions to
+                                               -- extract them from a dictionary of this
+                                               -- class
+
+       classOpStuff :: [ClassOpItem],          -- Ordered by tag
+
+       classTyCon :: TyCon             -- The data type constructor for dictionaries
+  }                                    -- of this class
+
+type FunDep a    = ([a],[a])   --  e.g. class C a b c |  a b -> c, a c -> b  where ...
+                               --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
+
+type ClassOpItem = (Id, DefMeth)
+       -- Selector function; contains unfolding
+       -- Default-method info
+
+data DefMeth = NoDefMeth               -- No default method
+            | DefMeth                  -- A polymorphic default method
+            | GenDefMeth               -- A generic default method
+             deriving Eq  
+\end{code}
+
+The @mkClass@ function fills in the indirect superclasses.
+
+\begin{code}
+mkClass :: Name -> [TyVar]
+       -> [([TyVar], [TyVar])]
+       -> [PredType] -> [Id]
+       -> [ClassOpItem]
+       -> TyCon
+       -> Class
+
+mkClass name tyvars fds super_classes superdict_sels
+       op_stuff tycon
+  = Class {    classKey = getUnique name, 
+               className = name,
+               classTyVars = tyvars,
+               classFunDeps = fds,
+               classSCTheta = super_classes,
+               classSCSels = superdict_sels,
+               classOpStuff = op_stuff,
+               classTyCon = tycon }
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection[Class-selectors]{@Class@: simple selectors}
+%*                                                                     *
+%************************************************************************
+
+The rest of these functions are just simple selectors.
+
+\begin{code}
+classArity :: Class -> Arity
+classArity clas = length (classTyVars clas)
+       -- Could memoise this
+
+classSelIds :: Class -> [Id]
+classSelIds c@(Class {classSCSels = sc_sels})
+  = sc_sels ++ classMethods c
+
+classMethods :: Class -> [Id]
+classMethods (Class {classOpStuff = op_stuff})
+  = [op_sel | (op_sel, _) <- op_stuff]
+
+classTvsFds c
+  = (classTyVars c, classFunDeps c)
+
+classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, 
+                   classSCSels = sc_sels, classOpStuff = op_stuff})
+  = (tyvars, sc_theta, sc_sels, op_stuff)
+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
+                        classSCTheta = sc_theta, classSCSels = sc_sels,
+                        classOpStuff = op_stuff})
+  = (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection[Class-instances]{Instance declarations for @Class@}
+%*                                                                     *
+%************************************************************************
+
+We compare @Classes@ by their keys (which include @Uniques@).
+
+\begin{code}
+instance Eq Class where
+    c1 == c2 = classKey c1 == classKey c2
+    c1 /= c2 = classKey c1 /= classKey c2
+
+instance Ord Class where
+    c1 <= c2 = classKey c1 <= classKey c2
+    c1 <  c2 = classKey c1 <  classKey c2
+    c1 >= c2 = classKey c1 >= classKey c2
+    c1 >  c2 = classKey c1 >  classKey c2
+    compare c1 c2 = classKey c1 `compare` classKey c2
+\end{code}
+
+\begin{code}
+instance Uniquable Class where
+    getUnique c = classKey c
+
+instance NamedThing Class where
+    getName clas = className clas
+
+instance Outputable Class where
+    ppr c = ppr (getName c)
+
+instance Show Class where
+    showsPrec p c = showsPrecSDoc p (ppr c)
+
+instance Outputable DefMeth where
+    ppr DefMeth     =  text "{- has default method -}"
+    ppr GenDefMeth  =  text "{- has generic method -}"
+    ppr NoDefMeth   =  empty   -- No default method
+\end{code}
+
+