diff --git a/Manatee/Core/Config.hs b/Manatee/Core/Config.hs --- a/Manatee/Core/Config.hs +++ b/Manatee/Core/Config.hs @@ -58,6 +58,10 @@ extensionGlobalKeymapPath :: FilePath extensionGlobalKeymapPath = "core/extensionGlobalKeymap" +-- | Customize path. +configPath :: FilePath +configPath = "config" + -- | Write config file. writeConfig :: Binary a => FilePath -> a -> IO () writeConfig path config = do diff --git a/Manatee/Core/Dynload.hs b/Manatee/Core/Dynload.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Dynload.hs @@ -0,0 +1,229 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{-#Language ScopedTypeVariables#-} +{-# LANGUAGE DeriveDataTypeable #-} +module Manatee.Core.Dynload where + +import Control.Concurrent +import Control.Monad +import Data.Maybe (fromMaybe) +import Data.Typeable +import DynFlags +import Exception +import GHC +import GHC.Paths (libdir) +import Manatee.Core.Config +import Manatee.Core.Types +import System.Directory +import System.FilePath + +import Data.List +import System.Exit +import System.Process +import HscTypes +import OccName +import Module +import BinIface +import HscMain hiding (compileExpr) +import TcRnMonad + +data EmptyCustomize = + EmptyCustomize + deriving Typeable + +instance Customize EmptyCustomize where + customizeConfigFile _ = "" + customizeLoad _ = [] + +-- | Empty customize new. +emptyCustomizeNew :: IO CustomizeWrap +emptyCustomizeNew = + return (CustomizeWrap EmptyCustomize) + +-- | Cast customize. +castCustomize :: Typeable b => CustomizeWrap -> b +castCustomize (CustomizeWrap c) = + fromMaybe (error "castCustomize : impossible failed.") (cast c) + +-- | Dynamic loading module in running program. +dynload :: (String, String, [(String, HValue -> IO ())]) -> IO () +dynload (filepath, moduleName, loadList) = + defaultErrorHandler defaultDynFlags $ + runGhc (Just libdir) $ + ghandle + -- Avoid exception when dynamic loading. + (\ (e :: SomeException) -> liftIO $ putStrLn $ "# " ++ show e) + (do + -- Set DynFlags. + dFlags <- getSessionDynFlags + setSessionDynFlags dFlags {ghcLink = LinkInMemory} -- this step is necessary + -- Load module. + target <- guessTarget filepath Nothing + setTargets [target] + r <- load (LoadUpTo (mkModuleName moduleName)) + -- Check. + case r of + Failed -> + liftIO $ putStrLn $ "* Load module " ++ moduleName ++ " failed." + Succeeded -> do + liftIO $ putStrLn $ "* Load module " ++ moduleName ++ " success." + -- Find module. + m <- findModule (mkModuleName moduleName) Nothing + -- Set context. + setContext [] [m] + -- Load value. + forM_ loadList $ \ (symbolName, loadFun) -> + ghandle + -- Skip current symbol if get error when compileExpr. + (\ (e :: SomeException) -> + liftIO $ putStrLn $ "# Get error and skip symbol `" ++ symbolName ++ "`\n " ++ show e) + (do + hValue <- compileExpr (moduleName ++ "." ++ symbolName) + liftIO $ loadFun hValue)) + +-- | Load user config. +loadConfig :: CustomizeWrap -> Bool -> IO () +loadConfig (CustomizeWrap customize) isAsync = do + -- Get configure directory. + configDir <- getConfigDirectory + -- Init. + let configFile = customizeConfigFile customize + filepath = configDir configPath configFile + configLoad = customizeLoad customize + load = do + putStrLn $ "* Loading configure file : " ++ filepath + dynload (filepath, "Config.User", configLoad) + isExist <- doesFileExist filepath + + -- Try load user's configure file. + if null configLoad + -- Skip load if no customize option. + then putStrLn "No customize option, skip load configure file." + else if isExist + -- Load config file. + then if isAsync then forkIO load >> return () else load + -- Skip load if no configure file exist. + else putStrLn $ "Config file `" ++ filepath ++ "` no exist, use default customize option." + +-- | Generate config file. +generateConfig :: String -> [String] -> IO () +generateConfig configFile scanList = do + -- Get directory. + configDir <- getConfigDirectory + let configHsFile = configDir configPath configFile + configHiFile = replaceExtension configHsFile ".hi" + isHsFileExist <- doesFileExist configHsFile + isHiFileExist <- doesFileExist configHiFile + -- Detect user configure file. + scanUser <- + if isHsFileExist + then do + processHandle <- runCommand ("ghc --make " ++ configHsFile) + exitCode <- waitForProcess processHandle + case exitCode of + ExitSuccess -> return True + ExitFailure _ -> do + putStrLn $ configHsFile ++ " compile failed, skip user's configure file." + return False + else do + putStrLn $ configHsFile ++ " no exist, skip scan user's configure file." + return False + -- Generate User.hs and Import.hs. + if scanUser && isHiFileExist + then do + -- Copy user's configure file. + readFile configHsFile >>= writeFile "./Config/User.hs" + -- Get export list. + moduleInterface <- readBinIface' configHiFile + let ifaceExport = mi_exports moduleInterface + exports = map (\ (mod, items) -> + (Module.moduleNameString $ Module.moduleName mod + ,concatMap (\item -> + case item of + Avail name -> [occNameString name] + AvailTC _ list -> + map occNameString list + ) items) + ) ifaceExport + (((_, exportList):_), _) = partition (\ (mName, _) -> mName == "Config.User") exports + -- Generate Import.hs + writeFile "./Config/Import.hs" $ generateImportString (filter (\x -> x `elem` scanList) exportList) scanList + else do + -- Generate User.hs and Import.hs + writeFile "./Config/User.hs" emptyUserString + writeFile "./Config/Import.hs" $ emptyImportString scanList + +-- | Read binary interface file to get module information. +readBinIface' :: FilePath -> IO ModIface +readBinIface' hi_path = do + e <- newHscEnv defaultCallbacks undefined + initTcRnIf 'r' e undefined undefined (readBinIface IgnoreHiWay QuietBinIFaceReading hi_path) + +-- | Concat improt, convert ["a","b","c"] to (a, b, c) +concatImport :: [String] -> String +concatImport [] = "" +concatImport [x] = x +concatImport (x:xs) = + (x ++ ", ") ++ concatImport xs + +-- | Emtpy user string. +emptyUserString :: String +emptyUserString = + copyrightString + ++ "module Config.User where" + +-- | Emtpy import string. +emptyImportString :: [String] -> String +emptyImportString scanList = + copyrightString + ++ "module Config.Import " + ++ "(" ++ concatImport scanList ++ ") where \n\n" + ++ "import Config.Default" + +-- | Generate import string. +generateImportString :: [String] -> [String] -> String +generateImportString [] scanList = + emptyImportString scanList +generateImportString exportList scanList = + copyrightString + ++ "module Config.Import " + ++ "(" ++ concatImport scanList ++ ") where \n\n" + ++ "import Config.User (" ++ concatImport exportList ++ ")\n" + ++ "import Config.Default hiding (" ++ concatImport exportList ++ ")\n" + +-- | Copyright string. +copyrightString :: String +copyrightString = + "-- Author: Andy Stewart " + ++ "\n-- Maintainer: Andy Stewart " + ++ "\n-- " + ++ "\n-- Copyright (C) 2010 Andy Stewart, all rights reserved." + ++ "\n-- " + ++ "\n-- This program is free software: you can redistribute it and/or modify" + ++ "\n-- it under the terms of the GNU General Public License as published by" + ++ "\n-- the Free Software Foundation, either version 3 of the License, or" + ++ "\n-- any later version." + ++ "\n-- " + ++ "\n-- This program is distributed in the hope that it will be useful," + ++ "\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of" + ++ "\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + ++ "\n-- GNU General Public License for more details." + ++ "\n-- " + ++ "\n-- You should have received a copy of the GNU General Public License" + ++ "\n-- along with this program. If not, see .\n\n" diff --git a/Manatee/Core/Render.hs b/Manatee/Core/Render.hs --- a/Manatee/Core/Render.hs +++ b/Manatee/Core/Render.hs @@ -24,11 +24,13 @@ import Graphics.UI.Gtk hiding (Window, windowNew, Frame, frameNew, Signal, Frame, Variant, Action, plugNew, plugGetId, get) import Manatee.Core.DBus import Manatee.Core.Debug +import Manatee.Core.Dynload import Manatee.Core.Page import Manatee.Core.PageView import Manatee.Core.Types import Manatee.Toolkit.General.DBus import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.General.Process import Manatee.Toolkit.General.STM import Manatee.Toolkit.General.Set hiding (mapM) import Manatee.Toolkit.General.State @@ -41,21 +43,21 @@ import qualified Data.Set as Set -- | Irc client render process. -startupRender :: PageBufferNewFun -> IO () -startupRender bufferNewFun = do +startupRender :: PageBufferNewFun -> CustomizeNewFun -> IO () +startupRender bufferNewFun customizeNewFun = do -- Get program arguments. args <- getArgs case args of [x] -> case (read x :: SpawnProcessArgs) of - arg@(SpawnRenderProcessArgs {}) -> renderMain arg bufferNewFun + arg@(SpawnRenderProcessArgs {}) -> renderMain arg bufferNewFun customizeNewFun _ -> return () _ -> return () -- | Render process main entry. -renderMain :: SpawnProcessArgs -> PageBufferNewFun -> IO () -renderMain (SpawnRenderProcessArgs pageId pType sId pagePath options) bufferNewFun = do +renderMain :: SpawnProcessArgs -> PageBufferNewFun -> CustomizeNewFun -> IO () +renderMain (SpawnRenderProcessArgs pageId pType sId pagePath options) bufferNewFun customizeNewFun = do -- Init. unsafeInitGUIForThreadedRTS @@ -65,17 +67,18 @@ -- Get render process id. processId <- getProcessID - -- Make client name. - let clientName = mkRenderClientName processId - -- Create client. + let clientName = mkRenderClientName processId client <- mkSessionClientWithName clientName + -- Load user's configure file. + customizeWrap <- customizeNewFun + -- Create page buffer. - bufferWrap <- bufferNewFun pagePath options client pageId + bufferWrap <- bufferNewFun pagePath options client pageId customizeWrap -- Build render client for listen dbus signal. - mkRenderClient client bufferWrap processId pageList pType + mkRenderClient client bufferWrap customizeWrap processId pageList pType -- Create first page. renderPageNew client bufferWrap pageList processId (pageId, pType, sId) True @@ -84,8 +87,8 @@ mainGUI -- | Build render client for listen dbus signal. -mkRenderClient :: Client -> PageBufferWrap -> ProcessID -> TVar PageList -> PageType -> IO () -mkRenderClient client bufferWrap processId pageList pType = +mkRenderClient :: Client -> PageBufferWrap -> CustomizeWrap -> ProcessID -> TVar PageList -> PageType -> IO () +mkRenderClient client bufferWrap customizeWrap processId pageList pType = -- Build match rule. mkRenderMatchRules client [(CloneRenderPage, renderHandleClonePage client bufferWrap pageList processId pType) @@ -93,7 +96,10 @@ ,(FocusRenderPage, renderHandleFocusPage pageList) ,(PageViewKeyPress, renderHandleKeyPress pageList) ,(DestroyRenderPage, renderHandleDestroyPage pageList) - ,(ExitRenderProcess, renderHandleExitProcess client processId)] + ,(ExitRenderProcess, renderHandleExitProcess client processId) + ,(UpdateConfig, renderHandleUpdateConfig customizeWrap) + ,(InstallConfig, renderHandleInstallConfig bufferWrap) + ] -- | Handle clone render page signal. renderHandleClonePage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> PageType -> RenderSignalArgs -> IO () @@ -208,3 +214,15 @@ -- Quit process. mainQuit + +-- | Handle update config signal. +renderHandleUpdateConfig :: CustomizeWrap -> RenderSignalArgs -> IO () +renderHandleUpdateConfig customizeWrap _ = + loadConfig customizeWrap True + +-- | Handle install config signal. +renderHandleInstallConfig :: PageBufferWrap -> RenderSignalArgs -> IO () +renderHandleInstallConfig (PageBufferWrap buffer) _ = do + packageName <- pageBufferPackageName buffer + runCommand_ ("cabal install " ++ packageName ++ " --reinstall") + diff --git a/Manatee/Core/Types.hs b/Manatee/Core/Types.hs --- a/Manatee/Core/Types.hs +++ b/Manatee/Core/Types.hs @@ -34,6 +34,7 @@ import Data.Set import Data.Text.Lazy (Text) import Data.Typeable +import GHC (HValue) import Graphics.UI.Gtk hiding (on, get, Action, Statusbar, statusbarNew, Window, Frame, frameNew, Plug) import Graphics.UI.Gtk.Gdk.SerializedEvent import Language.Haskell.TH @@ -146,11 +147,12 @@ pageBufferClient :: a -> Client pageBufferCreateView :: a -> PagePlugId -> IO PageViewWrap pageBufferMode :: a -> PageMode + pageBufferPackageName :: a -> IO String data PageBufferWrap = forall a . PageBuffer a => PageBufferWrap a -- | Page buffer new function. -type PageBufferNewFun = FilePath -> [String] -> Client -> PageId -> IO PageBufferWrap +type PageBufferNewFun = FilePath -> [String] -> Client -> PageId -> CustomizeWrap -> IO PageBufferWrap -- | PageView class. class Typeable a => PageView a where @@ -194,6 +196,14 @@ type PageViewKeymap = forall a . PageView a => Map Text (a -> IO ()) +class Typeable a => Customize a where + customizeConfigFile :: a -> FilePath + customizeLoad :: a -> [(String, HValue -> IO ())] + +data CustomizeWrap = forall a . Customize a => CustomizeWrap a + +type CustomizeNewFun = IO CustomizeWrap + data AnythingInteractiveType = GlobalSearch | GlobalInteractive | LocalInteractive @@ -273,6 +283,8 @@ | AnythingViewKeyPress | AnythingViewChangeCandidate | AnythingViewChangeInteractiveType + | UpdateConfig + | InstallConfig deriving (Show, Eq, Ord) data RenderSignalArgs = CloneRenderPageArgs PageId SignalBoxId @@ -284,6 +296,8 @@ | AnythingViewKeyPressArgs Text String String AnythingKeyPressId Bool | AnythingViewChangeCandidateArgs [String] | AnythingViewChangeInteractiveTypeArgs AnythingInteractiveType + | UpdateConfigArgs + | InstallConfigArgs deriving (Show, Eq, Ord) data DaemonBroadcastMember = ExitDaemonProcess diff --git a/Manatee/Toolkit/General/Time.hs b/Manatee/Toolkit/General/Time.hs --- a/Manatee/Toolkit/General/Time.hs +++ b/Manatee/Toolkit/General/Time.hs @@ -76,9 +76,9 @@ -- | Convert seconds to (day/hour/min/second) time. secondToDaytime :: Int -> String secondToDaytime seconds = - showTime day "d" - ++ showTime hour "h" - ++ showTime min "m" + showTime day "d " + ++ showTime hour "h " + ++ showTime min "m " ++ showTime sec "s" where sec = seconds `mod` 60 min = seconds `mod` 3600 `div` 60 diff --git a/Manatee/Toolkit/Gtk/Multiline.hs b/Manatee/Toolkit/Gtk/Multiline.hs --- a/Manatee/Toolkit/Gtk/Multiline.hs +++ b/Manatee/Toolkit/Gtk/Multiline.hs @@ -821,7 +821,9 @@ textBufferPlaceCursor tb nti -- | Toggle selection. -textViewToggleSelectionMark :: TextViewClass self => self -> IO () +-- Return True if selection active. +-- Otherwise, return False. +textViewToggleSelectionMark :: TextViewClass self => self -> IO Bool textViewToggleSelectionMark tv = do -- Get text buffer. tb <- textViewGetBuffer tv @@ -831,8 +833,12 @@ -- Toggle selection iter. if selectionActive - then textViewCancelSelectionMark tv - else textViewSetSelectionMark tv + then do + textViewCancelSelectionMark tv + return False + else do + textViewSetSelectionMark tv + return True -- | Exchange selection mark. textViewExchangeSelectionMark :: TextViewClass self => self -> IO () diff --git a/manatee-core.cabal b/manatee-core.cabal --- a/manatee-core.cabal +++ b/manatee-core.cabal @@ -1,5 +1,5 @@ name: manatee-core -version: 0.0.6 +version: 0.0.7 Cabal-Version: >= 1.6 license: GPL-3 license-file: LICENSE @@ -7,10 +7,10 @@ synopsis: The core of Manatee. description: manatee-core is core package of Manatee (Haskell/Gtk+ Integrated Live Environment) . - Video at (Select 720p HD) at : - . To provide basic communication protocol and toolkit. . + Video at (Select 720p HD) at : + . Screenshots at : . Manual at : @@ -39,10 +39,11 @@ filepath >= 1.1.0.3, unix >= 2.4.0.0, process >= 1.0.1.2, array >= 0.3.0.0, old-time >= 1.0.0.3, glib >= 0.12.0, time >= 1.1.4, gtksourceview2 >= 0.12.0, Cabal >= 1.8.0.2, old-locale >= 1.0.0.2, datetime >= 0.2, bytestring, split, dataenc, - derive, gconf >= 0.12.0, binary, directory, haskell-src-exts + derive, gconf >= 0.12.0, binary, directory, haskell-src-exts, ghc, ghc-paths exposed-modules: Manatee.Core.DBus Manatee.Core.Debug + Manatee.Core.Dynload Manatee.Core.Interactive Manatee.Core.FileOpenRule Manatee.Core.Page