diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7e13fdcc36ef15a2edf43cd7cff9c42504206eb8..303c7a08d3b625b07c08c1561d31fbc7571f1119 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1920,7 +1920,7 @@ globalVar name ; rep2 mk_varg [pkg,mod,occ] } | otherwise = do { MkC occ <- nameLit name - ; MkC uni <- coreIntLit (getKey (getUnique name)) + ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) ; rep2 mkNameLName [occ,uni] } where mod = ASSERT( isExternalName name) nameModule name @@ -2717,6 +2717,9 @@ coreIntLit :: Int -> DsM (Core Int) coreIntLit i = do dflags <- getDynFlags return (MkC (mkIntExprInt dflags i)) +coreIntegerLit :: Integer -> DsM (Core Integer) +coreIntegerLit i = fmap MkC (mkIntegerExpr i) + coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 57aaefb830856eb2df39a1a91aa95f272afdd5c8..2292a9fea42f88aa89489cbae9ccc6f53886ee62 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -1824,8 +1824,8 @@ thRdrName loc ctxt_ns th_occ th_name = case th_name of TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ - TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc) - TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc) + TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc) + TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name | otherwise -> mkRdrUnqual $! occ -- We check for built-in syntax here, because the TH diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 845e2029eda78c06d637f4b4027d9d790df95234..3434b686151e7c16e9bae3447a03d3e5a372e0dc 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -922,7 +922,7 @@ To call runQ in the Tc monad, we need to make TcM an instance of Quasi: instance TH.Quasi TcM where qNewName s = do { u <- newUnique - ; let i = getKey u + ; let i = toInteger (getKey u) ; return (TH.mkNameU s i) } -- 'msg' is forced to ensure exceptions don't escape, @@ -1947,8 +1947,9 @@ reify_tc_app tc tys ------------------------------ reifyName :: NamedThing n => n -> TH.Name reifyName thing - | isExternalName name = mk_varg pkg_str mod_str occ_str - | otherwise = TH.mkNameU occ_str (getKey (getUnique name)) + | isExternalName name + = mk_varg pkg_str mod_str occ_str + | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) -- Many of the things we reify have local bindings, and -- NameL's aren't supposed to appear in binding positions, so -- we use NameU. When/if we start to reify nested things, that diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs index 7e05d05d8393d772c9795dd80c25ea3d9cdeb0d3..ac0679a93eca291768b36b7b78dde9082ab3c607 100644 --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -36,14 +36,14 @@ module Language.Haskell.TH.PprLib ( import Language.Haskell.TH.Syntax - (Name(..), showName', NameFlavour(..), NameIs(..)) + (Uniq, Name(..), showName', NameFlavour(..), NameIs(..)) import qualified Text.PrettyPrint as HPJ import Control.Monad (liftM, liftM2, ap) import Language.Haskell.TH.Lib.Map ( Map ) import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) import Prelude hiding ((<>)) -infixl 6 <> +infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ @@ -117,7 +117,7 @@ punctuate :: Doc -> [Doc] -> [Doc] -- --------------------------------------------------------------------------- -- The "implementation" -type State = (Map Name Name, Int) +type State = (Map Name Name, Uniq) data PprM a = PprM { runPprM :: State -> (a, State) } pprName :: Name -> Doc diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 14b9de263c29647a3f84619a2627a9c72226af12..dfcdfd5f178ffb17312b3a501d3d75dbee7d3fce 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -155,7 +155,7 @@ badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad") ; fail "Template Haskell failure" } -- Global variable to generate unique symbols -counter :: IORef Int +counter :: IORef Uniq {-# NOINLINE counter #-} counter = unsafePerformIO (newIORef 0) @@ -1299,8 +1299,8 @@ instance Ord Name where data NameFlavour = NameS -- ^ An unqualified name; dynamically bound | NameQ ModName -- ^ A qualified name; dynamically bound - | NameU !Int -- ^ A unique local name - | NameL !Int -- ^ Local name bound outside of the TH AST + | NameU !Uniq -- ^ A unique local name + | NameL !Uniq -- ^ Local name bound outside of the TH AST | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST: -- An original name (occurrences only, not binders) -- Need the namespace too to be sure which @@ -1313,7 +1313,8 @@ data NameSpace = VarName -- ^ Variables -- in the same name space for now. deriving( Eq, Ord, Show, Data, Generic ) -type Uniq = Int +-- | @Uniq@ is used by GHC to distinguish names from each other. +type Uniq = Integer -- | The name without its module prefix. --