{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Symbol.Unsafe (
Symbol(..),
intern,
unintern
) where
import Control.Concurrent.MVar
import Control.DeepSeq
import Data.Data (Data)
#if __GLASGOW_HASKELL__ >= 608
import Data.String
#endif /* __GLASGOW_HASKELL__ >= 608 */
import Data.Typeable (Typeable)
import qualified Data.Map as Map
import System.IO.Unsafe (unsafePerformIO)
data Symbol =
Symbol {-# UNPACK #-} !Int !String
#if defined(__GLASGOW_HASKELL__)
deriving (Typeable Symbol
Typeable Symbol =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Symbol -> c Symbol)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Symbol)
-> (Symbol -> Constr)
-> (Symbol -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Symbol))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Symbol))
-> ((forall b. Data b => b -> b) -> Symbol -> Symbol)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Symbol -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Symbol -> r)
-> (forall u. (forall d. Data d => d -> u) -> Symbol -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Symbol -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol)
-> Data Symbol
Symbol -> Constr
Symbol -> DataType
(forall b. Data b => b -> b) -> Symbol -> Symbol
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Symbol -> u
forall u. (forall d. Data d => d -> u) -> Symbol -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Symbol -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Symbol -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Symbol
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Symbol -> c Symbol
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Symbol)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Symbol)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Symbol -> c Symbol
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Symbol -> c Symbol
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Symbol
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Symbol
$ctoConstr :: Symbol -> Constr
toConstr :: Symbol -> Constr
$cdataTypeOf :: Symbol -> DataType
dataTypeOf :: Symbol -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Symbol)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Symbol)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Symbol)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Symbol)
$cgmapT :: (forall b. Data b => b -> b) -> Symbol -> Symbol
gmapT :: (forall b. Data b => b -> b) -> Symbol -> Symbol
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Symbol -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Symbol -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Symbol -> r
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Symbol -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Symbol -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Symbol -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Symbol -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Symbol -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Symbol -> m Symbol
Data, Typeable)
#endif /* defined(__GLASGOW_HASKELL__) */
instance Eq Symbol where
(Symbol Int
i1 String
_) == :: Symbol -> Symbol -> Bool
== (Symbol Int
i2 String
_) = Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2
instance Ord Symbol where
compare :: Symbol -> Symbol -> Ordering
compare (Symbol Int
i1 String
_) (Symbol Int
i2 String
_) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i1 Int
i2
instance Show Symbol where
showsPrec :: Int -> Symbol -> ShowS
showsPrec Int
d (Symbol Int
_ String
s) = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d String
s
instance Read Symbol where
readsPrec :: Int -> ReadS Symbol
readsPrec Int
d String
t = [(String -> Symbol
intern String
s, String
t') | (String
s, String
t') <- ReadS String
forall a. Read a => ReadS [a]
readList String
t]
#if __GLASGOW_HASKELL__ >= 608
instance IsString Symbol where
fromString :: String -> Symbol
fromString = String -> Symbol
intern
#endif /* __GLASGOW_HASKELL__ >= 608 */
data SymbolEnv = SymbolEnv
{ SymbolEnv -> Int
uniq :: {-# UNPACK #-} !Int
, SymbolEnv -> Map String Symbol
symbols :: !(Map.Map String Symbol)
}
symbolEnv :: MVar SymbolEnv
{-# NOINLINE symbolEnv #-}
symbolEnv :: MVar SymbolEnv
symbolEnv = IO (MVar SymbolEnv) -> MVar SymbolEnv
forall a. IO a -> a
unsafePerformIO (IO (MVar SymbolEnv) -> MVar SymbolEnv)
-> IO (MVar SymbolEnv) -> MVar SymbolEnv
forall a b. (a -> b) -> a -> b
$ SymbolEnv -> IO (MVar SymbolEnv)
forall a. a -> IO (MVar a)
newMVar (SymbolEnv -> IO (MVar SymbolEnv))
-> SymbolEnv -> IO (MVar SymbolEnv)
forall a b. (a -> b) -> a -> b
$ Int -> Map String Symbol -> SymbolEnv
SymbolEnv Int
1 Map String Symbol
forall k a. Map k a
Map.empty
intern :: String -> Symbol
{-# NOINLINE intern #-}
intern :: String -> Symbol
intern String
s = String
s String -> Symbol -> Symbol
forall a b. NFData a => a -> b -> b
`deepseq` IO Symbol -> Symbol
forall a. IO a -> a
unsafePerformIO (IO Symbol -> Symbol) -> IO Symbol -> Symbol
forall a b. (a -> b) -> a -> b
$ MVar SymbolEnv
-> (SymbolEnv -> IO (SymbolEnv, Symbol)) -> IO Symbol
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar SymbolEnv
symbolEnv ((SymbolEnv -> IO (SymbolEnv, Symbol)) -> IO Symbol)
-> (SymbolEnv -> IO (SymbolEnv, Symbol)) -> IO Symbol
forall a b. (a -> b) -> a -> b
$ \SymbolEnv
env -> do
case String -> Map String Symbol -> Maybe Symbol
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
s (SymbolEnv -> Map String Symbol
symbols SymbolEnv
env) of
Maybe Symbol
Nothing -> do let sym :: Symbol
sym = Int -> String -> Symbol
Symbol (SymbolEnv -> Int
uniq SymbolEnv
env) String
s
let env' :: SymbolEnv
env' = SymbolEnv
env { uniq = uniq env + 1,
symbols = Map.insert s sym
(symbols env)
}
SymbolEnv
env' SymbolEnv -> IO (SymbolEnv, Symbol) -> IO (SymbolEnv, Symbol)
forall a b. a -> b -> b
`seq` (SymbolEnv, Symbol) -> IO (SymbolEnv, Symbol)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolEnv
env', Symbol
sym)
Just Symbol
sym -> (SymbolEnv, Symbol) -> IO (SymbolEnv, Symbol)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolEnv
env, Symbol
sym)
unintern :: Symbol -> String
unintern :: Symbol -> String
unintern (Symbol Int
_ String
s) = String
s