diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -20,7 +20,7 @@ main :: IO () main = do - putStrLn $ "processing for " ++ os + putStrLn $ "Setting up hpage for " ++ os defaultMainWithHooks $ addMacHook simpleUserHooks where addMacHook h = diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -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: diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -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 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 @@ -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, diff --git a/src/HPage/Test/Server.hs b/src/HPage/Test/Server.hs --- a/src/HPage/Test/Server.hs +++ b/src/HPage/Test/Server.hs @@ -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 diff --git a/src/Utils/Log.hs b/src/Utils/Log.hs --- a/src/Utils/Log.hs +++ b/src/Utils/Log.hs @@ -33,5 +33,6 @@ liftDebugIO = liftLogIO Debug liftInfoIO = liftLogIO Info liftWarnIO = liftLogIO Warning -liftErrorIO = liftLogIO Error +-- liftErrorIO = liftLogIO Error +liftErrorIO _ = return () liftFatalIO = liftLogIO Fatal