module Data.Homeomorphic.MemoCache where
import Data.Homeomorphic.Internal
import Data.Maybe
import Data.IORef
import System.IO.Unsafe
import qualified Data.IntMap as Map
import Control.Monad.State
import Data.Homeomorphic.ShellId as S
data Homeomorphic k v = Homeomorphic (IORef Cache) [(ShellId, v)] (IORef (ShellIds k))
type Cache = Map.IntMap (Map.IntMap Bool)
empty :: Homeomorphic k v
empty = Homeomorphic
(unsafePerformIO $ newIORef Map.empty)
[]
(unsafePerformIO $ newIORef S.empty)
insert :: Ord k => Shell k -> v -> Homeomorphic k v -> Homeomorphic k v
insert k v (Homeomorphic a b c) = unsafePerformIO $ do
c2 <- readIORef c
(c2,k2) <- return $ retrieve k c2
writeIORef c c2
return $ Homeomorphic a ((k2,v):b) c
findOne :: Ord k => Shell k -> Homeomorphic k v -> Maybe v
findOne k = listToMaybe . find k
find :: Ord k => Shell k -> Homeomorphic k v -> [v]
find y (Homeomorphic a b c) = concatMap f b
where
y2 = unsafePerformIO $ do
c2 <- readIORef c
(c2,y2) <- return $ retrieve y c2
writeIORef c c2
return y2
f (x,v) = unsafePerformIO $ do
s <- readIORef a
let (r,s2) = runState (test x y2) s
writeIORef a s2
return [v | r]
getCache :: ShellId -> ShellId -> State Cache (Maybe Bool)
getCache x y = do
s <- get
return $ Map.lookup (allId y) s >>= Map.lookup (allId x)
addCache :: ShellId -> ShellId -> Bool -> State Cache ()
addCache x y b = modify $ Map.insertWith add (allId y) (Map.singleton (allId x) b)
where add _ old = Map.insert (allId x) b old
test :: ShellId -> ShellId -> State Cache Bool
test x y | allId x == allId y = return True
test x y = do
v <- getCache x y
case v of
Just b -> return b
Nothing -> do
b <- diveM x y `orM` coupleM x y
addCache x y b
return b
diveM :: ShellId -> ShellId -> State Cache Bool
diveM x y = anyM (x `test`) (restId y)
coupleM :: ShellId -> ShellId -> State Cache Bool
coupleM x y = return (headId x == headId y) `andM` andsM (zipWith test (restId x) (restId y))
orM a b = do a <- a; if a then return True else b
orsM x = foldr orM (return False) x
anyM f = orsM . map f
andM a b = do a <- a; if a then b else return False
andsM x = foldr andM (return True) x