[commit: packages/template-haskell] master: Add TH support for annotations (#8340) (42c9082)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/template-haskell

On branch  : master
Link       : http://git.haskell.org/packages/template-haskell.git/commitdiff/42c9082435aa406116b0efdf42c0d33b06fe5d11

>---------------------------------------------------------------

commit 42c9082435aa406116b0efdf42c0d33b06fe5d11
Author: Austin Seipp <austin at well-typed.com>
Date:   Tue Oct 1 21:09:43 2013 -0500

    Add TH support for annotations (#8340)
    
    Authored-by: Gergely Risko <gergely at risko.hu>
    Signed-off-by: Austin Seipp <austin at well-typed.com>


>---------------------------------------------------------------

42c9082435aa406116b0efdf42c0d33b06fe5d11
 Language/Haskell/TH.hs        |    4 ++--
 Language/Haskell/TH/Lib.hs    |    6 ++++++
 Language/Haskell/TH/Ppr.hs    |    5 +++++
 Language/Haskell/TH/Syntax.hs |    6 ++++++
 4 files changed, 19 insertions(+), 2 deletions(-)

diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs
index 38c91fe..7133b61 100644
--- a/Language/Haskell/TH.hs
+++ b/Language/Haskell/TH.hs
@@ -53,7 +53,7 @@ module Language.Haskell.TH(
     -- ** Declarations
 	Dec(..), Con(..), Clause(..), 
 	Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
-	Inline(..), RuleMatch(..), Phases(..), RuleBndr(..),
+	Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
 	FunDep(..), FamFlavour(..), TySynEqn(..),
 	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
     -- ** Expressions
@@ -129,7 +129,7 @@ module Language.Haskell.TH(
     cCall, stdCall, unsafe, safe, forImpD,
     -- **** Pragmas
     ruleVar, typedRuleVar,
-    pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD,
+    pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
 
 	-- * Pretty-printer
     Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
index 94696b8..2480ff3 100644
--- a/Language/Haskell/TH/Lib.hs
+++ b/Language/Haskell/TH/Lib.hs
@@ -404,6 +404,12 @@ pragRuleD n bndrs lhs rhs phases
       rhs1   <- rhs
       return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
 
+pragAnnD :: AnnTarget -> ExpQ -> DecQ
+pragAnnD target expr
+  = do
+      exp1 <- expr
+      return $ PragmaD $ AnnP target exp1
+
 familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
 familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing
 
diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs
index 8222085..ce9fe15 100644
--- a/Language/Haskell/TH/Ppr.hs
+++ b/Language/Haskell/TH/Ppr.hs
@@ -395,6 +395,11 @@ instance Ppr Pragma where
                        | otherwise  =   text "forall"
                                     <+> fsep (map ppr bndrs)
                                     <+> char '.'
+    ppr (AnnP tgt expr)
+       = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
+      where target1 ModuleAnnotation    = text "module"
+            target1 (TypeAnnotation t)  = text "type" <+> ppr t
+            target1 (ValueAnnotation v) = ppr v
 
 ------------------------------
 instance Ppr Inline where
diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
index d59ffff..234225e 100644
--- a/Language/Haskell/TH/Syntax.hs
+++ b/Language/Haskell/TH/Syntax.hs
@@ -1209,6 +1209,7 @@ data Pragma = InlineP         Name Inline RuleMatch Phases
             | SpecialiseP     Name Type (Maybe Inline) Phases
             | SpecialiseInstP Type
             | RuleP           String [RuleBndr] Exp Exp Phases
+            | AnnP            AnnTarget Exp
         deriving( Show, Eq, Data, Typeable )
 
 data Inline = NoInline
@@ -1229,6 +1230,11 @@ data RuleBndr = RuleVar Name
               | TypedRuleVar Name Type
               deriving (Show, Eq, Data, Typeable)
 
+data AnnTarget = ModuleAnnotation
+               | TypeAnnotation Name
+               | ValueAnnotation Name
+              deriving (Show, Eq, Data, Typeable)
+
 type Cxt = [Pred]                 -- ^ @(Eq a, Ord b)@
 
 data Pred = ClassP Name [Type]    -- ^ @Eq (Int, a)@