Repository : ssh://g...@git.haskell.org/ghc
On branch : master
Link :
http://ghc.haskell.org/trac/ghc/changeset/7186bdb1007cce27bf98ec9d96c9fe1d07099f0b/ghc
>---------------------------------------------------------------
commit 7186bdb1007cce27bf98ec9d96c9fe1d07099f0b
Author: Austin Seipp <aus...@well-typed.com>
Date: Fri Oct 11 22:18:41 2013 -0500
Add machinery to reify annotations (#8397)
Authored-by: Gergely Risko <gerg...@risko.hu>
Signed-off-by: Austin Seipp <aus...@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
_______________________________________________
ghc-commits mailing list
ghc-commits@haskell.org
http://www.haskell.org/mailman/listinfo/ghc-commits
