{-# LINE 1 "MMAP.hsc" #-}
{-# LANGUAGE CPP, ForeignFunctionInterface, DeriveDataTypeable #-}
{-# LINE 2 "MMAP.hsc" #-}

-- | Provides @mmap@: mapping files into memory.
module MMAP where

import           Control.Exception
import           Control.Monad
import           Data.Bits ((.|.))
import           Data.Monoid
import           Data.Typeable
import           Foreign.C.Types
import           Foreign.Ptr
import           System.Posix.Types


{-# LINE 16 "MMAP.hsc" #-}


-- | Exception thrown when @mmap@ fails.
data MmapException = MmapException
  deriving (Eq, Ord, Show, Typeable)

instance Exception MmapException

-- | Exception thrown when @munmap@ fails.
data MunmapException = MunmapException
  { munmapExceptionSize :: CSize
  , munmapExceptionPtr  :: Ptr ()
  } deriving (Eq, Ord, Show, Typeable)

instance Exception MunmapException


-- | @mmap@ - map files or devices into memory.
--
-- The returned memory should be freed with `c_munmap` after use.
--
-- This is the raw C function, and its return value must be checked
-- according to @man mmap@.
--
-- See `mmap` for a variant that turns bad return values into exceptions.
foreign import ccall unsafe "sys/mman.h mmap"
  -- void *mmap(void *addr, size_t length, int prot, int flags,
  --            int fd, off_t offset)
  c_mmap :: Ptr ()      -- ^ void *addr
         -> CSize       -- ^ size_t length
         -> ProtOption  -- ^ int prot
         -> MmapFlags   -- ^ int flags,
         -> Fd          -- ^ int fd
         -> COff        -- ^ off_t offset
         -> IO (Ptr ()) -- void *mmap


-- | @munmap@ - unmap @mmap@'ed memory.
--
-- This is the raw C function, and its return value must be checked
-- according to @man mmap@.
--
-- See `munmap` for a variant that turns bad return values into exceptions.
foreign import ccall unsafe "sys/mman.h munmap"
  -- int munmap(void *addr, size_t length)
  c_munmap :: Ptr ()  -- ^ void *addr
           -> CSize   -- ^ size_t length
           -> IO CInt -- int munmap


-- | Convenience around `c_mmap`, throwing a `MmapException` on a negative return value.
mmap :: Ptr ()
     -> CSize
     -> ProtOption
     -> MmapFlags
     -> Fd
     -> COff
     -> IO (Ptr ())
mmap addr len prot flags fd offset = do
  ptr <- c_mmap addr len prot flags fd offset
  when (ptr == intPtrToPtr (-1)) $ throwIO MmapException
  return ptr


-- | Convenience around `c_munmap`, throwing a `MunmapException` on a negative return value.
munmap :: Ptr ()
       -> CSize
       -> IO ()
munmap addr len = do
  v <- c_munmap addr len
  when (v == -1) . throwIO $ MunmapException len addr


-- | Describes the desired memory protection of the mapping
-- (and  must  not  conflict  with  the open mode of the file).
--
-- Can be combined using the `Monoid` instance `(<>)`.
newtype ProtOption = ProtOption { unProtOption :: CInt }
  deriving (Eq, Show, Ord)

-- | Pages may be executed.
protExec :: ProtOption
protExec = ProtOption 4
{-# LINE 99 "MMAP.hsc" #-}

-- | Pages may be read.
protRead :: ProtOption
protRead = ProtOption 1
{-# LINE 103 "MMAP.hsc" #-}

-- | Pages may be written.
protWrite :: ProtOption
protWrite = ProtOption 2
{-# LINE 107 "MMAP.hsc" #-}

-- | Pages may not be accessed.
protNone :: ProtOption
protNone = ProtOption 0
{-# LINE 111 "MMAP.hsc" #-}

instance Monoid ProtOption where
  mempty = protNone
  mappend (ProtOption a) (ProtOption b) = ProtOption (a .|. b)


-- | Determines whether updates to the mapping are visible
-- to other processes mapping the same region, and whether updates
-- are carried through to the underlying file.
--
-- This behavior is determined by including exactly one of
-- `mapShared` and `mapPrivate`.
newtype MmapSharedFlag = MmapSharedFlag { unMmapSharedFlag :: CInt }
  deriving (Eq, Show, Ord)

-- | Share this mapping. Updates to the mapping are visible to
-- other processes that map the file, and are carried through to
-- the underlying file. The file may not actually be updated
-- until @msync(2)@ or @munmap()@ is called..
mapShared :: MmapSharedFlag
mapShared = MmapSharedFlag 1
{-# LINE 132 "MMAP.hsc" #-}

-- | Create a private copy-on-write mapping. Updates to the mapping
-- are not visible to other processes mapping the same file, and
-- are not carried through to the underlying file. It is unspecified
-- whether changes made to the file after the @mmap()@ call are
-- visible in the mapped region.
mapPrivate :: MmapSharedFlag
mapPrivate = MmapSharedFlag 2
{-# LINE 140 "MMAP.hsc" #-}


-- | And `MmapSharedFlag` with one or more `MmapOptionalFlag`s.
newtype MmapOptionalFlag = MmapOptionalFlag { unMmapOptionalFlag :: CInt }
  deriving (Eq, Show, Ord)



{-# LINE 148 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
map32Bit :: MmapOptionalFlag
map32Bit = MmapOptionalFlag 64
{-# LINE 151 "MMAP.hsc" #-}

{-# LINE 152 "MMAP.hsc" #-}


{-# LINE 154 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapAnonymous :: MmapOptionalFlag
mapAnonymous = MmapOptionalFlag 32
{-# LINE 157 "MMAP.hsc" #-}

{-# LINE 164 "MMAP.hsc" #-}


{-# LINE 166 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapDenywrite :: MmapOptionalFlag
mapDenywrite = MmapOptionalFlag 2048
{-# LINE 169 "MMAP.hsc" #-}

{-# LINE 170 "MMAP.hsc" #-}


{-# LINE 172 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapFile :: MmapOptionalFlag
mapFile = MmapOptionalFlag 0
{-# LINE 175 "MMAP.hsc" #-}

{-# LINE 176 "MMAP.hsc" #-}


{-# LINE 178 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapFixed :: MmapOptionalFlag
mapFixed = MmapOptionalFlag 16
{-# LINE 181 "MMAP.hsc" #-}

{-# LINE 182 "MMAP.hsc" #-}


{-# LINE 184 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapHugetlb :: MmapOptionalFlag
mapHugetlb = MmapOptionalFlag 262144
{-# LINE 187 "MMAP.hsc" #-}

{-# LINE 188 "MMAP.hsc" #-}


{-# LINE 190 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapLocked :: MmapOptionalFlag
mapLocked = MmapOptionalFlag 8192
{-# LINE 193 "MMAP.hsc" #-}

{-# LINE 194 "MMAP.hsc" #-}


{-# LINE 196 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapNonblock :: MmapOptionalFlag
mapNonblock = MmapOptionalFlag 65536
{-# LINE 199 "MMAP.hsc" #-}

{-# LINE 200 "MMAP.hsc" #-}


{-# LINE 202 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapNoreserve :: MmapOptionalFlag
mapNoreserve = MmapOptionalFlag 16384
{-# LINE 205 "MMAP.hsc" #-}

{-# LINE 206 "MMAP.hsc" #-}


{-# LINE 208 "MMAP.hsc" #-}
-- | See @man mmap@ for a description.
mapStack :: MmapOptionalFlag
mapStack = MmapOptionalFlag 131072
{-# LINE 211 "MMAP.hsc" #-}

{-# LINE 212 "MMAP.hsc" #-}


{-# LINE 218 "MMAP.hsc" #-}

instance Monoid MmapOptionalFlag where
  mempty = MmapOptionalFlag 0
  mappend (MmapOptionalFlag a) (MmapOptionalFlag b) = MmapOptionalFlag (a .|. b)


-- | An `MmapSharedFlag` with one or more `MmapOptionalFlag`s.
newtype MmapFlags = MmapFlags { unMmapFlags :: CInt }
  deriving (Eq, Show, Ord)

-- | Create `MmapFlags` to be passed to `c_mmap` from an `MmapSharedFlag`
-- and one or more `MmapOptionalFlag`s (combine them via `(<>)`,
-- `mempty` for none).
mkMmapFlags :: MmapSharedFlag -> MmapOptionalFlag -> MmapFlags
mkMmapFlags (MmapSharedFlag a) (MmapOptionalFlag b) = MmapFlags (a .|. b)