darcs - INblobs

1 {-|

2 Module : Functional.UI

3 Copyright : (c) Miguel VilaÃ§a and Daniel Mendes 2007

5 Maintainer : jmvilaca@di.uminho.pt and danielgomesmendes@gmail.com

6 Stability : experimental

7 Portability : portable

10 Small Functional Language: Graphical stuff for integration in INblobs.

12 -}

13 module Functional.UI

14 ( compileUI

15 ) where

17 import State

18 import StateUtil

19 import qualified PersistentDocument as PD

20 import Common

21 import CommonIO

22 import CommonUI

23 import InfoKind

24 import Text.XML.HaXml.XmlContent (XmlContent)

26 import Graphics.UI.WX

27 import Graphics.UI.WXCore

29 import Functional.Language

30 import Functional.Parser

31 import Functional.Compiler

33 import Data.List

34 import Data.Char

35 import qualified Control.Exception as E

38 -- | List of strategies for which compilation is available.

39 listCallBy :: [CallBy]

40 listCallBy = [ Name, Value ]

42 -- | GUI for compilation of BNL to INs.

43 compileUI :: (InfoKind n g, InfoKind e g, XmlContent g) => State g n e -> g -> n -> e -> IO ()

44 compileUI state g n e =

45 closeDocAndThen state $

46 do

47 theFrame <- getNetworkFrame state

49 res <- parseDialog theFrame

50 case res of

51 Nothing -> return ()

52 Just (term, callBy)

53 |not . null $ freeVars term ->

54 errorDialog theFrame "Free variables"

55 $ "Only closed terms are allowed and this one have the following free vars:\n" ++ commasAnd (freeVars term)

56 Just (term, callBy) ->

57 do

58 let iterSymbs = listIteratorSymbols term

59 names <- if null iterSymbs

60 then return (Just [])

61 else meaningfulNamesDialog iterSymbs theFrame

62 case names of

63 Nothing -> return ()

64 Just names ->

65 flip E.catch (\exception ->

66 do

67 logMessage "END COMPILATION BADLY"

68 wxcEndBusyCursor

69 errorDialog theFrame "Compilation failed..." (show exception)

70 ) $

71 do

72 -- loadDocument

73 let fname = "examples/New-Token-Passing/CallBy"

74 ++ show callBy ++

75 "ForClosedTerms+BNL-Iterators.INblobs"

76 openNetworkFile fname state (Just theFrame)

77 pDoc <- getDocument state

78 doc <- PD.getDocument pDoc

79 wxcBeginBusyCursor

80 logMessage "COMPILING..."

81 doc2 <- compile g n e callBy term names doc

82 logMessage "END COMPILATION SUCCESSFULLY"

83 wxcEndBusyCursor

84 let fname2 = "examples/New-Token-Passing/GENERATED-CallBy"

85 ++ show callBy ++

86 "ForClosedTerms+BNL-Iterators.INblobs"

87 PD.resetDocument (Just fname2) doc2 pDoc

89 -- Redraw

90 applyCanvasSize state

91 buildVisiblePalette state

92 reAddRules2Tree state

93 repaintAll state

95 -- | Deal with collecting a term from the user.

96 -- Graphical treatment of parsing errors is done here.

97 parseDialog :: Frame () -> IO (Maybe (FuncLang,CallBy))

98 parseDialog theFrame =

99 do

100 dial <- dialog theFrame [text := "Functional term to IN system", position := pt 200 20]

101 p <- panel dial []

102 termbox <- textCtrlRich p [text := ""]

103 help <- button p

104 [ text := "Help"

105 , on command := infoDialog dial "Help" helpString

106 ]

107

108 okB <- button p [ text := "Ok" ]

109 canB <- button p [ text := "Cancel" ]

110

111 -- one button per functional language constructor

112 listBs <- mapM (\(name,term) -> button p

113 [ text := name

114 , on command := addTxtInPlace2TextCtrl termbox $ show term

115 ])

116 listLangConstructors

117

118 -- CallByX

119 when (null listCallBy) (error "No strategies available.")

120 callByUI <- radioBox p Vertical (map show listCallBy)

121 [ text := "Which evaluation strategy?"

122 , selection := 0

123 ]

124

125 errorsUI <- textCtrl p [ visible := False ]

126

127 set dial [ layout := container p $

128 margin 10 $

129 column 5 [ label "Input your term:"

130 , row 2 [ hfill $ widget termbox

131 , column 10 (map widget listBs)

132 ]

133 , widget callByUI

134 , minsize (sz 30 30) . fill $ widget errorsUI

135 , widget help

136 , hrule 350

137 , floatRight $ row 5 [widget okB, widget canB]

138 ]

139 ]

140

141 showModal dial $ \stop ->

142 do

143 set canB [on command := stop Nothing]

144 set okB [on command :=

145 do

146 set errorsUI [ visible := False, text := ""]

147 txt <- get termbox text

148 i <- get callByUI selection

149

150 case parse txt of

151 Left term -> stop $ Just (term, listCallBy !! i)

152 Right errMsg ->

153 do

154 set errorsUI [ visible := True

155 , text := "Parse error:\n" ++ errMsg

156 ]

157 errorDialog theFrame "Parsing Error" "Parsing error.\nSee report."

158 ]

159

160 where helpString = "Use the buttons on the right side to create a term or write it if already familiar with the syntax."

161

162 -- | Allow the user to supply more meaningful names for symbols that correspond to iterators with internalized arguments.

163 -- Checks if:

164 -- * given names don't contain blank or control characters

165 -- * given names are disjoint

166 meaningfulNamesDialog :: [FuncLang] -> Frame () -> IO (Maybe [(FuncLang, String)])

167 meaningfulNamesDialog terms theFrame =

168 do

169 dial <- dialog theFrame [text := "Meaningful names"

170 , position := pt 200 20

171 , resizeable := True

172 ]

173 p <- panel dial []

174

175 listG <- listCtrl p [ columns := [ ("Symbol name", AlignRight, -1)

176 , ("Term", AlignLeft, 200)

177 ]

178 , items := [[name, showAgent term] | (term, name) <- giveNames terms]

179 , style :~ (wxLC_EDIT_LABELS .+. wxLC_VRULES .+.)

180 ]

181

182 okB <- button p [ text := "Ok" ]

183 canB <- button p [ text := "Cancel" ]

184

185 errorsUI <- textCtrl p [ visible := False ]

186

187 set dial [ layout := container p $

188 margin 10 $

189 column 5 [ label "Edit the \"Symbol name\" column to give more meaningful names."

190 , fill $ widget listG

191 , fill $ widget errorsUI

192 , hrule 350

193 , floatRight $ row 5 [widget okB, widget canB]

194 ]

195 ]

196

197 showModal dial $ \stop ->

198 do set okB [ on command :=

199 do

200 newNames <- get listG items

201 let mapp = zip terms (map head newNames)

202 -- Check that given names are good names.

203 badNames = filter (badName . snd) mapp

204 -- Check that given names are disjoint.

205 equalNames = filter ((> 1) . length)

206 $ groupBy (\(_,a) (_,b) -> a == b) mapp

207 case (null badNames, null equalNames) of

208 (True, True) -> stop $ Just mapp

209 (False, _) -> -- some bad names

210 set errorsUI [ visible := True

211 , text := "The symbol's name(s) for the following term(s) contain invalid (control or blank) characters:\n"

212 ++ (indent 1 . unlines) (map (showAgent . fst) badNames)

213 ]

214 (True, False) -> -- repeated names

215 set errorsUI [ visible := True

216 , text := "The following terms have the same name(s):\n "

217 ++ beautify equalNames

218 ]

219 ]

220 set canB [on command := stop Nothing]

221 where

222 beautify :: [[(FuncLang,String)]] -> String

223 beautify = unlines . map (\l -> snd (head l) ++ "\n"

224 ++ indent 1 (unlines $ map (showAgent.fst) l))

225 badName = any (\c -> isSpace c || isControl c)

226