1 files changed, 299 insertions, 0 deletions
diff --git a/ghc/compiler/abstractSyn/HsDecls.lhs b/ghc/compiler/abstractSyn/HsDecls.lhs
new file mode 100644
index 0000000000..806377563a
--- /dev/null
+++ b/ghc/compiler/abstractSyn/HsDecls.lhs
@@ -0,0 +1,299 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[HsDecls]{Abstract syntax: global declarations}
+
+Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
+@InstDecl@, @DefaultDecl@.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsDecls where
+
+import HsBinds		( nullMonoBinds, ProtoNameMonoBinds(..),
+			  MonoBinds, Sig
+			)
+import HsPat		( ProtoNamePat(..), RenamedPat(..), InPat )
+import HsPragmas	( DataPragmas, TypePragmas, ClassPragmas,
+			  InstancePragmas, ClassOpPragmas
+			)
+import HsTypes
+import Id		( Id )
+import Name		( Name )
+import Outputable
+import Pretty
+import ProtoName	( cmpProtoName, ProtoName(..) ) -- .. for pragmas only
+import SrcLoc		( SrcLoc )
+import Unique		( Unique )
+import Util
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[FixityDecl]{A fixity declaration}
+%*									*
+%************************************************************************
+
+These are only used in generating interfaces at the moment.  They are
+not used in pretty-printing.
+
+\begin{code}
+data FixityDecl name
+  = InfixL	    name Int
+  | InfixR	    name Int
+  | InfixN	    name Int
+
+type ProtoNameFixityDecl = FixityDecl ProtoName
+type RenamedFixityDecl   = FixityDecl Name
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name)
+     => Outputable (FixityDecl name) where
+    ppr sty (InfixL var prec)	= ppCat [ppStr "infixl", ppInt prec, pprOp sty var]
+    ppr sty (InfixR var prec)	= ppCat [ppStr "infixr", ppInt prec, pprOp sty var]
+    ppr sty (InfixN var prec)	= ppCat [ppStr "infix ", ppInt prec, pprOp sty var]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[TyDecl]{An algebraic datatype or type-synonym declaration (plus @DataTypeSig@...)}
+%*									*
+%************************************************************************
+
+\begin{code}
+data TyDecl name
+  = TyData	(Context name)	-- context (not used yet)
+		name		-- type constructor
+		[name]		-- type variables
+		[ConDecl name]	-- data constructors
+		[name]		-- derivings
+		(DataPragmas name)
+		SrcLoc
+
+  | TySynonym	name		-- type constructor
+		[name]		-- type variables
+		(MonoType name)	-- synonym expansion
+		TypePragmas
+		SrcLoc
+
+type ProtoNameTyDecl = TyDecl ProtoName
+type RenamedTyDecl   = TyDecl Name
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name)
+	      => Outputable (TyDecl name) where
+
+    ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
+     = ppAbove (ifPprShowAll sty (ppr sty src_loc)) -- ToDo: pragmas
+	(ppHang (ppCat [ppStr "data", pprContext sty context, ppr sty tycon, interppSP sty tyvars])
+	       4
+	       (ppSep [
+		ppr sty condecls,
+		if (null derivings) then
+		    ppNil
+		else
+		    ppBesides [ppStr "deriving (", interpp'SP sty derivings, ppStr ")"]]))
+
+    ppr sty (TySynonym tycon tyvars mono_ty pragmas src_loc)
+     = ppHang (ppCat [ppStr "type", ppr sty tycon, interppSP sty tyvars])
+	      4 (ppCat [ppEquals, ppr sty mono_ty,
+			ifPprShowAll sty (ppr sty src_loc)]) -- ToDo: pragmas
+\end{code}
+
+A type for recording what type synonyms the user wants treated as {\em
+abstract} types.  It's called a ``Sig'' because it's sort of like a
+``type signature'' for an synonym declaration.
+
+Note: the Right Way to do this abstraction game is for the language to
+support it.
+\begin{code}
+data DataTypeSig name
+  = AbstractTypeSig name	-- tycon to abstract-ify
+		    SrcLoc
+  | SpecDataSig name		-- tycon to specialise
+		(MonoType name)
+		SrcLoc
+		
+
+type ProtoNameDataTypeSig = DataTypeSig ProtoName
+type RenamedDataTypeSig   = DataTypeSig Name
+
+instance (NamedThing name, Outputable name)
+	      => Outputable (DataTypeSig name) where
+
+    ppr sty (AbstractTypeSig tycon _)
+      = ppCat [ppStr "{-# ABSTRACT", ppr sty tycon, ppStr "#-}"]
+
+    ppr sty (SpecDataSig tycon ty _)
+      = ppCat [ppStr "{-# SPECIALSIE data", ppr sty ty, ppStr "#-}"]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ConDecl]{A data-constructor declaration}
+%*									*
+%************************************************************************
+
+A data constructor for an algebraic data type.
+
+\begin{code}
+data ConDecl name = ConDecl name [MonoType name] SrcLoc
+
+type ProtoNameConDecl = ConDecl ProtoName
+type RenamedConDecl   = ConDecl Name
+\end{code}
+
+In checking interfaces, we need to ``compare'' @ConDecls@.  Use with care!
+\begin{code}
+eqConDecls cons1 cons2
+  = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False }
+  where
+    cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _)
+      = case cmpProtoName n1 n2 of
+	  EQ_ -> cmpList (cmpMonoType cmpProtoName) tys1 tys2
+	  xxx -> xxx
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
+
+    ppr sty (ConDecl con mono_tys src_loc)
+      = ppCat [pprNonOp sty con,
+	       ppInterleave ppNil (map (pprParendMonoType sty) mono_tys)]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[ClassDecl]{A class declaration}
+%*									*
+%************************************************************************
+
+\begin{code}
+data ClassDecl name pat
+  = ClassDecl	(Context name)	    	-- context...
+		name		    	-- name of the class
+		name		    	-- the class type variable
+		[Sig name]		-- methods' signatures
+		(MonoBinds name pat)	-- default methods
+		(ClassPragmas name)
+		SrcLoc
+
+type ProtoNameClassDecl = ClassDecl ProtoName ProtoNamePat
+type RenamedClassDecl   = ClassDecl Name      RenamedPat
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name,
+	  NamedThing pat, Outputable pat)
+		=> Outputable (ClassDecl name pat) where
+
+    ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
+     = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas,
+			ppr sty tyvar, ppStr "where"],
+			-- ToDo: really shouldn't print "where" unless there are sigs
+		 ppNest 4 (ppAboves (map (ppr sty) sigs)),
+		 ppNest 4 (ppr sty methods),
+		 ppNest 4 (ppr sty pragmas)]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[InstDecl]{An instance declaration (also, @SpecialisedInstanceSig@)}
+%*									*
+%************************************************************************
+
+\begin{code}
+data InstDecl name pat
+  = InstDecl	(Context name)
+		name		     -- class
+		(MonoType name)
+		(MonoBinds name pat)
+		Bool	-- True <=> This instance decl is from the
+			-- module being compiled; False <=> It is from
+			-- an imported interface.
+
+		FAST_STRING{-ModuleName-}
+			-- The module where the instance decl
+			-- originally came from; easy enough if it's
+			-- the module being compiled; otherwise, the
+			-- info comes from a pragma.
+
+		FAST_STRING
+			-- Name of the module who told us about this
+			-- inst decl (the `informer') ToDo: listify???
+
+		[Sig name]		-- actually user-supplied pragmatic info
+		(InstancePragmas name)	-- interface-supplied pragmatic info
+		SrcLoc
+
+type ProtoNameInstDecl = InstDecl ProtoName ProtoNamePat
+type RenamedInstDecl   = InstDecl Name      RenamedPat
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name,
+	  NamedThing pat, Outputable pat)
+	      => Outputable (InstDecl name pat) where
+
+    ppr sty (InstDecl context clas ty binds local modname imod uprags pragmas src_loc)
+      = let
+	    top_matter = ppCat [ppStr "instance", pprContext sty context, ppr sty clas, ppr sty ty]
+	in
+	if nullMonoBinds binds && null uprags then
+	    ppAbove top_matter (ppNest 4 (ppr sty pragmas))
+	else
+	    ppAboves [
+	      ppCat [top_matter, ppStr "where"],
+	      ppNest 4 (ppr sty uprags),
+	      ppNest 4 (ppr sty binds),
+	      ppNest 4 (ppr sty pragmas) ]
+\end{code}
+
+A type for recording what instances the user wants to specialise;
+called a ``Sig'' because it's sort of like a ``type signature'' for an
+instance.
+\begin{code}
+data SpecialisedInstanceSig name
+  = InstSpecSig  name		    -- class
+		 (MonoType name)    -- type to specialise to
+		 SrcLoc
+
+type ProtoNameSpecialisedInstanceSig = SpecialisedInstanceSig ProtoName
+type RenamedSpecialisedInstanceSig   = SpecialisedInstanceSig Name
+
+instance (NamedThing name, Outputable name)
+	      => Outputable (SpecialisedInstanceSig name) where
+
+    ppr sty (InstSpecSig clas ty _)
+      = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[DefaultDecl]{A @default@ declaration}
+%*									*
+%************************************************************************
+
+There can only be one default declaration per module, but it is hard
+for the parser to check that; we pass them all through in the abstract
+syntax, and that restriction must be checked in the front end.
+
+\begin{code}
+data DefaultDecl name
+  = DefaultDecl	[MonoType name]
+		SrcLoc
+
+type ProtoNameDefaultDecl = DefaultDecl ProtoName
+type RenamedDefaultDecl   = DefaultDecl Name
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name)
+	      => Outputable (DefaultDecl name) where
+
+    ppr sty (DefaultDecl tys src_loc)
+      = ppBesides [ppStr "default (", interpp'SP sty tys, ppStr ")"]
+\end{code}