hpage 0.4.3 → 0.4.4
raw patch · 5 files changed
+130/−94 lines, 5 files
Files
- hpage.cabal +1/−1
- res/help/helpPage.hs +5/−5
- src/HPage/Control.hs +29/−0
- src/HPage/GUI/FreeTextWindow.hs +90/−81
- src/HPage/GUI/IDs.hs +5/−7
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.4.3+version: 0.4.4 cabal-version: >=1.6 build-type: Custom license: BSD3
res/help/helpPage.hs view
@@ -6,8 +6,8 @@ length [0..41] --- Now you can place your cursor on any of them and then press the [Value] or [Type] buttons below--- to get their values or types+-- Now you can place your cursor on any of them and then press the [Interpret] button below+-- or just use Ctrl-I to get their values or types -- You can also type in Type names, like... @@ -15,16 +15,16 @@ IO --- ...to see their kind, using the [Kind] button below+-- ...to see their kind, using the same mechanism -- You can define functions too, let's try (once again) with the well known fact... fact x = foldl (*) 1 [1..x] --- Now if you place your cursor on the next instruction, you can ask for their values or types+-- Now if you place your cursor on the next expression, you can ask for its interpretation fact 20 --- If you don't want to use the whole page content in an evaluation, you can mark the exact page zone you want to evaluate+-- If you don't want to use the whole page content in an evaluation, you can mark the exact page zone you want to evaluate and then press [Interpret] -- That's just to start up... you can do some serious stuff with this application, just surf the different menues
src/HPage/Control.hs view
@@ -29,6 +29,7 @@ -- EDITION CONTROLS -- undo, redo, -- HINT CONTROLS --+ interpret, interpretNth, Interpretation, intKind, intValue, intType, isIntType, valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, loadModules, reloadModules, getLoadedModules,@@ -80,6 +81,13 @@ import Distribution.ModuleName import Distribution.Compiler +data Interpretation = Type {intKind :: String} | Expr {intValue :: String, intType :: String}+ deriving (Eq, Show)+ +isIntType :: Interpretation -> Bool+isIntType Type{} = True+isIntType Expr{} = False+ data ModuleDescription = ModDesc {modName :: String, modInterpreted :: Bool} deriving (Eq)@@ -409,11 +417,32 @@ currentExpr = currentExpr p}) in page{undoActions = undoAct : undoActions page, redoActions = accs})++interpret :: HPage (Either Hint.InterpreterError Interpretation)+interpret = getPage >>= interpretNth . currentExpr valueOf, kindOf, typeOf :: HPage (Either Hint.InterpreterError String) valueOf = getPage >>= valueOfNth . currentExpr kindOf = getPage >>= kindOfNth . currentExpr typeOf = getPage >>= typeOfNth . currentExpr++interpretNth :: Int -> HPage (Either Hint.InterpreterError Interpretation)+interpretNth i =+ do+ typeRes <- typeOfNth i+ case typeRes of+ Left terr ->+ do+ kindRes <- kindOfNth i+ case kindRes of+ Left _ -> return $ Left terr+ Right k -> return $ Right $ Type{intKind = k}+ Right t ->+ do+ valueRes <- valueOfNth i+ case valueRes of+ Left verr -> return $ Left verr+ Right v -> return $ Right $ Expr{intValue = v, intType = t} valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String) valueOfNth = runInExprNthWithLets Hint.eval
src/HPage/GUI/FreeTextWindow.hs view
@@ -7,6 +7,7 @@ module HPage.GUI.FreeTextWindow ( gui ) where +-- import Control.Concurrent.Process import System.FilePath import System.Directory import System.IO.Error hiding (try)@@ -43,12 +44,13 @@ helpFile :: IO FilePath helpFile = getDataFileName "res/help/helpPage.hs" -data GUIResultRow = GUIRRow { grrButton :: Button (),- grrText :: TextCtrl ()}--data GUIResults = GUIRes { resValue :: GUIResultRow,- resType :: GUIResultRow,- resKind :: GUIResultRow }+data GUIResults = GUIRes { resPanel :: Panel (),+ resButton :: Button (),+ resLabel :: StaticText (),+ resValue :: TextCtrl (),+ res4Dots :: StaticText (),+ resType :: TextCtrl (),+ resKind :: TextCtrl () } data GUIContext = GUICtx { guiWin :: Frame (), guiPages :: SingleListBox (),@@ -94,33 +96,37 @@ lstPkgModules <- singleListBox pnlPMs [style := wxLB_NEEDED_SB] - -- Results list- txtValue <- textEntry win [style := wxTE_READONLY]- txtType <- textEntry win [style := wxTE_READONLY]- txtKind <- textEntry win [style := wxTE_READONLY]- + -- Results panel+ pnlRes <- panel win []+ txtValue <- textEntry pnlRes [style := wxTE_READONLY]+ txtType <- textEntry pnlRes [style := wxTE_READONLY]+ txtKind <- textEntry pnlRes [style := wxTE_READONLY, visible := False]+ btnInterpret <- button pnlRes [text := "Interpret"]+ lblInterpret <- staticText pnlRes [text := "Value:"]+ lbl4Dots <- staticText pnlRes [text := " :: "]+ set pnlRes [layout := fill $ + row 5 [widget btnInterpret,+ centre $ widget lblInterpret,+ fill $ widget txtValue,+ centre $ widget lbl4Dots,+ fill $ widget txtType]]+ -- Status bar... status <- statusField [text := "hello... this is λPage! type in your instructions :)"]+ set win [statusBar := [status]]++ -- Timer ... refreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"] varTimer <- varCreate refreshTimer- set win [statusBar := [status]] - btnGetValue <- button win [text := "Value"]- btnGetType <- button win [text := "Type"]- btnGetKind <- button win [text := "Kind"]- + -- Search ... search <- findReplaceDataCreate wxFR_DOWN - let grrValue = GUIRRow btnGetValue txtValue- let grrType = GUIRRow btnGetType txtType- let grrKind = GUIRRow btnGetKind txtKind- let guiRes = GUIRes grrValue grrType grrKind+ let guiRes = GUIRes pnlRes btnInterpret lblInterpret txtValue lbl4Dots txtType txtKind let guiCtx = GUICtx win lstPages lstPkgModules lstLoadedModules txtCode guiRes status varTimer search let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx - set btnGetValue [on command := onCmd "getValue" getValue]- set btnGetType [on command := onCmd "getType" getType]- set btnGetKind [on command := onCmd "getKind" getKind]+ set btnInterpret [on command := onCmd "interpret" interpret] -- Events set lstPages [on select := onCmd "pageChange" pageChange]@@ -139,7 +145,6 @@ _ -> propagateEvent] -- Menu bar...- -- menuBar win [] mnuPage <- menuPane [text := "Page"] menuAppend mnuPage wxId_NEW "&New\tCtrl-n" "New Page" False menuAppend mnuPage wxId_CLOSE "&Close\tCtrl-w" "Close Page" False@@ -174,9 +179,7 @@ menuAppend mnuHask wxId_HASK_ADD "Import modules...\tCtrl-Shift-i" "Import Packaged Modules by Name" False menuAppend mnuHask wxId_HASK_RELOAD "&Reload\tCtrl-r" "Reload Modules" False menuAppendSeparator mnuHask- menuAppend mnuHask wxId_HASK_VALUE "&Value\tCtrl-e" "Get the Value of the Current Expression" False- menuAppend mnuHask wxId_HASK_TYPE "&Type\tCtrl-t" "Get the Type of the Current Expression" False- menuAppend mnuHask wxId_HASK_KIND "&Kind\tCtrl-k" "Get the Kind of the Current Expression" False+ menuAppend mnuHask wxId_HASK_INTERPRET "&Interpret\tCtrl-i" "Interpret the Current Expression" False mnuHelp <- menuHelp [] menuAppend mnuHelp wxId_HELP "&Help page\tCtrl-h" "Open the Help Page" False@@ -205,9 +208,7 @@ evtHandlerOnMenuCommand win wxId_HASK_LOAD_FAST $ onCmd "loadModulesByNameFast" loadModulesByNameFast evtHandlerOnMenuCommand win wxId_HASK_RELOAD $ onCmd "reloadModules" reloadModules evtHandlerOnMenuCommand win wxId_PREFERENCES $ onCmd "preferences" configure- evtHandlerOnMenuCommand win wxId_HASK_VALUE $ onCmd "getValue" getValue- evtHandlerOnMenuCommand win wxId_HASK_TYPE $ onCmd "getType" getType- evtHandlerOnMenuCommand win wxId_HASK_KIND $ onCmd "getKind" getKind+ evtHandlerOnMenuCommand win wxId_HASK_INTERPRET $ onCmd "interpret" interpret evtHandlerOnMenuCommand win wxId_HELP $ onCmd "help" openHelpPage -- Tool bar...@@ -246,12 +247,9 @@ pagesTabL = tab "Pages" $ container pnlPs $ fill $ margin 5 $ widget lstPages pkgModsTabL = tab "Package" $ container pnlPMs $ fill $ margin 5 $ widget lstPkgModules lddModsTabL = tab "Modules" $ container pnlLMs $ fill $ margin 5 $ widget lstLoadedModules- valueRowL = [widget btnGetValue, hfill $ widget txtValue]- typeRowL = [widget btnGetType, hfill $ widget txtType]- kindRowL = [widget btnGetKind, hfill $ widget txtKind]- resultsGridL= hfill $ boxed "Expression" $ grid 5 0 [valueRowL, typeRowL, kindRowL] leftL = tabs ntbkL [lddModsTabL, pkgModsTabL, pagesTabL]- rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsGridL]+ resultsL = hfill $ boxed "Expression" $ fill $ widget pnlRes+ rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsL] set win [layout := fill $ row 10 [leftL, rightL], clientSize := sz 800 600] @@ -266,7 +264,6 @@ justFind, justFindNext, justFindPrev, findReplace, textContextMenu, pkgModuleContextMenu, restartTimer, killTimer,- getValue, getType, getKind, loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () @@ -332,9 +329,7 @@ menuAppend contextMenu wxId_COPY "&Copy\tCtrl-c" "Copy" False menuAppend contextMenu wxId_PASTE "&Paste\tCtrl-v" "Paste" False menuAppendSeparator contextMenu- menuAppend contextMenu wxId_HASK_VALUE "&Value\tCtrl-e" "Get the Value of the Current Expression" False- menuAppend contextMenu wxId_HASK_TYPE "&Type\tCtrl-t" "Get the Type of the Current Expression" False- menuAppend contextMenu wxId_HASK_KIND "&Kind\tCtrl-k" "Get the Kind of the Current Expression" False+ menuAppend contextMenu wxId_HASK_INTERPRET "&Interpret\tCtrl-i" "Interpret the Current Expression" False propagateEvent pointWithinWindow <- windowGetMousePosition win@@ -356,15 +351,6 @@ menuPopup contextMenu pointWithinWindow win objectDelete contextMenu -getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} =- runTxtHP HP.valueOf model guiCtx grrValue--getType model guiCtx@GUICtx{guiResults = GUIRes{resType = grrType}} =- runTxtHP HP.typeOf model guiCtx grrType--getKind model guiCtx@GUICtx{guiResults = GUIRes{resKind = grrKind}} =- runTxtHP HP.kindOf model guiCtx grrKind- pageChange model guiCtx@GUICtx{guiPages = lstPages} = do i <- get lstPages selection@@ -614,31 +600,67 @@ Right () -> refreshPage model guiCtx -runTxtHP, runTxtHPPointer :: HP.HPage (Either HP.InterpreterError String) -> - HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO ()-runTxtHPSelection :: String -> HP.HPage (Either HP.InterpreterError String) -> - HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO ()-runTxtHP hpacc model guiCtx@GUICtx{guiCode = txtCode} guiRow =+interpret model guiCtx@GUICtx{guiResults = GUIRes{resPanel = pnlRes,+ resLabel = lblInterpret,+ resButton = btnInterpret,+ resValue = txtValue,+ res4Dots = lbl4Dots,+ resType = txtType,+ resKind = txtKind},+ guiCode = txtCode, guiWin = win} = do sel <- textCtrlGetStringSelection txtCode let runner = case sel of- "" -> runTxtHPPointer+ "" -> tryIn sl -> runTxtHPSelection sl- runner hpacc model guiCtx guiRow--runTxtHPSelection s hpacc model guiCtx@GUICtx{guiWin = win,- guiStatus = status}- GUIRRow{grrButton = btn,- grrText = txtBox} =- do refreshExpr model guiCtx False+ set btnInterpret [enabled := False]+ res <- runner model HP.interpret+ case res of+ Left err ->+ do+ warningDialog win "Error" err+ set btnInterpret [enabled := True]+ Right interp ->+ if HP.isIntType interp+ then do+ set btnInterpret [enabled := True]+ set txtValue [visible := False]+ set lbl4Dots [visible := False]+ set txtType [visible := False]+ set txtKind [visible := True, text := HP.intKind interp]+ set lblInterpret [text := "Kind:"]+ set pnlRes [layout := fill $ centre $+ row 5 [widget btnInterpret,+ centre $ widget lblInterpret,+ hfill $ widget txtKind]]+ repaint pnlRes+ else do+ set btnInterpret [enabled := True]+ set txtValue [visible := True, text := HP.intValue interp]+ set lbl4Dots [visible := True, text := " :: "]+ set txtType [visible := True, text := HP.intType interp]+ set txtKind [visible := False]+ set lblInterpret [text := "Value:"]+ set pnlRes [layout := fill $ + row 5 [widget btnInterpret,+ centre $ widget lblInterpret,+ hfill $ widget txtValue,+ centre $ widget lbl4Dots,+ hfill $ widget txtType]]+ repaint pnlRes+ +runTxtHPSelection :: String -> HPS.ServerHandle ->+ HP.HPage (Either HP.InterpreterError HP.Interpretation) -> IO (Either ErrorString HP.Interpretation)+runTxtHPSelection s model hpacc =+ do debugIO ("evaluating selection", s) piRes <- tryIn' model HP.getPageIndex added <- tryIn' model $ HP.addPage case added of Left err ->- warningDialog win "Error" err- Right _ ->+ return $ Left err+ Right () -> do let cpi = case piRes of Left err -> 0@@ -646,25 +668,12 @@ newacc = HP.setPageText s (length s) >> hpacc res <- tryIn model newacc tryIn' model $ HP.closePage >> HP.setPageIndex cpi - case res of- Left err -> warningDialog win "Error" err- Right val -> set txtBox [text := val]--runTxtHPPointer hpacc model guiCtx@GUICtx{guiWin = win,- guiStatus = status}- GUIRRow{grrButton = btn,- grrText = txtBox} =- do- refreshExpr model guiCtx False- res <- tryIn model hpacc- case res of- Left err -> warningDialog win "Error" err- Right val -> set txtBox [text := val]+ return res refreshExpr :: HPS.ServerHandle -> GUIContext -> Bool -> IO ()-refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue,- resType = grrType,- resKind = grrKind},+refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue,+ resType = txtType,+ resKind = txtKind}, guiCode = txtCode, guiWin = win} forceClear = do@@ -678,7 +687,7 @@ warningDialog win "Error" err Right changed -> if changed || forceClear- then mapM_ (flip set [text := ""] . grrText) [grrValue, grrType, grrKind]+ then mapM_ (flip set [text := ""]) [txtValue, txtType, txtKind] else debugIO "dummy refreshExpr" killTimer model guiCtx
src/HPage/GUI/IDs.hs view
@@ -32,15 +32,13 @@ wxId_CLOSE_ALL = 5018 wxId_HASK_LOAD, wxId_HASK_LOADNAME, wxId_HASK_LOAD_FAST, wxId_HASK_RELOAD,- wxId_HASK_VALUE, wxId_HASK_TYPE, wxId_HASK_KIND,+ wxId_HASK_INTERPRET, wxId_HASK_ADD, wxId_HASK_LOAD_PKG, wxId_HASK_MENUELEM :: Int wxId_HASK_LOAD = 5300 wxId_HASK_LOADNAME = 5301 wxId_HASK_RELOAD = 5302-wxId_HASK_VALUE = 5304-wxId_HASK_TYPE = 5305-wxId_HASK_KIND = 5306-wxId_HASK_ADD = 5307-wxId_HASK_LOAD_PKG = 5308-wxId_HASK_LOAD_FAST = 5309+wxId_HASK_INTERPRET = 5303+wxId_HASK_ADD = 5304+wxId_HASK_LOAD_PKG = 5305+wxId_HASK_LOAD_FAST = 5306 wxId_HASK_MENUELEM = 5310