{-# LANGUAGE DeriveDataTypeable #-}
module Data.Atom (
Atom,
newAtom,
share
) where
import Control.DeepSeq
import Data.ByteString (ByteString, pack, unpack)
import Data.ByteString.Internal (c2w, toForeignPtr, w2c)
import Data.IORef
import qualified Data.Map as M
import Data.String.Unicode (unicodeToUtf8)
import Data.String.UTF8Decoding (decodeUtf8)
import Data.Typeable
import System.IO.Unsafe (unsafePerformIO)
type Atoms = M.Map ByteString ByteString
newtype Atom = A { Atom -> ByteString
bs :: ByteString }
deriving (Typeable)
theAtoms :: IORef Atoms
theAtoms :: IORef Atoms
theAtoms = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty)
{-# NOINLINE theAtoms #-}
insertAtom :: ByteString -> Atoms -> (Atoms, Atom)
insertAtom :: ByteString -> Atoms -> (Atoms, Atom)
insertAtom ByteString
s Atoms
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ByteString
s ByteString
s Atoms
m, ByteString -> Atom
A ByteString
s)
(\ ByteString
s' -> (Atoms
m, ByteString -> Atom
A ByteString
s'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
s forall a b. (a -> b) -> a -> b
$ Atoms
m
newAtom :: String -> Atom
newAtom :: String -> Atom
newAtom = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Atom
newAtom'
{-# NOINLINE newAtom #-}
newAtom' :: String -> IO Atom
newAtom' :: String -> IO Atom
newAtom' String
s = do
Atom
res <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Atoms
theAtoms Atoms -> (Atoms, Atom)
insert
forall (m :: * -> *) a. Monad m => a -> m a
return Atom
res
where
insert :: Atoms -> (Atoms, Atom)
insert Atoms
m = let r :: (Atoms, Atom)
r = ByteString -> Atoms -> (Atoms, Atom)
insertAtom ([Word8] -> ByteString
packforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
c2w forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unicodeToUtf8 forall a b. (a -> b) -> a -> b
$ String
s) Atoms
m
in
forall a b. (a, b) -> a
fst (Atoms, Atom)
r seq :: forall a b. a -> b -> b
`seq` (Atoms, Atom)
r
share :: String -> String
share :: String -> String
share = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Atom
newAtom
instance Eq Atom where
Atom
a1 == :: Atom -> Atom -> Bool
== Atom
a2 = ForeignPtr Word8
fp1 forall a. Eq a => a -> a -> Bool
== ForeignPtr Word8
fp2
where
(ForeignPtr Word8
fp1, Int
_, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> ByteString
bs forall a b. (a -> b) -> a -> b
$ Atom
a1
(ForeignPtr Word8
fp2, Int
_, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> ByteString
bs forall a b. (a -> b) -> a -> b
$ Atom
a2
instance Ord Atom where
compare :: Atom -> Atom -> Ordering
compare Atom
a1 Atom
a2
| Atom
a1 forall a. Eq a => a -> a -> Bool
== Atom
a2 = Ordering
EQ
| Bool
otherwise = forall a. Ord a => a -> a -> Ordering
compare (Atom -> ByteString
bs Atom
a1) (Atom -> ByteString
bs Atom
a2)
instance Read Atom where
readsPrec :: Int -> ReadS Atom
readsPrec Int
p String
str = [ (String -> Atom
newAtom String
x, String
y) | (String
x, String
y) <- forall a. Read a => Int -> ReadS a
readsPrec Int
p String
str ]
instance Show Atom where
show :: Atom -> String
show = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, [String])
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
w2c forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> ByteString
bs
instance NFData Atom where
rnf :: Atom -> ()
rnf Atom
x = seq :: forall a b. a -> b -> b
seq Atom
x ()