diff --git a/README b/README --- a/README +++ b/README @@ -36,3 +36,5 @@ Also, instead of just placing your cursor on a expression, you can mark an area and hpage will evaluate just that area That's just to start up... you can do some serious stuff with this application, just check out the different menues + +visit us at http://haskell.hpage.com diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.8.4 +version: 0.8.6 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -50,7 +50,9 @@ hint-server >= 1.1.0, hint-server < 2, time >= 1.1.4, time < 2, cabal-macosx >= 0.1.0, cabal-macosx < 0.2, - FindBin >= 0.0.2, FindBin < 0.1 + FindBin >= 0.0.2, FindBin < 0.1, + ghc-paths >= 0.1.0.6, ghc-paths < 0.2, + process >= 1.0.1.1, process < 1.1 main-is: Main.hs buildable: True hs-source-dirs: src diff --git a/res/images/icon/hpage.ico b/res/images/icon/hpage.ico Binary files a/res/images/icon/hpage.ico and b/res/images/icon/hpage.ico differ diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -431,6 +431,7 @@ interpretNth :: Int -> HPage (Either Hint.InterpreterError Interpretation) interpretNth i = do + liftDebugIO ("Interpreting", i) typeRes <- typeOfNth i case typeRes of Left terr -> @@ -444,10 +445,9 @@ valueRes <- valueOfNth i case valueRes of Left verr -> - let verrStr = show verr - in if isNotShowable verr - then return $ Right $ Expr{intValue = "", intType = t} - else return $ Left verr + 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 @@ -504,8 +504,8 @@ res <- syncRun action case res of Right _ -> - modify (\ctx -> ctx{importedModules = union (fromList newms) (importedModules ctx), - recoveryLog = recoveryLog ctx >> action >> return ()}) + modify (\c -> c{importedModules = union (fromList newms) (importedModules c), + recoveryLog = recoveryLog c >> action >> return ()}) Left e -> liftErrorIO $ ("Error importing modules", ms, e) return res @@ -608,8 +608,8 @@ forM_ opts $ \opt -> Hint.unsafeSetGhcOption opt `catchError` (\_ -> return ()) return pkgname liftDebugIO mods - res <- syncRun action - case res of + res2 <- syncRun action + case res2 of Right x -> do modify (\ctx -> ctx{activePackage = Just pkgname, @@ -661,7 +661,7 @@ liftTraceIO $ "importing': " ++ show newms Hint.setImports $ ms ++ newms res <- asyncRun action - modify (\ctx -> ctx{running = Just $ ImportModules (fromList newms) action}) + modify (\c -> c{running = Just $ ImportModules (fromList newms) action}) return res reloadModules' :: HPage (MVar (Either Hint.InterpreterError ())) @@ -745,7 +745,7 @@ prettyPrintError :: Hint.InterpreterError -> String prettyPrintError (Hint.WontCompile ghcerrs) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerrs) -prettyPrintError (Hint.UnknownError errStr) = "Unknown Error: " ++ errStr +prettyPrintError (Hint.UnknownError errStr) = "Error: " ++ errStr prettyPrintError (Hint.NotAllowed errStr) = "Not Allowed Action: " ++ errStr prettyPrintError (Hint.GhcException errStr) = errStr @@ -815,15 +815,16 @@ syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a) syncRun action = do + liftTraceIO "sync - confirming" + ctx <- confirmRunning liftTraceIO "sync - running" - page <- confirmRunning - liftIO $ HS.runIn (server page) action + liftIO $ HS.runIn (server ctx) action asyncRun :: Hint.InterpreterT IO a -> HPage (MVar (Either Hint.InterpreterError a)) asyncRun action = do liftTraceIO "async - running" - page <- confirmRunning - liftIO $ HS.asyncRunIn (server page) action + ctx <- confirmRunning + liftIO $ HS.asyncRunIn (server ctx) action confirmRunning :: HPage Context confirmRunning = modify (\ctx -> apply (running ctx) ctx) >> get @@ -909,7 +910,7 @@ moduleElemDesc :: Hint.ModuleElem -> Hint.InterpreterT IO ModuleElemDesc moduleElemDesc (Hint.Fun fn) = do - t <- (Hint.typeOf fn) `catchError` (\e -> return []) + t <- (Hint.typeOf fn) `catchError` (\_ -> return []) return MEFun{funName = fn, funType = t} moduleElemDesc (Hint.Class cn cfs) = do mcfs <- flip mapM cfs $ moduleElemDesc . Hint.Fun @@ -945,7 +946,7 @@ then return (Left missing) else withFileContents filename $ \str -> case lines str of - [headder, rest] -> case reads rest of + [_header, rest] -> case reads rest of [(bi,_)] -> return (Right bi) _ -> return (Left cantParse) _ -> return (Left cantParse) diff --git a/src/HPage/GUI/Constants.hs b/src/HPage/GUI/Constants.hs --- a/src/HPage/GUI/Constants.hs +++ b/src/HPage/GUI/Constants.hs @@ -1,6 +1,7 @@ module HPage.GUI.Constants where +bottomString, bottomChar :: String bottomString = "\10200" bottomChar = "\724" diff --git a/src/HPage/GUI/Dialogs.hs b/src/HPage/GUI/Dialogs.hs --- a/src/HPage/GUI/Dialogs.hs +++ b/src/HPage/GUI/Dialogs.hs @@ -22,15 +22,15 @@ htmlDialog win "Hayoo!" (sz 640 480) $ "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=" ++ query htmlDialog :: Window a -> String -> Size -> String -> IO () -htmlDialog win caption size url = +htmlDialog win caption winsize url = do dlg <- dialog win [text := caption] - htmlw <- htmlWindowCreate dlg idAny (rect (point 0 0) size) 0 "" + htmlw <- htmlWindowCreate dlg idAny (rect (point 0 0) winsize) 0 "" debugIO ("url:", url) htmlWindowLoadPage htmlw url set dlg [layout := fill $ widget htmlw, visible := True, - clientSize := size] + clientSize := winsize] windowCenter dlg wxCENTRE_ON_SCREEN return () diff --git a/src/HPage/GUI/FreeTextWindow.hs b/src/HPage/GUI/FreeTextWindow.hs --- a/src/HPage/GUI/FreeTextWindow.hs +++ b/src/HPage/GUI/FreeTextWindow.hs @@ -14,6 +14,8 @@ import System.FilePath import System.Directory import System.IO.Error hiding (try, catch) +import System.Exit +import GHC.Paths import Data.List import Data.Bits import Data.Char (toLower) @@ -93,284 +95,303 @@ gui :: [String] -> IO () gui args = do - -- Server context - model <- HPS.start - win <- frame [text := "\955Page", visible := False] - imageFile ("icon" "hpage.tif") >>= topLevelWindowSetIconFromFile win - - set win [on closing := HPS.stop model >> propagateEvent] - ssh <- SS.start win - - SS.step ssh 20 "Starting up..." - - -- Containers - ntbkL <- notebook win [] - pnlPs <- panel ntbkL [] - pnlMs <- panel ntbkL [] - - -- Text page... - -- txtCode <- styledTextCtrl win [] - txtCode <- textCtrl win [font := fontFixed, text := ""] - - -- Document Selector - lstPages <- singleListBox pnlPs [style := wxLB_NEEDED_SB, outerSize := sz 400 600] - - -- Modules Lists - imageFiles <- mapM imageFile ["m_imported.ico", "m_interpreted.ico", "m_compiled.ico", "m_package.ico"] - imagePaths <- mapM getAbsoluteFilePath imageFiles - images <- imageListFromFiles (sz 16 16) imagePaths - varModsSel <- varCreate $ -1 - lstModules <- listCtrlEx pnlMs (wxLC_REPORT + wxLC_ALIGN_LEFT + wxLC_NO_HEADER + wxLC_SINGLE_SEL) - [columns := [("Module", AlignLeft, 200), - ("Origin", AlignLeft, 1)]] - listCtrlSetImageList lstModules images wxIMAGE_LIST_SMALL - - -- Results panel - pnlRes <- panel win [] - txtValue <- textEntry pnlRes [style := wxTE_READONLY] - varErrors <- varCreate [] - txtType <- textEntry pnlRes [style := wxTE_READONLY] - 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 \955Page! type in your instructions :)"] - set win [statusBar := [status]] - - -- Timers ... - refreshTimer <- timer win [] - charTimer <- timer win [] + iconFile <- imageFile $ "icon" "hpage" <.> "ico" + iconCreateFromFile iconFile sizeNull >>= topLevelWindowSetIcon win - -- Search ... - search <- findReplaceDataCreate wxFR_DOWN - - chv <- newEmptyMVar - chfv <- newEmptyMVar - vfv <- newEmptyMVar + ssh <- SS.start win - let guiRes = GUIRes btnInterpret lblInterpret txtValue lbl4Dots txtType varErrors - let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status refreshTimer charTimer search chv chfv vfv - let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx - - -- Helper processes - chf <- spawn $ charFiller guiCtx - putMVar chfv chf - vf <- spawn $ valueFiller guiCtx - putMVar vfv vf + SS.step ssh 0 "Checking installation..." - -- Events - timerOnCommand refreshTimer $ refreshExpr model guiCtx - timerOnCommand charTimer $ do - wasEmpty <- tryPutMVar chv Nothing - if wasEmpty - then do - newchf <- spawn $ charFiller guiCtx - swapMVar chfv newchf >>= kill - else return () - - set btnInterpret [on command := onCmd "interpret" interpret] + ghcInstalled <- doesFileExist ghc - set lstPages [on select := onCmd "pageChange" pageChange] - set txtCode [on keyboard := onCmd "key" . keyEvent, - on mouse := \e -> case e of - MouseLeftUp _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent - MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent - MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu - _ -> propagateEvent] - set txtValue [on mouse := \e -> case e of - MouseRightDown _ _ -> onCmd "valueContextMenu" valueContextMenu - _ -> propagateEvent] - set txtType [on mouse := \e -> case e of - MouseRightDown _ _ -> onCmd "typeContextMenu" typeContextMenu - _ -> propagateEvent] - set lstModules [on listEvent := \e -> case e of - ListItemSelected idx -> varSet varModsSel idx - ListItemRightClick idx -> varSet varModsSel idx >> onCmd "moduleContextMenu" moduleContextMenu - _ -> propagateEvent] + debugIO $ "ghc: " ++ ghc - -- Menu bar... - mnuPage <- menuPane [text := "Page"] - menuAppend mnuPage wxId_NEW "&New\tCtrl-n" "New Page" False - menuAppend mnuPage wxId_CLOSE "&Close\tCtrl-w" "Close Page" False - menuAppend mnuPage wxId_CLOSE_ALL "&Close All\tCtrl-Shift-w" "Close All Pages" False - menuAppendSeparator mnuPage - menuAppend mnuPage wxId_OPEN "&Open...\tCtrl-o" "Open Page" False - menuAppend mnuPage wxId_SAVE "&Save\tCtrl-s" "Save Page" False - menuAppend mnuPage wxId_SAVEAS "&Save as...\tCtrl-Shift-s" "Save Page as" False - menuAppendSeparator mnuPage - menuQuit mnuPage [on command := wxcAppExit] + if not ghcInstalled + then do + SS.step ssh 100 "failed" + set win [visible := True] + shutdownTimer <- timer win [on command := do + errorDialog win "Error" "Seems like you don't have GHC installed.\nPlease install the Haskelll Platform from http://hackage.haskell.org/platform/" + wxcAppExit + exitWith $ ExitFailure 1] + timerStart shutdownTimer 50 True + return () + else do + SS.step ssh 10 "Starting the hint-server..." + + -- Server context + model <- HPS.start + + SS.step ssh 20 "Starting up..." + + set win [on closing := HPS.stop model >> propagateEvent] - mnuEdit <- menuPane [text := "Edit"] - menuAppend mnuEdit wxId_UNDO "&Undo\tCtrl-z" "Undo" False - menuAppend mnuEdit wxId_REDO "&Redo\tCtrl-Shift-z" "Redo" False - menuAppendSeparator mnuEdit - menuAppend mnuEdit wxId_CUT "C&ut\tCtrl-x" "Cut" False - menuAppend mnuEdit wxId_COPY "&Copy\tCtrl-c" "Copy" False - menuAppend mnuEdit wxId_PASTE "&Paste\tCtrl-v" "Paste" False - menuAppendSeparator mnuEdit - menuAppend mnuEdit wxId_FIND "&Find...\tCtrl-f" "Find" False - menuAppend mnuEdit wxId_FORWARD "Find &Next\tCtrl-g" "Find Next" False - menuAppend mnuEdit wxId_BACKWARD "Find &Previous\tCtrl-Shift-g" "Find Previous" False - menuAppend mnuEdit wxId_REPLACE "&Replace...\tCtrl-Shift-r" "Replace" False - menuAppendSeparator mnuEdit - menuAppend mnuEdit wxId_PREFERENCES "&Preferences...\tCtrl-," "Preferences" False - - mnuHask <- menuPane [text := "Haskell"] - menuAppend mnuHask wxId_HASK_LOAD_PKG "Load &package...\tCtrl-Alt-l" "Load Cabal Package" False - menuAppendSeparator mnuHask - menuAppend mnuHask wxId_HASK_LOAD "&Load modules...\tCtrl-l" "Load Modules" False - menuAppend mnuHask wxId_HASK_LOADNAME "Load modules by &name...\tCtrl-Shift-l" "Load Modules by Name" False - 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_INTERPRET "&Interpret\tCtrl-i" "Interpret the Current Expression" False - menuAppend mnuHask wxId_HASK_NAVIGATE "Search on Ha&yoo!\tCtrl-y" "Search the Current Selection on Hayoo!" False + -- Containers + ntbkL <- notebook win [] + pnlPs <- panel ntbkL [] + pnlMs <- panel ntbkL [] + + -- Text page... + -- txtCode <- styledTextCtrl win [] + txtCode <- textCtrl win [font := fontFixed, text := ""] + + -- Document Selector + lstPages <- singleListBox pnlPs [style := wxLB_NEEDED_SB, outerSize := sz 400 600] + + -- Modules Lists + imageFiles <- mapM imageFile ["m_imported.ico", "m_interpreted.ico", "m_compiled.ico", "m_package.ico"] + imagePaths <- mapM getAbsoluteFilePath imageFiles + images <- imageListFromFiles (sz 16 16) imagePaths + varModsSel <- varCreate $ -1 + lstModules <- listCtrlEx pnlMs (wxLC_REPORT + wxLC_ALIGN_LEFT + wxLC_NO_HEADER + wxLC_SINGLE_SEL) + [columns := [("Module", AlignLeft, 200), + ("Origin", AlignLeft, 1)]] + listCtrlSetImageList lstModules images wxIMAGE_LIST_SMALL - mnuHelp <- menuHelp [] - menuAppend mnuHelp wxId_HELP "&Help page\tCtrl-h" "Open the Help Page" False - about <- aboutFile - menuAbout mnuHelp [on command := aboutDialog win about] + -- Results panel + pnlRes <- panel win [] + txtValue <- textEntry pnlRes [style := wxTE_READONLY] + varErrors <- varCreate [] + txtType <- textEntry pnlRes [style := wxTE_READONLY] + 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]] - set win [menuBar := [mnuPage, mnuEdit, mnuHask, mnuHelp]] - evtHandlerOnMenuCommand win wxId_NEW $ onCmd "runHP' addPage" $ runHP' HP.addPage - evtHandlerOnMenuCommand win wxId_CLOSE $ onCmd "runHP' closePage" $ runHP' HP.closePage - evtHandlerOnMenuCommand win wxId_CLOSE_ALL $ onCmd "runHP' closeAllPages" $ runHP' HP.closeAllPages - evtHandlerOnMenuCommand win wxId_OPEN $ onCmd "openPage" openPage - evtHandlerOnMenuCommand win wxId_SAVE $ onCmd "savePage" savePage - evtHandlerOnMenuCommand win wxId_SAVEAS $ onCmd "savePageAs" savePageAs - evtHandlerOnMenuCommand win wxId_UNDO $ onCmd "runHP' undo" $ runHP' HP.undo - evtHandlerOnMenuCommand win wxId_REDO $ onCmd "runHP' redo" $ runHP' HP.redo - evtHandlerOnMenuCommand win wxId_CUT $ onCmd "cut" cut - evtHandlerOnMenuCommand win wxId_COPY $ onCmd "copy" copy - evtHandlerOnMenuCommand win wxId_PASTE $ onCmd "paste" paste - evtHandlerOnMenuCommand win wxId_FIND $ onCmd "justFind" justFind - evtHandlerOnMenuCommand win wxId_FORWARD $ onCmd "findNext" justFindNext - evtHandlerOnMenuCommand win wxId_BACKWARD $ onCmd "findPrev" justFindPrev - evtHandlerOnMenuCommand win wxId_REPLACE $ onCmd "findReplace" findReplace - evtHandlerOnMenuCommand win wxId_HASK_LOAD_PKG $ onCmd "loadPackage" loadPackage - evtHandlerOnMenuCommand win wxId_HASK_LOAD $ onCmd "loadModules" loadModules - evtHandlerOnMenuCommand win wxId_HASK_ADD $ onCmd "importModules" importModules - evtHandlerOnMenuCommand win wxId_HASK_LOADNAME $ onCmd "loadModulesByName" loadModulesByName - 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_INTERPRET $ onCmd "interpret" interpret - evtHandlerOnMenuCommand win wxId_HASK_NAVIGATE $ onCmd "hayoo" hayoo - evtHandlerOnMenuCommand win wxId_HASK_COPY $ onCmd "copyResult" copyResult - evtHandlerOnMenuCommand win wxId_HASK_COPY_TYPE $ onCmd "copyType" copyType - evtHandlerOnMenuCommand win wxId_HASK_EXPLAIN $ onCmd "explain" explain - evtHandlerOnMenuCommand win wxId_HELP $ onCmd "help" openHelpPage + -- Status bar... + status <- statusField [text := "hello... this is \955Page! type in your instructions :)"] + set win [statusBar := [status]] - -- Tool bar... - tbMain <- toolBarEx win True True [] - mitLoadPkg <- menuFindItem mnuHask wxId_HASK_LOAD_PKG - mitNew <- menuFindItem mnuPage wxId_NEW - mitOpen <- menuFindItem mnuPage wxId_OPEN - mitSave <- menuFindItem mnuPage wxId_SAVE - mitCut <- menuFindItem mnuEdit wxId_CUT - mitCopy <- menuFindItem mnuEdit wxId_COPY - mitPaste <- menuFindItem mnuEdit wxId_PASTE - mitReload <- menuFindItem mnuHask wxId_HASK_RELOAD - loadPath <- imageFile "load.png" - newPath <- imageFile "new.png" - openPath <- imageFile "open.png" - savePath <- imageFile "save.png" - cutPath <- imageFile "cut.png" - copyPath <- imageFile "copy.png" - pastePath <- imageFile "paste.png" - reloadPath <- imageFile "reload.png" - toolMenu tbMain mitLoadPkg "Load Package" loadPath [tooltip := "Load Cabal Package"] - toolBarAddSeparator tbMain - toolMenu tbMain mitNew "New" newPath [tooltip := "New Page"] - toolMenu tbMain mitOpen "Open" openPath [tooltip := "Open Page"] - toolMenu tbMain mitSave "Save" savePath [tooltip := "Save Page"] - toolBarAddSeparator tbMain - toolMenu tbMain mitCut "Cut" cutPath [tooltip := "Cut"] - toolMenu tbMain mitCopy "Copy" copyPath [tooltip := "Copy"] - toolMenu tbMain mitPaste "Paste" pastePath [tooltip := "Paste"] - toolBarAddSeparator tbMain - toolMenu tbMain mitReload "Reload" reloadPath [tooltip := "Reload Modules"] - toolBarSetToolBitmapSize tbMain $ sz 32 32 - - -- Layout settings - 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) $ fill $ widget txtCode - set win [layout := column 5 [fill $ row 10 [leftL, rightL], resultsL], - clientSize := sz 800 600] - - --HACK: We need to keep a timer ticking just to refresh the screen when the user is doing nothing - -- That's because the main C loop of wx only calls wxHaskell callbacks when something happens - -- and we try to make things happen in this side but they're not reflected there until some- - -- thing happens there - timer win [interval := 50, on command := return ()] + -- Timers ... + refreshTimer <- timer win [] + charTimer <- timer win [] + + -- Search ... + search <- findReplaceDataCreate wxFR_DOWN - -- test the server... - SS.step ssh 40 "Preparing model..." - runTxtHPSelection "1" model HP.interpret + chv <- newEmptyMVar + chfv <- newEmptyMVar + vfv <- newEmptyMVar + + let guiRes = GUIRes btnInterpret lblInterpret txtValue lbl4Dots txtType varErrors + let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status refreshTimer charTimer search chv chfv vfv + let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx - SS.step ssh 60 "Loading first page..." - -- ...and RUN! - refreshPage model guiCtx + -- Helper processes + chf <- spawn $ charFiller guiCtx + putMVar chfv chf + vf <- spawn $ valueFiller guiCtx + putMVar vfv vf + + -- Events + timerOnCommand refreshTimer $ refreshExpr model guiCtx + timerOnCommand charTimer $ do + wasEmpty <- tryPutMVar chv Nothing + if wasEmpty + then do + newchf <- spawn $ charFiller guiCtx + swapMVar chfv newchf >>= kill + else return () - SS.step ssh 80 "Loading help page..." - onCmd "start" openHelpPage + set btnInterpret [on command := onCmd "interpret" interpret] + + set lstPages [on select := onCmd "pageChange" pageChange] + set txtCode [on keyboard := onCmd "key" . keyEvent, + on mouse := \e -> case e of + MouseLeftUp _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent + MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent + MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu + _ -> propagateEvent] + set txtValue [on mouse := \e -> case e of + MouseRightDown _ _ -> onCmd "valueContextMenu" valueContextMenu + _ -> propagateEvent] + set txtType [on mouse := \e -> case e of + MouseRightDown _ _ -> onCmd "typeContextMenu" typeContextMenu + _ -> propagateEvent] + set lstModules [on listEvent := \e -> case e of + ListItemSelected idx -> varSet varModsSel idx + ListItemRightClick idx -> varSet varModsSel idx >> onCmd "moduleContextMenu" moduleContextMenu + _ -> propagateEvent] + + -- Menu bar... + mnuPage <- menuPane [text := "Page"] + menuAppend mnuPage wxId_NEW "&New\tCtrl-n" "New Page" False + menuAppend mnuPage wxId_CLOSE "&Close\tCtrl-w" "Close Page" False + menuAppend mnuPage wxId_CLOSE_ALL "&Close All\tCtrl-Shift-w" "Close All Pages" False + menuAppendSeparator mnuPage + menuAppend mnuPage wxId_OPEN "&Open...\tCtrl-o" "Open Page" False + menuAppend mnuPage wxId_SAVE "&Save\tCtrl-s" "Save Page" False + menuAppend mnuPage wxId_SAVEAS "&Save as...\tCtrl-Shift-s" "Save Page as" False + menuAppendSeparator mnuPage + menuQuit mnuPage [on command := wxcAppExit] + + mnuEdit <- menuPane [text := "Edit"] + menuAppend mnuEdit wxId_UNDO "&Undo\tCtrl-z" "Undo" False + menuAppend mnuEdit wxId_REDO "&Redo\tCtrl-Shift-z" "Redo" False + menuAppendSeparator mnuEdit + menuAppend mnuEdit wxId_CUT "C&ut\tCtrl-x" "Cut" False + menuAppend mnuEdit wxId_COPY "&Copy\tCtrl-c" "Copy" False + menuAppend mnuEdit wxId_PASTE "&Paste\tCtrl-v" "Paste" False + menuAppendSeparator mnuEdit + menuAppend mnuEdit wxId_FIND "&Find...\tCtrl-f" "Find" False + menuAppend mnuEdit wxId_FORWARD "Find &Next\tCtrl-g" "Find Next" False + menuAppend mnuEdit wxId_BACKWARD "Find &Previous\tCtrl-Shift-g" "Find Previous" False + menuAppend mnuEdit wxId_REPLACE "&Replace...\tCtrl-Shift-r" "Replace" False + menuAppendSeparator mnuEdit + menuAppend mnuEdit wxId_PREFERENCES "&Preferences...\tCtrl-," "Preferences" False - SS.step ssh 90 "Loading UI..." - case args of - [] -> - return () - dir:_ -> - do - SS.step ssh 92 "looking for package files..." - setupConfig <- canonicalizePath $ dir "dist" "setup-config" - pkgExists <- doesFileExist setupConfig - case pkgExists of - False -> - warningDialog win "Error" $ setupConfig ++ " doesn't exist.\n Maybe you have to reconfigure the package" - True -> do - SS.step ssh 95 "Loading package..." - loadres <- tryIn' model $ do - lr <- HP.loadPackage setupConfig - HP.addPage - return lr - case loadres of - Left err -> - warningDialog win "Error" err - Right (Left err) -> - warningDialog win "Error" err - Right (Right pkg) -> - do - setCurrentDirectory dir - SS.step ssh 97 "warming up..." - frameSetTitle win $ "\955Page - " ++ prettyShow pkg - - SS.step ssh 99 "Cleaning UI..." - refreshPage model guiCtx + mnuHask <- menuPane [text := "Haskell"] + menuAppend mnuHask wxId_HASK_LOAD_PKG "Load &package...\tCtrl-Alt-l" "Load Cabal Package" False + menuAppendSeparator mnuHask + menuAppend mnuHask wxId_HASK_LOAD "&Load modules...\tCtrl-l" "Load Modules" False + menuAppend mnuHask wxId_HASK_LOADNAME "Load modules by &name...\tCtrl-Shift-l" "Load Modules by Name" False + 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_INTERPRET "&Interpret\tCtrl-i" "Interpret the Current Expression" False + menuAppend mnuHask wxId_HASK_NAVIGATE "Search on Ha&yoo!\tCtrl-y" "Search the Current Selection on Hayoo!" False + + mnuHelp <- menuHelp [] + menuAppend mnuHelp wxId_HELP "&Help page\tCtrl-h" "Open the Help Page" False + about <- aboutFile + menuAbout mnuHelp [on command := aboutDialog win about] + + set win [menuBar := [mnuPage, mnuEdit, mnuHask, mnuHelp]] + evtHandlerOnMenuCommand win wxId_NEW $ onCmd "runHP' addPage" $ runHP' HP.addPage + evtHandlerOnMenuCommand win wxId_CLOSE $ onCmd "runHP' closePage" $ runHP' HP.closePage + evtHandlerOnMenuCommand win wxId_CLOSE_ALL $ onCmd "runHP' closeAllPages" $ runHP' HP.closeAllPages + evtHandlerOnMenuCommand win wxId_OPEN $ onCmd "openPage" openPage + evtHandlerOnMenuCommand win wxId_SAVE $ onCmd "savePage" savePage + evtHandlerOnMenuCommand win wxId_SAVEAS $ onCmd "savePageAs" savePageAs + evtHandlerOnMenuCommand win wxId_UNDO $ onCmd "runHP' undo" $ runHP' HP.undo + evtHandlerOnMenuCommand win wxId_REDO $ onCmd "runHP' redo" $ runHP' HP.redo + evtHandlerOnMenuCommand win wxId_CUT $ onCmd "cut" cut + evtHandlerOnMenuCommand win wxId_COPY $ onCmd "copy" copy + evtHandlerOnMenuCommand win wxId_PASTE $ onCmd "paste" paste + evtHandlerOnMenuCommand win wxId_FIND $ onCmd "justFind" justFind + evtHandlerOnMenuCommand win wxId_FORWARD $ onCmd "findNext" justFindNext + evtHandlerOnMenuCommand win wxId_BACKWARD $ onCmd "findPrev" justFindPrev + evtHandlerOnMenuCommand win wxId_REPLACE $ onCmd "findReplace" findReplace + evtHandlerOnMenuCommand win wxId_HASK_LOAD_PKG $ onCmd "loadPackage" loadPackage + evtHandlerOnMenuCommand win wxId_HASK_LOAD $ onCmd "loadModules" loadModules + evtHandlerOnMenuCommand win wxId_HASK_ADD $ onCmd "importModules" importModules + evtHandlerOnMenuCommand win wxId_HASK_LOADNAME $ onCmd "loadModulesByName" loadModulesByName + 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_INTERPRET $ onCmd "interpret" interpret + evtHandlerOnMenuCommand win wxId_HASK_NAVIGATE $ onCmd "hayoo" hayoo + evtHandlerOnMenuCommand win wxId_HASK_COPY $ onCmd "copyResult" copyResult + evtHandlerOnMenuCommand win wxId_HASK_COPY_TYPE $ onCmd "copyType" copyType + evtHandlerOnMenuCommand win wxId_HASK_EXPLAIN $ onCmd "explain" explain + evtHandlerOnMenuCommand win wxId_HELP $ onCmd "help" openHelpPage + + -- Tool bar... + tbMain <- toolBarEx win True True [] + mitLoadPkg <- menuFindItem mnuHask wxId_HASK_LOAD_PKG + mitNew <- menuFindItem mnuPage wxId_NEW + mitOpen <- menuFindItem mnuPage wxId_OPEN + mitSave <- menuFindItem mnuPage wxId_SAVE + mitCut <- menuFindItem mnuEdit wxId_CUT + mitCopy <- menuFindItem mnuEdit wxId_COPY + mitPaste <- menuFindItem mnuEdit wxId_PASTE + mitReload <- menuFindItem mnuHask wxId_HASK_RELOAD + loadPath <- imageFile "load.png" + newPath <- imageFile "new.png" + openPath <- imageFile "open.png" + savePath <- imageFile "save.png" + cutPath <- imageFile "cut.png" + copyPath <- imageFile "copy.png" + pastePath <- imageFile "paste.png" + reloadPath <- imageFile "reload.png" + toolMenu tbMain mitLoadPkg "Load Package" loadPath [tooltip := "Load Cabal Package"] + toolBarAddSeparator tbMain + toolMenu tbMain mitNew "New" newPath [tooltip := "New Page"] + toolMenu tbMain mitOpen "Open" openPath [tooltip := "Open Page"] + toolMenu tbMain mitSave "Save" savePath [tooltip := "Save Page"] + toolBarAddSeparator tbMain + toolMenu tbMain mitCut "Cut" cutPath [tooltip := "Cut"] + toolMenu tbMain mitCopy "Copy" copyPath [tooltip := "Copy"] + toolMenu tbMain mitPaste "Paste" pastePath [tooltip := "Paste"] + toolBarAddSeparator tbMain + toolMenu tbMain mitReload "Reload" reloadPath [tooltip := "Reload Modules"] + toolBarSetToolBitmapSize tbMain $ sz 32 32 - SS.step ssh 100 "ready" - set win [visible := True] - set txtCode [font := fontFixed] -- again just to be sure - focusOn txtCode + -- Layout settings + 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) $ fill $ widget txtCode + set win [layout := column 5 [fill $ row 10 [leftL, rightL], resultsL], + clientSize := sz 800 600] + + --HACK: We need to keep a timer ticking just to refresh the screen when the user is doing nothing + -- That's because the main C loop of wx only calls wxHaskell callbacks when something happens + -- and we try to make things happen in this side but they're not reflected there until some- + -- thing happens there + timer win [interval := 50, on command := return ()] + + -- test the server... + SS.step ssh 40 "Preparing model..." + runTxtHPSelection "1" model HP.interpret + + SS.step ssh 60 "Loading first page..." + -- ...and RUN! + refreshPage model guiCtx + + SS.step ssh 80 "Loading help page..." + onCmd "start" openHelpPage + + SS.step ssh 90 "Loading UI..." + case args of + [] -> + return () + dir:_ -> + do + SS.step ssh 92 "looking for package files..." + setupConfig <- canonicalizePath $ dir "dist" "setup-config" + pkgExists <- doesFileExist setupConfig + case pkgExists of + False -> + warningDialog win "Error" $ setupConfig ++ " doesn't exist.\n Maybe you have to reconfigure the package" + True -> do + SS.step ssh 95 "Loading package..." + loadres <- tryIn' model $ do + lr <- HP.loadPackage setupConfig + HP.addPage + return lr + case loadres of + Left err -> + warningDialog win "Error" err + Right (Left err) -> + warningDialog win "Error" err + Right (Right pkg) -> + do + setCurrentDirectory dir + SS.step ssh 97 "warming up..." + frameSetTitle win $ "\955Page - " ++ prettyShow pkg + + SS.step ssh 99 "Cleaning UI..." + refreshPage model guiCtx + + SS.step ssh 100 "ready" + set win [visible := True] + set txtCode [font := fontFixed] -- again just to be sure + focusOn txtCode -- PROCESSES ------------------------------------------------------------------- charFiller :: GUIContext -> Process String () -charFiller GUICtx{guiResults = GUIRes{resValue = txtValue, - resErrors= varErrors}, - guiChrVar = chv, - guiStatus = status} = +charFiller GUICtx{guiResults = GUIRes{resErrors= varErrors}, + guiChrVar = chv} = forever $ do t <- recv liftIO $ do @@ -424,8 +445,7 @@ text := "Interpret"] valueFiller' :: GUIContext -> String -> IO String -valueFiller' guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue, - resErrors = varErrors}} val = +valueFiller' guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue}} val = do h <- try (case val of [] -> return [] @@ -486,12 +506,12 @@ refreshPage, savePageAs, savePage, openPage, pageChange, copy, copyResult, copyType, cut, paste, justFind, justFindNext, justFindPrev, findReplace, - textContextMenu, moduleContextMenu, valueContextMenu, + textContextMenu, moduleContextMenu, valueContextMenu, typeContextMenu, restartTimer, interpret, hayoo, explain, loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () -moduleContextMenu model guiCtx@GUICtx{guiWin = win, guiModules = (varModsSel, lstModules)} = +moduleContextMenu model GUICtx{guiWin = win, guiModules = (varModsSel, lstModules)} = do pointWithinWindow <- windowGetMousePosition win i <- varGet varModsSel @@ -500,9 +520,9 @@ (-1) -> do return () - i -> + j -> do - itm <- get lstModules $ item i + itm <- get lstModules $ item j case itm of [_, "Package"] -> menuAppend contextMenu wxId_HASK_LOAD_FAST "&Load" "Load Module" False @@ -576,7 +596,7 @@ return itemMenu -textContextMenu model guiCtx@GUICtx{guiWin = win, guiCode = txtCode} = +textContextMenu _model GUICtx{guiWin = win, guiCode = txtCode} = do contextMenu <- menuPane [] sel <- textCtrlGetStringSelection txtCode @@ -596,8 +616,8 @@ menuPopup contextMenu pointWithinWindow win objectDelete contextMenu -valueContextMenu model guiCtx@GUICtx{guiWin = win, - guiResults = GUIRes{resValue = txtValue}} = +valueContextMenu _model GUICtx{guiWin = win, + guiResults = GUIRes{resValue = txtValue}} = do contextMenu <- menuPane [] sel <- textCtrlGetStringSelection txtValue @@ -614,8 +634,8 @@ menuPopup contextMenu pointWithinWindow win objectDelete contextMenu -typeContextMenu model guiCtx@GUICtx{guiWin = win, - guiResults = GUIRes{resType = txtType}} = +typeContextMenu _model GUICtx{guiWin = win, + guiResults = GUIRes{resType = txtType}} = do contextMenu <- menuPane [] sel <- textCtrlGetStringSelection txtType @@ -758,14 +778,15 @@ set status [text := "loading..."] runHP (HP.loadModules $ words mns) model guiCtx -loadModulesByNameFast model guiCtx@GUICtx{guiWin = win, guiModules = (varModsSel, lstModules), guiStatus = status} = +loadModulesByNameFast model guiCtx@GUICtx{guiModules = (varModsSel, lstModules), + guiStatus = status} = do i <- varGet varModsSel case i of (-1) -> return () - i -> + j -> do - mnText <- listCtrlGetItemText lstModules i + mnText <- listCtrlGetItemText lstModules j let mns = [mnText] set status [text := "loading..."] runHP (HP.loadModules mns) model guiCtx @@ -893,9 +914,9 @@ Right () -> refreshPage model guiCtx -explain model guiCtx@GUICtx{guiWin = win, - guiResults = GUIRes{resValue = txtValue, - resErrors = varErrors}} = +explain _model GUICtx{guiWin = win, + guiResults = GUIRes{resValue = txtValue, + resErrors = varErrors}} = do sel <- textCtrlGetStringSelection txtValue if sel == bottomChar || sel == bottomString @@ -914,7 +935,7 @@ else errorDialog win "Bottom String" err else return () -hayoo model guiCtx@GUICtx{guiCode = txtCode, guiWin = win} = +hayoo _model GUICtx{guiCode = txtCode, guiWin = win} = textCtrlGetStringSelection txtCode >>= hayooDialog win interpret model guiCtx@GUICtx{guiResults = GUIRes{resLabel = lblInterpret, @@ -924,7 +945,6 @@ resType = txtType, resErrors = varErrors}, guiCode = txtCode, - guiCharTimer = charTimer, guiWin = win, guiChrVar = chv, guiValFiller = vfv, @@ -997,7 +1017,7 @@ Right () -> do let cpi = case piRes of - Left err -> 0 + Left _err -> 0 Right cp -> cp newacc = HP.setPageText s (length s) >> hpacc res <- tryIn model newacc @@ -1005,9 +1025,9 @@ return res refreshExpr :: HPS.ServerHandle -> GUIContext -> IO () -refreshExpr model guiCtx@GUICtx{guiCode = txtCode, - guiWin = win, - guiTimer = refreshTimer} = +refreshExpr model GUICtx{guiCode = txtCode, + guiWin = win, + guiTimer = refreshTimer} = do set txtCode [font := fontFixed] -- Just to be sure txt <- get txtCode text @@ -1025,7 +1045,7 @@ -- TIMER HANDLERS -------------------------------------------------------------- -restartTimer model guiCtx@GUICtx{guiWin = win, guiTimer = refreshTimer} = +restartTimer _model GUICtx{guiTimer = refreshTimer} = do started <- timerStart refreshTimer 1000 True if started @@ -1041,6 +1061,7 @@ tryIn :: HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError x) -> IO (Either ErrorString x) tryIn model hpacc = do + debugIO "Trying..." res <- HPS.runIn model $ catchError (hpacc >>= return . Right) (\ioerr -> return $ Left ioerr) case res of diff --git a/src/HPage/GUI/SplashScreen.hs b/src/HPage/GUI/SplashScreen.hs --- a/src/HPage/GUI/SplashScreen.hs +++ b/src/HPage/GUI/SplashScreen.hs @@ -26,11 +26,11 @@ start :: Window a -> IO SplashHandle start topWin = (spawn $ guiRunner topWin) >>= return . SH - where guiRunner topWin = do - (caption, progress, win) <- liftIO $ gui topWin + where guiRunner tw = do + (caption, progress, win) <- liftIO $ gui tw forever $ do myself <- self - (percent, label) <- recv + (percent, lbl) <- recv liftIO $ case percent of 100 -> do @@ -40,8 +40,8 @@ kill myself _ -> do - debugIO ("progress", percent, label) - set caption [text := label] + debugIO ("progress", percent, lbl) + set caption [text := lbl] set progress [selection := percent] wxcAppSafeYield win return () diff --git a/src/HPage/Server.hs b/src/HPage/Server.hs --- a/src/HPage/Server.hs +++ b/src/HPage/Server.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans import Control.Concurrent.Process import HPage.Control +import HPage.Utils.Log newtype ServerHandle = SH {handle :: Handle (HPage ())} @@ -16,8 +17,10 @@ runIn :: ServerHandle -> HPage a -> IO a runIn server action = runHere $ do + liftDebugIO "Sending an action..." me <- self sendTo (handle server) $ action >>= sendTo me + liftDebugIO "...waiting for result" recv stop :: ServerHandle -> IO () diff --git a/src/HPage/Utils/Log.hs b/src/HPage/Utils/Log.hs --- a/src/HPage/Utils/Log.hs +++ b/src/HPage/Utils/Log.hs @@ -28,12 +28,12 @@ errorIO = logIO Error fatalIO = logIO Fatal -{- with log... -liftTraceIO = liftLogIO Trace -liftDebugIO = liftLogIO Debug --} +{- without log... liftTraceIO _ = return () liftDebugIO _ = return () +-} +liftTraceIO = liftLogIO Trace +liftDebugIO = liftLogIO Debug liftInfoIO = liftLogIO Info liftWarnIO = liftLogIO Warning liftErrorIO = liftLogIO Error