hpage 0.4.6 → 0.4.7
raw patch · 4 files changed
+66/−1156 lines, 4 files
Files
- hpage.cabal +2/−9
- src/HPage/GUI/FreeTextWindow.hs +62/−64
- src/HPage/GUI/IDs.hs +2/−1
- src/HPage/Test/Server.hs +0/−1082
hpage.cabal view
@@ -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
src/HPage/GUI/FreeTextWindow.hs view
@@ -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]
src/HPage/GUI/IDs.hs view
@@ -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
− src/HPage/Test/Server.hs
@@ -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 ())