{-# LANGUAGE Trustworthy #-}

-- | Allows a block to be requested an unlimited number of times without using up the address space. N.B. Usage of memory cannot cross multiples of 64 kibibytes.
module File.Mapper where

import Data.Map
import Data.Word
import Data.Int
import Data.Traversable (mapM)
import Foreign.Ptr
import Control.Concurrent.MVar
import Control.Monad (liftM, void)
import Control.Exception
import System.IO.MMap
import System.IO
import Prelude hiding (lookup, catch, mapM)

type Pointer = Word32

data Table = Table !FilePath !(MVar (Map Pointer (Ptr ())))

newTable path = liftM (Table path) (newMVar empty)

mapBlock :: Table -> Pointer -> IO (Ptr a)
mapBlock (Table path mp) ptr = modifyMVar mp $ \mp -> case lookup aligned mp of
	Just p -> return (mp, castPtr (plusPtr p (fromIntegral r)))
	Nothing -> liftM (\(p, _, _, _) -> (insert aligned p mp, plusPtr p (fromIntegral r))) $ mmapFilePtr path ReadWrite (Just (fromIntegral aligned, 65536))
	where
	(d, r) = ptr `divMod` 65536
	aligned = 65536 * d

newBlock :: Table -> IO (Ptr a, Int)
newBlock (Table path mp) = do
	-- Get the file size.
	hdl <- openBinaryFile path ReadWriteMode
	fileSz <- finally (hFileSize hdl) (hClose hdl)

	-- Add a new block at the end.
	(p, _, _, _) <- mmapFilePtr path ReadWriteEx (Just (fromInteger fileSz, 65536))

	-- Store it.
	modifyMVar_ mp (return . insert (fromInteger fileSz) (castPtr p))

	return (p, fromInteger fileSz)

unmapAll (Table _ mvar) = do
	mp <- takeMVar mvar
	void $ mapM (\ptr -> munmapFilePtr ptr 65536) mp