<commit_before>{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HMenu.Cache (setupCache) where

import           ClassyPrelude
import           Control.Concurrent.Async
import           Control.DeepSeq
import           Data.Binary
import           Data.Hashable
import           System.Directory
import           System.FilePath

import           XDG.Directories

data CachedData a = CachedData Int a
    deriving (Eq, Show, Generic)

instance Binary a => Binary (CachedData a)

setupCache :: (Hashable b, Binary a, NFData a) => FilePath -> b -> (b -> a) -> IO (IO a)
setupCache name input func = do
    path <- cacheFilePath name
    cache <- newEmptyMVar
    setupCache' path cache input func
    return $ readMVar cache

setupCache' :: (Hashable b, Binary a, NFData a) => FilePath -> MVar a -> b -> (b -> a) -> IO ()
setupCache' path var input func = do
    aHash <- async calcHash
    aCachedHash <- async retrieve
    void $ async $ refresh aHash aCachedHash
    where
        calcHash =
            let value = hash input
            in value `seq` return value
        retrieve = do
            input <- readCache path
            case input of
                Just (CachedData h value) -> do
                    putMVar var value
                    return $ Just h
                _ ->
                    return Nothing
        refresh aHash aCachedHash = do
            (current, maybeOld) <- waitBoth aHash aCachedHash
            case maybeOld of
                Just old | current == old ->
                    return ()
                Nothing ->
                    let value = func input
                    in value `deepseq` do
                        _ <- tryReadMVar var
                        putMVar var value
                        writeCache path $ CachedData current value

writeCache :: Binary a => FilePath -> CachedData a -> IO ()
writeCache path dataToCache = ensureParent path >> encodeFile path dataToCache

readCache :: Binary a => FilePath -> IO (Maybe (CachedData a))
readCache path = do
    exists <- doesFileExist path
    if exists then do
        result <- decodeFileOrFail path
        return $ case result of
            Right v -> Just v
            _       -> Nothing
    else
        return Nothing

cacheFilePath :: FilePath -> IO FilePath
cacheFilePath n = do
    cacheDirs <- listDirectories CacheHome
    let cacheDir = headEx cacheDirs
    return $ cacheDir </> "hmenu" </> n <.> ".bin"

ensureParent :: FilePath -> IO ()
ensureParent "/" = return ()
ensureParent "." = return ()
ensureParent path = do
    let parent = takeDirectory path
    ensureParent parent
    unlessM (doesDirectoryExist parent) $ createDirectory parent<commit_msg>Refactored the cache to only expose basic read/write functions.<commit_after>{-# LANGUAGE NoImplicitPrelude #-}

module HMenu.Cache where

import           ClassyPrelude
import           Control.DeepSeq
import           Data.Binary
import           Data.Hashable
import           System.Directory
import           System.FilePath

import           XDG.Directories

readCache :: Binary a => FilePath -> IO (Maybe a)
readCache p = do
    r <- try (decodeFile p :: Binary a => IO a)
    case r of
        Right v -> return $ Just v
        Left e -> do
            putStrLn $ tshow p ++ ": " ++ tshow (e :: SomeException)
            return Nothing

writeCache :: Binary a => FilePath -> a -> IO ()
writeCache p d = do
    ensureParent p
    encodeFile p d
    where
        ensureParent :: FilePath -> IO ()
        ensureParent "/" = return ()
        ensureParent "." = return ()
        ensureParent path = do
            let parent = takeDirectory path
            ensureParent parent
            unlessM (doesDirectoryExist parent) $ createDirectory parent

cacheFilePath :: FilePath -> IO FilePath
cacheFilePath n = do
    cacheDirs <- listDirectories CacheHome
    let cacheDir = headEx cacheDirs
    return $ cacheDir </> "hmenu" </> n <.> ".bin"
{'fraction_non_alphanumeric': 0.07957693276252834, 'fraction_numerical': 0.0, 'mean_word_length': 1.8929351784413693, 'pattern_counts': {'":': 1, '<': 21, '<?xml version=': 0, '>': 46, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3579990', 'n_tokens_mistral': 1072, 'n_tokens_neox': 1031, 'n_words': 380}