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


-- Both the data structures in IORef's store a minimum amount of information
-- If some action happens, and additional (useless) information is added, this will not
-- break correctness. Since IORef's are only modified to add info, they are safe.
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


-- given a cache, test if it exists, then work the way back
test :: ShellId -> ShellId -> State Cache Bool
test x y | allId x == allId y = return True -- use the property the test is reflexive
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