diff --git a/EdenTV.hs b/EdenTV.hs --- a/EdenTV.hs +++ b/EdenTV.hs @@ -43,6 +43,7 @@ import System.CPUTime import System.IO import Data.List +import Data.Text(pack, unpack) import RTSEventsParser import System.IO.Unsafe @@ -853,96 +854,97 @@ -- Attention: parts of the window, that are off-screen, are not being exported! --saveToFile :: DrawColor -> Events -> (Int,Int,Int) -> Int -> ViewerState -> DrawingArea -> IO () saveToFile drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs traces (nt,np,nm) v st edentvState pic = do - -- redraw window (refresh the image) - widgetQueueDraw pic - -- extract Image from Window: - win <- widgetGetDrawWindow pic - visibleRegion <- drawableGetVisibleRegion win - visible <- regionGetClipbox visibleRegion - let Rectangle visX visY visW visH = visible - mPixbuf <- pixbufGetFromDrawable win visible - -- ask for filename: - selectFilename <- fileChooserDialogNew (Just "Save Picture") Nothing - FileChooserActionSave [("_Save",ResponseOk),("Cancel",ResponseCancel)] - dialogSetDefaultResponse selectFilename ResponseOk - -- add filters for special filetypes: - filterAll <- fileFilterNew - filterAll `fileFilterAddPattern` "*.*" - filterAll `fileFilterSetName` "all Files" - filterImg <- fileFilterNew -- to select the filetype - fileFilterAddPixbufFormats filterImg -- add imagetypes - filterImg `fileFilterAddPattern` "*.pdf" - filterImg `fileFilterSetName` "all known images" - selectFilename `fileChooserAddFilter` filterAll -- add filters to dialog - selectFilename `fileChooserAddFilter` filterImg - filterPDF <- fileFilterNew - filterPDF `fileFilterAddPattern` ("*.pdf") - filterPDF `fileFilterSetName` "Portable Document Format (*.pdf)" - selectFilename `fileChooserAddFilter` filterPDF - addSpecialFilters selectFilename pixbufGetFormats - -- show and run the dialog: - widgetShow selectFilename - response <- dialogRun selectFilename - case response of - ResponseCancel -> widgetDestroy selectFilename -- don't save the image - ResponseOk -> do - Just filename <- fileChooserGetFilename selectFilename - let filetype = reverse (takeWhile (/= '.') (reverse filename)) -- extract the choosen filetype - if (elem filetype ["bmp","jpg","jpeg","png", "pdf"]) -- filetype recognized? - then do - widgetDestroy selectFilename - pathExists <- doesDirectoryExist filename - fileExists <- doesFileExist filename - doWrite <- if pathExists - then do errorMessage (filename ++ " is a Directory.") - return False - else if fileExists - then yesNoMessage (filename ++ " exists, overwrite?") - else return True - if doWrite - then case mPixbuf of - Nothing -> error "saveToFile: Window not visible" - Just p -> do - if (elem filetype ["bmp","jpg","jpeg","png"]) - then pixbufSave p filename (if filetype == "jpg" then "jpeg" else filetype) [] - else do - - case v of - 3 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawGroupProcesses) pic traces st edentvState nt ) - 2 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawThreads) pic traces st edentvState nt ) - 1 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawProcesses) pic traces st edentvState nt ) - _ -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawMachines) pic traces st edentvState nt ) - else return () - else do -- unknown filetype - widgetDestroy selectFilename - gladeXML <- edentvGladeFile ["dlg_err_save_filetype", "accelgroup1"] - dlg <- builderGetObject gladeXML castToDialog "dlg_err_save_filetype" - dlg `afterResponse` (\_ -> widgetDestroy dlg) - widgetShowAll dlg - -- allowed filetypes: png bmp wbmp gif ico ani jpeg pnm ras tiff xpm xbm tga - -- supported: png, bmp, jpeg - _ -> widgetDestroy selectFilename - return () - where addSpecialFilters _ [] = return () - addSpecialFilters dlg (f:fs) = do - filter <- fileFilterNew - filter `fileFilterAddPattern` ("*." ++ f) - case f of - "pdf" -> do - filter `fileFilterSetName` "Portable Document Format(*.pdf)" - dlg `fileChooserAddFilter` filter - "png" -> do - filter `fileFilterSetName` "Portable Networks Graphics (*.png)" - dlg `fileChooserAddFilter` filter - "bmp" -> do - filter `fileFilterSetName` "Windows Bitmap (*.bmp)" - dlg `fileChooserAddFilter` filter - "jpeg" -> do - filter `fileFilterAddPattern` ("*.jpg") - filter `fileFilterSetName` "Joint Photographic Experts Group (*.jpeg)" - dlg `fileChooserAddFilter` filter - _ -> return () - addSpecialFilters dlg fs + -- redraw window (refresh the image) + widgetQueueDraw pic + -- extract Image from Window: + win <- widgetGetDrawWindow pic + visibleRegion <- drawableGetVisibleRegion win + visible <- regionGetClipbox visibleRegion + let Rectangle visX visY visW visH = visible + mPixbuf <- pixbufGetFromDrawable win visible + -- ask for filename: + selectFilename <- fileChooserDialogNew (Just "Save Picture") Nothing + FileChooserActionSave [("_Save",ResponseOk),("Cancel",ResponseCancel)] + dialogSetDefaultResponse selectFilename ResponseOk + -- add filters for special filetypes: + filterAll <- fileFilterNew + filterAll `fileFilterAddPattern` "*.*" + filterAll `fileFilterSetName` "all Files" + filterImg <- fileFilterNew -- to select the filetype + fileFilterAddPixbufFormats filterImg -- add imagetypes + filterImg `fileFilterAddPattern` "*.pdf" + filterImg `fileFilterSetName` "all known images" + selectFilename `fileChooserAddFilter` filterAll -- add filters to dialog + selectFilename `fileChooserAddFilter` filterImg + filterPDF <- fileFilterNew + filterPDF `fileFilterAddPattern` ("*.pdf") + filterPDF `fileFilterSetName` "Portable Document Format (*.pdf)" + selectFilename `fileChooserAddFilter` filterPDF + addSpecialFilters selectFilename pixbufGetFormats + -- show and run the dialog: + widgetShow selectFilename + response <- dialogRun selectFilename + case response of + ResponseCancel -> widgetDestroy selectFilename -- don't save the image + ResponseOk -> do + Just filename <- fileChooserGetFilename selectFilename + let filetype = reverse (takeWhile (/= '.') (reverse filename)) -- extract the choosen filetype + if (elem filetype ["bmp","jpg","jpeg","png", "pdf"]) -- filetype recognized? + then do + widgetDestroy selectFilename + pathExists <- doesDirectoryExist filename + fileExists <- doesFileExist filename + doWrite <- if pathExists + then do errorMessage (filename ++ " is a Directory.") + return False + else if fileExists + then yesNoMessage (filename ++ " exists, overwrite?") + else return True + if doWrite + then case mPixbuf of + Nothing -> error "saveToFile: Window not visible" + Just p -> do + if (elem filetype ["bmp","jpg","jpeg","png"]) + then pixbufSave p filename (pack $ if filetype == "jpg" then "jpeg" else filetype) ([] :: [(String, String)]) + else do + case v of + 3 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawGroupProcesses) pic traces st edentvState nt ) + 2 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawThreads) pic traces st edentvState nt ) + 1 -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawProcesses) pic traces st edentvState nt ) + _ -> withPDFSurface filename (fromIntegral visW) (fromIntegral visH) (\s -> drawAnyPic drawBlockMsgs drawStartupMarker hideStartupPhase drawDataMsgs drawSystemMsgs (-(fromIntegral visX)) (-(fromIntegral visY)) (renderWith s) (drawMachines) pic traces st edentvState nt ) + else return () + else do -- unknown filetype + widgetDestroy selectFilename + gladeXML <- edentvGladeFile ["dlg_err_save_filetype", "accelgroup1"] + dlg <- builderGetObject gladeXML castToDialog "dlg_err_save_filetype" + dlg `afterResponse` (\_ -> widgetDestroy dlg) + widgetShowAll dlg + -- allowed filetypes: png bmp wbmp gif ico ani jpeg pnm ras tiff xpm xbm tga + -- supported: png, bmp, jpeg + _ -> widgetDestroy selectFilename + return () + where + addSpecialFilters :: (FileChooserClass a) => a -> [ImageFormat] -> IO () + addSpecialFilters _ [] = return () + addSpecialFilters dlg (f:fs) = do + filter <- fileFilterNew + filter `fileFilterAddPattern` ("*." ++ (unpack f)) + case unpack f of + "pdf" -> do + filter `fileFilterSetName` "Portable Document Format(*.pdf)" + dlg `fileChooserAddFilter` filter + "png" -> do + filter `fileFilterSetName` "Portable Networks Graphics (*.png)" + dlg `fileChooserAddFilter` filter + "bmp" -> do + filter `fileFilterSetName` "Windows Bitmap (*.bmp)" + dlg `fileChooserAddFilter` filter + "jpeg" -> do + filter `fileFilterAddPattern` ("*.jpg") + filter `fileFilterSetName` "Joint Photographic Experts Group (*.jpeg)" + dlg `fileChooserAddFilter` filter + _ -> return () + addSpecialFilters dlg fs -- start GUI main :: IO () diff --git a/edentv.cabal b/edentv.cabal --- a/edentv.cabal +++ b/edentv.cabal @@ -1,5 +1,5 @@ name: edentv -version: 4.9.1 +version: 4.9.2 synopsis: A Tool to Visualize Parallel Functional Program Executions description: The Eden Trace Viewer is a tool designed to help programmers optimize Eden programs by visualising traces @@ -37,10 +37,11 @@ filepath, directory, zip-archive, - gtk >= 0.12, + gtk >= 0.13, cairo >= 0.12, array, - ghc-events-parallel >= 0.5.0.1 + ghc-events-parallel >= 0.5.0.1, + text GHC-Options: -rtsopts