diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.3.2 +version: 0.3.3 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -7,7 +7,7 @@ copyright: 2009 Fernando "Brujo" Benavides maintainer: greenmellon@gmail.com stability: provisional -homepage: http://elbrujohalcon.github.com/hPage/ +homepage: http://haskell.hpage.com package-url: http://code.haskell.org/hpage bug-reports: http://github.com/elbrujohalcon/hPage/issues synopsis: A scrapbook for Haskell developers @@ -17,10 +17,7 @@ tested-with: GHC ==6.10.3, GHC ==6.10.4 data-files: LICENSE README res/images/*.png - res/images/icon/hpage.gif res/images/icon/hPage.icns - res/images/icon/hpage.jpg - res/images/icon/hpage.png res/images/icon/hpage.tif res/help/helpPage.hs data-dir: "" @@ -60,7 +57,8 @@ extensions: CPP install-includes: hs-source-dirs: src - other-modules: HPage.GUI.IDs, + other-modules: + HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, HPage.Control, diff --git a/res/images/about.png b/res/images/about.png Binary files a/res/images/about.png and b/res/images/about.png differ diff --git a/res/images/copy.png b/res/images/copy.png Binary files a/res/images/copy.png and b/res/images/copy.png differ diff --git a/res/images/cut.png b/res/images/cut.png Binary files a/res/images/cut.png and b/res/images/cut.png differ diff --git a/res/images/icon/hpage.gif b/res/images/icon/hpage.gif deleted file mode 100644 Binary files a/res/images/icon/hpage.gif and /dev/null differ diff --git a/res/images/icon/hpage.jpg b/res/images/icon/hpage.jpg deleted file mode 100644 Binary files a/res/images/icon/hpage.jpg and /dev/null differ diff --git a/res/images/icon/hpage.png b/res/images/icon/hpage.png deleted file mode 100644 Binary files a/res/images/icon/hpage.png and /dev/null differ diff --git a/res/images/icon/hpage.tif b/res/images/icon/hpage.tif Binary files a/res/images/icon/hpage.tif and b/res/images/icon/hpage.tif differ diff --git a/res/images/load.png b/res/images/load.png new file mode 100644 Binary files /dev/null and b/res/images/load.png differ diff --git a/res/images/new.png b/res/images/new.png Binary files a/res/images/new.png and b/res/images/new.png differ diff --git a/res/images/open.png b/res/images/open.png Binary files a/res/images/open.png and b/res/images/open.png differ diff --git a/res/images/paste.png b/res/images/paste.png Binary files a/res/images/paste.png and b/res/images/paste.png differ diff --git a/res/images/reload.png b/res/images/reload.png Binary files a/res/images/reload.png and b/res/images/reload.png differ diff --git a/res/images/run.png b/res/images/run.png Binary files a/res/images/run.png and b/res/images/run.png differ diff --git a/res/images/save.png b/res/images/save.png Binary files a/res/images/save.png and b/res/images/save.png differ diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -30,19 +30,21 @@ undo, redo, -- HINT CONTROLS -- valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, - loadModules, reloadModules, getLoadedModules, importModules, getImportedModules, + loadModules, + reloadModules, getLoadedModules, + importModules, getImportedModules, + getPackageModules, getModuleExports, getLanguageExtensions, setLanguageExtensions, getSourceDirs, setSourceDirs, getGhcOpts, setGhcOpts, - loadPrefsFromCabal, + loadPackage, valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', loadModules', reloadModules', getLoadedModules', importModules', getImportedModules', getModuleExports', getLanguageExtensions', setLanguageExtensions', getSourceDirs', setSourceDirs', getGhcOpts', setGhcOpts', - loadPrefsFromCabal', reset, reset', cancel, Hint.InterpreterError, prettyPrintError, @@ -76,6 +78,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Package import Distribution.PackageDescription +import Distribution.ModuleName import Distribution.Compiler data ModuleElemDesc = MEFun {funName :: String, @@ -114,9 +117,6 @@ SetGhcOpts { settingGhcOpts :: String, runningAction :: Hint.InterpreterT IO () } | - LoadingCabal { settingSrcDirs :: [FilePath], - settingGhcOpts :: String, - runningAction :: Hint.InterpreterT IO () } | Reset data Page = Page { -- Display -- @@ -134,7 +134,10 @@ "\nFile: " ++ show (filePath p) where showExpressions pg = showWithCurrent (expressions pg) (currentExpr pg) "\n\n" $ ("["++) . (++"]") -data Context = Context { -- Pages -- +data Context = Context { -- Package -- + activePackage :: Maybe PackageIdentifier, + pkgModules :: [Hint.ModuleName], + -- Pages -- pages :: [Page], currentPage :: Int, -- Hint -- @@ -175,7 +178,7 @@ evalHPage hpt = do hs <- liftIO $ HS.start let nop = return () - let emptyContext = Context [emptyPage] 0 empty (fromList ["Prelude"]) [] "" hs Nothing nop + let emptyContext = Context Nothing [] [emptyPage] 0 empty (fromList ["Prelude"]) [] "" hs Nothing nop (state hpt) `evalStateT` emptyContext @@ -457,6 +460,9 @@ getImportedModules :: HPage [Hint.ModuleName] getImportedModules = confirmRunning >>= return . toList . importedModules +getPackageModules :: HPage [Hint.ModuleName] +getPackageModules = confirmRunning >>= return . pkgModules + getModuleExports :: Hint.ModuleName -> HPage (Either Hint.InterpreterError [ModuleElemDesc]) getModuleExports mn = do confirmRunning @@ -507,33 +513,37 @@ liftErrorIO $ ("Error setting ghc opts dirs", opts, e) return res -loadPrefsFromCabal :: FilePath -> HPage (Either Hint.InterpreterError PackageIdentifier) -loadPrefsFromCabal file = do - let dir = dropFileName file - lbinfo <- liftIO $ getPersistBuildConfig dir - let pkgdesc = localPkgDescr lbinfo - pkgname = package pkgdesc - bldinfos= allBuildInfo pkgdesc - dirs = uniq $ concatMap hsSourceDirs bldinfos - exts = uniq . map (read . show) $ concatMap extensions bldinfos - opts = uniq $ concatMap (hcOptions GHC) bldinfos - action = do - liftTraceIO $ "loading package: " ++ show pkgname - Hint.unsafeSetGhcOption "-i" - Hint.unsafeSetGhcOption "-i." - forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++) - Hint.set [Hint.languageExtensions := exts] - forM_ opts $ \opt -> Hint.unsafeSetGhcOption opt `catchError` (\_ -> return ()) - return pkgname - res <- syncRun action - case res of - Right _ -> - modify (\ctx -> ctx{extraSrcDirs = dirs, - ghcOptions = (ghcOptions ctx) ++ " " ++ (joinWith " " opts), - recoveryLog = recoveryLog ctx >> action >> return ()}) - Left e -> - liftErrorIO $ ("Error loading package", pkgname, e) - return res +loadPackage :: FilePath -> HPage (Either Hint.InterpreterError PackageIdentifier) +loadPackage file = do + let dir = dropFileName file + lbinfo <- liftIO $ getPersistBuildConfig dir + let pkgdesc = localPkgDescr lbinfo + pkgname = package pkgdesc + bldinfos= allBuildInfo pkgdesc + dirs = uniq $ concatMap hsSourceDirs bldinfos + exts = uniq . map (read . show) $ concatMap extensions bldinfos + opts = uniq $ concatMap (hcOptions GHC) bldinfos + mods = uniq . map (joinWith "." . components) $ exeModules pkgdesc ++ (libModules pkgdesc) + action = do + liftTraceIO $ "loading package: " ++ show pkgname + Hint.unsafeSetGhcOption "-i" + Hint.unsafeSetGhcOption "-i." + forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++) + Hint.set [Hint.languageExtensions := exts] + forM_ opts $ \opt -> Hint.unsafeSetGhcOption opt `catchError` (\_ -> return ()) + return pkgname + liftDebugIO mods + res <- syncRun action + case res of + Right _ -> + modify (\ctx -> ctx{activePackage = Just pkgname, + pkgModules = mods, + extraSrcDirs = dirs, + ghcOptions = (ghcOptions ctx) ++ " " ++ (joinWith " " opts), + recoveryLog = recoveryLog ctx >> action >> return ()}) + Left e -> + liftErrorIO $ ("Error loading package", pkgname, e) + return res reset :: HPage (Either Hint.InterpreterError ()) reset = do @@ -635,28 +645,6 @@ res <- asyncRun action modify $ \ctx -> ctx{running = Just $ SetGhcOpts opts action} return res - -loadPrefsFromCabal' :: FilePath -> HPage (MVar (Either Hint.InterpreterError PackageIdentifier)) -loadPrefsFromCabal' file = do - let dir = dropFileName file - lbinfo <- liftIO $ getPersistBuildConfig dir - let pkgdesc = localPkgDescr lbinfo - pkgname = package pkgdesc - bldinfos= allBuildInfo pkgdesc - dirs = uniq $ concatMap hsSourceDirs bldinfos - exts = uniq . map (read . show) $ concatMap extensions bldinfos - opts = joinWith " " . uniq $ concatMap (hcOptions GHC) bldinfos - action = do - liftTraceIO $ "loading package: " ++ show pkgname - Hint.unsafeSetGhcOption "-i" - Hint.unsafeSetGhcOption "-i." - forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++) - Hint.set [Hint.languageExtensions := exts] - Hint.unsafeSetGhcOption opts - return pkgname - res <- asyncRun action - modify $ \ctx -> ctx{running = Just $ LoadingCabal dirs opts $ action >> return ()} - return res reset' :: HPage (MVar (Either Hint.InterpreterError ())) reset' = do @@ -789,8 +777,6 @@ c{extraSrcDirs = ssds, recoveryLog = (recoveryLog c) >> ra} apply (Just SetGhcOpts{settingGhcOpts = opts, runningAction = ra}) c = c{ghcOptions = (ghcOptions c) ++ " " ++ opts, recoveryLog = (recoveryLog c) >> ra} -apply (Just LoadingCabal{settingSrcDirs = ssds, settingGhcOpts = opts, runningAction = ra}) c = - c{extraSrcDirs = ssds, ghcOptions = (ghcOptions c) ++ " " ++ opts, recoveryLog = (recoveryLog c) >> ra} fromString :: String -> [Expression] fromString s = map Exp $ splitOn "\n\n" s 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 @@ -15,16 +15,13 @@ ghcOptions :: String} deriving (Eq, Show) -data Result = SetPrefs Preferences | LoadPrefs FilePath - -preferencesDialog :: Window a -> String -> Preferences -> IO (Maybe Result) +preferencesDialog :: Window a -> String -> Preferences -> IO (Maybe Preferences) preferencesDialog win caption currentPrefs = do let availExts = sort HP.availableExtensions dlg <- dialog win [text := caption] btnok <- button dlg [text := "Ok", identity := wxId_OK] buttonSetDefault btnok - btnimport <- button dlg [text := "Import", identity := wxId_OPEN, tooltip := "Import settings from a setup-config file"] btnnok <- button dlg [text := "Cancel", identity := wxId_CANCEL] lstExts <- multiListBox dlg [items := map show availExts] @@ -46,13 +43,12 @@ column 5 [widget btnadd, expand $ widget btndel]] gosL = fill $ boxed "Ghc Options" $ fill $ grid 5 5 [[label "Applied", fill $ widget txtGhcOld], [label "New", fill $ widget txtGhcNew]] - btnsL = margin 5 $ floatRight $ row 5 [widget btnimport, widget btnnok, widget btnok] + btnsL = margin 5 $ floatRight $ row 5 [widget btnnok, widget btnok] set dlg [layout := fill $ column 5 [lesL, sdsL, gosL, btnsL], clientSize := sz 500 300] showModal dlg $ \stopFun -> do focusOn lstExts - buttonOnCommand btnimport $ openSetupFile dlg >>= stopFun - buttonOnCommand btnok $ getCurrentPrefs lstExts lstDirs txtGhcNew >>= stopFun . Just . SetPrefs + buttonOnCommand btnok $ getCurrentPrefs lstExts lstDirs txtGhcNew >>= stopFun . Just buttonOnCommand btnnok $ stopFun Nothing where getCurrentPrefs e d g = do let availExts = sort HP.availableExtensions @@ -61,14 +57,6 @@ sds <- get d items gos <- get g text return $ Prefs les sds gos - openSetupFile dlg = do - res <- fileOpenDialog dlg True True "Select the setup-config file for your project..." - [("setup-config",["setup-config"])] "dist" "setup-config" - case res of - Nothing -> - return Nothing - Just setupConfig -> - return . Just $ LoadPrefs setupConfig addDir w lstDirs = do res <- dirOpenDialog w False "Choose directory to add" "" case res of 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 @@ -10,6 +10,7 @@ import Control.Concurrent.Process import Control.Concurrent.MVar import System.FilePath +import System.Directory import System.IO.Error hiding (try) import Data.List import Data.Bits @@ -47,7 +48,8 @@ data GUIContext = GUICtx { guiWin :: Frame (), guiPages :: SingleListBox (), - guiModules :: SingleListBox (), + guiPkgModules :: SingleListBox (), + guiLoadedModules :: SingleListBox (), guiCode :: TextCtrl (), guiResults :: GUIResults, guiStatus :: StatusField, @@ -60,39 +62,40 @@ -- Server context model <- HPS.start - win <- frame [text := "hPage"] + win <- frame [text := "λPage"] imageFile "icon/hpage.tif" >>= topLevelWindowSetIconFromFile win set win [on closing := HPS.stop model >> propagateEvent] -- Containers - pnl <- panel win [] - splLR <- splitterWindow pnl [] - pnlL <- panel splLR [clientSize := sz 200 600] - pnlR <- panel splLR [] + ntbkL <- notebook win [] + pnlPs <- panel ntbkL [] + pnlPMs <- panel ntbkL [] + pnlLMs <- panel ntbkL [] -- Text page... -- txtCode <- styledTextCtrl win [] - txtCode <- textCtrl pnlR [font := fontFixed, text := ""] + txtCode <- textCtrl win [font := fontFixed, text := ""] -- Document Selector - lstModules <- singleListBox pnlL [style := wxLB_NEEDED_SB] - lstPages <- singleListBox pnlL [style := wxLB_NEEDED_SB] + lstPkgModules <- singleListBox pnlPMs [style := wxLB_NEEDED_SB] + lstLoadedModules <- singleListBox pnlLMs [style := wxLB_NEEDED_SB] + lstPages <- singleListBox pnlPs [style := wxLB_NEEDED_SB, outerSize := sz 400 600] -- Results list - txtValue <- textEntry pnlR [style := wxTE_READONLY] - txtType <- textEntry pnlR [style := wxTE_READONLY] - txtKind <- textEntry pnlR [style := wxTE_READONLY] + txtValue <- textEntry win [style := wxTE_READONLY] + txtType <- textEntry win [style := wxTE_READONLY] + txtKind <- textEntry win [style := wxTE_READONLY] -- Status bar... - status <- statusField [text := "hello... this is hPage! type in your instructions :)"] + status <- statusField [text := "hello... this is λPage! type in your instructions :)"] refreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"] varTimer <- varCreate refreshTimer set win [statusBar := [status]] - btnGetValue <- button pnlR [text := "Value"] - btnGetType <- button pnlR [text := "Type"] - btnGetKind <- button pnlR [text := "Kind"] + btnGetValue <- button win [text := "Value"] + btnGetType <- button win [text := "Type"] + btnGetKind <- button win [text := "Kind"] search <- findReplaceDataCreate wxFR_DOWN @@ -100,7 +103,7 @@ let grrType = GUIRRow btnGetType txtType let grrKind = GUIRRow btnGetKind txtKind let guiRes = GUIRes grrValue grrType grrKind - let guiCtx = GUICtx win lstPages lstModules txtCode guiRes status varTimer search + 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] @@ -115,7 +118,12 @@ MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu _ -> propagateEvent] - set lstModules [on select := onCmd "browseModule" browseModule >> propagateEvent] + set lstLoadedModules [on mouse := \e -> case e of + MouseLeftUp _ _ -> onCmd "browseModule" browseModule >> propagateEvent + _ -> propagateEvent] + set lstPkgModules [on mouse := \e -> case e of + MouseRightUp _ _ -> onCmd "pkgModuleContextMenu" pkgModuleContextMenu >> propagateEvent + _ -> propagateEvent] -- Menu bar... -- menuBar win [] @@ -128,7 +136,7 @@ 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 [] + menuQuit mnuPage [on command := close win] mnuEdit <- menuPane [text := "Edit"] menuAppend mnuEdit wxId_UNDO "&Undo\tCtrl-z" "Undo" False @@ -146,9 +154,11 @@ menuAppend mnuEdit wxId_PREFERENCES "&Preferences...\tCtrl-," "Preferences" False mnuHask <- menuPane [text := "Haskell"] + menuAppend mnuHask wxId_HASK_LOAD_PKG "Load &package...\tCtrl-Shift-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-l" "Import Packaged 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_VALUE "&Value\tCtrl-e" "Get the Value of the Current Expression" False @@ -157,7 +167,7 @@ mnuHelp <- menuHelp [] menuAppend mnuHelp wxId_HELP "&Help page\tCtrl-h" "Open the Help Page" False - menuAbout mnuHelp [on command := infoDialog win "About hPage" "Author: Fernando Brujo Benavides"] + menuAbout mnuHelp [on command := infoDialog win "About λPage" "Author: Fernando Brujo Benavides"] set win [menuBar := [mnuPage, mnuEdit, mnuHask, mnuHelp]] evtHandlerOnMenuCommand win wxId_NEW $ onCmd "runHP' addPage" $ runHP' HP.addPage @@ -175,9 +185,11 @@ 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_VALUE $ onCmd "getValue" getValue @@ -187,6 +199,7 @@ -- 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 @@ -194,6 +207,7 @@ 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" @@ -201,10 +215,12 @@ copyPath <- imageFile "copy.png" pastePath <- imageFile "paste.png" reloadPath <- imageFile "reload.png" - toolMenu tbMain mitNew "New" newPath [tooltip := "New"] - toolMenu tbMain mitOpen "Open" openPath [tooltip := "Open"] - toolMenu tbMain mitSave "Save" savePath [tooltip := "Save"] + 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"] @@ -214,15 +230,16 @@ -- Layout settings let txtCodeL = fill $ widget txtCode - lstPagesL = fill $ boxed "Pages" $ fill $ widget lstPages - lstModulesL = fill $ boxed "Modules" $ fill $ widget lstModules + pagesTabL = tab "Pages" $ container pnlPs $ fill $ widget lstPages + pkgModsTabL = tab "Package" $ container pnlPMs $ fill $ widget lstPkgModules + lddModsTabL = tab "Modules" $ container pnlLMs $ fill $ 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 = container pnlL $ hfill $ column 5 [lstPagesL, lstModulesL] - rightL = container pnlR $ column 5 [txtCodeL, resultsGridL] - set win [layout := container pnl $ fill $ vsplit splLR 7 400 leftL rightL, + leftL = tabs ntbkL [lddModsTabL, pkgModsTabL, pagesTabL] + rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsGridL] + set win [layout := fill $ row 10 [leftL, rightL], clientSize := sz 800 600] -- ...and RUN! @@ -234,20 +251,20 @@ refreshPage, savePageAs, savePage, openPage, pageChange, copy, cut, paste, justFind, justFindNext, justFindPrev, findReplace, - textContextMenu, browseModule, + textContextMenu, pkgModuleContextMenu, browseModule, restartTimer, killTimer, getValue, getType, getKind, - loadModules, importModules, loadModulesByName, reloadModules, + loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () -browseModule model guiCtx@GUICtx{guiWin = win, guiModules = lstModules, guiCode = txtCode} = +browseModule model guiCtx@GUICtx{guiWin = win, guiLoadedModules = lstLoadedModules, guiCode = txtCode} = do contextMenu <- menuPane [] - i <- get lstModules selection + i <- get lstLoadedModules selection case i of (-1) -> propagateEvent _ -> do - mnText <- listBoxGetString lstModules i + mnText <- listBoxGetString lstLoadedModules i let mn = case mnText of '*':rest -> rest fullname -> fullname @@ -302,6 +319,21 @@ menuPopup contextMenu pointWithinWindow win objectDelete contextMenu +pkgModuleContextMenu model guiCtx@GUICtx{guiWin = win, guiPkgModules = lstPkgModules} = + do + contextMenu <- menuPane [] + i <- get lstPkgModules selection + case i of + (-1) -> return () + i -> + do + mnText <- listBoxGetString lstPkgModules i + menuAppend contextMenu wxId_HASK_LOAD_FAST "&Load" "Load Module" False + propagateEvent + pointWithinWindow <- windowGetMousePosition win + menuPopup contextMenu pointWithinWindow win + objectDelete contextMenu + getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} = runTxtHP HP.valueOf' model guiCtx grrValue @@ -380,6 +412,32 @@ reloadModules = runHP HP.reloadModules +loadPackage model guiCtx@GUICtx{guiWin = win} = + do + distExists <- doesDirectoryExist "dist" + let startDir = if distExists then "dist" else "" + res <- fileOpenDialog win True True "Select the setup-config file for your project..." + [("setup-config",["setup-config"])] startDir "setup-config" + case res of + Nothing -> + return () + Just setupConfig -> + do + loadres <- tryIn model (HP.loadPackage setupConfig) + case loadres of + Left err -> + warningDialog win "Error" err + Right pkg -> + do + absPath <- canonicalizePath setupConfig + let dir = joinPath . reverse . drop 2 . reverse $ splitDirectories absPath + setCurrentDirectory dir + frameSetTitle win $ "λPage - " ++ prettyShow pkg + refreshPage model guiCtx + where prettyShow PackageIdentifier{pkgName = PackageName pkgname, + pkgVersion = pkgvsn} = pkgname ++ "-" ++ showVersion pkgvsn + + loadModules model guiCtx@GUICtx{guiWin = win, guiStatus = status} = do fileNames <- filesOpenDialog win True True "Load Module..." [("Haskell Modules",["*.hs"])] "" "" @@ -402,6 +460,18 @@ set status [text := "loading..."] runHP (HP.loadModules $ words mns) model guiCtx +loadModulesByNameFast model guiCtx@GUICtx{guiWin = win, guiPkgModules = lstPkgModules, guiStatus = status} = + do + i <- get lstPkgModules selection + case i of + (-1) -> return () + i -> + do + mnText <- listBoxGetString lstPkgModules i + let mns = [mnText] + set status [text := "loading..."] + runHP (HP.loadModules mns) model guiCtx + importModules model guiCtx@GUICtx{guiWin = win, guiStatus = status} = do moduleNames <- textDialog win "Enter the module names, separated by spaces" "Import Packaged Modules..." "" @@ -431,17 +501,7 @@ case res of Nothing -> return () - Just (LoadPrefs file) -> - do - set status [text := "setting..."] - loadres <- tryIn model (HP.loadPrefsFromCabal file) - case loadres of - Left err -> - warningDialog win "Error" err - Right pkg -> - infoDialog win "hPage" $ "Settings from package " ++ prettyShow pkg ++ " succesfully loaded" - refreshPage model guiCtx - Just (SetPrefs newps) -> + Just newps -> do set status [text := "setting..."] runHP (do @@ -451,8 +511,6 @@ "" -> return $ Right () newopts -> HP.setGhcOpts newopts ) model guiCtx - where prettyShow PackageIdentifier{pkgName = PackageName pkgname, - pkgVersion = pkgvsn} = pkgname ++ "-" ++ showVersion pkgvsn openHelpPage model guiCtx@GUICtx{guiCode = txtCode} = do @@ -464,7 +522,8 @@ refreshPage model guiCtx@GUICtx{guiWin = win, guiPages = lstPages, - guiModules = lstModules, + guiPkgModules = lstPkgModules, + guiLoadedModules = lstLoadedModules, guiCode = txtCode, guiStatus = status} = do @@ -475,14 +534,15 @@ txt <- HP.getPageText lmsRes <- HP.getLoadedModules ims <- HP.getImportedModules + pms <- HP.getPackageModules let lms = case lmsRes of Left _ -> [] Right x -> x - return (ims, lms, pages, ind, txt) + return (pms, ims, lms, pages, ind, txt) case res of Left err -> warningDialog win "Error" err - Right (ims, ms, ps, i, t) -> + Right (pms, ims, ms, ps, i, t) -> do -- Refresh the pages list itemsDelete lstPages @@ -495,10 +555,12 @@ Just fn -> takeFileName $ dropExtension fn in itemAppend lstPages $ prefix ++ name set lstPages [selection := i] - -- Refresh the modules list - itemsDelete lstModules - (flip mapM) ims $ itemAppend lstModules . ('*':) - (flip mapM) ms $ itemAppend lstModules + -- Refresh the modules lists + itemsDelete lstLoadedModules + (flip mapM) ims $ itemAppend lstLoadedModules + (flip mapM) ms $ itemAppend lstLoadedModules . ('*':) + itemsDelete lstPkgModules + (flip mapM) pms $ \pm -> itemAppend lstPkgModules (if pm `elem` ms then ('*':pm) else pm) -- Refresh the current text set txtCode [text := t] set status [text := ""] diff --git a/src/HPage/GUI/IDs.hs b/src/HPage/GUI/IDs.hs --- a/src/HPage/GUI/IDs.hs +++ b/src/HPage/GUI/IDs.hs @@ -31,9 +31,9 @@ wxId_PREFERENCES = 5022 wxId_CLOSE_ALL = 5018 -wxId_HASK_LOAD, wxId_HASK_LOADNAME, wxId_HASK_RELOAD, +wxId_HASK_LOAD, wxId_HASK_LOADNAME, wxId_HASK_LOAD_FAST, wxId_HASK_RELOAD, wxId_HASK_VALUE, wxId_HASK_TYPE, wxId_HASK_KIND, - wxId_HASK_ADD, wxId_HASK_MENUELEM :: Int + wxId_HASK_ADD, wxId_HASK_LOAD_PKG, wxId_HASK_MENUELEM :: Int wxId_HASK_LOAD = 5300 wxId_HASK_LOADNAME = 5301 wxId_HASK_RELOAD = 5302 @@ -41,4 +41,6 @@ wxId_HASK_TYPE = 5305 wxId_HASK_KIND = 5306 wxId_HASK_ADD = 5307 +wxId_HASK_LOAD_PKG = 5308 +wxId_HASK_LOAD_FAST = 5309 wxId_HASK_MENUELEM = 5310