% $Id: REPTk.oz,v 1.10 2012/01/31 19:35:02 leavens Exp $ % Interactive test interface for the Reducer, built Using Oz's QTk system, % based on an example by Peter van Roy. % % BUGS: this gives some Tk error ("Expected type: tickle") % when you press the Run Reductions button % % AUTHOR: Gary T. Leavens \insert 'Desugar.oz' \insert 'ReducerPrinting.oz' \insert 'Unparse.oz' \insert 'MyOzParser.oz' local [QTk] = {Module.link ['x-oz://system/wp/QTk.ozf']} fun {ParseStmtVS VS FileName Reporter} %% ENSURES: Result is an AST for the statement in the Virtual String VS %% (or parseError) {GetParseTree {ParseSequence {OzLexer {VirtualString.toString VS} FileName}}} end In ParseDisplay Out proc {Reporter error(coord:Coord msg:Message ...)} % ENSURES: Output shows the message {Out set({PositionMsg Coord}#': '#Message)} end ShowParse = true D=td(tdrubberframe(glue:nswe lr(glue:we button( glue:we bg:green text:"Run Reductions" tooltips:"Press to see reductions for the input statement" action: proc {$} PT = {ParseStmtVS {In get($)} 'input' Reporter} in {Out set("")} case PT of parseError then {Out set('Parse-Error!')} [] parseError(coord: C msg: Msg ...) then {Reporter error(coord: C msg: Msg)} else try local DPT = {DesugarStmt PT} if ShowParse then {ParseDisplay set({UnparseStmt DPT})} end _#InitConfig|Reds = {MakeStdReductions DPT} RedsVS = {StringForConfig InitConfig} # {FoldR Reds fun {$ RN#Config Rest} "\n"#Arrow#{By RN} #"\n"#SpacingBeforeConfig #{StringForConfig Config} #Rest end ""} in {Out set(RedsVS)} end catch Excpt then {Out set("Error: "#{Value.toVirtualString Excpt 20 20})} end end end) button(glue:we text:"Quit" bg:red action:toplevel#close)) lr(glue:nswe label(text:"Input Statement:") text(handle:In glue:nswe)) if ShowParse then lr(glue:we label(text:"Desugaring") text(handle:ParseDisplay glue:nwse tdscrollbar:true)) else lr(empty) end lr(glue:nswe label(text:"Reductions") text(handle:Out glue:nswe tdscrollbar:true))) ) W = {QTk.build D} in {W show(wait:true)} end