hpage 0.2.0 → 0.2.1
raw patch · 5 files changed
+98/−15 lines, 5 files
Files
- hpage.cabal +1/−1
- src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs +4/−2
- src/HPage/Control.hs +49/−9
- src/HPage/GUI/FreeTextWindow.hs +18/−3
- src/HPage/Test/Server.hs +26/−0
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.2.0+version: 0.2.1 cabal-version: >=1.6 build-type: Custom license: BSD3
src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs view
@@ -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
src/HPage/Control.hs view
@@ -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 =
src/HPage/GUI/FreeTextWindow.hs view
@@ -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]
src/HPage/Test/Server.hs view
@@ -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") ==>