git.iko.soy/elk
on 07acefe help sign in
elk/builder/src/File/IO.hs
234 lines 5.2 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 _ -> return Nothing
53 Right a -> return (Just a)
57-- WRITE UTF-8
60writeUtf8 :: FilePath -> BS.ByteString -> IO ()
61writeUtf8 filePath content =
62 withUtf8 filePath IO.WriteMode $ \handle ->
63 BS.hPut handle content
66withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
67withUtf8 filePath mode callback =
68 IO.withFile filePath mode $ \handle ->
69 do IO.hSetEncoding handle IO.utf8
70 callback handle
74-- READ UTF-8
77readUtf8 :: FilePath -> IO BS.ByteString
78readUtf8 filePath =
79 withUtf8 filePath IO.ReadMode $ \handle ->
80 modifyIOError (encodingError filePath) $
81 do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
82 let readSize = max 0 (fromIntegral fileSize) + 1
83 hGetContentsSizeHint handle readSize (max 255 readSize)
86useZeroIfNotRegularFile :: IOException -> IO Integer
87useZeroIfNotRegularFile _ =
88 return 0
91hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
92hGetContentsSizeHint handle =
93 readChunks []
94 where
95 readChunks chunks readSize incrementSize =
96 do fp <- BS.mallocByteString readSize
97 readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
98 let chunk = BS.PS fp 0 readCount
99 if readCount < readSize && readSize > 0
100 then return $! BS.concat (reverse (chunk:chunks))
101 else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
104encodingError :: FilePath -> IOError -> IOError
105encodingError filePath ioErr =
106 case ioeGetErrorType ioErr of
107 InvalidArgument ->
108 annotateIOError
109 (userError "Bad encoding; the file must be valid UTF-8")
110 ""
111 Nothing
112 (Just filePath)
114 _ ->
115 ioErr
119-- WRITE BUILDER
122writeBuilder :: FilePath -> B.Builder -> IO ()
123writeBuilder path builder =
124 IO.withBinaryFile path IO.WriteMode $ \handle ->
125 do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
126 B.hPutBuilder handle builder
130-- WRITER
133newtype Writer =
134 Writer (IO.Handle -> IO ())
137put :: FilePath -> Writer -> IO ()
138put path (Writer callback) =
139 IO.withBinaryFile path IO.WriteMode callback
142putByteString :: BS.ByteString -> Writer
143putByteString chunk =
144 Writer $ \handle ->
145 BS.hPut handle chunk
148putBuilder :: B.Builder -> Writer
149putBuilder builder =
150 Writer $ \handle ->
151 B.hPutBuilder handle builder
154putFile :: FilePath -> Writer
155putFile path =
156 Writer $ \sink ->
157 IO.withBinaryFile path IO.ReadMode $ \source ->
158 putHelp source sink
161putHelp :: IO.Handle -> IO.Handle -> IO ()
162putHelp source sink =
163 do chunk <- BS.hGet source B.defaultChunkSize
164 if BS.null chunk
165 then return ()
166 else
167 do BS.hPut sink chunk
168 putHelp source sink
172-- EXISTS
175exists :: FilePath -> IO Bool
176exists =
177 Dir.doesFileExist
181-- REMOVE FILES
184remove :: FilePath -> IO ()
185remove filePath =
186 do exists_ <- Dir.doesFileExist filePath
187 if exists_
188 then Dir.removeFile filePath
189 else return ()
192removeDir :: FilePath -> IO ()
193removeDir path =
194 do exists_ <- Dir.doesDirectoryExist path
195 if exists_
196 then Dir.removeDirectoryRecursive path
197 else return ()
201-- FIND FILES
204find :: FilePath -> IO (Maybe FilePath)
205find name =
206 do subDir <- Dir.getCurrentDirectory
207 findHelp name (FP.splitDirectories subDir)
210findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
211findHelp name dirs =
212 if null dirs then
213 return Nothing
215 else
216 do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
217 if exists_
218 then return (Just (FP.joinPath dirs))
219 else findHelp name (init dirs)
223-- HELPER
226andM :: (Monad m) => [m Bool] -> m Bool
227andM checks =
228 case checks of
229 [] ->
230 return True
232 check : otherChecks ->
233 do bool <- check
234 if bool then andM otherChecks else return False