diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.3.3 +version: 0.3.4 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -47,15 +47,9 @@ hint-server >= 1.0.0, hint-server < 2 main-is: Main.hs buildable: True - build-tools: - cpp-options: - cc-options: - ld-options: - pkgconfig-depends: - frameworks: - c-sources: + if os(windows) + cpp-options: -DWIN32 extensions: CPP - install-includes: hs-source-dirs: src other-modules: HPage.GUI.IDs, @@ -71,6 +65,3 @@ ghc-prof-options: -auto-all -prof ghc-shared-options: -auto-all -prof ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns - hugs-options: - nhc98-options: - jhc-options: diff --git a/res/images/compiled.png b/res/images/compiled.png new file mode 100644 Binary files /dev/null and b/res/images/compiled.png differ diff --git a/res/images/imported.png b/res/images/imported.png new file mode 100644 Binary files /dev/null and b/res/images/imported.png differ diff --git a/res/images/interpreted.png b/res/images/interpreted.png new file mode 100644 Binary files /dev/null and b/res/images/interpreted.png differ diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -520,7 +520,7 @@ let pkgdesc = localPkgDescr lbinfo pkgname = package pkgdesc bldinfos= allBuildInfo pkgdesc - dirs = uniq $ concatMap hsSourceDirs bldinfos + dirs = ("dist" "build" "autogen") : (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) 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 @@ -34,7 +34,13 @@ import Paths_hpage -- cabal locations of data files imageFile :: FilePath -> IO FilePath -imageFile = getDataFileName . ("res/images/"++) +imageFile fp = do + path <- getDataFileName $ "res/images/" ++ fp + real <- doesFileExist path + if real then return path + else do + errorIO ("file not found", path) + fail (path ++ " does not exist") helpFile :: IO FilePath helpFile = getDataFileName "res/help/helpPage.hs" @@ -49,7 +55,7 @@ data GUIContext = GUICtx { guiWin :: Frame (), guiPages :: SingleListBox (), guiPkgModules :: SingleListBox (), - guiLoadedModules :: SingleListBox (), + guiLoadedModules :: ListCtrl (), guiCode :: TextCtrl (), guiResults :: GUIResults, guiStatus :: StatusField, @@ -78,10 +84,18 @@ txtCode <- textCtrl win [font := fontFixed, text := ""] -- Document Selector - 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] + + -- Modules Lists + imageFiles <- mapM imageFile ["imported.png", "interpreted.png", "compiled.png"] + imagePaths <- mapM getAbsoluteFilePath imageFiles + images <- imageListFromFiles (sz 16 16) imagePaths + lstLoadedModules <- listCtrlEx pnlLMs (wxLC_NO_HEADER + wxLC_SINGLE_SEL) + [columns := [("Module", AlignLeft, 200)]] + listCtrlSetImageList lstLoadedModules images wxIMAGE_LIST_SMALL + lstPkgModules <- singleListBox pnlPMs [style := wxLB_NEEDED_SB] + -- Results list txtValue <- textEntry win [style := wxTE_READONLY] txtType <- textEntry win [style := wxTE_READONLY] @@ -118,11 +132,12 @@ MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu _ -> propagateEvent] - set lstLoadedModules [on mouse := \e -> case e of - MouseLeftUp _ _ -> onCmd "browseModule" browseModule >> propagateEvent - _ -> propagateEvent] + set lstLoadedModules [on listEvent := \e -> case e of + ListItemSelected idx -> onCmd "browseModule" (browseModule idx) + _ -> propagateEvent] set lstPkgModules [on mouse := \e -> case e of MouseRightUp _ _ -> onCmd "pkgModuleContextMenu" pkgModuleContextMenu >> propagateEvent + MouseLeftDClick _ _ -> onCmd "loadModulesByNameFast" loadModulesByNameFast _ -> propagateEvent] -- Menu bar... @@ -230,9 +245,9 @@ -- Layout settings let txtCodeL = fill $ widget txtCode - pagesTabL = tab "Pages" $ container pnlPs $ fill $ widget lstPages - pkgModsTabL = tab "Package" $ container pnlPMs $ fill $ widget lstPkgModules - lddModsTabL = tab "Modules" $ container pnlLMs $ fill $ widget lstLoadedModules + 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] @@ -251,34 +266,29 @@ refreshPage, savePageAs, savePage, openPage, pageChange, copy, cut, paste, justFind, justFindNext, justFindPrev, findReplace, - textContextMenu, pkgModuleContextMenu, browseModule, + textContextMenu, pkgModuleContextMenu, restartTimer, killTimer, getValue, getType, getKind, loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () -browseModule model guiCtx@GUICtx{guiWin = win, guiLoadedModules = lstLoadedModules, guiCode = txtCode} = +browseModule :: Int -> HPS.ServerHandle -> GUIContext -> IO () + +browseModule i model guiCtx@GUICtx{guiWin = win, guiLoadedModules = lstLoadedModules, guiCode = txtCode} = do contextMenu <- menuPane [] - i <- get lstLoadedModules selection - case i of - (-1) -> propagateEvent - _ -> do - mnText <- listBoxGetString lstLoadedModules i - let mn = case mnText of - '*':rest -> rest - fullname -> fullname - hpsRes <- tryIn model $ HP.getModuleExports mn - case hpsRes of - Left err -> - propagateEvent >> warningDialog win "Error" err - Right mes -> - do - flip mapM_ mes $ createMenuItem contextMenu - propagateEvent - pointWithinWindow <- windowGetMousePosition win - menuPopup contextMenu pointWithinWindow win - objectDelete contextMenu + mn <- listCtrlGetItemText lstLoadedModules i + hpsRes <- tryIn model $ HP.getModuleExports mn + case hpsRes of + Left err -> + propagateEvent >> warningDialog win "Error" err + Right mes -> + do + flip mapM_ mes $ createMenuItem contextMenu + propagateEvent + pointWithinWindow <- windowGetMousePosition win + menuPopup contextMenu pointWithinWindow win + objectDelete contextMenu where createMenuItem m fn@(HP.MEFun _ _) = do item <- menuItemCreate @@ -286,11 +296,25 @@ menuItemSetText item $ show fn menuItemSetId item wxId_HASK_MENUELEM menuAppendItem m item + createMenuItem m HP.MEClass{HP.clsName = cn, HP.clsFuns = []} = + do + item <- menuItemCreate + menuItemSetCheckable item False + menuItemSetText item $ "class " ++ cn + menuItemSetId item wxId_HASK_MENUELEM + menuAppendItem m item createMenuItem m HP.MEClass{HP.clsName = cn, HP.clsFuns = cfs} = do subMenu <- menuPane [] flip mapM_ cfs $ createMenuItem subMenu menuAppendSub m wxId_HASK_MENUELEM ("class " ++ cn) subMenu "" + createMenuItem m HP.MEData{HP.datName = dn, HP.datCtors = []} = + do + item <- menuItemCreate + menuItemSetCheckable item False + menuItemSetText item $ "data " ++ dn + menuItemSetId item wxId_HASK_MENUELEM + menuAppendItem m item createMenuItem m HP.MEData{HP.datName = dn, HP.datCtors = dcs} = do subMenu <- menuPane [] @@ -555,15 +579,27 @@ Just fn -> takeFileName $ dropExtension fn in itemAppend lstPages $ prefix ++ name set lstPages [selection := i] + -- Refresh the modules lists + --NOTE: we know 0 == "imported" / 1 == "interpreted" / 2 == "compiled" images + --TODO: move that to some kind of constants or so + let ims' = map (\m -> (0, m)) ims + ms' = map (\m -> (1, m)) ms --TODO: Verify if it is intrepreted + allms = zip [0..] (ims' ++ ms') itemsDelete lstLoadedModules - (flip mapM) ims $ itemAppend lstLoadedModules - (flip mapM) ms $ itemAppend lstLoadedModules . ('*':) + (flip mapM) allms $ \(idx, (img, m)) -> + listCtrlInsertItemWithLabel lstLoadedModules idx m img >> + set lstLoadedModules [item idx := [m]] + itemsDelete lstPkgModules (flip mapM) pms $ \pm -> itemAppend lstPkgModules (if pm `elem` ms then ('*':pm) else pm) + -- Refresh the current text set txtCode [text := t] + + -- Clean the status bar set status [text := ""] + -- Refresh the current expression box refreshExpr model guiCtx True diff --git a/src/HPage/Test/Server.hs b/src/HPage/Test/Server.hs --- a/src/HPage/Test/Server.hs +++ b/src/HPage/Test/Server.hs @@ -220,7 +220,7 @@ let mn = kmnString kmn Right hpsr <- HPS.runIn hps $ HP.importModules [mn] >> HP.getModuleExports mn Right hsr <- HS.runIn hs $ Hint.setImports ["Prelude", mn] >> Hint.getModuleExports mn - liftDebugIO (hpsr, hsr) + -- liftDebugIO (hpsr, hsr) return $ all match $ zip hpsr hsr where match ((HP.MEFun fn _), (Hint.Fun fn2)) = fn == fn2 match ((HP.MEClass cn cfs), (Hint.Class cn2 cfs2)) = cn == cn2 && all match (zip cfs (map Hint.Fun cfs2))