{-# LANGUAGE TypeFamilies
           , FlexibleInstances
           , FlexibleContexts
           , BangPatterns
           , CPP
           , GeneralizedNewtypeDeriving #-}

module Data.Interned.Internal
  ( Interned(..)
  , Uninternable(..)
  , mkCache
  , Cache(..)
  , CacheState(..)
  , cacheSize
  , Id
  , intern
  , recover
  ) where

import Data.Array
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import Data.Foldable
#if !(MIN_VERSION_base(4,8,0))
import Data.Traversable
#endif
import qualified Data.HashMap.Strict as HashMap
import Data.IORef
import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)

-- tuning parameter
defaultCacheWidth :: Int
defaultCacheWidth :: Int
defaultCacheWidth = Int
1024

data CacheState t = CacheState
   { forall t. CacheState t -> Int
fresh :: {-# UNPACK #-} !Id
   , forall t. CacheState t -> HashMap (Description t) t
content :: !(HashMap (Description t) t)
   }

newtype Cache t = Cache { forall t. Cache t -> Array Int (IORef (CacheState t))
getCache :: Array Int (IORef (CacheState t)) }

cacheSize :: Cache t -> IO Int
cacheSize :: forall t. Cache t -> IO Int
cacheSize (Cache Array Int (IORef (CacheState t))
t) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
   (\IORef (CacheState t)
a Int
b -> do
       CacheState t
v <- forall a. IORef a -> IO a
readIORef IORef (CacheState t)
a
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall k v. HashMap k v -> Int
HashMap.size (forall t. CacheState t -> HashMap (Description t) t
content CacheState t
v) forall a. Num a => a -> a -> a
+ Int
b
   ) Int
0 Array Int (IORef (CacheState t))
t

mkCache :: Interned t => Cache t
mkCache :: forall t. Interned t => Cache t
mkCache   = Cache t
result where
  element :: CacheState t
element = forall t. Int -> HashMap (Description t) t -> CacheState t
CacheState (forall t (p :: * -> *). Interned t => p t -> Int
seedIdentity Cache t
result) forall k v. HashMap k v
HashMap.empty
  w :: Int
w       = forall t (p :: * -> *). Interned t => p t -> Int
cacheWidth Cache t
result
  result :: Cache t
result  = forall t. Array Int (IORef (CacheState t)) -> Cache t
Cache
          forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. a -> IO (IORef a)
newIORef
          forall a b. (a -> b) -> a -> b
$ forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
w forall a. Num a => a -> a -> a
- Int
1)
          forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
w CacheState t
element

type Id = Int

class ( Eq (Description t)
      , Hashable (Description t)
      ) => Interned t where
  data Description t
  type Uninterned t
  describe :: Uninterned t -> Description t
  identify :: Id -> Uninterned t -> t
  -- identity :: t -> Id
  seedIdentity :: p t -> Id
  seedIdentity p t
_ = Int
0
  cacheWidth :: p t -> Int
  cacheWidth p t
_ = Int
defaultCacheWidth
  modifyAdvice :: IO t -> IO t
  modifyAdvice = forall a. a -> a
id
  cache        :: Cache t

class Interned t => Uninternable t where
  unintern :: t -> Uninterned t

intern :: Interned t => Uninterned t -> t
intern :: forall t. Interned t => Uninterned t -> t
intern !Uninterned t
bt = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ forall t. Interned t => IO t -> IO t
modifyAdvice forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (CacheState t)
slot CacheState t -> (CacheState t, t)
go
  where
  slot :: IORef (CacheState t)
slot = forall t. Cache t -> Array Int (IORef (CacheState t))
getCache forall t. Interned t => Cache t
cache forall i e. Ix i => Array i e -> i -> e
! Int
r
  !dt :: Description t
dt = forall t. Interned t => Uninterned t -> Description t
describe Uninterned t
bt
  !hdt :: Int
hdt = forall a. Hashable a => a -> Int
hash Description t
dt
  !wid :: Int
wid = forall t (p :: * -> *). Interned t => p t -> Int
cacheWidth Description t
dt
  r :: Int
r = Int
hdt forall a. Integral a => a -> a -> a
`mod` Int
wid
  go :: CacheState t -> (CacheState t, t)
go (CacheState Int
i HashMap (Description t) t
m) = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Description t
dt HashMap (Description t) t
m of
    Maybe t
Nothing -> let t :: t
t = forall t. Interned t => Int -> Uninterned t -> t
identify (Int
wid forall a. Num a => a -> a -> a
* Int
i forall a. Num a => a -> a -> a
+ Int
r) Uninterned t
bt in (forall t. Int -> HashMap (Description t) t -> CacheState t
CacheState (Int
i forall a. Num a => a -> a -> a
+ Int
1) (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Description t
dt t
t HashMap (Description t) t
m), t
t)
    Just t
t -> (forall t. Int -> HashMap (Description t) t -> CacheState t
CacheState Int
i HashMap (Description t) t
m, t
t)

-- given a description, go hunting for an entry in the cache
recover :: Interned t => Description t -> IO (Maybe t)
recover :: forall t. Interned t => Description t -> IO (Maybe t)
recover !Description t
dt = do
  CacheState Int
_ HashMap (Description t) t
m <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall t. Cache t -> Array Int (IORef (CacheState t))
getCache forall t. Interned t => Cache t
cache forall i e. Ix i => Array i e -> i -> e
! (forall a. Hashable a => a -> Int
hash Description t
dt forall a. Integral a => a -> a -> a
`mod` forall t (p :: * -> *). Interned t => p t -> Int
cacheWidth Description t
dt)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Description t
dt HashMap (Description t) t
m