X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPragmas.lhs;h=26075b3c0cfb5795237373ae4b96d773b58257af;hb=e8e9742681b0ef189f4c18ec36cd47be26327755;hp=876ba1d234eab5c5e813c80c5e3c06c71d852f91;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs
index 876ba1d..26075b3 100644
--- a/ghc/compiler/hsSyn/HsPragmas.lhs
+++ b/ghc/compiler/hsSyn/HsPragmas.lhs
@@ -19,15 +19,57 @@ module HsPragmas where
 IMP_Ubiq()
 
 -- friends:
-import HsCore		( UnfoldingCoreExpr )
-import HsTypes		( MonoType )
+import HsTypes		( HsType )
 
 -- others:
 import IdInfo
+import SpecEnv		( SpecEnv )
 import Outputable	( Outputable(..) )
 import Pretty
 \end{code}
 
+All the pragma stuff has changed.  Here are some placeholders!
+
+\begin{code}
+data GenPragmas name  = NoGenPragmas
+data DataPragmas name = NoDataPragmas
+data InstancePragmas name = NoInstancePragmas
+data ClassOpPragmas name  = NoClassOpPragmas
+data ClassPragmas name  = NoClassPragmas
+
+noClassPragmas = NoClassPragmas
+isNoClassPragmas NoClassPragmas = True
+
+noDataPragmas = NoDataPragmas
+isNoDataPragmas NoDataPragmas = True
+
+noGenPragmas = NoGenPragmas
+isNoGenPragmas NoGenPragmas = True
+
+noInstancePragmas = NoInstancePragmas
+isNoInstancePragmas NoInstancePragmas = True
+
+noClassOpPragmas = NoClassOpPragmas
+isNoClassOpPragmas NoClassOpPragmas = True
+
+instance Outputable name => Outputable (ClassPragmas name) where
+    ppr sty NoClassPragmas = empty
+
+instance Outputable name => Outputable (ClassOpPragmas name) where
+    ppr sty NoClassOpPragmas = empty
+
+instance Outputable name => Outputable (InstancePragmas name) where
+    ppr sty NoInstancePragmas = empty
+
+instance Outputable name => Outputable (GenPragmas name) where
+    ppr sty NoGenPragmas = empty
+\end{code}
+
+========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ==============
+
+\begin{code}
+{-		COMMENTED OUT 
+
 Certain pragmas expect to be pinned onto certain constructs.
 
 Pragma types may be parameterised, just as with any other
@@ -37,12 +79,10 @@ For a @data@ declaration---indicates which specialisations exist.
 \begin{code}
 data DataPragmas name
   = NoDataPragmas
-  | DataPragmas	[[Maybe (MonoType name)]]  -- types to which specialised
+  | DataPragmas	[[Maybe (HsType name)]]  -- types to which specialised
 
 noDataPragmas = NoDataPragmas
-
 isNoDataPragmas NoDataPragmas = True
-isNoDataPragmas _             = False
 \end{code}
 
 These are {\em general} things you can know about any value:
@@ -54,7 +94,7 @@ data GenPragmas name
 		DeforestInfo		-- deforest info
 		(ImpStrictness name)	-- strictness, worker-wrapper
 		(ImpUnfolding name)	-- unfolding (maybe)
-		[([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
+		[([Maybe (HsType name)], -- Specialisations: types to which spec'd;
 		  Int,			   -- # dicts to ignore
 		  GenPragmas name)] 	   -- Gen info about the spec'd version
 
@@ -118,7 +158,7 @@ data InstancePragmas name
 
   | SpecialisedInstancePragma
 	(GenPragmas name)	   -- for its "dfun"
-	[([Maybe (MonoType name)], -- specialised instance; type...
+	[([Maybe (HsType name)], -- specialised instance; type...
 	  Int,			   -- #dicts to ignore
 	  InstancePragmas name)]   -- (no SpecialisedInstancePragma please!)
 
@@ -131,68 +171,73 @@ isNoInstancePragmas _                 = False
 Some instances for printing (just for debugging, really)
 \begin{code}
 instance Outputable name => Outputable (ClassPragmas name) where
-    ppr sty NoClassPragmas = ppNil
+    ppr sty NoClassPragmas = empty
     ppr sty (SuperDictPragmas sdsel_prags)
-      = ppAbove (ppStr "{-superdict pragmas-}")
+      = ($$) (ptext SLIT("{-superdict pragmas-}"))
 		(ppr sty sdsel_prags)
 
 instance Outputable name => Outputable (ClassOpPragmas name) where
-    ppr sty NoClassOpPragmas = ppNil
+    ppr sty NoClassOpPragmas = empty
     ppr sty (ClassOpPragmas op_prags defm_prags)
-      = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags])
-		(ppCat [ppStr "{-defm-}", ppr sty defm_prags])
+      = ($$) (hsep [ptext SLIT("{-meth-}"), ppr sty op_prags])
+		(hsep [ptext SLIT("{-defm-}"), ppr sty defm_prags])
 
 instance Outputable name => Outputable (InstancePragmas name) where
-    ppr sty NoInstancePragmas = ppNil
+    ppr sty NoInstancePragmas = empty
     ppr sty (SimpleInstancePragma dfun_pragmas)
-      = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas]
+      = hsep [ptext SLIT("{-dfun-}"), ppr sty dfun_pragmas]
     ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
-      = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas])
-	    	(ppAboves (map pp_pair name_pragma_pairs))
+      = ($$) (hsep [ptext SLIT("{-constm-}"), ppr sty dfun_pragmas])
+	    	(vcat (map pp_pair name_pragma_pairs))
       where
 	pp_pair (n, prags)
-	  = ppCat [ppr sty n, ppEquals, ppr sty prags]
+	  = hsep [ppr sty n, equals, ppr sty prags]
 
     ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
-      = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas])
-	    	(ppAboves (map pp_info spec_pragma_info))
+      = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr sty dfun_pragmas])
+	    	(vcat (map pp_info spec_pragma_info))
       where
 	pp_info (ty_maybes, num_dicts, prags)
-	  = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
-		       ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
-	pp_ty Nothing = ppStr "_N_"
+	  = hcat [brackets (hsep (map pp_ty ty_maybes)),
+		       parens (int num_dicts), equals, ppr sty prags]
+	pp_ty Nothing = ptext SLIT("_N_")
 	pp_ty (Just t)= ppr sty t
 
 instance Outputable name => Outputable (GenPragmas name) where
-    ppr sty NoGenPragmas = ppNil
+    ppr sty NoGenPragmas = empty
     ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
-      = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
+      = hsep [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
 	       pp_str strictness, pp_unf unfolding,
 	       pp_specs specs]
       where
-    	pp_arity Nothing  = ppNil
-	pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
+    	pp_arity Nothing  = empty
+	pp_arity (Just i) = (<>) (ptext SLIT("ARITY=")) (int i)
 
-	pp_upd Nothing  = ppNil
-	pp_upd (Just u) = ppInfo sty id u
+	pp_upd Nothing  = empty
+	pp_upd (Just u) = ppUpdateInfo sty u
 
-	pp_str NoImpStrictness = ppNil
+	pp_str NoImpStrictness = empty
 	pp_str (ImpStrictness is_bot demands wrkr_prags)
-	  = ppBesides [ppStr "IS_BOT=", ppr sty is_bot,
-		       ppStr "STRICTNESS=", ppStr (showList demands ""),
-		       ppStr " {", ppr sty wrkr_prags, ppStr "}"]
+	  = hcat [ptext SLIT("IS_BOT="), ppr sty is_bot,
+		       ptext SLIT("STRICTNESS="), text (showList demands ""),
+		       ptext SLIT(" {"), ppr sty wrkr_prags, char '}']
 
-	pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING"
-	pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m)
-	pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core)
+	pp_unf NoImpUnfolding = ptext SLIT("NO_UNFOLDING")
+	pp_unf (ImpMagicUnfolding m) = (<>) (ptext SLIT("MAGIC=")) (ptext m)
+	pp_unf (ImpUnfolding g core) = (<>) (ptext SLIT("UNFOLD=")) (ppr sty core)
 
-	pp_specs [] = ppNil
+	pp_specs [] = empty
 	pp_specs specs
-	  = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"]
+	  = hcat [ptext SLIT("SPECS=["), hsep (map pp_spec specs), char ']']
 	  where
 	    pp_spec (ty_maybes, num_dicts, gprags)
-	      = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
+	      = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr sty gprags]
 
-	    pp_MaB Nothing  = ppStr "_N_"
+	    pp_MaB Nothing  = ptext SLIT("_N_")
 	    pp_MaB (Just x) = ppr sty x
 \end{code}
+
+
+\begin{code}
+-}
+\end{code}