Add TH support for annotations (#8340)

Authored-by: Gergely Risko <gergely@risko.hu>
Signed-off-by: Austin Seipp <austin@well-typed.com>

4 files changed, 19 insertions, 2 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 38c91fe56d..7133b61795 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/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/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 94696b822e..2480ff35a0 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/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/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 8222085375..ce9fe15859 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/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/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index d59fffff6b..234225ec86 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/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)@