Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Package Modules

  • Loading branch information...
commit ef346fe6b4aff6387e59cc6ca394b33688e5dbab 1 parent 6c29aac
Fernando Benavides authored
View
104 src/HPage/Control.hs
@@ -30,19 +30,21 @@ module HPage.Control (
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.Configure
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 @@ data InFlightData = LoadModules { loadingModules :: Set String,
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 @@ instance Show Page where
"\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 :: HPage a -> IO a
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 @@ getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules
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 @@ setGhcOpts opts = do
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 @@ setGhcOpts' opts = do
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 @@ apply (Just SetSourceDirs{settingSrcDirs = ssds, runningAction = ra}) c =
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
View
57 src/HPage/GUI/FreeTextWindow.hs
@@ -118,7 +118,12 @@ gui =
MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent
MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu
_ -> propagateEvent]
- set lstLoadedModules [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 []
@@ -184,6 +189,7 @@ gui =
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
@@ -231,7 +237,7 @@ gui =
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 [pagesTabL, pkgModsTabL, lddModsTabL]
+ 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]
@@ -245,10 +251,10 @@ gui =
refreshPage, savePageAs, savePage, openPage,
pageChange, copy, cut, paste,
justFind, justFindNext, justFindPrev, findReplace,
- textContextMenu, browseModule,
+ textContextMenu, pkgModuleContextMenu, browseModule,
restartTimer, killTimer,
getValue, getType, getKind,
- loadPackage, loadModules, importModules, loadModulesByName, reloadModules,
+ loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules,
configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO ()
browseModule model guiCtx@GUICtx{guiWin = win, guiLoadedModules = lstLoadedModules, guiCode = txtCode} =
@@ -313,6 +319,21 @@ textContextMenu model guiCtx@GUICtx{guiWin = win, guiCode = txtCode} =
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
@@ -402,7 +423,7 @@ loadPackage model guiCtx@GUICtx{guiWin = win} =
return ()
Just setupConfig ->
do
- loadres <- tryIn model (HP.loadPrefsFromCabal setupConfig)
+ loadres <- tryIn model (HP.loadPackage setupConfig)
case loadres of
Left err ->
warningDialog win "Error" err
@@ -439,6 +460,18 @@ loadModulesByName model guiCtx@GUICtx{guiWin = win, guiStatus = status} =
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..." ""
@@ -489,6 +522,7 @@ openHelpPage model guiCtx@GUICtx{guiCode = txtCode} =
refreshPage model guiCtx@GUICtx{guiWin = win,
guiPages = lstPages,
+ guiPkgModules = lstPkgModules,
guiLoadedModules = lstLoadedModules,
guiCode = txtCode,
guiStatus = status} =
@@ -500,14 +534,15 @@ refreshPage model guiCtx@GUICtx{guiWin = win,
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
@@ -520,10 +555,12 @@ refreshPage model guiCtx@GUICtx{guiWin = win,
Just fn -> takeFileName $ dropExtension fn
in itemAppend lstPages $ prefix ++ name
set lstPages [selection := i]
- -- Refresh the modules list
+ -- Refresh the modules lists
itemsDelete lstLoadedModules
- (flip mapM) ims $ itemAppend lstLoadedModules . ('*':)
- (flip mapM) ms $ itemAppend 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 := ""]
View
3  src/HPage/GUI/IDs.hs
@@ -31,7 +31,7 @@ wxId_REPLACE_ALL = 5039
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_LOAD_PKG, wxId_HASK_MENUELEM :: Int
wxId_HASK_LOAD = 5300
@@ -42,4 +42,5 @@ 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
Please sign in to comment.
Something went wrong with that request. Please try again.