hpage 0.1.5 → 0.1.6
raw patch · 8 files changed
+276/−12 lines, 8 files
Files
- hpage.cabal +7/−2
- src/Graphics/UI/WX/Dialogs/Extra.hs +60/−0
- src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs +20/−0
- src/HPage/Control.hs +90/−5
- src/HPage/Test/Extensions/FlexibleInstances.hs +4/−0
- src/HPage/Test/Extensions/OverlappingInstances.hs +13/−0
- src/HPage/Test/Extensions/TypeSynonymInstances.hs +5/−0
- src/HPage/Test/Server.hs +77/−5
hpage.cabal view
@@ -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
+ src/Graphics/UI/WX/Dialogs/Extra.hs view
@@ -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]
+ src/Graphics/UI/WXCore/WxcDefs/ExtraIdentities.hs view
@@ -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
src/HPage/Control.hs view
@@ -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
+ src/HPage/Test/Extensions/FlexibleInstances.hs view
@@ -0,0 +1,4 @@++instance Functor (Either Int) where + fmap _ (Left n) = Left n + fmap f (Right r) = Right (f r)
+ src/HPage/Test/Extensions/OverlappingInstances.hs view
@@ -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
+ src/HPage/Test/Extensions/TypeSynonymInstances.hs view
@@ -0,0 +1,5 @@+class ExtTest a where+ extes :: a -> String+ +instance ExtTest String where+ extes = show . map show
src/HPage/Test/Server.hs view
@@ -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 ())