hpage 0.4.7 → 0.4.8
raw patch · 4 files changed
+88/−84 lines, 4 filesdep ~eprocessdep ~hint-server
Dependency ranges changed: eprocess, hint-server
Files
- hpage.cabal +4/−4
- src/HPage/Control.hs +13/−4
- src/HPage/GUI/FreeTextWindow.hs +67/−57
- src/HPage/Server.hs +4/−19
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.4.7+version: 0.4.8 cabal-version: >=1.6 build-type: Custom license: BSD3@@ -42,10 +42,10 @@ wxcore >=0.11.1, wxcore < 0.12, wx >=0.11.1, wx < 0.12, filepath >=1.1.0, filepath < 1.2,- Cabal >= 1.6, Cabal < 1.7,+ Cabal >= 1.6, Cabal < 1.7, hint >= 0.3.2, hint < 0.4,- eprocess >= 1.0.0, eprocess < 2,- hint-server >= 1.0.0, hint-server < 2+ eprocess >= 1.1.0, eprocess < 2,+ hint-server >= 1.1.0, hint-server < 2 main-is: Main.hs buildable: True hs-source-dirs: src
src/HPage/Control.hs view
@@ -81,7 +81,8 @@ import Distribution.ModuleName import Distribution.Compiler -data Interpretation = Type {intKind :: String} | Expr {intValue :: String, intType :: String}+data Interpretation = Type {intKind :: String} |+ Expr {intValue :: String, intType :: String} deriving (Eq, Show) isIntType :: Interpretation -> Bool@@ -441,9 +442,17 @@ do valueRes <- valueOfNth i case valueRes of- Left verr -> return $ Left verr+ Left verr ->+ let verrStr = show verr+ in if isNotShowable verr+ then return $ Right $ Expr{intValue = "", intType = t}+ else return $ Left verr Right v -> return $ Right $ Expr{intValue = v, intType = t}-+ where isNotShowable (Hint.WontCompile ghcerrs) = any complainsAboutShow ghcerrs+ isNotShowable _ = False+ complainsAboutShow err = let errMsg = Hint.errMsg err+ in "No instance for (GHC.Show" `isPrefixOf` errMsg+ valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String) valueOfNth = runInExprNthWithLets Hint.eval kindOfNth = runInExprNth Hint.kindOf@@ -703,7 +712,7 @@ running = Nothing}) prettyPrintError :: Hint.InterpreterError -> String-prettyPrintError (Hint.WontCompile ghcerr) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerr)+prettyPrintError (Hint.WontCompile ghcerrs) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerrs) prettyPrintError (Hint.UnknownError errStr) = "Unknown Error: " ++ errStr prettyPrintError (Hint.NotAllowed errStr) = "Not Allowed Action: " ++ errStr prettyPrintError (Hint.GhcException errStr) = errStr
src/HPage/GUI/FreeTextWindow.hs view
@@ -7,12 +7,12 @@ module HPage.GUI.FreeTextWindow ( gui ) where --- import Control.Concurrent.Process-import Foreign.Ptr-import Foreign.Storable+import Prelude hiding (catch)+import Control.Exception+import Control.Concurrent.Process import System.FilePath import System.Directory-import System.IO.Error hiding (try)+import System.IO.Error hiding (try, catch) import Data.List import Data.Bits import Data.Char (toLower)@@ -21,11 +21,11 @@ import Control.Monad.Error import Control.Monad.Loops import Graphics.UI.WX-import Graphics.UI.WXCore+import Graphics.UI.WXCore hiding (kill, Process) import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Dialogs import Graphics.UI.WXCore.Events-import Graphics.UI.WXCore.WxcClasses+--import Graphics.UI.WXCore.WxcClasses hiding (Process, kill) import qualified HPage.Control as HP import qualified HPage.Server as HPS import HPage.GUI.Dialogs@@ -46,13 +46,11 @@ helpFile :: IO FilePath helpFile = getDataFileName "res/help/helpPage.hs" -data GUIResults = GUIRes { resPanel :: Panel (),- resButton :: Button (),+data GUIResults = GUIRes { resButton :: Button (), resLabel :: StaticText (), resValue :: TextCtrl (), res4Dots :: StaticText (),- resType :: TextCtrl (),- resKind :: TextCtrl () }+ resType :: TextCtrl () } data GUIContext = GUICtx { guiWin :: Frame (), guiPages :: SingleListBox (),@@ -93,14 +91,13 @@ varModsSel <- varCreate $ -1 lstModules <- listCtrlEx pnlMs (wxLC_REPORT + wxLC_ALIGN_LEFT + wxLC_NO_HEADER + wxLC_SINGLE_SEL) [columns := [("Module", AlignLeft, 200),- ("Origin", AlignLeft, 0)]]+ ("Origin", AlignLeft, 1)]] listCtrlSetImageList lstModules images wxIMAGE_LIST_SMALL -- 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 := " :: "]@@ -122,7 +119,7 @@ -- Search ... search <- findReplaceDataCreate wxFR_DOWN - let guiRes = GUIRes pnlRes btnInterpret lblInterpret txtValue lbl4Dots txtType txtKind+ let guiRes = GUIRes btnInterpret lblInterpret txtValue lbl4Dots txtType let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status varTimer search let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx @@ -240,13 +237,12 @@ toolBarSetToolBitmapSize tbMain $ sz 32 32 -- Layout settings- let txtCodeL = fill $ widget txtCode- pagesTabL = tab "Pages" $ container pnlPs $ fill $ margin 5 $ widget lstPages+ let pagesTabL = tab "Pages" $ container pnlPs $ fill $ margin 5 $ widget lstPages modsTabL = tab "Modules" $ container pnlMs $ fill $ margin 5 $ widget lstModules leftL = tabs ntbkL [modsTabL, pagesTabL] resultsL = hfill $ boxed "Expression" $ fill $ widget pnlRes- rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsL]- set win [layout := fill $ row 10 [leftL, rightL],+ rightL = minsize (sz 485 100) $ fill $ widget txtCode+ set win [layout := column 5 [fill $ row 10 [leftL, rightL], resultsL], clientSize := sz 800 600] -- ...and RUN!@@ -601,13 +597,11 @@ Right () -> refreshPage model guiCtx -interpret model guiCtx@GUICtx{guiResults = GUIRes{resPanel = pnlRes,- resLabel = lblInterpret,+interpret model guiCtx@GUICtx{guiResults = GUIRes{resLabel = lblInterpret, resButton = btnInterpret, resValue = txtValue, res4Dots = lbl4Dots,- resType = txtType,- resKind = txtKind},+ resType = txtType}, guiCode = txtCode, guiWin = win} = do sel <- textCtrlGetStringSelection txtCode@@ -615,41 +609,58 @@ "" -> tryIn sl -> runTxtHPSelection sl 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 win- 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 win+ Left err ->+ do+ warningDialog win "Error" err+ set btnInterpret [enabled := True]+ Right interp ->+ if HP.isIntType interp+ then do+ set txtValue [text := HP.intKind interp]+ set lbl4Dots [visible := False]+ set txtType [visible := False]+ set lblInterpret [text := "Kind:"]+ else do+ set lbl4Dots [visible := True]+ set txtType [visible := True, text := HP.intType interp]+ set lblInterpret [text := "Value:"]+ -- now we fill the textbox --+ set txtValue [text := ""]+ prevOnCmd <- get btnInterpret $ on command+ prevText <- get btnInterpret text+ let prevAttrs = [on command := prevOnCmd,+ text := prevText]+ debugIO "++> Spawning the value filler..."+ vfHandle <- spawn . valueFiller $ HP.intValue interp+ debugIO "++> Value filler spawned"+ set btnInterpret [text := "Cancel",+ on command := kill vfHandle >> set btnInterpret prevAttrs]+ where valueFiller :: String -> Process a ()+ valueFiller val =+ do+ let bottomString = "_|_"+ bottomChar = "_i_"+ liftDebugIO "++> starting loop..."+ h <- liftIO $ try (case val of+ [] -> return []+ (c:_) -> return [c])+ --liftDebugIO ("++> h =", h)+ case h of+ Left (ErrorCall desc) ->+ liftIO $ debugIO ("++> Left", desc) >> addText bottomString >> return ()+ Right [] ->+ liftIO $ debugIO "++> done" >> return ()+ Right t ->+ do+ liftIO $ catch (addText t) $ \(ErrorCall _desc) -> addText bottomChar+ liftDebugIO "++> restarting"+ valueFiller $ tail val+ addText t = do+ debugIO ("Adding", t)+ orig <- get txtValue text+ set txtValue [text := orig ++ t] runTxtHPSelection :: String -> HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError HP.Interpretation) -> IO (Either ErrorString HP.Interpretation)@@ -673,8 +684,7 @@ refreshExpr :: HPS.ServerHandle -> GUIContext -> Bool -> IO () refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue,- resType = txtType,- resKind = txtKind},+ resType = txtType}, guiCode = txtCode, guiWin = win} forceClear = do@@ -688,7 +698,7 @@ warningDialog win "Error" err Right changed -> if changed || forceClear- then mapM_ (flip set [text := ""]) [txtValue, txtType, txtKind]+ then mapM_ (flip set [text := ""]) [txtValue, txtType] else debugIO "dummy refreshExpr" killTimer model guiCtx
src/HPage/Server.hs view
@@ -5,35 +5,20 @@ import Control.Monad import Control.Monad.Trans-import Control.Monad.Loops import Control.Concurrent.Process import HPage.Control-import HPage.Utils.Log -newtype ServerHandle = SH {handle :: Handle (Either Stop (HPage ()))}--data Stop = Stop+newtype ServerHandle = SH {handle :: Handle (HPage ())} start :: IO ServerHandle start = (spawn $ makeProcess evalHPage pageRunner) >>= return . SH- where pageRunner = iterateWhile id $ do- liftTraceIO "hps iterating..."- v <- recv- case v of- Left Stop ->- do- liftTraceIO "hps stop"- return False- Right acc ->- do- liftTraceIO "hps continue"- lift acc >> return True+ where pageRunner = forever $ recv >>= lift runIn :: ServerHandle -> HPage a -> IO a runIn server action = runHere $ do me <- self- sendTo (handle server) $ Right $ action >>= sendTo me+ sendTo (handle server) $ action >>= sendTo me recv stop :: ServerHandle -> IO ()-stop server = sendTo (handle server) $ Left Stop+stop = kill . handle