Commit 7186bdb1 authored by Austin Seipp's avatar Austin Seipp

Add machinery to reify annotations (#8397)

Authored-by: errge's avatarGergely Risko <gergely@risko.hu>
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent eafae362
...@@ -78,6 +78,7 @@ import Type ...@@ -78,6 +78,7 @@ import Type
import Class import Class
import CoAxiom import CoAxiom
import Inst ( tcGetInstEnvs, tcGetInsts ) import Inst ( tcGetInstEnvs, tcGetInsts )
import Annotations
import Data.List ( sortBy ) import Data.List ( sortBy )
import Data.IORef ( readIORef ) import Data.IORef ( readIORef )
import Data.Ord import Data.Ord
...@@ -1228,13 +1229,14 @@ tcTopSrcDecls boot_details ...@@ -1228,13 +1229,14 @@ tcTopSrcDecls boot_details
-- Extend the GblEnv with the (as yet un-zonked) -- Extend the GblEnv with the (as yet un-zonked)
-- bindings, rules, foreign decls -- bindings, rules, foreign decls
; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
, tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names
, tcg_rules = tcg_rules tcg_env ++ rules , tcg_rules = tcg_rules tcg_env ++ rules
, tcg_vects = tcg_vects tcg_env ++ vects , tcg_vects = tcg_vects tcg_env ++ vects
, tcg_anns = tcg_anns tcg_env ++ annotations , tcg_anns = tcg_anns tcg_env ++ annotations
, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; , 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] -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
addUsedRdrNames fo_rdr_names ; addUsedRdrNames fo_rdr_names ;
......
...@@ -48,6 +48,7 @@ import StaticFlags ...@@ -48,6 +48,7 @@ import StaticFlags
import FastString import FastString
import Panic import Panic
import Util import Util
import Annotations
import Control.Exception import Control.Exception
import Data.IORef import Data.IORef
...@@ -124,6 +125,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this ...@@ -124,6 +125,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_type_env_var = type_env_var, tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv, tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv, tcg_fam_inst_env = emptyFamInstEnv,
tcg_ann_env = emptyAnnEnv,
tcg_th_used = th_var, tcg_th_used = th_var,
tcg_th_splice_used = th_splice_var, tcg_th_splice_used = th_splice_var,
tcg_exports = [], tcg_exports = [],
......
...@@ -232,6 +232,7 @@ data TcGblEnv ...@@ -232,6 +232,7 @@ data TcGblEnv
-- ^ Instance envt for all /home-package/ modules; -- ^ Instance envt for all /home-package/ modules;
-- Includes the dfuns in tcg_insts -- Includes the dfuns in tcg_insts
tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances 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 -- Now a bunch of things about this module that are simply
-- accumulated, but never consulted until the end. -- accumulated, but never consulted until the end.
......
...@@ -23,6 +23,7 @@ import HscMain ...@@ -23,6 +23,7 @@ import HscMain
-- These imports are the reason that TcSplice -- These imports are the reason that TcSplice
-- is very high up the module hierarchy -- is very high up the module hierarchy
import HscTypes
import HsSyn import HsSyn
import Convert import Convert
import RnExpr import RnExpr
...@@ -93,6 +94,7 @@ import Data.Dynamic ( fromDynamic, toDyn ) ...@@ -93,6 +94,7 @@ import Data.Dynamic ( fromDynamic, toDyn )
import Data.Typeable ( typeOf ) import Data.Typeable ( typeOf )
#endif #endif
import Data.Data (Data)
import GHC.Exts ( unsafeCoerce# ) import GHC.Exts ( unsafeCoerce# )
\end{code} \end{code}
...@@ -1043,10 +1045,11 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where ...@@ -1043,10 +1045,11 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
, TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
, TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
qLookupName = lookupName qLookupName = lookupName
qReify = reify qReify = reify
qReifyInstances = reifyInstances qReifyInstances = reifyInstances
qReifyRoles = reifyRoles qReifyRoles = reifyRoles
qReifyAnnotations = reifyAnnotations
-- For qRecover, discard error messages if -- For qRecover, discard error messages if
-- the recovery action is chosen. Otherwise -- the recovery action is chosen. Otherwise
...@@ -1648,6 +1651,22 @@ reifyStrict (HsUserBang _ True) = TH.IsStrict ...@@ -1648,6 +1651,22 @@ reifyStrict (HsUserBang _ True) = TH.IsStrict
reifyStrict HsStrict = TH.IsStrict reifyStrict HsStrict = TH.IsStrict
reifyStrict (HsUnpack {}) = TH.Unpacked 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 :: TH.Type -> [TH.Type] -> TH.Type
mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment