Ticket #3710: FilePlus.hs

File FilePlus.hs, 1.9 KB (added by dherington, 4 years ago)

FFI-based extension module

Line 
1{-# INCLUDE <windows.h> #-}
2{-# LINE 1 "FilePlus.hsc" #-}
3module FilePlus where
4{-# LINE 2 "FilePlus.hsc" #-}
5
6import System.Win32.Types (HANDLE)
7import System.Win32.File (LPOVERLAPPED, win32_WriteFile)
8import Data.Word (Word32, Word64)
9import Foreign.Ptr (Ptr)
10import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrBytes)
11import Foreign.Storable (peekByteOff, pokeByteOff)
12import Foreign.C.String (withCAStringLen)
13import Control.Monad (unless)
14
15
16
17{-# LINE 14 "FilePlus.hsc" #-}
18
19type T_DWORD = Word32
20{-# LINE 16 "FilePlus.hsc" #-}
21
22
23-- The type of the size of a memory object (in bytes)
24type MemSize = Word64
25
26-- (Maybe) allocates an OVERLAPPED structure and fills it with the given position.
27withOverlappedFromPosition :: (Integral i) => Maybe MemSize -> (Maybe LPOVERLAPPED -> IO i) -> IO i
28withOverlappedFromPosition mbPosition func =
29    case mbPosition of
30      Just position -> do
31          let (hi,lo) = position `quotRem` (2^32)
32          fp <- mallocForeignPtrBytes (20)
33{-# LINE 28 "FilePlus.hsc" #-}
34          withForeignPtr fp $ \ p -> do
35              (\hsc_ptr -> pokeByteOff hsc_ptr 12) p (fromIntegral hi :: T_DWORD)
36{-# LINE 30 "FilePlus.hsc" #-}
37              (\hsc_ptr -> pokeByteOff hsc_ptr 8)     p (fromIntegral lo :: T_DWORD)
38{-# LINE 31 "FilePlus.hsc" #-}
39              func (Just p)
40      Nothing -> func Nothing
41
42-- Writes `(length string)` bytes to handle `handle`.
43-- Starts at `mbStart` position if given, else current position.
44writeFile' :: HANDLE -> Maybe MemSize -> String -> IO ()
45writeFile' handle mbStart string = do
46  withCAStringLen string $ \ (p_buffer, len) -> do
47    let length = fromIntegral len
48    actual <- withOverlappedFromPosition mbStart $ win32_WriteFile handle p_buffer length
49    unless (actual == length) $
50      fail $ "writeFile tried to write " ++ show length ++ " bytes but wrote only " ++ show actual