diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.4.6 +version: 0.4.7 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -49,12 +49,5 @@ main-is: Main.hs buildable: True hs-source-dirs: src - other-modules: - HPage.GUI.IDs, - HPage.GUI.FreeTextWindow, - HPage.GUI.Dialogs, - HPage.Control, - HPage.Server, - HPage.Test.Server, - HPage.Utils.Log + other-modules: HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, HPage.Control, HPage.Server, HPage.Utils.Log ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns 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 @@ -8,6 +8,8 @@ module HPage.GUI.FreeTextWindow ( gui ) where -- import Control.Concurrent.Process +import Foreign.Ptr +import Foreign.Storable import System.FilePath import System.Directory import System.IO.Error hiding (try) @@ -54,8 +56,7 @@ data GUIContext = GUICtx { guiWin :: Frame (), guiPages :: SingleListBox (), - guiPkgModules :: SingleListBox (), - guiLoadedModules :: ListCtrl (), + guiModules :: (Var Int, ListCtrl ()), guiCode :: TextCtrl (), guiResults :: GUIResults, guiStatus :: StatusField, @@ -76,8 +77,7 @@ -- Containers ntbkL <- notebook win [] pnlPs <- panel ntbkL [] - pnlPMs <- panel ntbkL [] - pnlLMs <- panel ntbkL [] + pnlMs <- panel ntbkL [] -- Text page... -- txtCode <- styledTextCtrl win [] @@ -90,12 +90,12 @@ imageFiles <- mapM imageFile ["m_imported.ico", "m_interpreted.ico", "m_compiled.ico", "m_package.ico"] imagePaths <- mapM getAbsoluteFilePath imageFiles images <- imageListFromFiles (sz 16 16) imagePaths - lstLoadedModules <- listCtrlEx pnlLMs (wxLC_REPORT + wxLC_ALIGN_LEFT + wxLC_SINGLE_SEL) - [columns := [("Module", AlignLeft, 200)]] - listCtrlSetImageList lstLoadedModules images wxIMAGE_LIST_SMALL + varModsSel <- varCreate $ -1 + lstModules <- listCtrlEx pnlMs (wxLC_REPORT + wxLC_ALIGN_LEFT + wxLC_NO_HEADER + wxLC_SINGLE_SEL) + [columns := [("Module", AlignLeft, 200), + ("Origin", AlignLeft, 0)]] + listCtrlSetImageList lstModules images wxIMAGE_LIST_SMALL - lstPkgModules <- singleListBox pnlPMs [style := wxLB_NEEDED_SB] - -- Results panel pnlRes <- panel win [] txtValue <- textEntry pnlRes [style := wxTE_READONLY] @@ -123,7 +123,7 @@ search <- findReplaceDataCreate wxFR_DOWN let guiRes = GUIRes pnlRes btnInterpret lblInterpret txtValue lbl4Dots txtType txtKind - let guiCtx = GUICtx win lstPages lstPkgModules lstLoadedModules txtCode guiRes status varTimer search + let guiCtx = GUICtx win lstPages (varModsSel, lstModules) txtCode guiRes status varTimer search let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx set btnInterpret [on command := onCmd "interpret" interpret] @@ -136,12 +136,9 @@ MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu _ -> 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 + set lstModules [on listEvent := \e -> case e of + ListItemSelected idx -> varSet varModsSel idx + ListItemRightClick idx -> varSet varModsSel idx >> onCmd "moduleContextMenu" moduleContextMenu _ -> propagateEvent] -- Menu bar... @@ -245,9 +242,8 @@ -- Layout settings let txtCodeL = fill $ widget txtCode 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 - leftL = tabs ntbkL [lddModsTabL, pkgModsTabL, pagesTabL] + modsTabL = tab "Modules" $ container pnlMs $ fill $ margin 5 $ widget lstModules + leftL = tabs ntbkL [modsTabL, pagesTabL] resultsL = hfill $ boxed "Expression" $ fill $ widget pnlRes rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsL] set win [layout := fill $ row 10 [leftL, rightL], @@ -262,30 +258,46 @@ refreshPage, savePageAs, savePage, openPage, pageChange, copy, cut, paste, justFind, justFindNext, justFindPrev, findReplace, - textContextMenu, pkgModuleContextMenu, + textContextMenu, moduleContextMenu, restartTimer, killTimer, loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules, configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO () -browseModule :: Int -> HPS.ServerHandle -> GUIContext -> IO () - -browseModule i model guiCtx@GUICtx{guiWin = win, guiLoadedModules = lstLoadedModules, guiCode = txtCode} = +moduleContextMenu model guiCtx@GUICtx{guiWin = win, guiModules = (varModsSel, lstModules)} = do + pointWithinWindow <- windowGetMousePosition win + i <- varGet varModsSel contextMenu <- menuPane [] - mn <- listCtrlGetItemText lstLoadedModules i - hpsRes <- tryIn model $ HP.getModuleExports mn - case hpsRes of - Left err -> - propagateEvent >> warningDialog win "Error" err - Right mes -> + case i of + (-1) -> do - flip mapM_ mes $ createMenuItem contextMenu + return () + i -> + do + itm <- get lstModules $ item i + debugIO ("the item", itm) + case itm of + [_, "Package"] -> + menuAppend contextMenu wxId_HASK_LOAD_FAST "&Load" "Load Module" False + [modname, _] -> + appendBrowseMenu contextMenu modname + other -> + menuAppend contextMenu idAny (show other) "Other" False propagateEvent - pointWithinWindow <- windowGetMousePosition win menuPopup contextMenu pointWithinWindow win objectDelete contextMenu - where createMenuItem m fn@(HP.MEFun _ _) = + where appendBrowseMenu contextMenu mn = do + browseMenu <- menuPane [] + hpsRes <- tryIn model $ HP.getModuleExports mn + case hpsRes of + Left err -> + menuAppend browseMenu idAny err "Error" False + Right mes -> + flip mapM_ mes $ createMenuItem browseMenu + menuAppendSub contextMenu wxId_HASK_BROWSE "&Browse" browseMenu "" + createMenuItem m fn@(HP.MEFun _ _) = + do item <- menuItemCreate menuItemSetCheckable item False menuItemSetText item $ show fn @@ -336,21 +348,6 @@ 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 - pageChange model guiCtx@GUICtx{guiPages = lstPages} = do i <- get lstPages selection @@ -448,7 +445,6 @@ 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"])] "" "" @@ -471,14 +467,14 @@ set status [text := "loading..."] runHP (HP.loadModules $ words mns) model guiCtx -loadModulesByNameFast model guiCtx@GUICtx{guiWin = win, guiPkgModules = lstPkgModules, guiStatus = status} = +loadModulesByNameFast model guiCtx@GUICtx{guiWin = win, guiModules = (varModsSel, lstModules), guiStatus = status} = do - i <- get lstPkgModules selection + i <- varGet varModsSel case i of (-1) -> return () i -> do - mnText <- listBoxGetString lstPkgModules i + mnText <- listCtrlGetItemText lstModules i let mns = [mnText] set status [text := "loading..."] runHP (HP.loadModules mns) model guiCtx @@ -533,8 +529,7 @@ refreshPage model guiCtx@GUICtx{guiWin = win, guiPages = lstPages, - guiPkgModules = lstPkgModules, - guiLoadedModules = lstLoadedModules, + guiModules = (varModsSel, lstModules), guiCode = txtCode, guiStatus = status} = do @@ -568,18 +563,21 @@ set lstPages [selection := i] -- Refresh the modules lists - --NOTE: we know 0 == "imported" / 1 == "interpreted" / 2 == "compiled" images + --NOTE: we know 0 == "imported" / 1 == "interpreted" / 2 == "compiled" / 3 == "package" images --TODO: move that to some kind of constants or so - let ims' = map (\m -> (0, m)) ims - ms' = map (\m -> (if HP.modInterpreted m then 1 else 2, HP.modName m)) ms - allms = zip [0..] (ims' ++ ms') - itemsDelete 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 any (\xm -> HP.modName xm == pm) ms then ('*':pm) else pm) + let ims' = map (\m -> (0, [m, "Imported"])) ims + ms' = map (\m -> if HP.modInterpreted m + then (1, [HP.modName m, "Interpred"]) + else (2, [HP.modName m, "Compiled"])) ms + pms' = map (\m -> (3, [m, "Package"])) $ + flip filter pms $ \pm -> all (\xm -> HP.modName xm /= pm) ms + allms = zip [0..] (ims' ++ ms' ++ pms') + debugIO ("allms", allms) + itemsDelete lstModules + (flip mapM) allms $ \(idx, (img, m@(mn:_))) -> + listCtrlInsertItemWithLabel lstModules idx mn img >> + set lstModules [item idx := m] + varSet varModsSel $ -1 -- Refresh the current text set txtCode [text := t] 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 @@ -33,7 +33,7 @@ wxId_HASK_LOAD, wxId_HASK_LOADNAME, wxId_HASK_LOAD_FAST, wxId_HASK_RELOAD, wxId_HASK_INTERPRET, - wxId_HASK_ADD, wxId_HASK_LOAD_PKG, wxId_HASK_MENUELEM :: Int + wxId_HASK_ADD, wxId_HASK_LOAD_PKG, wxId_HASK_MENUELEM, wxId_HASK_BROWSE :: Int wxId_HASK_LOAD = 5300 wxId_HASK_LOADNAME = 5301 wxId_HASK_RELOAD = 5302 @@ -41,4 +41,5 @@ wxId_HASK_ADD = 5304 wxId_HASK_LOAD_PKG = 5305 wxId_HASK_LOAD_FAST = 5306 +wxId_HASK_BROWSE = 5307 wxId_HASK_MENUELEM = 5310 diff --git a/src/HPage/Test/Server.hs b/src/HPage/Test/Server.hs deleted file mode 100644 --- a/src/HPage/Test/Server.hs +++ /dev/null @@ -1,1082 +0,0 @@ -module HPage.Test.Server where - -import Data.Char -import GHC.IOBase -import Control.Monad.Error -import Test.QuickCheck -import Test.QuickCheck.Batch -import qualified HPage.Control as HP -import qualified HPage.Server as HPS -import qualified Language.Haskell.Interpreter as Hint -import qualified Language.Haskell.Interpreter.Server as HS -import System.Directory -import Control.Monad.Loops -import qualified Data.ByteString.Char8 as Str -import HPage.Utils.Log -import Paths_hpage - -instance Arbitrary Char where - arbitrary = elements (['A'..'Z'] ++ ['a' .. 'z']) - coarbitrary c = variant (ord c `rem` 16) - -newtype ModuleName = MN {mnString :: String} - deriving (Eq) - -instance Show ModuleName where - show = mnString - -instance Arbitrary ModuleName where - arbitrary = do - s <- arbitrary - 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) - -instance Arbitrary ClassName where - 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) - -instance Arbitrary WorkingExtension where - arbitrary = elements [wexTypeSynonymInstances, wexOverlappingInstances, wexFlexibleInstances] - coarbitrary _ = undefined - -wexTypeSynonymInstances :: WorkingExtension -wexTypeSynonymInstances = WEX [HP.TypeSynonymInstances] "TypeSynonymInstances.hs" - -wexOverlappingInstances :: WorkingExtension -wexOverlappingInstances = WEX [HP.TypeSynonymInstances, - HP.OverlappingInstances] "OverlappingInstances.hs" - -wexFlexibleInstances :: WorkingExtension -wexFlexibleInstances = WEX [HP.FlexibleInstances] "FlexibleInstances.hs" - -shouldFail :: (MonadError e m) => m a -> m Bool -shouldFail a = (a >> return False) `catchError` (\_ -> return True) - -options :: TestOptions -options = TestOptions - { no_of_tests = 200 - , length_of_tests = 1 - , debug_tests = False } - -testDir :: FilePath -testDir = "TestFiles" - -main :: IO () -main = - do - createDirectoryIfMissing True testDir - hps <- HPS.start - hs <- HS.start - runTests "Editing" options - [ run $ prop_setget_text hps - , run $ prop_setget_expr hps - , run $ prop_setget_expr_fail hps - , run $ prop_addrem_expr hps - , run $ prop_addrem_expr_fail hps - , run $ prop_setget_nth hps - , run $ prop_setget_nth_fail hps - , run $ prop_remove_nth hps - , run $ prop_remove_nth_fail hps - , run $ prop_undoredo hps - ] - runTests "Many Pages" options - [ run $ prop_new_page hps - , run $ prop_open_page hps - , run $ prop_open_page_fail hps - , run $ prop_setget_page hps - , run $ prop_set_page_index_fail hps - , run $ prop_save_page hps - , run $ prop_save_page_fail hps - , run $ prop_save_page_as hps - , run $ prop_close_page hps - , run $ prop_is_modified_page hps - , run $ prop_save_nth_page hps - , run $ prop_save_nth_page_fail hps - , run $ prop_save_nth_page_as hps - , run $ prop_save_nth_page_as_fail hps - , run $ prop_is_modified_nth_page hps - , run $ prop_is_modified_nth_page_fail hps - , run $ prop_close_nth_page hps - , run $ prop_close_nth_page_fail hps - , run $ prop_close_all_pages hps - ] - runTests "Many Pages (Safe)" options - [ run $ prop_safe_save_page_as hps - , run $ prop_safe_close_page hps - , run $ prop_safe_save_nth_page_as hps - , run $ prop_safe_close_nth_page hps - , run $ prop_safe_close_all_pages hps - ] - runTests "Named Expressions" options - [ run $ prop_let_fail hps hs - , run $ prop_let_valueOf hps hs - , run $ prop_let_typeOf hps hs - ] - runTests "Expressions" options - [ run $ prop_fail hps hs - , run $ prop_valueOf hps hs - , 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 - , run $ prop_get_module_exports hps hs - ] - runTests "Cancelation" options - [ run $ prop_sequential hps - , run $ prop_cancel_load hps - ] - runTests "Extensions" options - [ run prop_get_available_extensions - , run $ prop_get_set_extensions hps - , run $ prop_working_extensions hps - , run $ prop_get_set_extension_fail hps - ] - runTests "Src. Dirs." options - [ run $ prop_get_set_source_dirs hps - , run $ prop_working_source_dirs hps - ] - runTests "GHC Options" options - [ run $ prop_get_set_ghc_opts hps - , run $ prop_get_set_ghc_opts_fail hps - , run $ prop_working_ghc_opts hps - ] - removeDirectoryRecursive testDir - -instance Eq (Hint.InterpreterError) where - a == b = show a == show b - -prop_valueOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool -prop_valueOf hps hs txt = - unsafePerformIO $ do - let expr = "length \"" ++ txt ++ "\"" - hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.valueOf - hsr <- HS.runIn hs $ Hint.eval expr - return $ hpsr == hsr - -prop_typeOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Property -prop_typeOf hps hs txt = txt /= "" ==> - unsafePerformIO $ do - let h = head txt - let expr = if isNumber h then [h, h] else "\"" ++ txt ++ "\"" - hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.typeOf - hsr <- HS.runIn hs $ Hint.typeOf expr - return $ hpsr == hsr - -prop_kindOf :: HPS.ServerHandle -> HS.ServerHandle -> ClassName -> Bool -prop_kindOf hps hs (CN expr) = - unsafePerformIO $ do - hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.kindOf - hsr <- HS.runIn hs $ Hint.kindOf expr - return $ hpsr == hsr - -prop_fail :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool -prop_fail hps hs txt = - unsafePerformIO $ do - let expr = "lenggth \"" ++ txt ++ "\"" - Left hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.valueOf - 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_get_module_exports :: HPS.ServerHandle -> HS.ServerHandle -> KnownModuleName -> Bool -prop_get_module_exports hps hs kmn = - unsafePerformIO $ do - 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) - 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)) - match ((HP.MEData dn dcs), (Hint.Data dn2 dcs2)) = dn == dn2 && all match (zip dcs (map Hint.Fun dcs2)) - match _ = False - -prop_load_module :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Property -prop_load_module hps hs mn = - (show mn /= "Test") ==> - unsafePerformIO $ do - let mname = testDir ++ "." ++ show mn - let ftxt = "module " ++ mname ++ " where v = 32" - let f2txt = "v = \"" ++ show mn ++ "\"" - hpsr <- HPS.runIn hps $ do - -- Save TestFiles/Test...hs - HP.setPageText ftxt 0 - HP.savePageAs $ testDir ++ "/" ++ show mn ++ ".hs" - -- Save TestFiles/test.hs - HP.setPageText f2txt 0 - HP.savePageAs $ testDir ++ "/test.hs" - -- Load TestFiles/test.hs by path - HP.loadModules [testDir ++ "/test.hs"] - HP.setPageText "v" 0 - fv <- HP.valueOf - fm <- HP.getLoadedModules >>= return . mN - -- Load TestFiles/Test...hs by name - HP.loadModules [mname] - HP.setPageText "v" 0 - sv <- HP.valueOf - sm <- HP.getLoadedModules >>= return . mN - return (fv, sv, fm, sm) - hsr <- HS.runIn hs $ do - Hint.loadModules [testDir ++ "/test.hs"] - Hint.getLoadedModules >>= Hint.setTopLevelModules - fv <- Hint.eval "v" - fm <- Hint.getLoadedModules - Hint.loadModules [mname] - Hint.getLoadedModules >>= Hint.setTopLevelModules - sv <- Hint.eval "v" - sm <- Hint.getLoadedModules - return (Right fv, Right sv, Right fm, Right sm) - -- liftDebugIO (hpsr, hsr) - return $ Right hpsr == hsr - where mN (Right mns) = Right $ map HP.modName mns - mN (Left err) = Left err - - -prop_reload_modules :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool -prop_reload_modules hps hs txt = - unsafePerformIO $ do - let expr = "test = show \"" ++ txt ++ "\"" - hpsr <- HPS.runIn hps $ do - HP.setPageText expr 0 - HP.savePageAs $ testDir ++ "/test.hs" - HP.setPageText "test" 0 - HP.loadModules [testDir ++ "/test.hs"] - HP.reloadModules - HP.valueOf - hsr <- HS.runIn hs $ do - Hint.loadModules [testDir ++ "/test.hs"] - Hint.getLoadedModules >>= Hint.setTopLevelModules - Hint.eval "test" - return $ hpsr == hsr - -prop_get_loaded_modules :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Bool -prop_get_loaded_modules hps hs mn = - unsafePerformIO $ do - let expr1 = "ytest = show \"" ++ show mn ++ "\"" - let expr2 = "module " ++ testDir ++ ".XX" ++ show mn ++ "2 where import " ++ testDir ++ ".XX" ++ show mn ++ "3; xtest = show \"" ++ show mn ++ "\"" - let expr3 = "module " ++ testDir ++ ".XX" ++ show mn ++ "3 where xfact = (1,2,3)" - let mnf1 = testDir ++ "/XX" ++ (show mn) ++ "1.hs" - let mnf2 = testDir ++ "/XX" ++ (show mn) ++ "2.hs" - let mnf3 = testDir ++ "/XX" ++ (show mn) ++ "3.hs" - HPS.runIn hps $ do - HP.setPageText expr1 0 - HP.savePageAs mnf1 - HP.setPageText expr2 0 - HP.savePageAs mnf2 - HP.setPageText expr3 0 - HP.savePageAs mnf3 - hpsr1 <- HPS.runIn hps $ HP.loadModules [mnf1] >> HP.getLoadedModules - hsr1 <- HS.runIn hs $ Hint.loadModules [mnf1] >> Hint.getLoadedModules - hpsr2 <- HPS.runIn hps $ HP.loadModules [mnf2] >> HP.getLoadedModules - hsr2 <- HS.runIn hs $ Hint.loadModules [mnf2] >> Hint.getLoadedModules - hpsr3 <- HPS.runIn hps $ HP.loadModules [mnf3] >> HP.getLoadedModules - hsr3 <- HS.runIn hs $ Hint.loadModules [mnf3] >> Hint.getLoadedModules - --liftDebugIO [(hpsr1, hpsr2, hpsr3), (hsr1, hsr2, hsr3)] - return $ (mN hpsr1, mN hpsr2, mN hpsr3) == (hsr1, hsr2, hsr3) - where mN (Right mns) = Right $ map HP.modName mns - mN (Left err) = Left err - -prop_sequential :: HPS.ServerHandle -> String -> Bool -prop_sequential hps txt = - unsafePerformIO $ do - let expr = "test = \"" ++ txt ++ "\"" - HPS.runIn hps $ do - HP.setPageText expr 0 - HP.savePageAs $ testDir ++ "/test.hs" - HP.loadModules' [testDir ++ "/test.hs"] - Right hpsr <- HPS.runIn hps $ do - HP.setPageText "test" 0 - HP.valueOf - return $ hpsr == show txt - -prop_cancel_load :: HPS.ServerHandle -> ModuleName -> Bool -prop_cancel_load hps mn = - unsafePerformIO $ do - let expr1 = "module " ++ show mn ++ " where cancelLoadTest = (1,2,3)" - let expr2 = "module " ++ show mn ++ "2 where cancelLoadTest = foldl (*) 1 [1.." ++ show (length $ show mn) ++ "]" - HPS.runIn hps $ do - HP.reset - HP.setPageText expr2 0 - HP.savePageAs $ testDir ++ "/" ++ show mn ++ "2.hs" - HP.setPageText expr1 0 - HP.savePageAs $ testDir ++ "/" ++ show mn ++ ".hs" - HP.setPageText "cancelLoadTest" 0 - HP.loadModules [testDir ++ "/" ++ show mn ++ ".hs"] - oldMs <- HP.getLoadedModules - oldRes <- HP.valueOf - oldCtx <- HP.ctxString - HP.loadModules' [testDir ++ "/" ++ show mn ++ "2.hs"] - HP.cancel - newMs <- HP.getLoadedModules - newRes <- HP.valueOf - newCtx <- HP.ctxString - -- liftDebugIO [(oldRes, oldMs, oldCtx), (newRes, newMs, newCtx)] - return $ (oldRes, oldMs, oldCtx) == (newRes, newMs, newCtx) - -prop_setget_text :: HPS.ServerHandle -> String -> Bool -prop_setget_text hps txt = - unsafePerformIO $ HPS.runIn hps $ do - HP.setPageText txt 0 - HP.getPageText >>= return . (txt ==) - -prop_setget_expr :: HPS.ServerHandle -> String -> Property -prop_setget_expr hps txt = - txt /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.setPageText (txt ++ "\n\nxx") (length txt + 3) - exi1 <- HP.getExprIndex - exp1 <- HP.getExprText - HP.setExprIndex 0 - exi0 <- HP.getExprIndex - exp0 <- HP.getExprText - HP.setExprText "yy" - exi2 <- HP.getExprIndex - exp2 <- HP.getExprText - HP.setExprIndex 1 - exi3 <- HP.getExprIndex - exp3 <- HP.getExprText - -- liftDebugIO [(exi1, exp1), (exi0, exp0), (exi2, exp2), (exi3, exp3)] - return $ (exi1 == 1) && (exp1 == "xx") && - (exi0 == 0) && (exp0 == txt) && - (exi2 == 0) && (exp2 == "yy") && - (exi3 == 1) && (exp3 == "xx") - -prop_setget_expr_fail :: HPS.ServerHandle -> String -> Bool -prop_setget_expr_fail hps _ = - unsafePerformIO $ HPS.runIn hps $ shouldFail $ HP.clearPage >> HP.getExprText - -prop_addrem_expr :: HPS.ServerHandle -> String -> Property -prop_addrem_expr hps txt = - txt /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.clearPage - HP.addExpr txt - exi1 <- HP.getExprIndex - exp1 <- HP.getExprText - HP.removeExpr - exi0 <- HP.getExprIndex - exp0 <- HP.getPageText - HP.addExpr txt - HP.addExpr txt - exi2 <- HP.getExprIndex - exp2 <- HP.getExprText - HP.removeExpr - exi3 <- HP.getExprIndex - exp3 <- HP.getPageText - -- liftDebugIO [(exi1, exp1), (exi0, exp0), (exi2, exp2), (exi3, exp3)] - return $ (exi1 == 0) && (exp1 == txt) && - (exi0 == -1) && (exp0 == "") && - (exi2 == 1) && (exp2 == txt) && - (exi3 == 0) && (exp3 == txt) - -prop_addrem_expr_fail :: HPS.ServerHandle -> String -> Bool -prop_addrem_expr_fail hps _ = - unsafePerformIO $ HPS.runIn hps $ shouldFail $ HP.clearPage >> HP.removeExpr - -prop_setget_nth :: HPS.ServerHandle -> Int -> Property -prop_setget_nth hps i = - i >= 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.clearPage - replicateM (i+1) $ HP.addExpr "ww" - exp0 <- HP.getExprNthText 0 - exp1 <- HP.getExprNthText i - HP.setExprNthText i "xxx" - exp2 <- HP.getExprNthText i - HP.setExprNthText i "x\n\ny" - exp3 <- HP.getExprNthText $ i+1 - -- liftDebugIO [exp0, exp1, exp2, exp3] - return $ (exp1 == "ww") && - (exp0 == "ww") && - (exp2 == "xxx") && - (exp3 == "y") - -prop_setget_nth_fail :: HPS.ServerHandle -> Int -> String -> Property -prop_setget_nth_fail hps i txt = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.clearPage - set <- shouldFail $ HP.setExprNthText i txt - get <- shouldFail $ HP.getExprNthText i - -- liftDebugIO (get, set) - return (set && get) - -prop_remove_nth :: HPS.ServerHandle -> Int -> Property -prop_remove_nth hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.clearPage - forM [0..i] $ HP.addExpr . show - HP.removeNth 0 - exp0 <- HP.getExprNthText 0 - forM [i-2,i-3..0] $ HP.removeNth - exp1 <- HP.getPageText - -- liftDebugIO [exp0, exp1] - return $ (exp0 == "1") && - (exp1 == show i) - -prop_remove_nth_fail :: HPS.ServerHandle -> Int -> Property -prop_remove_nth_fail hps i = - i >= 0 ==> - unsafePerformIO $ HPS.runIn hps $ HP.clearPage >> shouldFail (HP.removeNth $ i+1) - - -prop_undoredo :: HPS.ServerHandle -> String -> Property -prop_undoredo hps txt = - txt /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.addPage - b0 <- HP.getPageText - HP.setPageText txt 0 - b1 <- HP.getPageText - HP.addExpr "xx" - b2 <- HP.getPageText - HP.addExpr "yy" - b3 <- HP.getPageText - HP.setExprIndex 1 - b4 <- HP.getPageText - HP.setExprText $ txt ++ "|" ++ txt - b5 <- HP.getPageText - HP.removeExpr - b6 <- HP.getPageText - HP.removeNth 0 - b7 <- HP.getPageText - HP.setExprNthText 0 txt - b8 <- HP.getPageText - HP.addExpr "zz" - b9 <- HP.getPageText - let to10 = [0..10] :: [Int] - after <- mapM (\_ -> HP.undo >> HP.getPageText) to10 - redo <- mapM (\_ -> HP.redo >> HP.getPageText) to10 - HP.clearPage >> HP.addExpr "cc" >> HP.clearPage - c0 <- HP.addExpr "zz" >> HP.getPageText - c1 <- HP.undo >> HP.getPageText - c2 <- HP.undo >> HP.getPageText - c3 <- HP.setPageText "ww" 0 >> HP.getPageText - c4 <- HP.redo >> HP.getPageText - let result = ([b8, b7, b6, b5, b4, b3, b2, b1, b0, "", ""] == after) && - ([b1, b2, b3, b4, b5, b6, b7, b8, b9, b9, b9] == redo) && - ([c0, c1, c2, c3, c4] == ["zz", "", "cc", "ww", "ww"]) - if not result - then - do - liftDebugIO [b8, b7, b6, b5, b4, b3, b2, b1, b0, "", ""] - liftDebugIO after - liftDebugIO [b1, b2, b3, b4, b5, b6, b7, b8, b8, b8, b8] - liftDebugIO redo - liftDebugIO ["zz", "", "cc", "ww", "ww"] - liftDebugIO [c0, c1, c2, c3, c4] - return False - else - return True - -prop_new_page :: HPS.ServerHandle -> Int -> Property -prop_new_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.clearPage - HP.closeAllPages - pc0 <- HP.getPageCount - pi0 <- HP.getPageIndex - pt0 <- HP.getPageText - pss <- (flip mapM) [1..i] $ \x -> do - HP.addPage - psc <- HP.getPageCount - psi <- HP.getPageIndex - pst <- HP.getPageText - HP.setPageIndex $ psc - 1 - HP.setPageText ("old "++ show x) 0 - return (x, psc, psi, pst) - let results = (0,pc0,pi0,pt0):pss - -- liftDebugIO results - return $ all (\(k, kc, ki, kt) -> - kc == k+1 && - ki == 0 && - kt == "") $ results - -prop_open_page, prop_open_page_fail :: HPS.ServerHandle -> String -> Property -prop_open_page hps file = - file /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/Test" ++ file - Hint.liftIO $ writeFile path file - HP.closeAllPages - HP.openPage path - liftM (file ==) HP.getPageText - -prop_open_page_fail hps file = - file /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/NO-Test" ++ file - HP.closeAllPages - shouldFail $ HP.openPage path - -prop_setget_page, prop_set_page_index_fail :: HPS.ServerHandle -> Int -> Property -prop_setget_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.clearPage - HP.closeAllPages - HP.setPageText "0" 0 - forM [1..i] $ \x -> - do - HP.addPage - HP.setPageText (show x) 0 - pc <- HP.getPageCount - pss <- (flip mapM) [0..i] $ \x -> do - HP.setPageIndex (i-x) - psi <- HP.getPageIndex - pst <- HP.getPageText - HP.setPageText ("old "++ show x) 0 - return (x, psi, pst) - -- liftDebugIO pss - return . ((pc == i+1) &&) $ all (\(k, ki, kt) -> - ki == (i-k) && - kt == show k) $ pss -prop_set_page_index_fail hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - replicateM (i-1) HP.addPage - shouldFail $ HP.setPageIndex i - -prop_save_page, prop_save_page_fail, prop_save_page_as :: HPS.ServerHandle -> String -> Property -prop_save_page hps file = - file /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/Test" ++ file - Hint.liftIO $ writeFile path file - HP.closeAllPages - HP.openPage path - HP.savePage - p1 <- HP.getPageText - HP.openPage path - p2 <- HP.getPageText - HP.addExpr file - HP.savePage - p3 <- HP.getPageText - return $ p1 == file && - p2 == file && - p3 == (file ++ "\n\n" ++ file) -prop_save_page_fail hps file = - file /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - shouldFail $ HP.savePage -prop_save_page_as hps file = - file /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/Test" ++ file - HP.closeAllPages - HP.setPageText file 0 - HP.savePageAs path - HP.openPage path - p0 <- HP.getPageText - HP.savePage - HP.openPage path - p1 <- HP.getPageText - return $ p0 == file && - p1 == file - -prop_close_page :: HPS.ServerHandle -> Int -> Property -prop_close_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - HP.setPageText (show i) 0 - forM [1..i] $ \x -> - do - HP.addPage - HP.setPageText (show (i-x)) 0 - pcb <- HP.getPageCount - pss <- (flip mapM) [i,i-1..1] $ \x -> do - HP.setPageIndex x - pbi <- HP.getPageIndex - pbt <- HP.getPageText - HP.closePage - pai <- HP.getPageIndex - pat <- HP.getPageText - return (x, pbi, pbt, pai, pat) - pca <- HP.getPageCount - pia <- HP.getPageIndex - pta <- HP.getPageText - HP.closePage - pcf <- HP.getPageCount - pif <- HP.getPageIndex - ptf <- HP.getPageText - --liftDebugIO (pcb, (pca, pia, pta), (pcf, pif, ptf), pss) - --let ff = \(k, _, _, _, _) -> (k, k, show k, k-1, show (k-1)) - --liftDebugIO (i+1, (1, 0, "0"), (1, 0, ""), map ff pss) - return . ((pcb == i+1 && - pca == 1 && pia == 0 && pta == "0" && - pcf == 1 && pif == 0 && ptf == "") &&) $ - all (\(k, kbi, kbt, kai, kat) -> - kbi == k && - kbt == show k && - kai == k-1 && - kat == show (k-1) ) $ pss - -prop_is_modified_page :: HPS.ServerHandle -> FilePath -> Property -prop_is_modified_page hps file = - file /= "" ==> - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/Test" ++ file - HP.addPage - f0 <- HP.isModifiedPage - HP.setPageText file 0 - HP.addExpr file - t0 <- HP.isModifiedPage - HP.undo - t1 <- HP.isModifiedPage - HP.undo - f1 <- HP.isModifiedPage - HP.redo - t2 <- HP.isModifiedPage - HP.redo - t3 <- HP.isModifiedPage - HP.savePageAs path - f2 <- HP.isModifiedPage - HP.undo - t4 <- HP.isModifiedPage - HP.addExpr $ file ++ "$$$" - t5 <- HP.isModifiedPage - HP.openPage path - f3 <- HP.isModifiedPage - HP.redo - f4 <- HP.isModifiedPage - let result = not (f0 || f1 || f2 || f3 || f4) && - t0 && t1 && t2 && t3 && t4 && t5 - if not result - then do - liftDebugIO $ (('F', f0, f1, f2, f3, f4), - ('T', t0, t1, t2, t3, t4, t5)) - return False - else - return True - -prop_save_nth_page, prop_save_nth_page_fail :: HPS.ServerHandle -> Int -> Property -prop_save_nth_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \x -> - do - let y = show $ i - x - path = testDir ++ "/Test" ++ y - Hint.liftIO $ writeFile path y - HP.openPage path - forM [0..i-1] $ \x -> - do - HP.setPageText (show x) 0 - HP.savePageNth x - HP.closeAllPages - (flip allM) [0..i-1] $ \x -> - do - let path = testDir ++ "/Test" ++ show x - HP.openPage path - liftM ((show x) ==) $ HP.getPageText -prop_save_nth_page_fail hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - a <- shouldFail $ HP.savePageNth 0 - forM [1..i] $ \_ -> HP.addPage - b <- (flip allM) [1..i] $ shouldFail . HP.savePageNth - c <- shouldFail $ HP.savePageNth $ i + 1 - return $ a && b && c - -prop_save_nth_page_as, prop_save_nth_page_as_fail :: HPS.ServerHandle -> Int -> Property -prop_save_nth_page_as hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \x -> - do - let y = show $ i - x - HP.addPage - HP.setPageText y 0 - forM [0..i-1] $ \x -> - do - let path = testDir ++ "/Test" ++ show x - HP.savePageNthAs x path - HP.closeAllPages - (flip allM) [0..i-1] $ \x -> - do - let path = testDir ++ "/Test" ++ show x - HP.openPage path - liftM ((show x) ==) $ HP.getPageText -prop_save_nth_page_as_fail hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \_ -> HP.addPage - a <- shouldFail $ HP.savePageNth $ i + 1 - b <- shouldFail $ HP.savePageNth $ -1 - return $ a && b - -prop_is_modified_nth_page, prop_is_modified_nth_page_fail :: HPS.ServerHandle -> Int -> Property -prop_is_modified_nth_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \x -> - do - let y = show $ i - x - HP.addPage - HP.setPageText y 0 - t0 <- allM HP.isModifiedPageNth [0..i-1] - f0 <- HP.isModifiedPageNth i - let path = testDir ++ "/Test.page" - forM [0..i-1] $ flip HP.savePageNthAs $ path - f1 <- allM HP.isModifiedPageNth [0..i-1] - return $ t0 && not (f0 || f1) -prop_is_modified_nth_page_fail hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \_ -> HP.addPage - a <- shouldFail $ HP.isModifiedPageNth $ i + 1 - b <- shouldFail $ HP.isModifiedPageNth $ -1 - return $ a && b - -prop_close_nth_page, prop_close_nth_page_fail :: HPS.ServerHandle -> Int -> Property -prop_close_nth_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \_ -> HP.addPage - t0 <- (flip allM) [1..i] $ \x -> - do - let y = i - x - HP.closePageNth y - pgc <- liftM (y+1==) $ HP.getPageCount - pgi <- liftM (0 ==) $ HP.getPageIndex - let result = pgc && pgi - if not result - then - do - liftDebugIO [pgc, pgi] - return False - else - return True - HP.closeAllPages - HP.setPageText "two" 0 - HP.addPage - HP.setPageText "one" 0 - HP.addPage - HP.setPageText "zero" 0 - HP.setPageIndex 1 - HP.closePageNth 1 - t1 <- liftM ("zero" ==) $ HP.getPageText - t2 <- liftM (0 ==) $ HP.getPageIndex - HP.setPageIndex 1 - t3 <- liftM ("two" ==) $ HP.getPageText - HP.closePageNth 1 - HP.closePageNth 0 - t4 <- liftM ("" ==) $ HP.getPageText - t5 <- liftM (0 ==) $ HP.getPageIndex - t6 <- liftM (1 ==) $ HP.getPageCount - let result = t0 && t1 && t2 && t3 && t4 && t5 && t6 - if not result - then - do - liftDebugIO [t0, t1, t2, t3, t4, t5, t6] - return False - else - return True -prop_close_nth_page_fail hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \_ -> HP.addPage - a <- shouldFail $ HP.closePageNth $ i + 1 - b <- shouldFail $ HP.closePageNth $ -1 - return $ a && b - -prop_close_all_pages :: HPS.ServerHandle -> Int -> Property -prop_close_all_pages hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - c0 <- HP.getPageCount - HP.setPageText "not empty" 0 - forM [1..i-1] $ \_ -> HP.addPage - c1 <- HP.getPageCount - HP.setPageIndex $ c1 - 1 - HP.closeAllPages - c2 <- HP.getPageCount - i2 <- HP.getPageIndex - t2 <- HP.getPageText - let result = (c0, c1, c2, i2, t2) == (1, i, 1, 0, "") - if not result - then - do - liftDebugIO (c0, c1, c2, i2, t2) - return False - else - return True - -prop_safe_save_page_as :: HPS.ServerHandle -> ModuleName -> Bool -prop_safe_save_page_as hps (MN file) = - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/" ++ file - Hint.liftIO $ removeFileMayNotExist path - HP.closeAllPages - HP.setPageText file 0 - HP.safeSavePageAs path - HP.openPage path - p0 <- HP.getPageText - p1 <- shouldFail $ HP.safeSavePageAs path - HP.openPage path - p2 <- HP.getPageText - return $ p0 == file && p1 && p2 == file - where removeFileMayNotExist f = do - e <- doesFileExist f - if e then removeFile f else return () - -prop_safe_close_page :: HPS.ServerHandle -> Int -> Property -prop_safe_close_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ (flip allM) [1..i] $ \_ -> - do - HP.addPage -- To avoid page 0 - HP.addPage - HP.setPageText (show i) 0 - c0 <- HP.getPageCount - t1 <- shouldFail $ HP.safeClosePage - c1 <- HP.getPageCount - HP.undo - HP.safeClosePage - c2 <- HP.getPageCount - return $ c0 == c1 && - c0 == (c2 + 1) && - t1 - -prop_safe_save_nth_page_as :: HPS.ServerHandle -> Int -> Property -prop_safe_save_nth_page_as hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \x -> - do - let y = show $ i - x - HP.addPage - HP.setPageText y 0 - let path = testDir ++ "/Test" - Hint.liftIO $ Str.writeFile path $ Str.pack $ show i - t0 <- (flip allM) [0..i-1] $ shouldFail . ((flip HP.safeSavePageNthAs) path) - Hint.liftIO $ removeFile path - HP.safeSavePageNthAs 0 path - return t0 - -prop_safe_close_nth_page :: HPS.ServerHandle -> Int -> Property -prop_safe_close_nth_page hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \x -> - do - let y = show $ i - x - HP.addPage - HP.setPageText y 0 - t0 <- allM (shouldFail . HP.safeClosePageNth) [0..i-2] - HP.addPage - HP.safeClosePageNth 0 - t1 <- allM HP.isModifiedPageNth [1..i-1] - return $ t0 && t1 - -prop_safe_close_all_pages :: HPS.ServerHandle -> Int -> Property -prop_safe_close_all_pages hps i = - i > 0 ==> - unsafePerformIO $ HPS.runIn hps $ do - HP.closeAllPages - forM [1..i] $ \x -> - do - let y = show $ i - x - HP.addPage - HP.setPageText y 0 - shouldFail HP.safeCloseAllPages - -prop_let_valueOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool -prop_let_valueOf hps hs txt = - unsafePerformIO $ do - let expr = "length \"" ++ txt ++ "\"" - (hpsr1, hpsr2) <- HPS.runIn hps $ do - HP.addPage - HP.addExpr $ "testL = " ++ expr - HP.addExpr $ "test2L x = 2 * x" - HP.addExpr "test2L testL" - r1 <- HP.valueOf - HP.addExpr $ "(test2L testL) `div` 2" - r2 <- HP.valueOf - return (r1, r2) - hsr1 <- HS.runIn hs $ Hint.eval $ "2 * " ++ expr - hsr2 <- HS.runIn hs $ Hint.eval $ expr - -- liftDebugIO [(hpsr1, hpsr2), (hsr1, hsr2)] - return $ (hpsr1, hpsr2) == (hsr1, hsr2) - -prop_let_typeOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Property -prop_let_typeOf hps hs txt = txt /= "" ==> - unsafePerformIO $ do - let expr = "\"" ++ txt ++ "\"" - (hpsr1, hpsr2) <- HPS.runIn hps $ do - HP.addPage - HP.addExpr $ "testL = " ++ expr - HP.addExpr "testL" - r1 <- HP.typeOf - HP.addExpr $ "test2L x = length x" - HP.addExpr $ "2 * (test2L testL)" - r2 <- HP.typeOf - return (r1, r2) - hsr1 <- HS.runIn hs $ Hint.typeOf expr - hsr2 <- HS.runIn hs $ Hint.typeOf $ "2 * (length " ++ expr ++ ")" - -- liftDebugIO [(hpsr1, hpsr2), (hsr1, hsr2)] - return $ (hpsr1, hpsr2) == (hsr1, hsr2) - -prop_let_fail :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool -prop_let_fail hps hs txt = - unsafePerformIO $ do - let expr = "testL x = lenggth x" - Left hpsr <- HPS.runIn hps $ do - HP.addPage - HP.addExpr expr - HP.addExpr $ "test2L = 2 * (testL \"" ++ txt ++ "\")" - HP.addExpr $ "test2L / 2" - HP.valueOf - Left hsr <- HS.runIn hs $ Hint.eval "lenggth \"\"" - return $ hsr == hpsr - -prop_get_available_extensions :: String -> Bool -prop_get_available_extensions _ = HP.availableExtensions == Hint.availableExtensions - -prop_get_set_extensions :: HPS.ServerHandle -> [HP.Extension] -> Bool -prop_get_set_extensions hps exs = - unsafePerformIO $ HPS.runIn hps $ do - HP.setLanguageExtensions [] - exs0 <- HP.getLanguageExtensions - HP.setLanguageExtensions exs - exs1 <- HP.getLanguageExtensions - HP.setLanguageExtensions [] - exs2 <- HP.getLanguageExtensions - return $ (exs0 == Right []) && (exs1 == Right exs) && (exs2 == Right []) - -prop_working_extensions :: HPS.ServerHandle -> WorkingExtension -> Bool -prop_working_extensions hps (WEX es m) = - unsafePerformIO $ HPS.runIn hps $ do - path <- Hint.liftIO . getDataFileName $ "res/test/" ++ m - HP.setLanguageExtensions [] - before <- HP.loadModules [path] - HP.setLanguageExtensions es - after <- HP.loadModules [path] - let failed = case before of - Left _ -> True - _ -> False - -- liftDebugIO (before, after, failed) - return $ failed && (after == Right ()) - -prop_get_set_extension_fail :: HPS.ServerHandle -> String -> Bool -prop_get_set_extension_fail hps s = - unsafePerformIO $ HPS.runIn hps $ do - r <- HP.setLanguageExtensions [HP.UnknownExtension s] - case r of - Left _ -> return True - Right _ -> return False - -prop_get_set_source_dirs :: HPS.ServerHandle -> [FilePath] -> Bool -prop_get_set_source_dirs hps sds = - unsafePerformIO $ HPS.runIn hps $ do - HP.setSourceDirs [] - sds0 <- HP.getSourceDirs - HP.setSourceDirs sds - sds1 <- HP.getSourceDirs - HP.setSourceDirs [] - sds2 <- HP.getSourceDirs - return $ (sds0 == []) && (sds1 == sds) && (sds2 == []) - -prop_working_source_dirs :: HPS.ServerHandle -> ModuleName -> Bool -prop_working_source_dirs hps (MN file) = - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/" ++ file ++ ".hs" - HP.setPageText ("module " ++ file ++ " where t = 1") 0 - HP.savePageAs path - HP.setSourceDirs [] - before <- HP.loadModules [file] - HP.setSourceDirs [testDir, testDir] - after <- HP.loadModules [file] - let failed = case before of - Left _ -> True - _ -> False - -- liftDebugIO (before, after, failed) - return $ failed && (after == Right ()) - - -prop_get_set_ghc_opts :: HPS.ServerHandle -> String -> Bool -prop_get_set_ghc_opts hps ops = - unsafePerformIO $ HPS.runIn hps $ do - ops0 <- HP.getGhcOpts - HP.setGhcOpts $ "-i" ++ ops - ops1 <- HP.getGhcOpts - HP.setGhcOpts "" - ops2 <- HP.getGhcOpts - -- liftDebugIO (ops, ops0, ops1, ops2) - return $ (ops1 == (ops0 ++ " -i" ++ ops)) && (ops2 == ops1) - -prop_get_set_ghc_opts_fail :: HPS.ServerHandle -> ClassName -> Bool -prop_get_set_ghc_opts_fail hps (CN ops) = - unsafePerformIO $ HPS.runIn hps $ do - res <- HP.setGhcOpts ops - case res of - Left _ -> return True - _ -> return False - -prop_working_ghc_opts :: HPS.ServerHandle -> ModuleName -> Bool -prop_working_ghc_opts hps (MN file) = - unsafePerformIO $ HPS.runIn hps $ do - let path = testDir ++ "/" ++ file ++ ".hs" - HP.setPageText ("module " ++ file ++ " where t = 1") 0 - HP.savePageAs path - HP.setSourceDirs [] - before <- HP.loadModules [file] - HP.setGhcOpts $ "-i" ++ testDir - after <- HP.loadModules [file] - let failed = case before of - Left _ -> True - _ -> False - -- liftDebugIO (before, after, failed) - return $ failed && (after == Right ())