-
Notifications
You must be signed in to change notification settings - Fork 1
/
Data.hs
227 lines (187 loc) · 6.15 KB
/
Data.hs
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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
-----------------------------------------------------------------------------
--
-- Module : Data.hs
-- Copyright : (c) Neil Mitchell 2007
-- License :
--
-- Maintainer :
-- Stability : unstable
-- Portability : not portable, uses Gtk2Hs
--
-- Defines the core data structures for GuiHaskell.
--
-- Data passes around some global state. Data includes
-- EvalState, which holds the states of the individual
-- compilers that GuiHaskell can run.
--
-----------------------------------------------------------------------------
module Data (
Data(..), Evaluator(..), Handles(..),
empty, getHandles, setHandles, setCurrentFile,
setupFonts, appendText, appendRed, applyEscape,
promptCmd
) where
import PropLang.Gtk
import PropLang.Variable
import Data.Map (Map)
import qualified Data.Map as M
import Control.Concurrent (ThreadId)
import System.IO (Handle)
import System.Process (ProcessHandle)
import Text.EscapeCodes
import Control.Monad
import Numeric
import Graphics.UI.Gtk hiding (Action, Window, ComboBox, MenuItem, TextView, ToolButton, FontButton, Event, onClicked, onChanged)
data Data = Data {
-- Main Window and friends
window :: Window
, txtOut :: TextView
, txtIn :: TextView
, txtSelect :: TextEntry
, sb :: StatusBar
, tbRun :: ToolButton
, tbStop :: ToolButton
, tbRestart :: ToolButton
, tbOpen :: ToolButton
, tbRecent :: ToolButton
, tbProfile :: ToolButton
, tbPref :: ToolButton
, cbCompiler :: ComboBox
, fbFont :: FontButton
, miFile :: MenuItem
, miOpen :: MenuItem
, miQuit :: MenuItem
, miEdit :: MenuItem
, miCut :: MenuItem
, miCopy :: MenuItem
, miPaste :: MenuItem
, miView :: MenuItem
, miTools :: MenuItem
, miRun :: MenuItem
, miProfile :: MenuItem
, miPref :: MenuItem
, miHelp :: MenuItem
, miAbout :: MenuItem
-- Preferences Dialog and friends
, wndPref :: Window
, txtExecutable :: TextEntry
, txtProfCFlags :: TextEntry
, txtProfRFlags :: TextEntry
, tbClose :: ToolButton
-- About dialog
, wndAbout :: Window
, running :: Var Bool -- is the code executing
, filename :: Var (Maybe FilePath) -- the main file loaded
, outputTags :: Var [String]
, history :: Var ([String], [String]) -- command history
-- Configuration variables
, profCFlags :: Var String
, profRFlags :: Var String
, executable :: Var FilePath
, font :: Var String
--
-- Stores the current evaluator and
-- the states of background evaluators
--
-- When a new evaluator is chosen, the
-- current evaluator is swapped into the list
-- and the new evalutor is put into current
, current :: Var Evaluator
, states :: Var (Map Evaluator Handles)
}
--
-- A data structure for storing the compiler-specific
-- details
--
data Handles = Handles {
handle :: Handle,
process :: ProcessHandle,
outId :: ThreadId,
errId :: ThreadId
}
-- hack!
-- shouldn't matter as long as you use Var like an IORef
-- maybe ProcessHandle should instantiate Eq
instance Eq Handles where
_ == _ = True
data Evaluator = Hugs | GHCi deriving (Show, Read, Eq, Ord)
-- So Main doesn't need to import Map
empty :: Map Evaluator Handles
empty = M.empty
-- Probably belongs in Evaluator.hs
promptCmd :: Evaluator -> String -> String
promptCmd Hugs xs = ":set -p\"" ++ xs ++ "\""
promptCmd GHCi xs = ":set prompt " ++ xs
-- Get the current evaluator
getHandles :: Data -> IO (Maybe Handles)
getHandles dat = do
c <- getVar $ current dat
s <- getVar $ states dat
return $ M.lookup c s
-- Set the handles for the current evaluator
setHandles :: Data -> Maybe Handles -> IO ()
setHandles dat hndls = do
c <- getVar $ current dat
s <- getVar $ states dat
case hndls of
Nothing -> states dat -< M.delete c s
Just x ->
case M.lookup c s of
Nothing -> states dat -< M.insert c x s
Just _ -> states dat -< M.adjust (\_ -> x) c s
-- Set the currently open file
setCurrentFile :: Data -> Maybe FilePath -> IO ()
setCurrentFile dat path = do
filename dat -< path
--
--
--
setupFonts :: Data -> IO ()
setupFonts dat@Data{txtOut=out,txtIn=inp} = do
buf <- textviewBuffer out
tags <- textBufferGetTagTable buf
fontStr <- getVar $ (fbFont dat)!text
mapM (addTags tags) [minBound..maxBound]
fdesc <- fontDescriptionFromString fontStr
widgetModifyFont (getTextViewRaw out) (Just fdesc)
widgetModifyFont (getTextViewRaw inp) (Just fdesc)
where
addTags tags col = do
let name = show col
(r,g,b) = getColor col
f x = let xs = showHex x "" in ['0' | length xs == 1] ++ xs
css = "#" ++ f r ++ f g ++ f b
tagFg <- textTagNew (Just $ "fg" ++ name)
tagBg <- textTagNew (Just $ "bg" ++ name)
textTagTableAdd tags tagFg
textTagTableAdd tags tagBg
set tagFg [textTagForeground := css]
set tagBg [textTagBackground := css]
--
-- Append text to output area
--
appendText :: Data -> String -> IO ()
appendText dat@Data{txtOut=out} s = do
buf <- textviewBuffer out
end <- textBufferGetEndIter buf
textBufferInsert buf end s
len <- textBufferGetCharCount buf
strt <- textBufferGetIterAtOffset buf (len - length s)
end2 <- textBufferGetEndIter buf
tags <- getVar (outputTags dat)
mapM_ (f buf strt end2) tags
where
f buf strt end tag = textBufferApplyTagByName buf tag strt end
appendRed :: Data -> String -> IO ()
appendRed dat msg = do
let tags = outputTags dat
res <- getVar tags
tags -< ["fgRed"]
appendText dat msg
tags -< res
applyEscape :: Data -> EscapeCode -> IO ()
applyEscape dat (FormatAttribute Normal) = outputTags dat -< []
applyEscape dat (FormatForeground Green) = outputTags dat -< ["fgGreen"]
applyEscape _ _ = return ()
--when_ :: Monad m => Bool -> m () -> m ()
--when_ b x = when b (x >> return ())