[commit: packages/template-haskell] master: Add reifyAnnotations (#8397) (694c734)

[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/694c734f508369004ec6f8ff2351520a45b91a24

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

commit 694c734f508369004ec6f8ff2351520a45b91a24
Author: Austin Seipp <austin at well-typed.com>
Date:   Fri Oct 11 22:19:56 2013 -0500

    Add reifyAnnotations (#8397)
    
    Signed-off-by: Austin Seipp <austin at well-typed.com>


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

694c734f508369004ec6f8ff2351520a45b91a24
 Language/Haskell/TH.hs        |    2 ++
 Language/Haskell/TH/Syntax.hs |   21 ++++++++++++++++++---
 2 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs
index ed07f38..a5ccca2 100644
--- a/Language/Haskell/TH.hs
+++ b/Language/Haskell/TH.hs
@@ -32,6 +32,8 @@ module Language.Haskell.TH(
 	isInstance,
         -- *** Roles lookup
         reifyRoles,
+        -- *** Annotation lookup
+        reifyAnnotations, AnnLookup(..),
 
 	-- * Typed expressions
 	TExp, unType,
diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
index 11a35c1..9660dcd 100644
--- a/Language/Haskell/TH/Syntax.hs
+++ b/Language/Haskell/TH/Syntax.hs
@@ -53,7 +53,8 @@ class (Monad m, Applicative m) => Quasi m where
        -- Returns list of matching instance Decs
        --    (with empty sub-Decs)
        -- Works for classes and type functions
-  qReifyRoles     :: Name -> m [Role]
+  qReifyRoles       :: Name -> m [Role]
+  qReifyAnnotations :: Data a => AnnLookup -> m [a]
 
   qLocation :: m Loc
 
@@ -93,6 +94,7 @@ instance Quasi IO where
   qReify _            = badIO "reify"
   qReifyInstances _ _ = badIO "classInstances"
   qReifyRoles _       = badIO "reifyRoles"
+  qReifyAnnotations _ = badIO "reifyAnnotations"
   qLocation    	      = badIO "currentLocation"
   qRecover _ _ 	      = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _ = badIO "addDependentFile"
@@ -324,6 +326,13 @@ The returned list should never contain 'InferR'.
 reifyRoles :: Name -> Q [Role]
 reifyRoles nm = Q (qReifyRoles nm)
 
+-- | @reifyAnnotations target@ returns the list of annotations
+-- associated with @target at .  Only the annotations that are
+-- appropriately typed is returned.  So if you have @Int@ and @String@
+-- annotations for the same target, you have to call this function twice.
+reifyAnnotations :: Data a => AnnLookup -> Q [a]
+reifyAnnotations an = Q (qReifyAnnotations an)
+
 -- | Is the list of instances returned by 'reifyInstances' nonempty?
 isInstance :: Name -> [Type] -> Q Bool
 isInstance nm tys = do { decs <- reifyInstances nm tys
@@ -375,6 +384,7 @@ instance Quasi Q where
   qReify    	    = reify
   qReifyInstances   = reifyInstances
   qReifyRoles       = reifyRoles
+  qReifyAnnotations = reifyAnnotations
   qLookupName       = lookupName
   qLocation 	    = location
   qRunIO    	    = runIO
@@ -490,10 +500,10 @@ rightName = mkNameG DataName "base" "Data.Either" "Right"
 -----------------------------------------------------
 
 newtype ModName = ModName String	-- Module name
- deriving (Eq,Ord,Typeable,Data)
+ deriving (Show,Eq,Ord,Typeable,Data)
 
 newtype PkgName = PkgName String	-- package name
- deriving (Eq,Ord,Typeable,Data)
+ deriving (Show,Eq,Ord,Typeable,Data)
 
 newtype OccName = OccName String
  deriving (Eq,Ord,Typeable,Data)
@@ -1338,6 +1348,11 @@ data Role = NominalR            -- ^ @nominal@
           | InferR              -- ^ @_@
   deriving( Show, Eq, Data, Typeable )
 
+-- | Annotation target for reifyAnnotations
+data AnnLookup = AnnLookupModule PkgName ModName
+               | AnnLookupName Name
+               deriving( Show, Eq, Data, Typeable )
+
 -- | To avoid duplication between kinds and types, they
 -- are defined to be the same. Naturally, you would never
 -- have a type be 'StarT' and you would never have a kind