File: Dialogs.hs

package info (click to toggle)
threadscope 0.2.14.1-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm
  • size: 580 kB
  • sloc: haskell: 5,457; ansic: 10; makefile: 7
file content (162 lines) | stat: -rw-r--r-- 5,724 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
{-# LANGUAGE TemplateHaskell #-}
module GUI.Dialogs where

import GUI.DataFiles (loadLogo)
import Paths_threadscope (version)

import Graphics.UI.Gtk

import Data.Version (showVersion)
import System.FilePath


-------------------------------------------------------------------------------

aboutDialog :: WindowClass window => window -> IO ()
aboutDialog parent
 = do dialog <- aboutDialogNew
      logo <- $loadLogo
      set dialog [
         aboutDialogName      := "ThreadScope",
         aboutDialogVersion   := showVersion version,
         aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.",
         aboutDialogComments  := "A GHC eventlog profile viewer",
         aboutDialogAuthors   := ["Donnie Jones <donnie@darthik.com>",
                                  "Simon Marlow <simonm@microsoft.com>",
                                  "Satnam Singh <s.singh@ieee.org>",
                                  "Duncan Coutts <duncan@well-typed.com>",
                                  "Mikolaj Konarski <mikolaj@well-typed.com>",
                                  "Nicolas Wu <nick@well-typed.com>",
                                  "Eric Kow <eric@well-typed.com>"],
         aboutDialogLogo      := logo,
         aboutDialogWebsite   := "http://www.haskell.org/haskellwiki/ThreadScope",
         windowTransientFor   := toWindow parent
        ]
      onResponse dialog $ \_ -> widgetDestroy dialog
      widgetShow dialog

-------------------------------------------------------------------------------

openFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO ()
openFileDialog parent  open
  = do dialog <- fileChooserDialogNew
                   (Just "Open Profile...")
                   (Just (toWindow parent))
                   FileChooserActionOpen
                   [("gtk-cancel", ResponseCancel)
                   ,("gtk-open", ResponseAccept)]
       set dialog [
           windowModal := True
         ]

       eventlogfiles <- fileFilterNew
       fileFilterSetName eventlogfiles "GHC eventlog files (*.eventlog)"
       fileFilterAddPattern eventlogfiles "*.eventlog"
       fileChooserAddFilter dialog eventlogfiles

       allfiles <- fileFilterNew
       fileFilterSetName allfiles "All files"
       fileFilterAddPattern allfiles "*"
       fileChooserAddFilter dialog allfiles

       onResponse dialog $ \response -> do
         case response of
           ResponseAccept -> do
             mfile <- fileChooserGetFilename dialog
             case mfile of
               Just file -> open file
               Nothing   -> return ()
           _             -> return ()
         widgetDestroy dialog

       widgetShowAll dialog

-------------------------------------------------------------------------------

data FileExportFormat = FormatPDF | FormatPNG

exportFileDialog :: WindowClass window => window
                 -> FilePath
                 -> (FilePath -> FileExportFormat -> IO ())
                 -> IO ()
exportFileDialog parent oldfile save = do
    dialog <- fileChooserDialogNew
                (Just "Save timeline image...")
                (Just (toWindow parent))
                FileChooserActionSave
                [("gtk-cancel", ResponseCancel)
                ,("gtk-save", ResponseAccept)]
    set dialog [
       fileChooserDoOverwriteConfirmation := True,
       windowModal := True
     ]

    let (olddir, oldfilename) = splitFileName oldfile
    fileChooserSetCurrentName   dialog (replaceExtension oldfilename "png")
    fileChooserSetCurrentFolder dialog olddir

    pngFiles <- fileFilterNew
    fileFilterSetName pngFiles "PNG bitmap files"
    fileFilterAddPattern pngFiles "*.png"
    fileChooserAddFilter dialog pngFiles

    pdfFiles <- fileFilterNew
    fileFilterSetName pdfFiles "PDF files"
    fileFilterAddPattern pdfFiles "*.pdf"
    fileChooserAddFilter dialog pdfFiles

    onResponse dialog $ \response ->
      case response of
        ResponseAccept -> do
          mfile <- fileChooserGetFilename dialog
          case mfile of
            Just file
              | takeExtension file == ".pdf" -> do
                  save file FormatPDF
                  widgetDestroy dialog
              | takeExtension file == ".png" -> do
                  save file FormatPNG
                  widgetDestroy dialog
              | otherwise ->
                  formatError dialog
            Nothing  -> widgetDestroy dialog
        _            -> widgetDestroy dialog

    widgetShowAll dialog
  where
    formatError dialog = do
      msg <- messageDialogNew (Just (toWindow dialog))
               [DialogModal, DialogDestroyWithParent]
               MessageError ButtonsClose
               "The file format is unknown or unsupported"
      set msg [
        messageDialogSecondaryText := Just $
             "The PNG and PDF formats are supported. "
          ++ "Please use a file extension of '.png' or '.pdf'."
        ]
      dialogRun msg
      widgetDestroy msg



-------------------------------------------------------------------------------

errorMessageDialog :: WindowClass window => window -> String -> String -> IO ()
errorMessageDialog parent headline explanation = do

  dialog <- messageDialogNew (Just (toWindow parent))
              [] MessageError ButtonsNone ""

  set dialog
    [ windowModal := True
    , windowTransientFor := toWindow parent
    , messageDialogText  := Just headline
    , messageDialogSecondaryText := Just explanation
    , windowResizable := True
    ]

  dialogAddButton dialog "Close" ResponseClose
  dialogSetDefaultResponse dialog ResponseClose

  onResponse dialog $ \_-> widgetDestroy dialog
  widgetShowAll dialog