diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.2.0 +version: 0.2.1 cabal-version: >=1.6 build-type: Custom license: BSD3 diff --git a/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs b/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs --- a/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs +++ b/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs @@ -5,14 +5,16 @@ wxID_CLOSE_ALL :: Int wxID_REPLACE = 5038 wxID_REPLACE_ALL = 5039 -wxID_PREFERENCES = 5019 +wxID_PREFERENCES = 5022 wxID_CLOSE_ALL = 5018 wxID_HASK_LOAD, wxID_HASK_LOADNAME, wxID_HASK_RELOAD, - wxID_HASK_VALUE, wxID_HASK_TYPE, wxID_HASK_KIND :: Int + wxID_HASK_VALUE, wxID_HASK_TYPE, wxID_HASK_KIND, + wxID_HASK_ADD :: Int wxID_HASK_LOAD = 5300 wxID_HASK_LOADNAME = 5301 wxID_HASK_RELOAD = 5302 wxID_HASK_VALUE = 5304 wxID_HASK_TYPE = 5305 wxID_HASK_KIND = 5306 +wxID_HASK_ADD = 5307 diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -4,7 +4,6 @@ FunctionalDependencies, TypeSynonymInstances, UndecidableInstances #-} - module HPage.Control ( -- MONAD CONTROLS -- HPage, evalHPage, @@ -31,13 +30,13 @@ undo, redo, -- HINT CONTROLS -- valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, - loadModules, reloadModules, getLoadedModules, + loadModules, reloadModules, getLoadedModules, importModules, getImportedModules, getLanguageExtensions, setLanguageExtensions, getSourceDirs, setSourceDirs, getGhcOpts, setGhcOpts, loadPrefsFromCabal, valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', - loadModules', reloadModules', getLoadedModules', + loadModules', reloadModules', getLoadedModules', importModules', getImportedModules', getLanguageExtensions', setLanguageExtensions', getSourceDirs', setSourceDirs', getGhcOpts', setGhcOpts', @@ -87,7 +86,10 @@ data InFlightData = LoadModules { loadingModules :: Set String, runningAction :: Hint.InterpreterT IO () - } | + } | + ImportModules { importingModules :: Set String, + runningAction :: Hint.InterpreterT IO () + } | SetSourceDirs { settingSrcDirs :: [FilePath], runningAction :: Hint.InterpreterT IO () } | @@ -119,6 +121,7 @@ currentPage :: Int, -- Hint -- loadedModules :: Set String, + importedModules :: Set String, extraSrcDirs :: [FilePath], ghcOptions :: String, server :: HS.ServerHandle, @@ -154,7 +157,7 @@ evalHPage hpt = do hs <- liftIO $ HS.start let nop = return () - let emptyContext = Context [emptyPage] 0 empty [] "" hs Nothing nop + let emptyContext = Context [emptyPage] 0 empty (fromList ["Prelude"]) [] "" hs Nothing nop (state hpt) `evalStateT` emptyContext @@ -405,6 +408,22 @@ liftErrorIO $ ("Error loading modules", ms, e) return res +importModules :: [String] -> HPage (Either Hint.InterpreterError ()) +importModules newms = do + ctx <- confirmRunning + let ms = toList $ importedModules ctx + action = do + liftTraceIO $ "importing: " ++ show newms + Hint.setImports $ ms ++ newms + res <- syncRun action + case res of + Right _ -> + modify (\ctx -> ctx{importedModules = union (fromList newms) (importedModules ctx), + recoveryLog = recoveryLog ctx >> action >> return ()}) + Left e -> + liftErrorIO $ ("Error importing modules", ms, e) + return res + reloadModules :: HPage (Either Hint.InterpreterError ()) reloadModules = do ctx <- confirmRunning @@ -417,6 +436,9 @@ getLoadedModules :: HPage (Either Hint.InterpreterError [Hint.ModuleName]) getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules +getImportedModules :: HPage [Hint.ModuleName] +getImportedModules = confirmRunning >>= return . toList . importedModules + getLanguageExtensions :: HPage (Either Hint.InterpreterError [Hint.Extension]) getLanguageExtensions = confirmRunning >> syncRun (Hint.get Hint.languageExtensions) @@ -424,7 +446,7 @@ setLanguageExtensions exs = confirmRunning >> syncRun (Hint.set [Hint.languageExtensions := exs]) getSourceDirs :: HPage [FilePath] -getSourceDirs = confirmRunning >> get >>= return . extraSrcDirs +getSourceDirs = confirmRunning >>= return . extraSrcDirs setSourceDirs :: [FilePath] -> HPage (Either Hint.InterpreterError ()) setSourceDirs ds = do @@ -498,6 +520,7 @@ case res of Right _ -> modify (\ctx -> ctx{loadedModules = empty, + importedModules = fromList ["Prelude"], extraSrcDirs = [], ghcOptions = "", running = Nothing, @@ -526,11 +549,21 @@ modify (\ctx -> ctx{running = Just $ LoadModules (fromList ms) action}) return res +importModules' :: [String] -> HPage (MVar (Either Hint.InterpreterError ())) +importModules' newms = do + ctx <- confirmRunning + let ms = toList $ importedModules ctx + action = do + liftTraceIO $ "importing': " ++ show newms + Hint.setImports $ ms ++ newms + res <- asyncRun action + modify (\ctx -> ctx{running = Just $ ImportModules (fromList newms) action}) + return res reloadModules' :: HPage (MVar (Either Hint.InterpreterError ())) reloadModules' = do - page <- confirmRunning - let ms = toList $ loadedModules page + ctx <- confirmRunning + let ms = toList $ loadedModules ctx asyncRun $ do liftTraceIO $ "reloading': " ++ (show ms) Hint.loadModules ms @@ -539,6 +572,9 @@ getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [Hint.ModuleName])) getLoadedModules' = confirmRunning >> asyncRun Hint.getLoadedModules +getImportedModules' :: HPage (MVar [Hint.ModuleName]) +getImportedModules' = confirmRunning >>= liftIO . newMVar . toList . importedModules + getLanguageExtensions' :: HPage (MVar (Either Hint.InterpreterError [Hint.Extension])) getLanguageExtensions' = confirmRunning >> asyncRun (Hint.get Hint.languageExtensions) @@ -546,7 +582,7 @@ setLanguageExtensions' exs = confirmRunning >> asyncRun (Hint.set [Hint.languageExtensions := exs]) getSourceDirs' :: HPage (MVar [FilePath]) -getSourceDirs' = confirmRunning >> get >>= liftIO . newMVar . extraSrcDirs +getSourceDirs' = confirmRunning >>= liftIO . newMVar . extraSrcDirs setSourceDirs' :: [FilePath] -> HPage (MVar (Either Hint.InterpreterError ())) setSourceDirs' ds = do @@ -704,6 +740,7 @@ apply :: Maybe InFlightData -> Context -> Context apply Nothing c = c apply (Just Reset) c = c{loadedModules = empty, + importedModules = fromList ["Prelude"], extraSrcDirs = [], ghcOptions = "", recoveryLog = return (), @@ -711,6 +748,9 @@ apply (Just LoadModules{loadingModules = lms, runningAction = ra}) c = c{loadedModules = union lms (loadedModules c), recoveryLog = (recoveryLog c) >> ra} +apply (Just ImportModules{importingModules = ims, runningAction = ra}) c = + c{importedModules = union ims (importedModules c), + recoveryLog = (recoveryLog c) >> ra} apply (Just SetSourceDirs{settingSrcDirs = ssds, runningAction = ra}) c = c{extraSrcDirs = ssds, recoveryLog = (recoveryLog c) >> ra} apply (Just SetGhcOpts{settingGhcOpts = opts, runningAction = ra}) c = 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 @@ -146,6 +146,7 @@ mnuHask <- menuPane [text := "Haskell"] 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_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 @@ -173,6 +174,7 @@ evtHandlerOnMenuCommand win wxID_BACKWARD $ onCmd "findPrev" justFindPrev evtHandlerOnMenuCommand win wxID_REPLACE $ onCmd "findReplace" findReplace 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_RELOAD $ onCmd "reloadModules" reloadModules evtHandlerOnMenuCommand win wxID_PREFERENCES $ onCmd "preferences" configure @@ -232,7 +234,7 @@ justFind, justFindNext, justFindPrev, findReplace, restartTimer, killTimer, getValue, getType, getKind, - loadModules, loadModulesByName, reloadModules, + loadModules, importModules, loadModulesByName, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} = @@ -335,6 +337,17 @@ set status [text := "loading..."] runHP (HP.loadModules $ words 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..." "" + case moduleNames of + "" -> + return () + mns -> + do + set status [text := "loading..."] + runHP (HP.importModules $ words mns) model guiCtx + configure model guiCtx@GUICtx{guiWin = win, guiStatus = status} = do hpsRes <- tryIn model $ do @@ -396,14 +409,15 @@ ind <- HP.getPageIndex txt <- HP.getPageText lmsRes <- HP.getLoadedModules + ims <- HP.getImportedModules let lms = case lmsRes of Left _ -> [] Right x -> x - return (lms, pages, ind, txt) + return (ims, lms, pages, ind, txt) case res of Left err -> warningDialog win "Error" err - Right (ms, ps, i, t) -> + Right (ims, ms, ps, i, t) -> do -- Refresh the pages list itemsDelete lstPages @@ -418,6 +432,7 @@ set lstPages [selection := i] -- Refresh the modules list itemsDelete lstModules + (flip mapM) ims $ itemAppend lstModules . ('*':) (flip mapM) ms $ itemAppend lstModules -- Refresh the current text set txtCode [text := t] 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 @@ -31,6 +31,14 @@ return . MN $ "Test" ++ map toLower s coarbitrary _ = undefined +newtype KnownModuleName = KMN {kmnString :: String} + deriving (Eq, Show) + +instance Arbitrary KnownModuleName where + arbitrary = elements $ map KMN ["Data.List", "Control.Monad", "System.Directory", "Control.Monad.Loops"] + coarbitrary _ = undefined + + newtype ClassName = CN {cnString :: String} deriving (Eq, Show) @@ -38,10 +46,12 @@ arbitrary = elements $ map CN ["HPage", "IO", "IO a", "Int", "String"] coarbitrary _ = undefined + instance Arbitrary HP.Extension where arbitrary = elements HP.availableExtensions coarbitrary _ = undefined + data WorkingExtension = WEX {wexExts :: [HP.Extension], wexModule :: String} deriving (Eq, Show) @@ -129,6 +139,7 @@ , run $ prop_typeOf hps hs , run $ prop_kindOf hps hs , run $ prop_load_module hps hs + , run $ prop_import_module hps , run $ prop_reload_modules hps hs , run $ prop_get_loaded_modules hps hs ] @@ -188,6 +199,21 @@ Left hsr <- HS.runIn hs $ Hint.eval expr return $ hsr == hpsr +prop_import_module :: HPS.ServerHandle -> KnownModuleName -> Bool +prop_import_module hps kmn = + unsafePerformIO $ do + let mn = kmnString kmn + HPS.runIn hps $ do + r1 <- HP.importModules [mn] + r2 <- HP.getImportedModules + r3 <- HP.importModules [mn] + r4 <- HP.getImportedModules + return $ r1 == (Right ()) && + r3 == (Right ()) && + mn `elem` r2 && + mn `elem` r4 + + prop_load_module :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Property prop_load_module hps hs mn = (show mn /= "Test") ==>