git.iko.soy/elk
on 83cd588 help sign in
elk/builder/src/File/IO.hs
237 lines 5.3 kB history raw
1module File.IO
2 ( writeBinary, readBinary
3 , writeUtf8, readUtf8
4 , writeBuilder
5 , Writer
6 , put
7 , putByteString
8 , putBuilder
9 , putFile
10 , exists
11 , remove, removeDir
12 , find
13 , andM
14 )
15 where
18import Control.Exception (catch)
19import qualified Data.Binary as Binary
20import qualified Data.ByteString as BS
21import qualified Data.ByteString.Internal as BS
22import qualified Data.ByteString.Builder as B
23import qualified Data.ByteString.Builder.Extra as B (defaultChunkSize)
24import qualified Foreign.ForeignPtr as FPtr
25import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
26import qualified System.Directory as Dir
27import System.FilePath ((</>))
28import qualified System.FilePath as FP
29import qualified System.IO as IO
30import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
34-- BINARY
37writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
38writeBinary path value =
39 do let dir = FP.dropFileName path
40 Dir.createDirectoryIfMissing True dir
41 Binary.encodeFile path value
44readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
45readBinary path =
46 do exists_ <- Dir.doesFileExist path
47 if not exists_
48 then return Nothing
49 else
50 do result <- Binary.decodeFileOrFail path
51 case result of
52 Left _ ->
53 return Nothing
55 Right value ->
56 return value
60-- WRITE UTF-8
63writeUtf8 :: FilePath -> BS.ByteString -> IO ()
64writeUtf8 filePath content =
65 withUtf8 filePath IO.WriteMode $ \handle ->
66 BS.hPut handle content
69withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
70withUtf8 filePath mode callback =
71 IO.withFile filePath mode $ \handle ->
72 do IO.hSetEncoding handle IO.utf8
73 callback handle
77-- READ UTF-8
80readUtf8 :: FilePath -> IO BS.ByteString
81readUtf8 filePath =
82 withUtf8 filePath IO.ReadMode $ \handle ->
83 modifyIOError (encodingError filePath) $
84 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
85 let readSize = max 0 (fromIntegral fileSize) + 1
86 hGetContentsSizeHint handle readSize (max 255 readSize)
89useZeroIfNotRegularFile :: IOException -> IO Integer
90useZeroIfNotRegularFile _ =
91 return 0
94hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
95hGetContentsSizeHint handle =
96 readChunks []
97 where
98 readChunks chunks readSize incrementSize =
99 do fp <- BS.mallocByteString readSize
100 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
101 let chunk = BS.PS fp 0 readCount
102 if readCount < readSize && readSize > 0
103 then return $! BS.concat (reverse (chunk:chunks))
104 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
107encodingError :: FilePath -> IOError -> IOError
108encodingError filePath ioErr =
109 case ioeGetErrorType ioErr of
110 InvalidArgument ->
111 annotateIOError
112 (userError "Bad encoding; the file must be valid UTF-8")
113 ""
114 Nothing
115 (Just filePath)
117 _ ->
118 ioErr
122-- WRITE BUILDER
125writeBuilder :: FilePath -> B.Builder -> IO ()
126writeBuilder path builder =
127 IO.withBinaryFile path IO.WriteMode $ \handle ->
128 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
129 B.hPutBuilder handle builder
133-- WRITER
136newtype Writer =
137 Writer (IO.Handle -> IO ())
140put :: FilePath -> Writer -> IO ()
141put path (Writer callback) =
142 IO.withBinaryFile path IO.WriteMode callback
145putByteString :: BS.ByteString -> Writer
146putByteString chunk =
147 Writer $ \handle ->
148 BS.hPut handle chunk
151putBuilder :: B.Builder -> Writer
152putBuilder builder =
153 Writer $ \handle ->
154 B.hPutBuilder handle builder
157putFile :: FilePath -> Writer
158putFile path =
159 Writer $ \sink ->
160 IO.withBinaryFile path IO.ReadMode $ \source ->
161 putHelp source sink
164putHelp :: IO.Handle -> IO.Handle -> IO ()
165putHelp source sink =
166 do chunk <- BS.hGet source B.defaultChunkSize
167 if BS.null chunk
168 then return ()
169 else
170 do BS.hPut sink chunk
171 putHelp source sink
175-- EXISTS
178exists :: FilePath -> IO Bool
179exists =
180 Dir.doesFileExist
184-- REMOVE FILES
187remove :: FilePath -> IO ()
188remove filePath =
189 do exists_ <- Dir.doesFileExist filePath
190 if exists_
191 then Dir.removeFile filePath
192 else return ()
195removeDir :: FilePath -> IO ()
196removeDir path =
197 do exists_ <- Dir.doesDirectoryExist path
198 if exists_
199 then Dir.removeDirectoryRecursive path
200 else return ()
204-- FIND FILES
207find :: FilePath -> IO (Maybe FilePath)
208find name =
209 do subDir <- Dir.getCurrentDirectory
210 findHelp name (FP.splitDirectories subDir)
213findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
214findHelp name dirs =
215 if null dirs then
216 return Nothing
218 else
219 do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
220 if exists_
221 then return (Just (FP.joinPath dirs))
222 else findHelp name (init dirs)
226-- HELPER
229andM :: (Monad m) => [m Bool] -> m Bool
230andM checks =
231 case checks of
232 [] ->
233 return True
235 check : otherChecks ->
236 do bool <- check
237 if bool then andM otherChecks else return False