diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.1.5 +version: 0.1.6 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -56,10 +56,15 @@ install-includes: hs-source-dirs: src other-modules: Control.Concurrent.Process, - HPage.Control, + Graphics.UI.WX.Dialogs.Extra + Graphics.UI.WXCore.WxcDefs.ExtraIdentities HPage.GUI.FreeTextWindow, + HPage.Control, HPage.Server, HPage.Test.Server, + HPage.Test.Extensions.FlexibleInstances, + HPage.Test.Extensions.OverlappingInstances, + HPage.Test.Extensions.TypeSynonymInstances, Language.Haskell.Interpreter.Server, Language.Haskell.Interpreter.Utils, Utils.Log diff --git a/src/Graphics/UI/WX/Dialogs/Extra.hs b/src/Graphics/UI/WX/Dialogs/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Dialogs/Extra.hs @@ -0,0 +1,60 @@ + +module Graphics.UI.WX.Dialogs.Extra (optionDialog, multiOptionsDialog) where + +import Data.List +import Graphics.UI.WX +import Graphics.UI.WX.Dialogs +import Graphics.UI.WXCore +import Graphics.UI.WXCore.WxcClasses + +-- | Retrieve an option from a list. Returns 'Nothing' on cancel. Usage: +-- +-- > optionsDialog window message caption options selectedOption +-- +optionDialog :: (Eq t, Show t) => Window a -> String -> String -> [t] -> Maybe t -> IO (Maybe t) +optionDialog win message caption options selectedOption = + do + dlg <- dialog win [text := caption] + btnok <- button dlg [text := "Ok", identity := wxID_OK] + btnnok <- button dlg [text := "Cancel", identity := wxID_CANCEL] + cboOpts <- comboBoxEx dlg wxCB_READONLY [items := map show options] + case selectedOption of + Nothing -> + set cboOpts [selection := -1] + Just option -> + case elemIndex option options of + Nothing -> + set cboOpts [selection := -1] + Just ind -> + set cboOpts [selection := ind] + let cboL = fill $ column 5 [margin 5 $ label message, fill $ widget cboOpts] + btnsL = margin 5 $ floatRight $ row 5 [widget btnnok, widget btnok] + set dlg [layout := fill $ column 5 [cboL, btnsL]] + showModal dlg $ \stopFun -> do + focusOn cboOpts + set btnok [on command := get cboOpts selection >>= stopFun . Just . (options !!)] + set btnnok [on command := stopFun Nothing] + +-- | Retrieve a list of options from a list of possible ones. Returns 'Nothing' on cancel. Usage: +-- +-- > multiOptionsDialog window message caption options selectedOptions +-- +multiOptionsDialog :: (Eq t, Show t) => Window a -> String -> String -> [t] -> [t] -> IO (Maybe [t]) +multiOptionsDialog win message caption options selectedOptions = + do + dlg <- dialog win [text := caption] + btnok <- button dlg [text := "Ok", identity := wxID_OK] + btnnok <- button dlg [text := "Cancel", identity := wxID_CANCEL] + lstOpts <- multiListBox dlg [items := map show options] + let selIndexes = foldr (\option acc -> + case elemIndex option options of + Nothing -> acc + Just ind -> ind : acc) [] selectedOptions + set lstOpts [selections := selIndexes] + let cboL = fill $ column 5 [margin 5 $ label message, fill $ widget lstOpts] + btnsL = margin 5 $ floatRight $ row 5 [widget btnnok, widget btnok] + set dlg [layout := fill $ column 5 [cboL, btnsL]] + showModal dlg $ \stopFun -> do + focusOn lstOpts + set btnok [on command := get lstOpts selections >>= stopFun . Just . map (options !!)] + set btnnok [on command := stopFun Nothing] diff --git a/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs b/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs @@ -0,0 +1,20 @@ + +module Graphics.UI.WXCore.WxcDefs.ExtraIdentities where + +wxID_REPLACE, wxID_REPLACE_ALL :: Int +wxID_REPLACE = 5038 +wxID_REPLACE_ALL = 5039 + +wxID_CLOSE_ALL :: Int +wxID_CLOSE_ALL = 5201 + +wxID_HASK_LOAD, wxID_HASK_LOADNAME, wxID_HASK_RELOAD, + wxID_HASK_EXTENSIONS, + wxID_HASK_VALUE, wxID_HASK_TYPE, wxID_HASK_KIND :: Int +wxID_HASK_LOAD = 5300 +wxID_HASK_LOADNAME = 5301 +wxID_HASK_RELOAD = 5302 +wxID_HASK_EXTENSIONS= 5303 +wxID_HASK_VALUE = 5304 +wxID_HASK_TYPE = 5305 +wxID_HASK_KIND = 5306 diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -33,13 +33,17 @@ valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, loadModules, reloadModules, getLoadedModules, getLanguageExtensions, setLanguageExtensions, + getSourceDirs, setSourceDirs, + getGhcOpts, setGhcOpts, valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', loadModules', reloadModules', getLoadedModules', getLanguageExtensions', setLanguageExtensions', + getSourceDirs', setSourceDirs', + getGhcOpts', setGhcOpts', reset, reset', cancel, Hint.InterpreterError, Hint.prettyPrintError, - Hint.availableExtensions, Extension, + Hint.availableExtensions, Hint.Extension(..), -- DEBUG -- ctxString ) where @@ -55,6 +59,7 @@ import Control.Concurrent.MVar import Language.Haskell.Interpreter (OptionVal((:=))) import qualified Language.Haskell.Interpreter as Hint +import qualified Language.Haskell.Interpreter.Unsafe as Hint import qualified Language.Haskell.Interpreter.Utils as Hint import qualified Language.Haskell.Interpreter.Server as HS import Utils.Log @@ -73,7 +78,14 @@ data InFlightData = LoadModules { loadingModules :: Set String, runningAction :: Hint.InterpreterT IO () - } | Reset + } | + SetSourceDirs { settingSrcDirs :: [FilePath], + runningAction :: Hint.InterpreterT IO () + } | + SetGhcOpts { settingGhcOpts :: String, + runningAction :: Hint.InterpreterT IO () + } | + Reset data Page = Page { -- Display -- expressions :: [Expression], @@ -95,6 +107,8 @@ currentPage :: Int, -- Hint -- loadedModules :: Set String, + extraSrcDirs :: [FilePath], + ghcOptions :: String, server :: HS.ServerHandle, running :: Maybe InFlightData, recoveryLog :: Hint.InterpreterT IO () -- To allow cancelation of actions @@ -128,7 +142,7 @@ evalHPage hpt = do hs <- liftIO $ HS.start let nop = return () - let emptyContext = Context [emptyPage] 0 empty hs Nothing nop + let emptyContext = Context [emptyPage] 0 empty [] "" hs Nothing nop (state hpt) `evalStateT` emptyContext @@ -397,6 +411,42 @@ setLanguageExtensions :: [Hint.Extension] -> HPage (Either Hint.InterpreterError ()) setLanguageExtensions exs = confirmRunning >> syncRun (Hint.set [Hint.languageExtensions := exs]) +getSourceDirs :: HPage [FilePath] +getSourceDirs = confirmRunning >> get >>= return . extraSrcDirs + +setSourceDirs :: [FilePath] -> HPage (Either Hint.InterpreterError ()) +setSourceDirs ds = do + let action = do + liftTraceIO $ "setting src dirs: " ++ show ds + Hint.unsafeSetGhcOption "-i" + Hint.unsafeSetGhcOption "-i." + forM_ ds $ Hint.unsafeSetGhcOption . ("-i" ++) + res <- syncRun action + case res of + Right _ -> + modify (\ctx -> ctx{extraSrcDirs = ds, + recoveryLog = recoveryLog ctx >> action >> return ()}) + Left e -> + liftErrorIO $ ("Error setting source dirs", ds, e) + return res + +getGhcOpts :: HPage String +getGhcOpts = confirmRunning >> get >>= return . ghcOptions + +setGhcOpts :: String -> HPage (Either Hint.InterpreterError ()) +setGhcOpts opts = do + let action = do + liftTraceIO $ "setting ghc opts: " ++ opts + Hint.unsafeSetGhcOption opts + res <- syncRun action + case res of + Right _ -> + modify (\ctx -> ctx{ghcOptions = (ghcOptions ctx) ++ " " ++ opts, + recoveryLog = recoveryLog ctx >> action >> return ()}) + Left e -> + liftErrorIO $ ("Error setting ghc opts dirs", opts, e) + return res + reset :: HPage (Either Hint.InterpreterError ()) reset = do res <- syncRun $ do @@ -408,6 +458,8 @@ case res of Right _ -> modify (\ctx -> ctx{loadedModules = empty, + extraSrcDirs = [], + ghcOptions = "", running = Nothing, recoveryLog = return ()}) Left e -> @@ -453,6 +505,32 @@ setLanguageExtensions' :: [Hint.Extension] -> HPage (MVar (Either Hint.InterpreterError ())) setLanguageExtensions' exs = confirmRunning >> asyncRun (Hint.set [Hint.languageExtensions := exs]) +getSourceDirs' :: HPage (MVar [FilePath]) +getSourceDirs' = confirmRunning >> get >>= liftIO . newMVar . extraSrcDirs + +setSourceDirs' :: [FilePath] -> HPage (MVar (Either Hint.InterpreterError ())) +setSourceDirs' ds = do + let action = do + liftTraceIO $ "setting src dirs: " ++ show ds + Hint.unsafeSetGhcOption "-i" + Hint.unsafeSetGhcOption "-i." + forM_ ds $ Hint.unsafeSetGhcOption . ("-i" ++) + res <- asyncRun action + modify $ \ctx -> ctx{running = Just $ SetSourceDirs ds action} + return res + +getGhcOpts' :: HPage (MVar String) +getGhcOpts' = confirmRunning >> get >>= liftIO . newMVar . ghcOptions + +setGhcOpts' :: String -> HPage (MVar (Either Hint.InterpreterError ())) +setGhcOpts' opts = do + let action = do + liftTraceIO $ "setting ghc opts: " ++ opts + Hint.unsafeSetGhcOption opts + res <- asyncRun action + modify $ \ctx -> ctx{running = Just $ SetGhcOpts opts action} + return res + reset' :: HPage (MVar (Either Hint.InterpreterError ())) reset' = do res <- asyncRun $ do @@ -564,10 +642,17 @@ apply :: Maybe InFlightData -> Context -> Context apply Nothing c = c apply (Just Reset) c = c{loadedModules = empty, + extraSrcDirs = [], + ghcOptions = "", recoveryLog = return (), running = Nothing} -apply (Just lm) c = c{loadedModules = union (loadingModules lm) (loadedModules c), - recoveryLog = (recoveryLog c) >> (runningAction lm)} +apply (Just LoadModules{loadingModules = lms, runningAction = ra}) c = + c{loadedModules = union lms (loadedModules c), + recoveryLog = (recoveryLog c) >> ra} +apply (Just SetSourceDirs{settingSrcDirs = ssds, runningAction = ra}) c = + c{extraSrcDirs = ssds, recoveryLog = (recoveryLog c) >> ra} +apply (Just SetGhcOpts{settingGhcOpts = opts, runningAction = ra}) c = + c{ghcOptions = (ghcOptions c) ++ " " ++ opts, recoveryLog = (recoveryLog c) >> ra} fromString :: String -> [Expression] fromString s = map Exp $ splitOn "\n\n" s diff --git a/src/HPage/Test/Extensions/FlexibleInstances.hs b/src/HPage/Test/Extensions/FlexibleInstances.hs new file mode 100644 --- /dev/null +++ b/src/HPage/Test/Extensions/FlexibleInstances.hs @@ -0,0 +1,4 @@ + +instance Functor (Either Int) where + fmap _ (Left n) = Left n + fmap f (Right r) = Right (f r) diff --git a/src/HPage/Test/Extensions/OverlappingInstances.hs b/src/HPage/Test/Extensions/OverlappingInstances.hs new file mode 100644 --- /dev/null +++ b/src/HPage/Test/Extensions/OverlappingInstances.hs @@ -0,0 +1,13 @@ +import Data.List + +class Foo a where + foo :: a -> String + +instance Foo a => Foo [a] where + foo = concat . intersperse ", " . map foo + +instance Foo Char where + foo c = [c] + +instance Foo String where + foo = id diff --git a/src/HPage/Test/Extensions/TypeSynonymInstances.hs b/src/HPage/Test/Extensions/TypeSynonymInstances.hs new file mode 100644 --- /dev/null +++ b/src/HPage/Test/Extensions/TypeSynonymInstances.hs @@ -0,0 +1,5 @@ +class ExtTest a where + extes :: a -> String + +instance ExtTest String where + extes = show . map show 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 @@ -118,12 +118,12 @@ , run $ prop_safe_close_nth_page hps , run $ prop_safe_close_all_pages hps ] - runTests "Named Expressions vs. Hint Server" options + runTests "Named Expressions" options [ run $ prop_let_fail hps hs , run $ prop_let_valueOf hps hs , run $ prop_let_typeOf hps hs ] - runTests "Expressions vs. Hint Server" options + runTests "Expressions" options [ run $ prop_fail hps hs , run $ prop_valueOf hps hs , run $ prop_typeOf hps hs @@ -140,8 +140,17 @@ [ run prop_get_available_extensions , run $ prop_get_set_extensions hps , run $ prop_working_extensions hps - , run $ prop_set_set_extension_fail 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 @@ -956,10 +965,73 @@ -- liftDebugIO (before, after, failed) return $ failed && (after == Right ()) -prop_set_set_extension_fail :: HPS.ServerHandle -> String -> Bool -prop_set_set_extension_fail hps s = +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 ())