gale client

root / Atom.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-}
module Atom(
    Atom(),
    Atom.toString,
    FromAtom(..),
    ToAtom(..),
    atomIndex,
    dumpAtomTable,
    fromPackedStringIO,
    fromString,
    fromStringIO,
    intToAtom,
    toPackedString
    ) where

import System.IO.Unsafe (unsafePerformIO)

import Data.Generics
import Data.Monoid
import Foreign
import Data.List(sort)
import qualified Data.HashTable.IO as HT
import Data.Binary

import PackedString


instance Monoid Atom where
    mempty = toAtom nilPS
    mappend x y = toAtom $ appendPS (fromAtom x)  (fromAtom y)
    mconcat xs = toAtom $ concatPS (map fromAtom xs)

{-# NOINLINE table #-}
table :: HT.CuckooHashTable PackedString Atom
table = unsafePerformIO HT.new

{-# NOINLINE reverseTable #-}
reverseTable :: HT.CuckooHashTable Int PackedString
reverseTable = unsafePerformIO HT.new

{-# NOINLINE intPtr #-}
intPtr :: Ptr Int
intPtr = unsafePerformIO (new 1)


newtype Atom = Atom Int
    deriving(Typeable, Data,Eq,Ord)

instance Show Atom where
    showsPrec _ atom = (toString atom ++)

instance Read Atom where
    readsPrec _ s = [ (fromString s,"") ]
    --readsPrec p s = [ (fromString x,y) |  (x,y) <- readsPrec p s]

toPackedString :: Atom -> PackedString
toPackedString = atomToPS

toString :: Atom -> String
toString atom = unpackPS $ toPackedString atom

atomIndex :: Atom -> Int
atomIndex (Atom x) = x

instance Binary Atom where
    put x = put (toPackedString x)
    get = (unsafePerformIO . fromPackedStringIO) `fmap` get

{- these are separate in case operations are one-way -}
class ToAtom a where
    toAtom :: a -> Atom
class FromAtom a where
    fromAtom :: Atom -> a

instance ToAtom String where
    toAtom = fromString
instance FromAtom String where
    fromAtom = toString
instance FromAtom (String -> String) where
    fromAtom x = showsPS (fromAtom x)

instance ToAtom PackedString where
    toAtom x = unsafePerformIO $ fromPackedStringIO x
instance FromAtom PackedString where
    fromAtom = toPackedString

instance ToAtom Atom where
    toAtom x = x
instance FromAtom Atom where
    fromAtom x = x

instance ToAtom Char where
    toAtom x = toAtom [x]


fromString :: String -> Atom
fromString xs = unsafePerformIO $ fromStringIO xs

fromStringIO :: String -> IO Atom
fromStringIO cs = fromPackedStringIO (packString cs)

fromPackedStringIO :: PackedString -> IO Atom
fromPackedStringIO ps = HT.lookup table ps >>= \x -> case x of
    Just z -> return z
    Nothing -> do
        i <- peek intPtr
        poke intPtr (i + 2)
        let a = Atom i
        HT.insert table ps a
        HT.insert reverseTable i ps
        return a


-- The following are 'unwise' in that they may reveal internal structure that may differ between program runs

dumpAtomTable = do
    x <- HT.toList table
    mapM_ putStrLn [ show i ++ " " ++ show ps  | (ps,Atom i) <- sort x]


intToAtom :: Monad m => Int -> m Atom
intToAtom i = unsafePerformIO $  HT.lookup reverseTable i >>= \x -> case x of
    Just _ -> return (return $ Atom i)
    Nothing -> return $ fail $ "intToAtom: " ++ show i

atomToPS :: Atom -> PackedString
atomToPS (Atom i) = unsafePerformIO $  HT.lookup reverseTable i >>= \x -> case x of
    Just ps -> return ps
    Nothing -> return $ error $ "atomToPS: " ++ show i