module LambdaSound.Cache (cache) where

import Codec.Compression.GZip (compress, decompress)
import Control.Monad.IO.Class (MonadIO (..))
import Data.ByteString (fromStrict, toStrict)
import Data.ByteString.Lazy qualified as BL
import Data.Hashable (hash)
import Data.Massiv.Array qualified as M
import Data.Massiv.Array.Unsafe qualified as MU
import Data.Vector.Storable.ByteString (byteStringToVector, vectorToByteString)
import Data.Word
import LambdaSound.Sound
import LambdaSound.Sound.ComputeSound
import LambdaSound.Sound.Types
import System.Directory
import System.FilePath (joinPath)

-- | Caches a sound. If the sound is cached, then
-- the sound gets read from the XDG cache directory and does not have to
-- be computed again.
--
-- It might load a cached sound which which is incorrect, but this should be very unlikely
cache :: Sound d Pulse -> Sound d Pulse
cache :: forall (d :: SoundDuration). Sound d Pulse -> Sound d Pulse
cache (TimedSound Duration
d ComputeSound Pulse
msc) = Duration -> ComputeSound Pulse -> Sound 'T Pulse
forall a. Duration -> ComputeSound a -> Sound 'T a
TimedSound Duration
d (ComputeSound Pulse -> Sound 'T Pulse)
-> ComputeSound Pulse -> Sound 'T Pulse
forall a b. (a -> b) -> a -> b
$ ComputeSound Pulse -> ComputeSound Pulse
cacheComputation ComputeSound Pulse
msc
cache (InfiniteSound ComputeSound Pulse
msc) = ComputeSound Pulse -> Sound 'I Pulse
forall a. ComputeSound a -> Sound 'I a
InfiniteSound (ComputeSound Pulse -> Sound 'I Pulse)
-> ComputeSound Pulse -> Sound 'I Pulse
forall a b. (a -> b) -> a -> b
$ ComputeSound Pulse -> ComputeSound Pulse
cacheComputation ComputeSound Pulse
msc

cacheComputation :: ComputeSound Pulse -> ComputeSound Pulse
cacheComputation :: ComputeSound Pulse -> ComputeSound Pulse
cacheComputation ComputeSound Pulse
cs = (SamplingInfo
 -> MemoComputeSound -> IO (SoundResult Pulse, ComputationInfo))
-> ComputeSound Pulse
forall a.
(SamplingInfo
 -> MemoComputeSound -> IO (SoundResult a, ComputationInfo))
-> ComputeSound a
ComputeSound ((SamplingInfo
  -> MemoComputeSound -> IO (SoundResult Pulse, ComputationInfo))
 -> ComputeSound Pulse)
-> (SamplingInfo
    -> MemoComputeSound -> IO (SoundResult Pulse, ComputationInfo))
-> ComputeSound Pulse
forall a b. (a -> b) -> a -> b
$ \SamplingInfo
si MemoComputeSound
memo -> do
  (MVector RealWorld S Pulse -> IO ()
writeSamples, ComputationInfo
ci) <- ComputeSound Pulse
-> SamplingInfo
-> MemoComputeSound
-> IO (MVector RealWorld S Pulse -> IO (), ComputationInfo)
asWriteResult ComputeSound Pulse
cs SamplingInfo
si MemoComputeSound
memo

  let tryCache :: MVector RealWorld S Pulse -> IO ()
tryCache MVector RealWorld S Pulse
dest = do
        let memoInfo :: MemoInfo
memoInfo = SamplingInfo -> ComputationInfo -> MemoInfo
MemoInfo SamplingInfo
si ComputationInfo
ci

        Maybe (Vector S Pulse)
memoized <- MemoComputeSound -> MemoInfo -> IO (Maybe (Vector S Pulse))
lookupMemoizedComputeSound MemoComputeSound
memo MemoInfo
memoInfo

        case Maybe (Vector S Pulse)
memoized of
          Just Vector S Pulse
memoSource -> do
            Vector S Pulse -> MVector RealWorld S Pulse -> IO ()
copyArrayIntoMArray Vector S Pulse
memoSource MVector RealWorld S Pulse
dest
          Maybe (Vector S Pulse)
Nothing -> do
            Word64
key <- IO Word64 -> IO Word64
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word64 -> IO Word64) -> IO Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ ComputeSound Pulse -> IO Word64
computeCacheKey ComputeSound Pulse
cs
            FilePath
cacheDir <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgCache FilePath
"lambdasound"
            let directoryPath :: FilePath
directoryPath = [FilePath] -> FilePath
joinPath [FilePath
cacheDir, Word64 -> FilePath
forall a. Show a => a -> FilePath
show Word64
key]
            IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
directoryPath

            let filePath :: FilePath
filePath = [FilePath] -> FilePath
joinPath [FilePath
directoryPath, Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ SamplingInfo
si.samples]

            Bool
exists <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
filePath
            if Bool
exists
              then do
                ByteString
file <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BL.readFile FilePath
filePath
                let floats :: Vector S Pulse
floats = Comp -> Vector Pulse -> Vector S Pulse
forall e. Comp -> Vector e -> Vector S e
M.fromStorableVector Comp
M.Seq (Vector Pulse -> Vector S Pulse) -> Vector Pulse -> Vector S Pulse
forall a b. (a -> b) -> a -> b
$ ByteString -> Vector Pulse
forall a. Storable a => ByteString -> Vector a
byteStringToVector (ByteString -> Vector Pulse) -> ByteString -> Vector Pulse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
file
                MemoComputeSound -> MemoInfo -> Vector S Pulse -> IO ()
memoizeComputeSound MemoComputeSound
memo MemoInfo
memoInfo Vector S Pulse
floats
                MVector RealWorld S Pulse -> Vector S Pulse -> IO ()
forall r' ix' e r ix (m :: * -> *).
(Load r' ix' e, Manifest r e, Index ix, MonadIO m) =>
MArray RealWorld r ix e -> Array r' ix' e -> m ()
M.computeInto MVector RealWorld S Pulse
dest Vector S Pulse
floats
              else do
                MVector RealWorld S Pulse -> IO ()
writeSamples MVector RealWorld S Pulse
dest
                Vector S Pulse
floats <- Comp -> MArray (PrimState IO) S Int Pulse -> IO (Vector S Pulse)
forall r e ix (m :: * -> *).
(Manifest r e, Index ix, PrimMonad m) =>
Comp -> MArray (PrimState m) r ix e -> m (Array r ix e)
forall ix (m :: * -> *).
(Index ix, PrimMonad m) =>
Comp -> MArray (PrimState m) S ix Pulse -> m (Array S ix Pulse)
MU.unsafeFreeze Comp
M.Seq MVector RealWorld S Pulse
MArray (PrimState IO) S Int Pulse
dest
                let bytes :: ByteString
bytes = ByteString -> ByteString
compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Pulse -> ByteString
forall a. Storable a => Vector a -> ByteString
vectorToByteString (Vector Pulse -> ByteString) -> Vector Pulse -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector S Pulse -> Vector Pulse
forall ix e. Index ix => Array S ix e -> Vector e
M.toStorableVector Vector S Pulse
floats
                FilePath -> ByteString -> IO ()
BL.writeFile FilePath
filePath ByteString
bytes

  (SoundResult Pulse, ComputationInfo)
-> IO (SoundResult Pulse, ComputationInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((MVector RealWorld S Pulse -> IO ()) -> SoundResult Pulse
WriteResult MVector RealWorld S Pulse -> IO ()
tryCache, ComputationInfo
ci)

computeCacheKey :: ComputeSound Pulse -> IO Word64
computeCacheKey :: ComputeSound Pulse -> IO Word64
computeCacheKey ComputeSound Pulse
cs = do
  let sr :: SamplingInfo
sr = Hz -> Duration -> SamplingInfo
makeSamplingInfo Hz
50 Duration
1
  Vector S Pulse
floats <- SamplingInfo -> ComputeSound Pulse -> IO (Vector S Pulse)
sampleComputeSound SamplingInfo
sr ComputeSound Pulse
cs
  Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ [Pulse] -> Int
forall a. Hashable a => a -> Int
hash ([Pulse] -> Int) -> [Pulse] -> Int
forall a b. (a -> b) -> a -> b
$ Array D Int Pulse -> [Pulse]
forall ix r e. (Index ix, Source r e) => Array r ix e -> [e]
M.toList (Array D Int Pulse -> [Pulse]) -> Array D Int Pulse -> [Pulse]
forall a b. (a -> b) -> a -> b
$ (Pulse -> Pulse) -> Vector S Pulse -> Array D Int Pulse
forall ix r e' e.
(Index ix, Source r e') =>
(e' -> e) -> Array r ix e' -> Array D ix e
M.map (Pulse -> Pulse -> Pulse
forall a. Num a => a -> a -> a
* Pulse
1000) Vector S Pulse
floats