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

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
import Class
import CoAxiom
import Inst ( tcGetInstEnvs, tcGetInsts )
import Annotations
import Data.List ( sortBy )
import Data.IORef ( readIORef )
import Data.Ord
......@@ -1233,6 +1234,7 @@ tcTopSrcDecls boot_details
, 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]
......
......@@ -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 = [],
......
......@@ -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.
......
......@@ -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}
......@@ -1047,6 +1049,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
qReify = reify
qReifyInstances = reifyInstances
qReifyRoles = reifyRoles
qReifyAnnotations = reifyAnnotations
-- For qRecover, discard error messages if
-- the recovery action is chosen. Otherwise
......@@ -1648,6 +1651,22 @@ reifyStrict (HsUserBang _ True) = TH.IsStrict
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
......
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