repos / INblobs / headblob
summary | shortlog | log | tree | annotate | headblob | filehistory
plain
/ src /
src/CommonIO.hs
1 module CommonIO where
2
3 import Math
4 import Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey)
5 import SafetyNet
6
7 import Graphics.UI.WX
8 import Graphics.UI.WXCore
9 import Data.List(elemIndex)
10 import System.Directory
11 import System.IO
12
13 ignoreResult :: IO a -> IO ()
14 ignoreResult action = do { action; return () }
15
16 -- | Writes file to disk. If writing fails, an error
17 -- dialog is shown and False is returned
18 safeWriteFile :: Window a -> String -> String -> IO Bool
19 safeWriteFile parentWindow fileName contents =
20 do{ let tmpName = fileName ++ ".tmp"
21
22 ; -- try to write to .tmp file
23 ; writeOkay <-
24 catch
25 (do { writeFile tmpName contents
26 ; return True
27 })
28 (\ioExc ->
29 do{ errorDialog parentWindow "Save failed"
30 ( "Saving " ++ fileName ++ " failed.\n\n"
31 ++ "Technical reason: " ++ show ioExc ++ "\n\n"
32 ++ "Tip: do you have write permissions and enough disk space?"
33 )
34 ; return False
35 }
36 )
37 ; if not writeOkay then
38 return False
39 else
40 do{ -- remove old file if it exists and then rename .tmp to the real name
41 ; catch (do { exists <- doesFileExist fileName
42 ; when exists $ removeFile fileName
43 ; renameFile tmpName fileName
44 ; return True
45 })
46 (\ioExc ->
47 do{ errorDialog parentWindow "Save failed"
48 ( "The file has been saved to " ++ show tmpName ++ "\nbut "
49 ++ "renaming it to " ++ show fileName ++ " failed.\n\n"
50 ++ "Technical reason: " ++ show ioExc
51 )
52 ; return False
53 }
54 )
55 }}
56
57 strictReadFile :: String -> IO String
58 strictReadFile fname =
59 do{ contents <- readFile fname
60 ; seq (length contents) $ return contents -- force reading of entire file
61 }
62
63 data TextCtrlSize = SingleLine | MultiLine
64
65 myTextDialog :: Window a -> TextCtrlSize -> String -> String -> Bool
66 -> IO (Maybe String)
67 myTextDialog parentWindow size dialogTitle initial selectAll =
68 do{ d <- dialog parentWindow [text := dialogTitle]
69 ; textInput <- (case size of
70 SingleLine -> textEntry
71 MultiLine -> textCtrl)
72 d [ alignment := AlignLeft, text := initial ]
73 ; ok <- button d [text := "Ok"]
74 ; can <- button d [text := "Cancel", identity := wxID_CANCEL]
75 ; buttonSetDefault ok
76 ; set d [layout := column 10 [ hfill $ widget textInput
77 , floatBottomRight $ row 5 [widget ok, widget can]
78 ]
79 ]
80 ; when (not selectAll) $ do set d [ visible := True ]
81 textCtrlSetInsertionPointEnd textInput
82 ; showModal d $ \stop ->
83 do set ok [on command := safetyNet parentWindow $
84 do theText <- get textInput text
85 stop (Just theText)]
86 set can [on command := safetyNet parentWindow $ stop Nothing]
87 }
88
89 -- Dialog for selecting a multiple Strings (0 or more)
90 -- Returns Nothing if Cancel was pressed, otherwise it returns the selected strings
91 multiSelectionDialog :: Window a -> String -> [String] -> [String]
92 -> IO (Maybe [String])
93 multiSelectionDialog parentWindow dialogTitle strings initialSelection =
94 do{ d <- dialog parentWindow
95 [ text := dialogTitle
96 , resizeable := True
97 ]
98 ; p <- panel d []
99 ; theListBox <- multiListBox p
100 [ items := strings
101 , selections :=
102 [ case maybeIndex of
103 Nothing -> internalError "CommonIO" "multiSelectionDialog"
104 ( "initial selection " ++ show s
105 ++ " can not be found in " ++ show strings )
106 Just i -> i
107 | s <- initialSelection
108 , let maybeIndex = elemIndex s strings
109 ]
110 ]
111 ; selectAll <- button p
112 [ text := "Select all"
113 , on command := safetyNet parentWindow $ set theListBox [ selections := take (length strings) [0..] ]
114 ]
115 ; selectNone <- button p
116 [ text := "Select none"
117 , on command := safetyNet parentWindow $ set theListBox [ selections := [] ]
118 ]
119 ; ok <- button p [text := "Ok"]
120 ; can <- button p [text := "Cancel", identity := wxID_CANCEL]
121 ; buttonSetDefault ok
122 ; set d [ layout := container p $
123 column 10 [ vfill $ widget theListBox
124 , row 5 [widget selectAll, widget selectNone, widget ok, widget can]
125 ]
126 , clientSize := sz 300 400
127 ]
128 ; showModal d $ \stop ->
129 do set ok [on command := safetyNet parentWindow $
130 do indices <- get theListBox selections
131 stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))]
132 set can [on command := safetyNet parentWindow $
133 stop Nothing]
134 }
135
136 -- Dialog for selecting a single String
137 -- Returns Nothing if Cancel was pressed, otherwise it returns the selected string
138 singleSelectionDialog :: Window a -> String -> [String] -> (Maybe String)
139 -> IO (Maybe String)
140 singleSelectionDialog _ _ [] _ =
141 internalError "CommonIO" "singleSelectionDialog" "no strings"
142 singleSelectionDialog parentWindow dialogTitle strings initialSelection =
143 do{ d <- dialog parentWindow [ text := dialogTitle, resizeable := True ]
144 ; p <- panel d []
145 ; theListBox <- singleListBox p [ items := strings, selection := 0]
146 ; ifJust initialSelection $ \selString ->
147 case elemIndex selString strings of
148 Nothing -> internalError "CommonIO" "singleSelectionDialog"
149 ( "initial selection " ++ show selString
150 ++ " can not be found in " ++ show strings )
151 Just i -> set theListBox [ selection := i ]
152 ; ok <- button p [text := "Ok"]
153 ; can <- button p [text := "Cancel", identity := wxID_CANCEL]
154 ; buttonSetDefault ok
155 ; set d [ layout := container p $
156 column 10 [ vfill $ widget theListBox
157 , row 5 [widget ok, widget can]
158 ]
159 , clientSize := sz 300 400
160 ]
161 ; showModal d $ \stop ->
162 do set ok [on command := safetyNet parentWindow $
163 do index <- get theListBox selection
164 stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))]
165 set can [on command := safetyNet parentWindow $
166 stop Nothing]
167 }
168
169 -- | Fill a grid from a list of lists of texts. Each list inside the
170 -- big list represents a row. Also set the given number or rows and
171 -- columns to be header: grey background and not editable.
172 -- This function assumes that the normal spreadsheet-like grid header row
173 -- and column have been made invisible.
174 fillGridFromList :: Grid () -> Int -> Int -> [[String]] -> IO ()
175 fillGridFromList _ _ _ [] = return ()
176 fillGridFromList theGrid nrHeaderRows nrHeaderCols list =
177 do{ nrOfCols <- gridGetNumberCols theGrid
178 ; nrOfRows <- gridGetNumberRows theGrid
179 ; when (length list > nrOfRows || maximum (map length list) > nrOfCols) $
180 internalError "Common" "fillGridFromList" "grid is not big enough"
181 ; sequence_ . concat $
182 [ [ do{ gridSetCellValue theGrid rowNr colNr txt
183 ; let isHeaderCell = rowNr < nrHeaderRows || colNr < nrHeaderCols
184 ; gridSetCellBackgroundColour theGrid rowNr colNr
185 (if isHeaderCell then systemGrey else white)
186 ; gridSetReadOnly theGrid rowNr colNr isHeaderCell
187 }
188 | (txt, colNr) <- zip theRow [0..]
189 ]
190 | (theRow, rowNr) <- zip list [0..]
191 ]
192 }
193
194 -- | Export some data (a list of lists of strings) to a tab delimited
195 -- file. The user is asked to choose a location
196 exportToTabFile :: Window a -> String -> String -> [[String]] -> IO ()
197 exportToTabFile parentWindow description fileName theData =
198 do { mFilename <- fileSaveDialog
199 parentWindow
200 False -- remember current directory
201 True -- overwrite prompt
202 ("Export " ++ description)
203 [("Tab delimited files",["*.txt"])]
204 "" -- directory
205 fileName
206 ; ifJust mFilename $ \filename ->
207 ignoreResult (safeWriteFile parentWindow filename (tabDelimited theData))
208 }
209
210 getScreenPPI :: IO Size
211 getScreenPPI =
212 do{ dc <- screenDCCreate
213 ; s <- dcGetPPI dc
214 ; screenDCDelete dc
215 ; return s
216 }
217
218 screenToLogicalPoint :: Size -> Point -> DoublePoint
219 screenToLogicalPoint ppi p =
220 DoublePoint (screenToLogicalX ppi (pointX p))
221 (screenToLogicalY ppi (pointY p))
222
223 logicalToScreenPoint :: Size -> DoublePoint -> Point
224 logicalToScreenPoint ppi doublePoint =
225 pt (logicalToScreenX ppi (doublePointX doublePoint))
226 (logicalToScreenY ppi (doublePointY doublePoint))
227
228 screenToLogicalX :: Size -> Int -> Double
229 screenToLogicalX ppi x =
230 fromIntegral x / (fromIntegral (sizeW ppi) / 2.54)
231
232 logicalToScreenX :: Size -> Double -> Int
233 logicalToScreenX ppi x =
234 truncate (x * fromIntegral (sizeW ppi) / 2.54)
235
236 screenToLogicalY :: Size -> Int -> Double
237 screenToLogicalY ppi y =
238 fromIntegral y / (fromIntegral (sizeH ppi) / 2.54)
239
240 logicalToScreenY :: Size -> Double -> Int
241 logicalToScreenY ppi y =
242 truncate (y * fromIntegral (sizeH ppi) / 2.54)
243
244 -- Create a grid of which the standard labels (A,B,C... for columns
245 -- and 1,2,3... for rows) are invisible
246 mkNoLabelGrid :: Window a -> Int -> Int -> IO (Grid ())
247 mkNoLabelGrid thePanel nrOfRows nrOfCols =
248 do{ theGrid <- gridCreate thePanel idAny rectNull 0
249 ; gridCreateGrid theGrid nrOfRows nrOfCols 0
250 ; gridSetColLabelSize theGrid 0
251 ; gridSetRowLabelSize theGrid 0
252 ; return theGrid
253 }
254
255 resizeGrid :: Grid () -> Int -> Int -> IO ()
256 resizeGrid theGrid nrOfRows nrOfCols =
257 do{ oldNrOfRows <- gridGetNumberRows theGrid
258 ; oldNrOfCols <- gridGetNumberCols theGrid
259 ; when (nrOfRows > oldNrOfRows) . ignoreResult $
260 gridAppendRows theGrid (nrOfRows - oldNrOfRows) False
261 ; when (nrOfRows < oldNrOfRows) . ignoreResult $
262 gridDeleteRows theGrid nrOfRows (oldNrOfRows - nrOfRows) False
263 ; when (nrOfCols > oldNrOfCols) . ignoreResult $
264 gridAppendCols theGrid (nrOfCols - oldNrOfCols) False
265 ; when (nrOfCols < oldNrOfCols) . ignoreResult $
266 gridDeleteCols theGrid nrOfCols (oldNrOfCols - nrOfCols) False
267 }
268
269 -- | Get the position of a frame, if the frame is minimized or maximized
270 -- it is restored to its normal size first. Otherwise, you get
271 -- (-32000, -32000) for a minimized window :-)
272 safeGetPosition :: Frame a -> IO (Int, Int)
273 safeGetPosition f =
274 do{ isMax <- frameIsMaximized f
275 ; isMin <- frameIsIconized f
276 ; when (isMax || isMin) $ frameRestore f
277 ; p <- get f position
278 ; return (pointX p, pointY p)
279 }
280
281 -- Show a dialog with a grid and a save button
282 gridDialogWithSave :: Window a -> String -> Maybe String -> [[String]]
283 -> IO () -> IO ()
284 gridDialogWithSave parentWindow title maybeNote matrixContents saveAction =
285 do{
286 -- Create dialog and panel
287 ; theDialog <- dialog parentWindow
288 [ text := title
289 , resizeable := True
290 ]
291 ; p <- panel theDialog []
292
293 -- Create and fill grid
294 ; theGrid <- mkNoLabelGrid p height width
295 ; gridEnableEditing theGrid False
296 ; fillGridFromList theGrid 0 0 matrixContents
297 ; gridAutoSizeColumns theGrid False
298
299 -- File menu
300 ; saveButton <- button p
301 [ text := "Save as..."
302 , on command := safetyNet parentWindow $ saveAction
303 ]
304
305 -- Dialog layout
306 ; set theDialog
307 [ layout := minsize (sz 600 400) $ column 5
308 ( case maybeNote of
309 Just note -> [ hfill $ label note ]
310 Nothing -> []
311 ++ [ container p $
312 column 5 [ fill $ widget theGrid
313 , row 0 [ widget saveButton, glue ]
314 ]
315 ]
316 )
317 , visible := True
318 ]
319 }
320 where
321 width = maximum . map length $ matrixContents
322 height = length matrixContents
323
324
325 -- | Using bootstrapUI, a record containing all widgets and variables can be created
326 -- at the end of the create function, but still referred to before creation
327 -- NOTE: widgets should not be referred to in a strict way because this will
328 -- cause a loop
329 bootstrapUI :: (uistate -> IO uistate) -> IO ()
330 bootstrapUI fIO =
331 do { fixIO fIO
332 ; return ()
333 }
Crece desde el pueblo el futuro / crece desde el pie