path: root/ghc/compiler/abstractSyn/HsDecls.lhs

%
% (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}