[commit: ghc] master: Add machinery to reify annotations (#8397) (7186bdb)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/7186bdb1007cce27bf98ec9d96c9fe1d07099f0b/ghc

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

commit 7186bdb1007cce27bf98ec9d96c9fe1d07099f0b
Author: Austin Seipp <austin at well-typed.com>
Date:   Fri Oct 11 22:18:41 2013 -0500

    Add machinery to reify annotations (#8397)
    
    Authored-by: Gergely Risko <gergely at risko.hu>
    Signed-off-by: Austin Seipp <austin at well-typed.com>


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

7186bdb1007cce27bf98ec9d96c9fe1d07099f0b
 compiler/typecheck/TcRnDriver.lhs |   16 +++++++++-------
 compiler/typecheck/TcRnMonad.lhs  |    2 ++
 compiler/typecheck/TcRnTypes.lhs  |    1 +
 compiler/typecheck/TcSplice.lhs   |   27 +++++++++++++++++++++++----
 4 files changed, 35 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index f9f7abb..7b2c339 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -78,6 +78,7 @@ import Type
 import Class
 import CoAxiom
 import Inst     ( tcGetInstEnvs, tcGetInsts )
+import Annotations
 import Data.List ( sortBy )
 import Data.IORef ( readIORef )
 import Data.Ord
@@ -1228,13 +1229,14 @@ tcTopSrcDecls boot_details
 
                 -- Extend the GblEnv with the (as yet un-zonked)
                 -- bindings, rules, foreign decls
-            ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
-                                 , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
-                                 , tcg_rules = tcg_rules tcg_env ++ rules
-                                 , tcg_vects = tcg_vects tcg_env ++ vects
-                                 , tcg_anns  = tcg_anns tcg_env ++ annotations
-                                 , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
-                                 , tcg_dus   = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
+            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds
+                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSets` sig_names
+                                 , tcg_rules   = tcg_rules tcg_env ++ rules
+                                 , tcg_vects   = tcg_vects tcg_env ++ vects
+                                 , tcg_anns    = tcg_anns tcg_env ++ annotations
+                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
+                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
+                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
                                  -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
 
         addUsedRdrNames fo_rdr_names ;
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index be2ca1c..bcccb95 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -48,6 +48,7 @@ import StaticFlags
 import FastString
 import Panic
 import Util
+import Annotations
 
 import Control.Exception
 import Data.IORef
@@ -124,6 +125,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_type_env_var   = type_env_var,
                 tcg_inst_env       = emptyInstEnv,
                 tcg_fam_inst_env   = emptyFamInstEnv,
+                tcg_ann_env        = emptyAnnEnv,
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
                 tcg_exports        = [],
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index e08da5a..6502d6d 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -232,6 +232,7 @@ data TcGblEnv
           -- ^ Instance envt for all /home-package/ modules;
           -- Includes the dfuns in tcg_insts
         tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances
+        tcg_ann_env      :: AnnEnv,     -- ^ And for annotations
 
                 -- Now a bunch of things about this module that are simply
                 -- accumulated, but never consulted until the end.
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index b88b026..458fc07 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -23,6 +23,7 @@ import HscMain
         -- These imports are the reason that TcSplice
         -- is very high up the module hierarchy
 
+import HscTypes
 import HsSyn
 import Convert
 import RnExpr
@@ -93,6 +94,7 @@ import Data.Dynamic  ( fromDynamic, toDyn )
 import Data.Typeable ( typeOf )
 #endif
 
+import Data.Data (Data)
 import GHC.Exts         ( unsafeCoerce# )
 \end{code}
 
@@ -1043,10 +1045,11 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
                                   , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
                                   , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
 
-  qLookupName     = lookupName
-  qReify          = reify
-  qReifyInstances = reifyInstances
-  qReifyRoles     = reifyRoles
+  qLookupName       = lookupName
+  qReify            = reify
+  qReifyInstances   = reifyInstances
+  qReifyRoles       = reifyRoles
+  qReifyAnnotations = reifyAnnotations
 
         -- For qRecover, discard error messages if
         -- the recovery action is chosen.  Otherwise
@@ -1649,6 +1652,22 @@ reifyStrict HsStrict                      = TH.IsStrict
 reifyStrict (HsUnpack {})                 = TH.Unpacked
 
 ------------------------------
+lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
+lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
+lookupThAnnLookup (TH.AnnLookupModule pn mn)
+  = return $ ModuleTarget $
+    mkModule (stringToPackageId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
+
+reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
+reifyAnnotations th_nm
+  = do { name <- lookupThAnnLookup th_nm
+       ; eps <- getEps
+       ; tcg <- getGblEnv
+       ; let epsAnns = findAnns deserializeWithData (eps_ann_env eps) name
+       ; let envAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
+       ; return (envAnns ++ epsAnns) }
+
+------------------------------
 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys