X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsDecls.lhs;h=644050e6b2649734312b968ab7027028476127fb;hp=f559d4b3956d7636d7143e5e906f615524b52699;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hpb=b1f3ff48870a3a4670cb41b890b78bbfffa8a32e

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index f559d4b..644050e 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -47,10 +47,13 @@ module HsDecls (
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
   WarnDecl(..),  LWarnDecl,
+  -- ** Annotations
+  AnnDecl(..), LAnnDecl, 
+  AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
 
   -- * Grouping
-  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
-) where
+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
+    ) where
 
 -- friends:
 import {-# SOURCE #-}	HsExpr( HsExpr, pprExpr )
@@ -72,6 +75,7 @@ import Util
 import SrcLoc
 import FastString
 
+import Control.Monad    ( liftM )
 import Data.Maybe       ( isJust )
 \end{code}
 
@@ -94,6 +98,7 @@ data HsDecl id
   | DefD	(DefaultDecl id)
   | ForD        (ForeignDecl id)
   | WarningD	(WarnDecl id)
+  | AnnD	(AnnDecl id)
   | RuleD	(RuleDecl id)
   | SpliceD	(SpliceDecl id)
   | DocD	(DocDecl id)
@@ -128,6 +133,7 @@ data HsGroup id
 	hs_defds  :: [LDefaultDecl id],
 	hs_fords  :: [LForeignDecl id],
 	hs_warnds :: [LWarnDecl id],
+	hs_annds   :: [LAnnDecl id],
 	hs_ruleds :: [LRuleDecl id],
 
 	hs_docs   :: [LDocDecl id]
@@ -138,8 +144,8 @@ emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
-		       hs_fixds = [], hs_defds = [], hs_fords = [], 
-		       hs_warnds = [], hs_ruleds = [],
+		       hs_fixds = [], hs_defds = [], hs_annds = [],
+		       hs_fords = [], hs_warnds = [], hs_ruleds = [],
 		       hs_valds = error "emptyGroup hs_valds: Can't happen",
                        hs_docs = [] }
 
@@ -152,6 +158,7 @@ appendGroups
         hs_derivds = derivds1,
 	hs_fixds  = fixds1, 
 	hs_defds  = defds1,
+	hs_annds  = annds1,
 	hs_fords  = fords1, 
 	hs_warnds = warnds1,
 	hs_ruleds = rulds1,
@@ -163,6 +170,7 @@ appendGroups
         hs_derivds = derivds2,
 	hs_fixds  = fixds2, 
 	hs_defds  = defds2,
+	hs_annds  = annds2,
 	hs_fords  = fords2, 
 	hs_warnds = warnds2,
 	hs_ruleds = rulds2,
@@ -173,7 +181,8 @@ appendGroups
 	hs_tyclds = tyclds1 ++ tyclds2, 
 	hs_instds = instds1 ++ instds2,
         hs_derivds = derivds1 ++ derivds2,
-	hs_fixds  = fixds1 ++ fixds2, 
+	hs_fixds  = fixds1 ++ fixds2,
+	hs_annds  = annds1 ++ annds2,
 	hs_defds  = defds1 ++ defds2,
 	hs_fords  = fords1 ++ fords2, 
 	hs_warnds = warnds1 ++ warnds2,
@@ -192,6 +201,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (SigD sd)               = ppr sd
     ppr (RuleD rd)              = ppr rd
     ppr (WarningD wd)           = ppr wd
+    ppr (AnnD ad)               = ppr ad
     ppr (SpliceD dd)            = ppr dd
     ppr (DocD doc)              = ppr doc
 
@@ -202,11 +212,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where
                    hs_derivds = deriv_decls,
 		   hs_fixds  = fix_decls,
 		   hs_warnds = deprec_decls,
+		   hs_annds  = ann_decls,
 		   hs_fords  = foreign_decls,
 		   hs_defds  = default_decls,
 		   hs_ruleds = rule_decls })
 	= vcat [ppr_ds fix_decls, ppr_ds default_decls, 
-		ppr_ds deprec_decls, ppr_ds rule_decls,
+		ppr_ds deprec_decls, ppr_ds ann_decls,
+		ppr_ds rule_decls,
 		ppr val_decls,
 		ppr_ds tycl_decls, ppr_ds inst_decls,
                 ppr_ds deriv_decls,
@@ -1034,3 +1046,42 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
     ppr (Warning thing txt)
       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 \end{code}
+
+%************************************************************************
+%*									*
+\subsection[AnnDecl]{Annotations}
+%*									*
+%************************************************************************
+
+\begin{code}
+type LAnnDecl name = Located (AnnDecl name)
+
+data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
+
+instance (OutputableBndr name) => Outputable (AnnDecl name) where
+    ppr (HsAnnotation provenance expr) 
+      = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
+
+
+data AnnProvenance name = ValueAnnProvenance name
+                        | TypeAnnProvenance name
+                        | ModuleAnnProvenance
+
+annProvenanceName_maybe :: AnnProvenance name -> Maybe name
+annProvenanceName_maybe (ValueAnnProvenance name) = Just name
+annProvenanceName_maybe (TypeAnnProvenance name)  = Just name
+annProvenanceName_maybe ModuleAnnProvenance       = Nothing
+
+-- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough
+modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after)
+modifyAnnProvenanceNameM fm prov =
+    case prov of
+            ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name)
+            TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name)
+            ModuleAnnProvenance -> return ModuleAnnProvenance
+
+pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
+pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
+pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
+pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
+\end{code}