hpage 0.1.4 → 0.1.5
raw patch · 6 files changed
+213/−64 lines, 6 filesdep ~MonadCatchIO-mtldep ~bytestringdep ~containerssetup-changed
Dependency ranges changed: MonadCatchIO-mtl, bytestring, containers, directory, filepath, haskell-src-exts, hint, monad-loops, mtl, wx, wxcore
Files
- Setup.hs +1/−1
- hpage.cabal +13/−4
- src/HPage/Control.hs +21/−0
- src/HPage/GUI/FreeTextWindow.hs +83/−30
- src/HPage/Test/Server.hs +93/−28
- src/Utils/Log.hs +2/−1
Setup.hs view
@@ -20,7 +20,7 @@ main :: IO () main = do- putStrLn $ "processing for " ++ os+ putStrLn $ "Setting up hpage for " ++ os defaultMainWithHooks $ addMacHook simpleUserHooks where addMacHook h =
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.1.4+version: 0.1.5 cabal-version: >=1.6 build-type: Custom license: BSD3@@ -31,9 +31,18 @@ location: git://github.com/elbrujohalcon/hPage.git Executable hpage- build-depends: base >= 4, base < 5, mtl >=1.1.0.2, haskell-src-exts >=1.1.3.1, bytestring >=0.9.1.4, hint >=0.3.1.0,- MonadCatchIO-mtl >= 0.1.0.1, monad-loops >=0.3.0.2, containers >=0.2.0.1, directory >=1.0.0.3,- wxcore >=0.11.1.2, wx >=0.11.1.2, filepath >=1.1.0.2+ build-depends: base >= 4, base < 5,+ mtl >=1.1.0, mtl < 1.2,+ haskell-src-exts >=1.1.3, haskell-src-exts < 1.2,+ bytestring >=0.9.1, bytestring <0.10,+ hint >=0.3.1, hint < 0.4,+ MonadCatchIO-mtl >= 0.1.0, MonadCatchIO-mtl < 0.3,+ monad-loops >=0.3.0, monad-loops < 0.4,+ containers >=0.2.0, containers < 0.3,+ directory >=1.0.0, directory < 1.1,+ wxcore >=0.11.1, wxcore < 0.12,+ wx >=0.11.1, wx < 0.12,+ filepath >=1.1.0, filepath < 1.2 main-is: Main.hs buildable: True build-tools:
src/HPage/Control.hs view
@@ -2,6 +2,7 @@ MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies,+ TypeSynonymInstances, UndecidableInstances #-} module HPage.Control (@@ -31,11 +32,14 @@ -- HINT CONTROLS -- valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, loadModules, reloadModules, getLoadedModules,+ getLanguageExtensions, setLanguageExtensions, valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', loadModules', reloadModules', getLoadedModules',+ getLanguageExtensions', setLanguageExtensions', reset, reset', cancel, Hint.InterpreterError, Hint.prettyPrintError,+ Hint.availableExtensions, Extension, -- DEBUG -- ctxString ) where@@ -49,6 +53,7 @@ import Control.Monad.State import Control.Monad.State.Class import Control.Concurrent.MVar+import Language.Haskell.Interpreter (OptionVal((:=))) import qualified Language.Haskell.Interpreter as Hint import qualified Language.Haskell.Interpreter.Utils as Hint import qualified Language.Haskell.Interpreter.Server as HS@@ -112,7 +117,11 @@ throwError = lift . throwError catchError (HPT a) h = HPT $ a `catchError` (\e -> state $ h e) +type Extension = Hint.Extension +instance Ord Extension where+ e1 `compare` e2 = (show e1) `compare` (show e2)+ type HPage = HPageT IO evalHPage :: HPage a -> IO a@@ -382,6 +391,12 @@ getLoadedModules :: HPage (Either Hint.InterpreterError [Hint.ModuleName]) getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules +getLanguageExtensions :: HPage (Either Hint.InterpreterError [Hint.Extension])+getLanguageExtensions = confirmRunning >> syncRun (Hint.get Hint.languageExtensions)++setLanguageExtensions :: [Hint.Extension] -> HPage (Either Hint.InterpreterError ())+setLanguageExtensions exs = confirmRunning >> syncRun (Hint.set [Hint.languageExtensions := exs])+ reset :: HPage (Either Hint.InterpreterError ()) reset = do res <- syncRun $ do@@ -431,6 +446,12 @@ getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [Hint.ModuleName])) getLoadedModules' = confirmRunning >> asyncRun Hint.getLoadedModules++getLanguageExtensions' :: HPage (MVar (Either Hint.InterpreterError [Hint.Extension]))+getLanguageExtensions' = confirmRunning >> asyncRun (Hint.get Hint.languageExtensions)++setLanguageExtensions' :: [Hint.Extension] -> HPage (MVar (Either Hint.InterpreterError ()))+setLanguageExtensions' exs = confirmRunning >> asyncRun (Hint.set [Hint.languageExtensions := exs]) reset' :: HPage (MVar (Either Hint.InterpreterError ())) reset' = do
src/HPage/GUI/FreeTextWindow.hs view
@@ -17,7 +17,9 @@ import Control.Monad.Error import Control.Monad.Loops import Graphics.UI.WX+import Graphics.UI.WX.Dialogs.Extra import Graphics.UI.WXCore+import Graphics.UI.WXCore.WxcDefs.ExtraIdentities import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Dialogs import Graphics.UI.WXCore.Events@@ -111,46 +113,76 @@ -- Menu bar... -- menuBar win [] mnuPage <- menuPane [text := "Page"]- mitNew <- menuItem mnuPage [text := "&New\tCtrl-n", on command := onCmd "runHP' addPage" $ runHP' HP.addPage]- menuItem mnuPage [text := "&Close\tCtrl-w", on command := onCmd "runHP' closePage" $ runHP' HP.closePage]- menuItem mnuPage [text := "&Close All\tCtrl-Shift-w", on command := onCmd "runHP' closeAllPages" $ runHP' HP.closeAllPages]- menuLine mnuPage- mitOpen <- menuItem mnuPage [text := "&Open...\tCtrl-o", on command := onCmd "openPage" openPage]- mitSave <- menuItem mnuPage [text := "&Save\tCtrl-s", on command := onCmd "savePage" savePage]- menuItem mnuPage [text := "&Save as...\tCtrl-Shift-s", on command := onCmd "savePageAs" savePageAs]- menuLine mnuPage+ menuAppend mnuPage wxID_NEW "&New\tCtrl-n" "New Page" False+ menuAppend mnuPage wxID_CLOSE "&Close\tCtrl-w" "Close Page" False+ menuAppend mnuPage wxID_CLOSE_ALL "&Close All\tCtrl-Shift-w" "Close All Pages" False+ menuAppendSeparator mnuPage+ menuAppend mnuPage wxID_OPEN "&Open...\tCtrl-o" "Open Page" False+ menuAppend mnuPage wxID_SAVE "&Save\tCtrl-s" "Save Page" False+ menuAppend mnuPage wxID_SAVEAS "&Save as...\tCtrl-Shift-s" "Save Page as" False+ menuAppendSeparator mnuPage menuQuit mnuPage [] mnuEdit <- menuPane [text := "Edit"]- menuItem mnuEdit [text := "&Undo\tCtrl-z", on command := onCmd "runHP' undo" $ runHP' HP.undo]- menuItem mnuEdit [text := "&Redo\tCtrl-Shift-z", on command := onCmd "runHP' redo" $ runHP' HP.redo]- menuLine mnuEdit- mitCut <- menuItem mnuEdit [text := "C&ut\tCtrl-x", on command := onCmd "cut" cut]- mitCopy <- menuItem mnuEdit [text := "&Copy\tCtrl-c", on command := onCmd "copy" copy]- mitPaste <- menuItem mnuEdit [text := "&Paste\tCtrl-v", on command := onCmd "paste" paste]- menuLine mnuEdit- menuItem mnuEdit [text := "&Find...\tCtrl-f", on command := onCmd "justFind" justFind]- menuItem mnuEdit [text := "&Find Next\tCtrl-g", on command := onCmd "findNext" justFindNext]- menuItem mnuEdit [text := "&Find Previous\tCtrl-Shift-g", on command := onCmd "findPrev" justFindPrev]- menuItem mnuEdit [text := "&Replace...\tCtrl-Shift-r", on command := onCmd "findReplace" findReplace]+ menuAppend mnuEdit wxID_UNDO "&Undo\tCtrl-z" "Undo" False+ menuAppend mnuEdit wxID_REDO "&Redo\tCtrl-Shift-z" "Redo" False+ menuAppendSeparator mnuEdit+ menuAppend mnuEdit wxID_CUT "C&ut\tCtrl-x" "Cut" False+ menuAppend mnuEdit wxID_COPY "&Copy\tCtrl-c" "Copy" False+ menuAppend mnuEdit wxID_PASTE "&Paste\tCtrl-v" "Paste" False+ menuAppendSeparator mnuEdit+ menuAppend mnuEdit wxID_FIND "&Find...\tCtrl-f" "Find" False+ menuAppend mnuEdit wxID_FORWARD "Find &Next\tCtrl-g" "Find Next" False+ menuAppend mnuEdit wxID_BACKWARD "Find &Previous\tCtrl-Shift-g" "Find Previous" False+ menuAppend mnuEdit wxID_REPLACE "&Replace...\tCtrl-Shift-r" "Replace" False mnuHask <- menuPane [text := "Haskell"]- menuItem mnuHask [text := "&Load modules...\tCtrl-l", on command := onCmd "loadModules" loadModules]- menuItem mnuHask [text := "&Load modules by name...\tCtrl-Shift-l",- on command := onCmd "loadModulesByName" loadModulesByName]- mitReload <- menuItem mnuHask [text := "&Reload\tCtrl-r", on command := onCmd "reloadModules" reloadModules]- menuLine mnuHask- menuItem mnuHask [text := "&Value of Expression\tCtrl-e", on command := onCmd "getValue" getValue]- menuItem mnuHask [text := "&Type of Expression\tCtrl-t", on command := onCmd "getType" getType]- menuItem mnuHask [text := "&Kind of Expression\tCtrl-k", on command := onCmd "getKind" getKind]+ 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_RELOAD "&Reload\tCtrl-r" "Reload Modules" False+ menuAppendSeparator mnuHask+ menuAppend mnuHask wxID_HASK_EXTENSIONS "&Extensions...\tCtrl-Shift-x" "Configure Extensions" False+ menuAppendSeparator mnuHask+ menuAppend mnuHask wxID_HASK_VALUE "&Value\tCtrl-e" "Get the Value of the Current Expression" False+ menuAppend mnuHask wxID_HASK_TYPE "&Type\tCtrl-t" "Get the Type of the Current Expression" False+ menuAppend mnuHask wxID_HASK_KIND "&Kind\tCtrl-k" "Get the Kind of the Current Expression" False mnuHelp <- menuHelp [] menuAbout mnuHelp [on command := infoDialog win "About hPage" "Author: Fernando Brujo Benavides"] set win [menuBar := [mnuPage, mnuEdit, mnuHask, mnuHelp]]- + evtHandlerOnMenuCommand win wxID_NEW $ onCmd "runHP' addPage" $ runHP' HP.addPage+ evtHandlerOnMenuCommand win wxID_CLOSE $ onCmd "runHP' closePage" $ runHP' HP.closePage+ evtHandlerOnMenuCommand win wxID_CLOSE_ALL $ onCmd "runHP' closeAllPages" $ runHP' HP.closeAllPages+ evtHandlerOnMenuCommand win wxID_OPEN $ onCmd "openPage" openPage+ evtHandlerOnMenuCommand win wxID_SAVE $ onCmd "savePage" savePage+ evtHandlerOnMenuCommand win wxID_SAVEAS $ onCmd "savePageAs" savePageAs+ evtHandlerOnMenuCommand win wxID_UNDO $ onCmd "runHP' undo" $ runHP' HP.undo+ evtHandlerOnMenuCommand win wxID_REDO $ onCmd "runHP' redo" $ runHP' HP.redo+ evtHandlerOnMenuCommand win wxID_CUT $ onCmd "cut" cut+ evtHandlerOnMenuCommand win wxID_COPY $ onCmd "copy" copy+ evtHandlerOnMenuCommand win wxID_PASTE $ onCmd "paste" paste+ evtHandlerOnMenuCommand win wxID_FIND $ onCmd "justFind" justFind+ evtHandlerOnMenuCommand win wxID_FORWARD $ onCmd "findNext" justFindNext+ 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_LOADNAME $ onCmd "loadModulesByName" loadModulesByName+ evtHandlerOnMenuCommand win wxID_HASK_RELOAD $ onCmd "reloadModules" reloadModules+ evtHandlerOnMenuCommand win wxID_HASK_EXTENSIONS $ onCmd "extensions" configureExtensions+ evtHandlerOnMenuCommand win wxID_HASK_VALUE $ onCmd "getValue" getValue+ evtHandlerOnMenuCommand win wxID_HASK_TYPE $ onCmd "getType" getType+ evtHandlerOnMenuCommand win wxID_HASK_KIND $ onCmd "getKind" getKind+ -- Tool bar... tbMain <- toolBarEx win True True []+ mitNew <- menuFindItem mnuPage wxID_NEW+ mitOpen <- menuFindItem mnuPage wxID_OPEN+ mitSave <- menuFindItem mnuPage wxID_SAVE+ mitCut <- menuFindItem mnuEdit wxID_CUT+ mitCopy <- menuFindItem mnuEdit wxID_COPY+ mitPaste <- menuFindItem mnuEdit wxID_PASTE+ mitReload <- menuFindItem mnuHask wxID_HASK_RELOAD newPath <- imageFile "new.png" openPath <- imageFile "open.png" savePath <- imageFile "save.png"@@ -161,11 +193,14 @@ toolMenu tbMain mitNew "New" newPath [tooltip := "New"] toolMenu tbMain mitOpen "Open" openPath [tooltip := "Open"] toolMenu tbMain mitSave "Save" savePath [tooltip := "Save"]+ toolBarAddSeparator tbMain toolMenu tbMain mitCut "Cut" cutPath [tooltip := "Cut"] toolMenu tbMain mitCopy "Copy" copyPath [tooltip := "Copy"] toolMenu tbMain mitPaste "Paste" pastePath [tooltip := "Paste"]+ toolBarAddSeparator tbMain toolMenu tbMain mitReload "Reload" reloadPath [tooltip := "Reload Modules"]- + toolBarSetToolBitmapSize tbMain $ sz 32 32+ -- Layout settings let txtCodeL = fill $ widget txtCode lstPagesL = fill $ boxed "Pages" $ fill $ widget lstPages@@ -189,7 +224,8 @@ justFind, justFindNext, justFindPrev, findReplace, restartTimer, killTimer, getValue, getType, getKind,- loadModules, loadModulesByName, reloadModules :: HPS.ServerHandle -> GUIContext -> IO ()+ loadModules, loadModulesByName, reloadModules,+ configureExtensions :: HPS.ServerHandle -> GUIContext -> IO () getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} = runTxtHP HP.valueOf' model guiCtx grrValue@@ -290,6 +326,23 @@ do set status [text := "loading..."] runHP (HP.loadModules $ words mns) model guiCtx++configureExtensions model guiCtx@GUICtx{guiWin = win, guiStatus = status} =+ do+ hpsRes <- tryIn model HP.getLanguageExtensions+ case hpsRes of+ Left err ->+ warningDialog win "Error" err+ Right exs ->+ do+ res <- multiOptionsDialog win "Choose the language extensions to activate" "Extensions" (sort HP.availableExtensions) exs+ case res of+ Nothing ->+ return ()+ Just newexs ->+ do+ set status [text := "setting..."]+ runHP (HP.setLanguageExtensions newexs) model guiCtx refreshPage model guiCtx@GUICtx{guiWin = win, guiPages = lstPages,
src/HPage/Test/Server.hs view
@@ -13,6 +13,7 @@ import Control.Monad.Loops import qualified Data.ByteString.Char8 as Str import Utils.Log+-- import Data.Set (fromList) instance Arbitrary Char where arbitrary = elements (['A'..'Z'] ++ ['a' .. 'z'])@@ -34,9 +35,31 @@ deriving (Eq, Show) instance Arbitrary ClassName where- arbitrary = elements $ map CN [ "HPage", "IO", "IO a", "Int", "String"]+ 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] "HPage/Test/Extensions/TypeSynonymInstances.hs"++wexOverlappingInstances :: WorkingExtension+wexOverlappingInstances = WEX [HP.TypeSynonymInstances,+ HP.OverlappingInstances] "HPage/Test/Extensions/OverlappingInstances.hs"++wexFlexibleInstances :: WorkingExtension+wexFlexibleInstances = WEX [HP.FlexibleInstances] "HPage/Test/Extensions/FlexibleInstances.hs"+ shouldFail :: (MonadError e m) => m a -> m Bool shouldFail a = (a >> return False) `catchError` (\_ -> return True) @@ -100,7 +123,7 @@ , run $ prop_let_valueOf hps hs , run $ prop_let_typeOf hps hs ]- runTests "vs. Hint Server" options+ runTests "Expressions vs. Hint Server" options [ run $ prop_fail hps hs , run $ prop_valueOf hps hs , run $ prop_typeOf hps hs@@ -113,6 +136,12 @@ [ 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_set_set_extension_fail hps+ ] removeDirectoryRecursive testDir instance Eq (Hint.InterpreterError) where@@ -150,31 +179,32 @@ Left hsr <- HS.runIn hs $ Hint.eval expr return $ hsr == hpsr -prop_load_module :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Bool+prop_load_module :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Property prop_load_module hps hs mn =- 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- -- Load TestFiles/Test...hs by name- HP.loadModules [mname]- HP.setPageText "v" 0- sv <- HP.valueOf- sm <- HP.getLoadedModules- return (fv, sv, fm, sm)- Right hsr <- HS.runIn hs $ do+ (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+ -- Load TestFiles/Test...hs by name+ HP.loadModules [mname]+ HP.setPageText "v" 0+ sv <- HP.valueOf+ sm <- HP.getLoadedModules+ return (fv, sv, fm, sm)+ hsr <- HS.runIn hs $ do Hint.loadModules [testDir ++ "/test.hs"] Hint.getLoadedModules >>= Hint.setTopLevelModules fv <- Hint.eval "v"@@ -184,8 +214,8 @@ sv <- Hint.eval "v" sm <- Hint.getLoadedModules return (Right fv, Right sv, Right fm, Right sm)- -- liftDebugIO (hpsr, hsr)- return $ hpsr == hsr+ -- liftDebugIO (hpsr, hsr)+ return $ Right hpsr == hsr prop_reload_modules :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool prop_reload_modules hps hs txt =@@ -898,3 +928,38 @@ 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+ HP.setLanguageExtensions []+ before <- HP.loadModules [m]+ HP.setLanguageExtensions es+ after <- HP.loadModules [m]+ let failed = case before of+ Left _ -> True+ _ -> False+ -- liftDebugIO (before, after, failed)+ return $ failed && (after == Right ())++prop_set_set_extension_fail :: HPS.ServerHandle -> String -> Bool+prop_set_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
src/Utils/Log.hs view
@@ -33,5 +33,6 @@ liftDebugIO = liftLogIO Debug liftInfoIO = liftLogIO Info liftWarnIO = liftLogIO Warning-liftErrorIO = liftLogIO Error+-- liftErrorIO = liftLogIO Error+liftErrorIO _ = return () liftFatalIO = liftLogIO Fatal