X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=ce68cefce86f4518982966b8fb7f09a8771ccf6e;hb=be33dbc967b4915cfdb0307ae1b7ae3cee651b8c;hp=b4356c7e819bbf8894d070a275670d26f32456ca;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index b4356c7..ce68cef 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -7,53 +7,103 @@ Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
 @InstDecl@, @DefaultDecl@.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsDecls where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
 -- friends:
-IMPORT_DELOOPER(HsLoop)		( nullMonoBinds, MonoBinds, Sig )
-import HsPragmas	( DataPragmas, ClassPragmas,
-			  InstancePragmas, ClassOpPragmas
-			)
+import HsBinds		( HsBinds, MonoBinds, Sig, nullMonoBinds )
+import HsPragmas	( DataPragmas, ClassPragmas )
 import HsTypes
+import HsCore		( UfExpr )
+import BasicTypes	( Fixity, NewOrData(..) )
+import IdInfo		( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo )
+import Demand		( Demand )
 
 -- others:
-import Name		( pprSym, pprNonSym )
-import Outputable	( interppSP, interpp'SP,
-			  Outputable(..){-instance * []-}
-			)
-import Pretty
+import Name		( getOccName, OccName, NamedThing(..) )
+import Outputable	
 import SrcLoc		( SrcLoc )
-import Util		( panic#{-ToDo:rm eventually-} )
+import Util
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection[FixityDecl]{A fixity declaration}
+\subsection[HsDecl]{Declarations}
 %*									*
 %************************************************************************
 
 \begin{code}
-data FixityDecl name
-  = InfixL	name Int
-  | InfixR	name Int
-  | InfixN	name Int
+data HsDecl flexi name pat
+  = TyD		(TyDecl name)
+  | ClD		(ClassDecl flexi name pat)
+  | InstD	(InstDecl  flexi name pat)
+  | DefD	(DefaultDecl name)
+  | ValD	(HsBinds flexi name pat)
+  | SigD	(IfaceSig name)
 \end{code}
 
 \begin{code}
-instance (NamedThing name, Outputable name)
-     => Outputable (FixityDecl name) where
-    ppr sty (InfixL var prec)	= print_it sty "l" prec var
-    ppr sty (InfixR var prec)	= print_it sty "r" prec var
-    ppr sty (InfixN var prec)	= print_it sty ""  prec var
+#ifdef DEBUG
+hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
+	   => HsDecl flexi name pat -> name
+#endif
+hsDeclName (TyD (TyData _ _ name _ _ _ _ _))  	  = name
+hsDeclName (TyD (TySynonym name _ _ _))       	  = name
+hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name
+hsDeclName (SigD (IfaceSig name _ _ _))	      	  = name
+hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
+-- Others don't make sense
+#ifdef DEBUG
+hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr x)
+#endif
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat)
+	=> Outputable (HsDecl flexi name pat) where
+
+    ppr (TyD td)     = ppr td
+    ppr (ClD cd)     = ppr cd
+    ppr (SigD sig)   = ppr sig
+    ppr (ValD binds) = ppr binds
+    ppr (DefD def)   = ppr def
+    ppr (InstD inst) = ppr inst
+
+#ifdef DEBUG
+-- hsDeclName needs more context when DEBUG is on
+instance (NamedThing name, Outputable name, Outputable pat, Eq name)
+      => Eq (HsDecl flex name pat) where
+   d1 == d2 = hsDeclName d1 == hsDeclName d2
+	
+instance (NamedThing name, Outputable name, Outputable pat, Ord name)
+      => Ord (HsDecl flex name pat) where
+	d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
+#else
+instance (Eq name) => Eq (HsDecl flex name pat) where
+	d1 == d2 = hsDeclName d1 == hsDeclName d2
+	
+instance (Ord name) => Ord (HsDecl flexi name pat) where
+	d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
+#endif
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[FixityDecl]{A fixity declaration}
+%*									*
+%************************************************************************
 
-print_it sty suff prec var
-  = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var]
+\begin{code}
+data FixityDecl name  = FixityDecl name Fixity SrcLoc
+
+instance Outputable name => Outputable (FixityDecl name) where
+  ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name]
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
@@ -62,9 +112,10 @@ print_it sty suff prec var
 
 \begin{code}
 data TyDecl name
-  = TyData	(Context name)	-- context
+  = TyData	NewOrData
+		(Context name)	-- context
 		name		-- type constructor
-		[name]		-- type variables
+		[HsTyVar name]	-- type variables
 		[ConDecl name]	-- data constructors (empty if abstract)
 		(Maybe [name])	-- derivings; Nothing => not specified
 				-- (i.e., derive default); Just [] => derive
@@ -73,17 +124,9 @@ data TyDecl name
 		(DataPragmas name)
 		SrcLoc
 
-  | TyNew	(Context name)	-- context
-		name		-- type constructor
-		[name]		-- type variables
-		[ConDecl name]	-- data constructor (empty if abstract)
-		(Maybe [name])	-- derivings; as above
-		(DataPragmas name)
-		SrcLoc
-
   | TySynonym	name		-- type constructor
-		[name]		-- type variables
-		(MonoType name)	-- synonym expansion
+		[HsTyVar name]	-- type variables
+		(HsType name)	-- synonym expansion
 		SrcLoc
 
 \end{code}
@@ -92,37 +135,39 @@ data TyDecl name
 instance (NamedThing name, Outputable name)
 	      => Outputable (TyDecl name) where
 
-    ppr sty (TySynonym tycon tyvars mono_ty src_loc)
-      = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
-	     4 (ppCat [ppEquals, ppr sty mono_ty])
-
-    ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
-      = pp_tydecl sty
-		  (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars)
-		  (pp_condecls sty condecls)
-		  derivings
+    ppr (TySynonym tycon tyvars mono_ty src_loc)
+      = hang (pp_decl_head SLIT("type") empty tycon tyvars)
+	     4 (ppr mono_ty)
 
-    ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
-      = pp_tydecl sty
-		  (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars)
-		  (pp_condecls sty condecl)
+    ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
+      = pp_tydecl
+		  (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars)
+		  (pp_condecls condecls)
 		  derivings
+      where
+	keyword = case new_or_data of
+			NewType  -> SLIT("newtype")
+			DataType -> SLIT("data")
 
-pp_decl_head sty str pp_context tycon tyvars
-  = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
+pp_decl_head str pp_context tycon tyvars
+  = hsep [ptext str, pp_context, ppr tycon,
+	   interppSP tyvars, ptext SLIT("=")]
 
-pp_condecls sty [] = ppNil -- abstract datatype
-pp_condecls sty (c:cs)
-  = ppSep (ppBeside (ppStr "= ") (ppr sty c)
-	   : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs)
+pp_condecls [] = empty		-- Curious!
+pp_condecls (c:cs)
+  = sep (ppr c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr c)) cs)
 
-pp_tydecl sty pp_head pp_decl_rhs derivings
-  = ppHang pp_head 4 (ppSep [
+pp_tydecl pp_head pp_decl_rhs derivings
+  = hang pp_head 4 (sep [
 	pp_decl_rhs,
 	case derivings of
-	  Nothing -> ppNil
-	  Just ds -> ppBeside (ppPStr SLIT("deriving "))
-			(ppParens (ppInterleave ppComma (map (ppr sty) ds)))])
+	  Nothing 	   -> empty
+	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
+    ])
+
+pp_context_and_arrow :: Outputable name => Context name -> SDoc
+pp_context_and_arrow [] = empty
+pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
 \end{code}
 
 A type for recording what types a datatype should be specialised to.
@@ -132,14 +177,14 @@ for an datatype declaration.
 \begin{code}
 data SpecDataSig name
   = SpecDataSig name		-- tycon to specialise
-		(MonoType name)
+		(HsType name)
 		SrcLoc
 
 instance (NamedThing name, Outputable name)
 	      => Outputable (SpecDataSig name) where
 
-    ppr sty (SpecDataSig tycon ty _)
-      = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
+    ppr (SpecDataSig tycon ty _)
+      = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
 \end{code}
 
 %************************************************************************
@@ -150,45 +195,53 @@ instance (NamedThing name, Outputable name)
 
 \begin{code}
 data ConDecl name
-  = ConDecl	name		-- prefix-style con decl
-		[BangType name]
+  = ConDecl 	name			-- Constructor name
+		(Context name)		-- Existential context for this constructor
+		(ConDetails name)
 		SrcLoc
 
-  | ConOpDecl	(BangType name)	-- infix-style con decl
-		name
+data ConDetails name
+  = VanillaCon			-- prefix-style con decl
+		[BangType name]
+
+  | InfixCon			-- infix-style con decl
+		(BangType name)
 		(BangType name)
-		SrcLoc
 
-  | RecConDecl	name
+  | RecCon			-- record-style con decl
 		[([name], BangType name)]	-- list of "fields"
-		SrcLoc
 
-  | NewConDecl  name		-- newtype con decl
-		(MonoType name)
-		SrcLoc
+  | NewCon	 		-- newtype con decl
+		(HsType name)
 
 data BangType name
-  = Banged   (PolyType name)	-- PolyType: to allow Haskell extensions
-  | Unbanged (PolyType name)	-- (MonoType only needed for straight Haskell)
+  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
+  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
 \end{code}
 
 \begin{code}
 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
+    ppr (ConDecl con cxt con_details  loc)
+      = pp_context_and_arrow cxt <+> ppr_con_details con con_details
 
-    ppr sty (ConDecl con tys _)
-      = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
-    ppr sty (ConOpDecl ty1 op ty2 _)
-      = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2]
-    ppr sty (NewConDecl con ty _)
-      = ppCat [pprNonSym sty con, pprParendMonoType sty ty]
-    ppr sty (RecConDecl con fields _)
-      = ppCat [pprNonSym sty con, ppChar '{',
-	       ppInterleave pp'SP (map pp_field fields), ppChar '}']
-      where
-	pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
+ppr_con_details con (InfixCon ty1 ty2)
+  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
+
+ppr_con_details con (VanillaCon tys)
+  = ppr con <+> hsep (map (ppr_bang) tys)
+
+ppr_con_details con (NewCon ty)
+  = ppr con <+> pprParendHsType ty
+
+ppr_con_details con (RecCon fields)
+  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
+  where
+    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
+			 ptext SLIT("::") <+>
+			 ppr_bang ty
 
-ppr_bang sty (Banged   ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
-ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
+ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
+ppr_bang (Unbanged ty) = pprParendHsType ty
 \end{code}
 
 %************************************************************************
@@ -198,33 +251,35 @@ ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
 %************************************************************************
 
 \begin{code}
-data ClassDecl tyvar uvar name pat
+data ClassDecl flexi name pat
   = ClassDecl	(Context name)	    		-- context...
 		name		    		-- name of the class
-		name		    		-- the class type variable
+		[HsTyVar name]	    		-- the class type variables
 		[Sig name]			-- methods' signatures
-		(MonoBinds tyvar uvar name pat)	-- default methods
+		(MonoBinds flexi name pat)	-- default methods
 		(ClassPragmas name)
+		name name			-- The names of the tycon and datacon for this class
+						-- These are filled in by the renamer
 		SrcLoc
 \end{code}
 
 \begin{code}
-instance (NamedThing name, Outputable name, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
-		=> Outputable (ClassDecl tyvar uvar name pat) where
-
-    ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
-     = let 
-           top_matter = ppCat [ppStr "class", pprContext sty context,
-                               ppr sty clas, ppr sty tyvar]
-       in
-       if null sigs && nullMonoBinds methods then
-	   ppAbove top_matter (ppNest 4 (ppr sty pragmas))
-       else
-	   ppAboves [ppCat [top_matter, ppStr "where"],
-		     ppNest 4 (ppAboves (map (ppr sty) sigs)),
-		     ppNest 4 (ppr sty methods),
-		     ppNest 4 (ppr sty pragmas) ]
+instance (NamedThing name, Outputable name, Outputable pat)
+		=> Outputable (ClassDecl flexi name pat) where
+
+    ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
+      | null sigs	-- No "where" part
+      = top_matter
+
+      | otherwise	-- Laid out
+      = sep [hsep [top_matter, ptext SLIT("where {")],
+	       nest 4 (vcat [sep (map ppr_sig sigs),
+				   ppr methods,
+				   char '}'])]
+      where
+        top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context,
+                            ppr clas, hsep (map (ppr) tyvars)]
+	ppr_sig sig = ppr sig <> semi
 \end{code}
 
 %************************************************************************
@@ -234,49 +289,32 @@ instance (NamedThing name, Outputable name, Outputable pat,
 %************************************************************************
 
 \begin{code}
-data InstDecl tyvar uvar name pat
-  = InstDecl	name		-- Class
-
-		(PolyType name)	-- Context => Instance-type
+data InstDecl flexi name pat
+  = InstDecl	(HsType name)	-- Context => Class Instance-type
 				-- Using a polytype means that the renamer conveniently
 				-- figures out the quantified type variables for us.
 
-		(MonoBinds tyvar uvar name pat)
+		(MonoBinds flexi name pat)
 
-		Bool		-- True <=> This instance decl is from the
-				-- module being compiled; False <=> It is from
-				-- an imported interface.
+		[Sig name]		-- User-supplied pragmatic info
 
-		(Maybe Module)	-- The name of the module where the instance decl
-				-- originally came from; Nothing => Prelude
+		(Maybe name)		-- Name for the dictionary function
 
-		[Sig name]		-- actually user-supplied pragmatic info
-		(InstancePragmas name)	-- interface-supplied pragmatic info
 		SrcLoc
 \end{code}
 
 \begin{code}
-instance (NamedThing name, Outputable name, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
-	      => Outputable (InstDecl tyvar uvar name pat) where
-
-    ppr sty (InstDecl clas ty binds local modname uprags pragmas src_loc)
-      = let
-	    (context, inst_ty)
-	      = case ty of
-		  HsPreForAllTy c t -> (c, t)
-		  HsForAllTy  _ c t -> (c, t)
-
-	    top_matter = ppCat [ppStr "instance", pprContext sty context,
-			        ppr sty clas, pprParendMonoType sty inst_ty]
-	in
-	if nullMonoBinds binds && null uprags then
-	    ppAbove top_matter (ppNest 4 (ppr sty pragmas))
+instance (NamedThing name, Outputable name, Outputable pat)
+	      => Outputable (InstDecl flexi name pat) where
+
+    ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
+      = getPprStyle $ \ sty ->
+        if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
+           hsep [ptext SLIT("instance"), ppr inst_ty]
 	else
-	    ppAboves [ppCat [top_matter, ppStr "where"],
-	              if null uprags then ppNil else ppNest 4 (ppr sty uprags),
-	              ppNest 4 (ppr sty binds),
-	              ppNest 4 (ppr sty pragmas) ]
+	   vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
+	         nest 4 (ppr uprags),
+	         nest 4 (ppr binds) ]
 \end{code}
 
 A type for recording what instances the user wants to specialise;
@@ -285,14 +323,14 @@ instance.
 \begin{code}
 data SpecInstSig name
   = SpecInstSig  name		    -- class
-		 (MonoType name)    -- type to specialise to
+		 (HsType name)    -- type to specialise to
 		 SrcLoc
 
 instance (NamedThing name, Outputable name)
 	      => Outputable (SpecInstSig name) where
 
-    ppr sty (SpecInstSig clas ty _)
-      = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
+    ppr (SpecInstSig clas ty _)
+      = hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"]
 \end{code}
 
 %************************************************************************
@@ -307,12 +345,46 @@ syntax, and that restriction must be checked in the front end.
 
 \begin{code}
 data DefaultDecl name
-  = DefaultDecl	[MonoType name]
+  = DefaultDecl	[HsType name]
 		SrcLoc
 
 instance (NamedThing name, Outputable name)
 	      => Outputable (DefaultDecl name) where
 
-    ppr sty (DefaultDecl tys src_loc)
-      = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
+    ppr (DefaultDecl tys src_loc)
+      = ptext SLIT("default") <+> parens (interpp'SP tys)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Signatures in interface files}
+%*									*
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+  = IfaceSig	name
+		(HsType name)
+		[HsIdInfo name]
+		SrcLoc
+
+instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
+    ppr (IfaceSig var ty _ _)
+      = hang (hsep [ppr var, ptext SLIT("::")])
+	     4 (ppr ty)
+
+data HsIdInfo name
+  = HsArity		ArityInfo
+  | HsStrictness	(HsStrictnessInfo name)
+  | HsUnfold		Bool (UfExpr name)	-- True <=> INLINE pragma
+  | HsUpdate		UpdateInfo
+  | HsArgUsage		ArgUsageInfo
+  | HsFBType		FBTypeInfo
+	-- ToDo: specialisations
+
+data HsStrictnessInfo name
+  = HsStrictnessInfo [Demand] 
+		     (Maybe (name, [name]))	-- Worker, if any
+						-- and needed constructors
+  | HsBottom
 \end{code}