{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- |
-- Module      :  Data.Symbol.Unsafe
-- Copyright   :  (c) Harvard University 2009-2011
--             :  (c) Geoffrey Mainland 2011-2014
-- License     :  BSD-style
-- Maintainer  :  Geoffrey Mainland <mainland@cs.drexel.edu>

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 =  -- | Unique identifier and the string itself
               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

-- We @'deepseq' s@ so that we can guarantee that when we perform the lookup we
-- won't potentially have to evaluate a thunk that might itself call @'intern'@,
-- leading to a deadlock.

-- |Intern a string to produce a 'Symbol'.
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)

-- |Return the 'String' associated with a 'Symbol'.
unintern :: Symbol -> String
unintern :: Symbol -> String
unintern (Symbol Int
_ String
s) = String
s