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 qualified as V
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
  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 Pulse
floats = 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
          (ComputeSound SamplingInfo
-> MemoComputeSound -> IO (SoundResult Pulse, ComputationInfo)
compute) = forall a. (SamplingInfo -> Int -> a) -> ComputeSound a
makeWithIndexFunction @Pulse (\SamplingInfo
_ Int
index -> Vector Pulse
floats Vector Pulse -> Int -> Pulse
forall a. Storable a => Vector a -> Int -> a
V.! Int
index)
      SamplingInfo
-> MemoComputeSound -> IO (SoundResult Pulse, ComputationInfo)
compute SamplingInfo
si MemoComputeSound
memo
    else 
    do
      (MVector RealWorld S Pulse -> IO ()
writeResult, ComputationInfo
ci) <- ComputeSound Pulse
-> SamplingInfo
-> MemoComputeSound
-> IO (MVector RealWorld S Pulse -> IO (), ComputationInfo)
asWriteResult ComputeSound Pulse
cs SamplingInfo
si MemoComputeSound
memo
      (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 ()) -> SoundResult Pulse)
-> (MVector RealWorld S Pulse -> IO ()) -> SoundResult Pulse
forall a b. (a -> b) -> a -> b
$ \MVector RealWorld S Pulse
dest -> do
            MVector RealWorld S Pulse -> IO ()
writeResult MVector RealWorld S Pulse
dest
            Array S Int Pulse
floats <- Comp -> MArray (PrimState IO) S Int Pulse -> IO (Array S Int 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
$ Array S Int Pulse -> Vector Pulse
forall ix e. Index ix => Array S ix e -> Vector e
M.toStorableVector Array S Int Pulse
floats
            FilePath -> ByteString -> IO ()
BL.writeFile FilePath
filePath ByteString
bytes,
          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
  Array S Int Pulse
floats <- SamplingInfo -> ComputeSound Pulse -> IO (Array S Int 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) -> Array S Int 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) Array S Int Pulse
floats