diff --git a/Manatee/Core/Config.hs b/Manatee/Core/Config.hs --- a/Manatee/Core/Config.hs +++ b/Manatee/Core/Config.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -58,6 +58,33 @@ extensionGlobalKeymapPath :: FilePath extensionGlobalKeymapPath = "core/extensionGlobalKeymap" +-- | Welcome Application info. +welcomeApplicationPath :: FilePath +welcomeApplicationPath = "core/welcomeApplications" + +-- | State path. +statePath :: FilePath +statePath = "state" + +-- | Layout path. +layoutPath :: FilePath +layoutPath = + statePath "layout" + +-- | Buffer state. +bufferStatePath :: FilePath +bufferStatePath = + "bufferState" + +-- | View state. +viewStatePath :: FilePath +viewStatePath = + "viewState" + +-- | Startup filename. +subprocessStartupPath :: FilePath +subprocessStartupPath = "startup" + -- | Customize path. configPath :: FilePath configPath = "config" @@ -66,7 +93,11 @@ writeConfig :: Binary a => FilePath -> a -> IO () writeConfig path config = do configDir <- getConfigDirectory - let configPath = configDir path + writeConfigPath (configDir path) config + +-- | Write config file. +writeConfigPath :: Binary a => FilePath -> a -> IO () +writeConfigPath configPath config = bracket (openFile configPath WriteMode) hClose (\fileHandle -> L.hPutStr fileHandle (encode config)) @@ -75,7 +106,11 @@ readConfig :: Binary a => FilePath -> a -> IO a readConfig path emptyConfig = do configDir <- getConfigDirectory - let configPath = configDir path + readConfigPath (configDir path) emptyConfig + +-- | Read config file. +readConfigPath :: Binary a => FilePath -> a -> IO a +readConfigPath configPath emptyConfig = do isExist <- doesFileExist configPath if isExist then @@ -104,4 +139,3 @@ -- Return empty config. putStrLn ("Config file " ++ configPath ++ " doesn't exist, create it.") return emptyConfig - diff --git a/Manatee/Core/DBus.hs b/Manatee/Core/DBus.hs --- a/Manatee/Core/DBus.hs +++ b/Manatee/Core/DBus.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Core/Debug.hs b/Manatee/Core/Debug.hs --- a/Manatee/Core/Debug.hs +++ b/Manatee/Core/Debug.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Core/Dynload.hs b/Manatee/Core/Dynload.hs --- a/Manatee/Core/Dynload.hs +++ b/Manatee/Core/Dynload.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -86,7 +86,7 @@ -- Find module. m <- findModule (mkModuleName moduleName) Nothing -- Set context. - setContext [] [m] + setContext [] [(m, Nothing)] -- Load value. forM_ loadList $ \ (symbolName, loadFun) -> ghandle diff --git a/Manatee/Core/FileOpenRule.hs b/Manatee/Core/FileOpenRule.hs --- a/Manatee/Core/FileOpenRule.hs +++ b/Manatee/Core/FileOpenRule.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Core/Interactive.hs b/Manatee/Core/Interactive.hs deleted file mode 100644 --- a/Manatee/Core/Interactive.hs +++ /dev/null @@ -1,48 +0,0 @@ --- 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 ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -module Manatee.Core.Interactive where - -import Data.Text.Lazy (Text) - --- | Parse interactive string. --- Return error reason if parse failed. -parseInteractiveString :: String -> Either Text [(String, String)] -parseInteractiveString interactiveStr - | null prompts - = Left "Empty interactive string." - | any null prompts - = Left "Have null line in interactive string." - | any (`notElem` "cdfsn") types - = Left "Have invalid type character in interactive string." - | otherwise - = Right $ - map (\x -> (interactiveCandidateName (head x), tail x)) prompts - where prompts = lines interactiveStr - types = map head prompts - --- | Get candidate name for type character. -interactiveCandidateName :: Char -> String -interactiveCandidateName 'c' = "InteractiveChar" -interactiveCandidateName 'd' = "InteractiveDirectory" -interactiveCandidateName 'f' = "InteractiveFile" -interactiveCandidateName 'n' = "InteractiveNumber" -interactiveCandidateName 's' = "InteractiveString" - diff --git a/Manatee/Core/Page.hs b/Manatee/Core/Page.hs --- a/Manatee/Core/Page.hs +++ b/Manatee/Core/Page.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -20,14 +20,15 @@ module Manatee.Core.Page where import Graphics.UI.Gtk hiding (Frame, frameNew, Signal, Plug) +import Manatee.Core.PageView import Manatee.Core.Types import Manatee.Toolkit.Gtk.Struct import Manatee.Toolkit.Widget.Plug -- | New page. -pageNew :: PageId -> PageType -> PagePlug -> PageViewWrap -> IO Page -pageNew pId pType plug pvw = - return $ Page pId pType plug pvw +pageNew :: PageId -> SignalBoxId -> PageType -> PagePlug -> PageViewWrap -> IO Page +pageNew pId sId pType plug pvw = + return $ Page pId sId pType plug pvw -- | Page box. pageBox :: Page -> VBox diff --git a/Manatee/Core/PageFrame.hs b/Manatee/Core/PageFrame.hs --- a/Manatee/Core/PageFrame.hs +++ b/Manatee/Core/PageFrame.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -18,27 +18,36 @@ module Manatee.Core.PageFrame where +import Control.Concurrent.STM import Graphics.UI.Gtk hiding (Statusbar, statusbarNew) +import Manatee.Core.Types +import Manatee.Toolkit.General.STM import Manatee.Toolkit.General.String import Manatee.Toolkit.Gtk.Gtk import Manatee.Toolkit.Gtk.ScrolledWindow +import Manatee.Toolkit.Widget.Interactivebar import Manatee.Toolkit.Widget.Outputbar +import Manatee.Toolkit.Widget.CompletionWindow +import Manatee.Toolkit.Widget.KeymapWindow import Manatee.Toolkit.Widget.Statusbar -data PageFrame = - PageFrame {pageFrameBox :: VBox -- box for contain `PageView' - ,pageFrameFrame :: Frame -- frame - ,pageFrameScrolledWindow :: ScrolledWindow -- scrolled window - ,pageFrameOutputbar :: Outputbar -- outputbar for display message - ,pageFrameStatusbar :: Statusbar -- statusbar - } +-- | Auto completion enable color. +autoCompletionEnableColor :: Color +autoCompletionEnableColor = Color 61440 30464 17920 +-- | Auto completion disable color. +autoCompletionDisableColor :: Color +autoCompletionDisableColor = Color 0 0 0 + -- | Create 'PageFrame'. pageFrameNew :: IO PageFrame pageFrameNew = do -- Create box. box <- vBoxNew False 0 + -- Interactivebar + interactivebar <- interactivebarNew + -- Body frame. frame <- frameNewWithShadowType Nothing boxPackStart box frame PackGrow 0 @@ -53,8 +62,33 @@ -- Statusbar. statusbar <- statusbarNew box - return $ PageFrame box frame scrolledWindow outputbar statusbar + -- Completion window. + autoCompletion <- newTVarIO False + completionWindow <- completionWindowNew + -- Interactive args. + args <- newTVarIO [] + typ <- newTVarIO IDefault + result <- newTVarIO [] + func <- newTVarIO (\_ -> return ()) + + -- Keymap window. + keymapWin <- keymapWindowNew + + -- Destory keymap window when page destory. + box `onDestroy` keymapWindowExit keymapWin + + -- Hide keymap window when page frame parent changed. + -- In most case, box's parent will changed when got + -- `ReparentRenderPage` DBus signal, + -- look the source code of `Manatee.Core.Render.renderHandleReparentPage` :) + box `on` parentSet $ \_ -> keymapWindowHide keymapWin + + return $ PageFrame box interactivebar frame + scrolledWindow outputbar statusbar + autoCompletion completionWindow + args typ result func keymapWin + -- | Page frame new with mode name. pageFrameNewWithModeName :: String -> IO PageFrame pageFrameNewWithModeName name = do @@ -62,6 +96,12 @@ pageFrameUpdateStatusbar frame "PageMode" ("Mode (" ++ name ++ ")") return frame +-- | Show interactivebar. +pageFrameShowInteractivebar :: PageFrame -> IO () +pageFrameShowInteractivebar pageFrame = + interactivebarShow (pageFrameBox pageFrame) + (pageFrameInteractivebar pageFrame) + -- | Add child. pageFrameAddChild :: WidgetClass widget => PageFrame -> widget -> IO () pageFrameAddChild pageFrame widget = @@ -82,7 +122,34 @@ pageFrameUpdateStatusbar pageFrame = statusbarInfoItemUpdate (pageFrameStatusbar pageFrame) --- | Update statusbar. +-- | Update progress. pageFrameUpdateProgress :: PageFrame -> Double -> IO () pageFrameUpdateProgress pageFrame = statusbarProgressUpdate (pageFrameStatusbar pageFrame) + +-- | Close interactivebar. +pageFrameCloseInteractivebar :: PageFrame -> IO () +pageFrameCloseInteractivebar pageFrame = do + -- Close interactivebar. + interactivebarExit (pageFrameBox pageFrame) (pageFrameInteractivebar pageFrame) + + -- Clean interactive data. + writeTVarIO (pageFrameInteractiveArgs pageFrame) [] + writeTVarIO (pageFrameInteractiveType pageFrame) IDefault + writeTVarIO (pageFrameInteractiveResult pageFrame) [] + writeTVarIO (pageFrameInteractiveFun pageFrame) (\_ -> return ()) + +-- | Switch auto completion. +pageFrameSwitchAutoCompletion :: PageFrame -> IO () +pageFrameSwitchAutoCompletion pageFrame = do + title <- interactivebarGetTitle (pageFrameInteractivebar pageFrame) + let label = interactivebarTitleLabel $ pageFrameInteractivebar pageFrame + titleLen = length title + autoCompletion <- readTVarIO $ pageFrameAutoCompletion pageFrame + case autoCompletion of + True -> do + set label [labelAttributes := [AttrForeground 0 titleLen autoCompletionDisableColor]] + writeTVarIO (pageFrameAutoCompletion pageFrame) False + False -> do + set label [labelAttributes := [AttrForeground 0 titleLen autoCompletionEnableColor]] + writeTVarIO (pageFrameAutoCompletion pageFrame) True diff --git a/Manatee/Core/PageMode.hs b/Manatee/Core/PageMode.hs --- a/Manatee/Core/PageMode.hs +++ b/Manatee/Core/PageMode.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Core/PageView.hs b/Manatee/Core/PageView.hs --- a/Manatee/Core/PageView.hs +++ b/Manatee/Core/PageView.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -23,43 +23,191 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Map (Map) +import Data.Text.Lazy (Text) import DBus.Client hiding (Signal) -import DBus.Message +import DBus.Message import DBus.Types +import Graphics.UI.Gtk hiding (Statusbar, statusbarNew) +import Manatee.Core.Config import Manatee.Core.DBus -import Manatee.Core.Interactive +import Manatee.Core.PageFrame import Manatee.Core.Types import Manatee.Toolkit.General.Basic import Manatee.Toolkit.General.Maybe -import Graphics.UI.Gtk.General.General +import Manatee.Toolkit.General.STM +import Manatee.Toolkit.Gtk.Editable +import Manatee.Toolkit.Gtk.Gtk +import Manatee.Toolkit.Gtk.ScrolledWindow +import Manatee.Toolkit.Widget.Interactivebar +import Manatee.Toolkit.Widget.CompletionWindow +import Manatee.Toolkit.Widget.KeymapWindow +import Manatee.Toolkit.Widget.Tooltip +import System.Directory +import System.FilePath +import System.Time import qualified Data.Map as M +import qualified Control.Exception as Exc +-- | Helper keymap. +helperKeymap :: Map Text Text +helperKeymap = + M.fromList + [("M-u", "Scroll step up") + ,("M-i", "Scroll step down") + ,("M-U", "Scroll page up") + ,("M-I", "Scroll page down") + ,("C-I", "Scroll to top") + ,("C-U", "Scroll to bottom") + ,("PageDown", "Scroll step up") + ,("PageUp", "Scroll step down") + ,("Home", "Scroll page up") + ,("End", "Scroll page down") + ,("C-/", "Show/Hide local keymap") + ,("C-?", "Show global keymap") + ] + +-- | Helper keymap. +helperCommandMap :: PageViewKeymap +helperCommandMap = + M.fromList + [("Scroll step up", scrolledWindowScrollVerticalStep True . pageViewKeymapScrolledWindow) + ,("Scroll step down", scrolledWindowScrollVerticalStep False . pageViewKeymapScrolledWindow) + ,("Scroll page up", scrolledWindowScrollVerticalPage True . pageViewKeymapScrolledWindow) + ,("Scroll page down", scrolledWindowScrollVerticalPage False . pageViewKeymapScrolledWindow) + ,("Scroll to top", scrolledWindowScrollToTop . pageViewKeymapScrolledWindow) + ,("Scroll to bottom", scrolledWindowScrollToBottom . pageViewKeymapScrolledWindow) + ,("Show/Hide local keymap", pageViewShowLocalKeymap) + ,("Show global keymap", pageViewShowGlobalKeymap) + ] + -- | PageViewKeymap. -pageViewKeymap :: PageViewKeymap +pageViewKeymap :: Map Text Text pageViewKeymap = M.fromList - [("M-u", pageViewScrollStepUp) - ,("M-i", pageViewScrollStepDown) - ,("M-U", pageViewScrollPageUp) - ,("M-I", pageViewScrollPageDown) - ,("C-I", pageViewScrollToTop) - ,("C-U", pageViewScrollToBottom) - ,("PageDown", pageViewScrollPageUp) - ,("PageUp", pageViewScrollPageDown) - ,("Home", pageViewScrollToTop) - ,("End", pageViewScrollToBottom) - ,("M-y", pageViewScrollStepRight) - ,("M-o", pageViewScrollStepLeft) - ,("M-Y", pageViewScrollPageRight) - ,("M-O", pageViewScrollPageLeft) - ,("C-Y", pageViewScrollToLeft) - ,("C-O", pageViewScrollToRight) - ,("M-x", pageViewCutAction) - ,("M-c", pageViewCopyAction) - ,("M-v", pageViewPasteAction) + [("M-u", "Scroll step up") + ,("M-i", "Scroll step down") + ,("M-U", "Scroll page up") + ,("M-I", "Scroll page down") + ,("C-I", "Scroll to top") + ,("C-U", "Scroll to bottom") + ,("PageDown", "Scroll page up") + ,("PageUp", "Scroll page down") + ,("Home", "Scroll to top") + ,("End", "Scroll to bottom") + ,("M-y", "Scroll step right") + ,("M-o", "Scroll step left") + ,("M-Y", "Scroll page right") + ,("M-O", "Scroll page left") + ,("C-Y", "Scroll to left") + ,("C-O", "Scroll to right") + ,("M-x", "Cut") + ,("M-c", "Copy") + ,("M-v", "Paste") + ,("C-F1", "Save snapshot") + ,("M-b", "Focus interactive bar") + ,("M-g", "Exit interactive bar") + ,("C-/", "Show/Hide local keymap") + ,("C-?", "Show/Hide global keyamp") ] +-- | PageViewKeymap. +pageViewCommandMap :: PageViewKeymap +pageViewCommandMap = + M.fromList + [("Scroll step up", pageViewScrollStepUp) + ,("Scroll step down", pageViewScrollStepDown) + ,("Scroll page up", pageViewScrollPageUp) + ,("Scroll page down", pageViewScrollPageDown) + ,("Scroll to top", pageViewScrollToTop) + ,("Scroll to bottom", pageViewScrollToBottom) + ,("Scroll step right", pageViewScrollStepRight) + ,("Scroll step left", pageViewScrollStepLeft) + ,("Scroll page right", pageViewScrollPageRight) + ,("Scroll page left", pageViewScrollPageLeft) + ,("Scroll to left", pageViewScrollToLeft) + ,("Scroll to right", pageViewScrollToRight) + ,("Cut", pageViewCutAction) + ,("Copy", pageViewCopyAction) + ,("Paste", pageViewPasteAction) + ,("Save snapshot", pageViewSaveSnapshot) + ,("Focus interactive bar", pageViewFocusInteractivebar) + ,("Exit interactive bar", interactiveExit) + ,("Show/Hide local keymap", pageViewShowLocalKeymap) + ,("Show/Hide global keyamp", pageViewShowGlobalKeymap) + ] + +-- | Interactive keymap. +interactiveKeymap :: Map Text Text +interactiveKeymap = + M.fromList $ + [("C-/", "Show/Hide local keymap") + ,("C-?", "Show/Hide global keymap") + ,("M-g", "Exit interactivebar") + ,("M-m", "Return interactivebar") + ,("Return", "Return interactivebar") + ,("Tab", "Switch auto completion") + ,("M-d", "Delete all") + ,("M-,", "Delete backward char") + ,("M-.", "Delete forward char") + ,("M-<", "Delete backward word") + ,("M->", "Delete forward word") + ,("C-M-,", "Delete to start") + ,("C-M-.", "Delete to end") + ,("M-a", "Select all") + ,("M-b", "Focus") + ,("M-x", "Cut") + ,("M-c", "Copy") + ,("M-v", "Paste") + ,("M-h", "Backward char") + ,("M-l", "Forward char") + ,("M-H", "Backward word") + ,("M-L", "Forward word") + ,("M-P-h", "Move to start") + ,("M-P-l", "Move to end")] + +-- | Interactive keymap. +interactiveCommandMap :: InteractiveKeymap +interactiveCommandMap = + M.fromList $ + [("Show/Hide local keymap", pageViewShowLocalKeymap) + ,("Show/Hide global keymap", pageViewShowGlobalKeymap) + ,("Exit interactivebar", interactiveExit) + ,("Return interactivebar", interactiveReturn) + ,("Switch auto completion", interactiveSwitchAutoCompletion) + ] + ++ map (\ (k, f) -> (k, f . pageViewEntry)) + [("Delete all", editableDeleteAllText) + ,("Delete backward char", editableDeleteBackwardChar) + ,("Delete forward char", editableDeleteForwardChar) + ,("Delete backward word", editableDeleteBackwardWord) + ,("Delete forward word", editableDeleteForwardWord) + ,("Delete to start", editableDeleteToStart) + ,("Delete to end", editableDeleteToEnd) + ,("Select all", editableSelectAll) + ,("Focus", editableFocus) + ,("Cut", editableCutClipboard) + ,("Copy", editableCopyClipboard) + ,("Paste", editablePasteClipboard) + ,("Backward char", editableBackwardChar) + ,("Forward char", editableForwardChar) + ,("Backward word", editableBackwardWord) + ,("Forward word", editableForwardWord) + ,("Move to start", editableMoveToStart) + ,("Move to end", editableMoveToEnd) + ] + +-- | Page View box. +pageViewBox :: forall a . PageView a => a -> VBox +pageViewBox = + pageFrameBox . pageViewFrame + +-- | Page View scrolled window. +pageViewScrolledWindow :: forall a . PageView a => a -> ScrolledWindow +pageViewScrolledWindow = + pageFrameScrolledWindow . pageViewFrame + -- | Basic scroll action. pageViewScrollStepUp, pageViewScrollStepDown, pageViewScrollPageUp, pageViewScrollPageDown :: PageView a => a -> IO () pageViewScrollStepUp = pageViewScrollVerticalStep True @@ -101,29 +249,281 @@ unlessM (pageViewPaste view) $ putStrLn "pageViewPasteAction : Haven't implement pageViewPaste." --- | Call local interactive. -localInteractive :: forall a . PageView a => a -> String -> ([String] -> IO ()) -> IO () -localInteractive view args action = - case parseInteractiveString args of - -- Don't do anything if parse failed. - Left err -> putStrLn $ "localInteractive : Failed with reason : " ++ show err - Right strList -> do - plugId <- pageViewGetPlugId view - callDaemonMethodAsync - (pageViewClient view) - "Interactive" - [toVariant (plugId, args)] - (\ err -> putStrLn $ "localInteractive : Failed with reason : " ++ show err) +-- | Apply with page view rectangle. +pageViewApplyRectangle :: forall a . PageView a => a -> (Rectangle -> IO ()) -> IO () +pageViewApplyRectangle view func = do + pagePlugId <- pageViewGetPlugId view + callDaemonMethodAsync + (pageViewClient view) + "GetWindowAllocation" + [toVariant pagePlugId] + (\ err -> pageViewShowOutputbar view (show err) Nothing) + (\ methodReturn -> do + let variants = messageBody methodReturn + unless (null variants) $ + (fromVariant (head variants) :: Maybe Rectangle) + ?>= func) + +-- | Is focus on keymap window. +pageViewIsFocusKeymapWindow :: forall a . PageView a => a -> IO Bool +pageViewIsFocusKeymapWindow = + keymapWindowIsVisible . pageFrameKeymapWindow . pageViewFrame + +-- | Page view keymap scrolled window. +pageViewKeymapScrolledWindow :: forall a . PageView a => a -> ScrolledWindow +pageViewKeymapScrolledWindow = + kwScrolledWindow . pageFrameKeymapWindow . pageViewFrame + +-- | Show/Hide local keymap. +pageViewShowLocalKeymap :: forall a . PageView a => a -> IO () +pageViewShowLocalKeymap view = do + let keymapWin = pageFrameKeymapWindow $ pageViewFrame view + frame = pageFrameFrame $ pageViewFrame view + isVisible <- keymapWindowIsVisible keymapWin + if isVisible + then keymapWindowHide keymapWin + else + pageViewApplyRectangle view $ \ (Rectangle x y w h) -> + postGUIAsync $ do + let rw = floor (fromIntegral w * 2 / 3) + rh = floor (fromIntegral h * 2 / 3) + rx = (x + floor (fromIntegral w / 6)) + ry = (y + floor (fromIntegral h / 6)) + keymapWindowShow keymapWin + frame + (Rectangle rx ry rw rh) + [("Local keymap", M.toList (pageViewLocalKeymap view))] + +-- | Show/Hide global keymap. +pageViewShowGlobalKeymap :: forall a . PageView a => a -> IO () +pageViewShowGlobalKeymap view = do + let keymapWin = pageFrameKeymapWindow $ pageViewFrame view + frame = pageFrameFrame $ pageViewFrame view + isVisible <- keymapWindowIsVisible keymapWin + if isVisible + then keymapWindowHide keymapWin + else do + pagePlugId <- pageViewGetPlugId view + callDaemonMethodAsync + (pageViewClient view) + "GetGlobalKeymap" + [toVariant pagePlugId] + (\ err -> pageViewShowOutputbar view (show err) Nothing) (\ methodReturn -> do let variants = messageBody methodReturn unless (null variants) $ - (fromVariant (head variants) :: Maybe [String]) - ?>= \ list -> - -- Just do action if return list match. - when (length strList == length list) $ - -- Use `postGUIAsync` to protected GTK+ main thread. - postGUIAsync (bracketOnError - (return list) - -- Print error message if exception rasied when do action. - (\ _ -> putStrLn "localInteractive: exception rasied.") - action)) + (fromVariant (head variants) :: Maybe (Rectangle, [(Text, Text)])) + ?>= \ ((Rectangle x y w h), list) -> + postGUIAsync $ do + let rw = floor (fromIntegral w * 2 / 3) + rh = floor (fromIntegral h * 2 / 3) + rx = (x + floor (fromIntegral w / 6)) + ry = (y + floor (fromIntegral h / 6)) + keymapWindowShow keymapWin + frame + (Rectangle rx ry rw rh) + [("Global keymap", list) + ,("Page view keymap", M.toList pageViewKeymap) + ,("Interactivebar keymap", M.toList interactiveKeymap) + ,("Helper keymap", M.toList helperKeymap)]) + +-- | Save page view snapshot. +pageViewSaveSnapshot :: forall a . PageView a => a -> IO () +pageViewSaveSnapshot view = + widgetGetSnapshotPixbuf (pageViewScrolledWindow view) >?>= \pixbuf -> do + -- Get snapshot save path. + configDir <- getConfigDirectory + time <- getClockTime + let snapshotDir = configDir "snapshot" + snapshotPath = snapshotDir (show time ++ "_snapshot.png") + + -- Create it directory if haven't create. + createDirectoryIfMissing True snapshotDir + + -- Save snapshot. + pixbufSave pixbuf snapshotPath "png" [] + pageViewShowOutputbar view ("Has save snapshot at : " ++ snapshotPath) Nothing + +-- | Hide completion window. +pageViewHideCompletionWindow :: forall a . PageView a => a -> IO () +pageViewHideCompletionWindow = + completionWindowHide . pageFrameCompletionWindow . pageViewFrame + +-- | Show outputbar. +pageViewShowOutputbar :: forall a . PageView a => a -> String -> Maybe Int -> IO () +pageViewShowOutputbar = + pageFrameShowOutputbar . pageViewFrame + +-- | Update Statusbar. +pageViewUpdateStatusbar :: forall a . PageView a => a -> String -> String -> IO () +pageViewUpdateStatusbar = + pageFrameUpdateStatusbar . pageViewFrame + +-- | Update progress. +pageViewUpdateProgress :: forall a . PageView a => a -> Double -> IO () +pageViewUpdateProgress = + pageFrameUpdateProgress . pageViewFrame + +-- | Page view entry. +pageViewEntry :: forall a . PageView a => a -> Entry +pageViewEntry = + interactivebarEntry . pageFrameInteractivebar . pageViewFrame + +-- | Is interactivebar is focus. +pageViewIsFocusInteractivebar :: forall a . PageView a => a -> IO Bool +pageViewIsFocusInteractivebar = + widgetGetIsFocus . pageViewEntry + +-- | Focus interactivebar. +pageViewFocusInteractivebar :: forall a . PageView a => a -> IO () +pageViewFocusInteractivebar = + editableFocus . pageViewEntry + +-- | Interactive. +interactive :: forall a . PageView a => a -> [(InteractiveType, String, String)] -> ([String] -> IO ()) -> IO () +interactive view [] _ = pageViewShowOutputbar view "Interactive arguments is empty." Nothing +interactive view ((typ, title, content):rest) func = do + -- Init. + let pageFrame = pageViewFrame view + + -- Show interactivebar first. + pageFrameShowInteractivebar pageFrame + + -- Set interactive data. + writeTVarIO (pageFrameInteractiveArgs pageFrame) rest + writeTVarIO (pageFrameInteractiveResult pageFrame) [] + writeTVarIO (pageFrameInteractiveFun pageFrame) func + + -- Prompt first one. + writeTVarIO (pageFrameInteractiveType pageFrame) typ + interactivebarSetTitle (pageFrameInteractivebar pageFrame) title + interactivebarSetContent (pageFrameInteractivebar pageFrame) content + +-- | Interactive return. +interactiveReturn :: forall a . PageView a => a -> IO () +interactiveReturn view = do + -- Init. + let pageFrame = pageViewFrame view + + -- Hide completion window first. + pageViewHideCompletionWindow view + + -- Get input. + status <- interactivebarGetStatus (pageFrameInteractivebar pageFrame) + case status of + Nothing -> pageViewShowOutputbar view "Interactive is invisible." Nothing + Just (_, (arg, _)) -> do + -- Store input. + modifyTVarIO (pageFrameInteractiveResult pageFrame) (\ list -> list ++ [arg]) + + args <- readTVarIO $ pageFrameInteractiveArgs pageFrame + case args of + [] -> do + -- Read result and function. + result <- readTVarIO $ pageFrameInteractiveResult pageFrame + fun <- readTVarIO $ pageFrameInteractiveFun pageFrame + + -- Exit interactivebar first. + interactiveExit view + + -- Execute command. + Exc.catch + (fun result) + -- Show error if catch any exception when do command. + (\ (e :: SomeException) -> + pageViewShowOutputbar view (show e) Nothing) + -- Otherwise continue read argument from user. + ((typ, title, content):rest) -> do + -- Popup top element from arguments. + writeTVarIO (pageFrameInteractiveArgs pageFrame) rest + + -- Prompt next argument. + writeTVarIO (pageFrameInteractiveType pageFrame) typ + interactivebarSetTitle (pageFrameInteractivebar pageFrame) title + interactivebarSetContent (pageFrameInteractivebar pageFrame) content + +-- | Close interactivebar. +interactiveExit :: forall a . PageView a => a -> IO () +interactiveExit view = do + -- Close interactive first. + pageFrameCloseInteractivebar $ pageViewFrame view + pageViewHideCompletionWindow view + +-- | Switch auto completion. +interactiveSwitchAutoCompletion :: forall a . PageView a => a -> IO () +interactiveSwitchAutoCompletion view = + pageFrameSwitchAutoCompletion (pageViewFrame view) + +-- | Interactive complete. +interactiveCompletion :: forall a . PageView a => a -> IO () +interactiveCompletion view = do + -- Init. + let pageFrame = pageViewFrame view + window = pageFrameCompletionWindow pageFrame + entry = pageViewEntry view + + -- completion <- interactiveGetCompletion view + -- case completion of + + case [1] of + + [] -> return () + _ -> + pageViewApplyRectangle view $ \ (Rectangle wx wy _ _) -> + postGUIAsync $ do + -- Get coordinate. + (Rectangle x y w h) <- widgetGetAllocation entry + + -- Show completion window. + completionWindowShow window (pageViewEntry view) (Rectangle (wx + x) (wy + y + h) w 100) + +-- -- | Get completion. +-- interactiveGetCompletion :: forall a . PageView a => a -> IO [String] +-- interactiveGetCompletion view = do +-- let pageFrame = pageViewFrame view +-- iType <- readTVarIO $ pageFrameInteractiveType pageFrame +-- case iType of +-- IFile -> do +-- status <- interactivebarGetStatus (pageFrameInteractivebar pageFrame) +-- case status of +-- Just (_, (input, _)) -> do +-- home <- getEnv "HOME" +-- let -- Expand '~' with HOME value. +-- path = if ("~" :: String) `isPrefixOf` filepath +-- then home ++ drop (length ("~" :: String)) filepath +-- else filepath +-- -- Try to get upper directory of current file path. +-- upperDir | hasTrailingPathSeparator path +-- = fromString path +-- | otherwise +-- = fromString $ getUpperDirectory path +-- if directoryDoesExist upperDir +-- then do +-- fileInfos <- directoryGetFileInfos upperDir +-- let infos = map (\info -> ((fileInfoGetDisplayNameWithType info), (fileInfoGetFileType info))) fileInfos +-- files = sortBy (\ a b -> +-- compareFileWithType +-- (fileInfoDisplayName a, fileInfoFileType a) +-- (fileInfoDisplayName b, fileInfoFileType b) +-- ) infos +-- return $ map fst files +-- else return [] +-- Nothing -> return [] +-- _ -> return [] + +-- | Show tooltip. +pageViewShowTooltip :: forall a . PageView a => a -> String -> Maybe Point -> IO () +pageViewShowTooltip view text Nothing = + tooltipNew (pageViewPropagateWidget view) + text + Nothing + Nothing Nothing Nothing + >> return () +pageViewShowTooltip view text (Just (px, py)) = + pageViewApplyRectangle view $ \ (Rectangle x y _ _) -> postGUIAsync $ + tooltipNew (pageViewPropagateWidget view) + text + (Just (x + px, y + py)) + Nothing Nothing Nothing + >> return () + diff --git a/Manatee/Core/Render.hs b/Manatee/Core/Render.hs --- a/Manatee/Core/Render.hs +++ b/Manatee/Core/Render.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -16,26 +16,37 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings #-} module Manatee.Core.Render where +import Control.Monad import Control.Monad.State import DBus.Client hiding (Signal) +import Data.Text.Lazy (unpack) import GHC.Conc import Graphics.UI.Gtk hiding (Window, windowNew, Frame, frameNew, Signal, Frame, Variant, Action, plugNew, plugGetId, get) +import Manatee.Core.Config 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.Basic import Manatee.Toolkit.General.DBus +import Manatee.Toolkit.General.FilePath +import Manatee.Toolkit.General.List 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 +import Manatee.Toolkit.Gtk.Gtk import Manatee.Toolkit.Widget.Plug +import System.Directory import System.Environment +import System.FilePath +import System.IO import System.Posix.Process import System.Posix.Types (ProcessID) @@ -52,12 +63,12 @@ [x] -> case (read x :: SpawnProcessArgs) of arg@(SpawnRenderProcessArgs {}) -> renderMain arg bufferNewFun customizeNewFun - _ -> return () _ -> return () -- | Render process main entry. renderMain :: SpawnProcessArgs -> PageBufferNewFun -> CustomizeNewFun -> IO () -renderMain (SpawnRenderProcessArgs pageId pType sId pagePath options) bufferNewFun customizeNewFun = do +renderMain spawnProcessArgs@(SpawnRenderProcessArgs pageId pType pagePath options sIds isRestore) + bufferNewFun customizeNewFun = do -- Init. unsafeInitGUIForThreadedRTS @@ -76,13 +87,27 @@ -- Create page buffer. bufferWrap <- bufferNewFun pagePath options client pageId customizeWrap + when isRestore (renderReadBufferState bufferWrap pageId) -- Build render client for listen dbus signal. pongStatusTVar <- newTVarIO GotPongMessage - mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar + mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar spawnProcessArgs - -- Create first page. - renderPageNew client bufferWrap pageList processId (pageId, pType, sId) True + -- Send NewRenderProcessConfirm signal or create new page. + if null sIds + -- Send NewRenderProcessConfirm signal if haven't any page need create. + then + case bufferWrap of + (PageBufferWrap buffer) -> do + let modeName = pageModeName $ pageBufferMode buffer + path <- pageBufferGetName buffer + mkDaemonSignal client + NewRenderProcessConfirm + (NewRenderProcessConfirmArgs pageId pType processId modeName path) + -- Otherwise, create new page. + else + forM_ (pairPred sIds) $ \ (sId, index) -> + renderPageNew client bufferWrap pageList processId (pageId, pType, sId) (index == 0) isRestore -- Send ping signal. renderSendPing client pongStatusTVar @@ -98,16 +123,18 @@ -> TVar PageList -> PageType -> TVar PongStatus + -> SpawnProcessArgs -> IO () -mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar = +mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar spawnProcessArgs = -- Build match rule. mkRenderMatchRules client [(CloneRenderPage, renderHandleClonePage client bufferWrap pageList processId pType) ,(ReparentRenderPage, renderHandleReparentPage client bufferWrap pageList processId) ,(FocusRenderPage, renderHandleFocusPage pageList) ,(PageViewKeyPress, renderHandleKeyPress pageList) - ,(DestroyRenderPage, renderHandleDestroyPage pageList) - ,(ExitRenderProcess, renderHandleExitProcess client processId) + ,(DestroyRenderPage, renderHandleDestroyPage True pageList) + ,(RestoreRenderPageState, renderHandleRestorePageState pageList) + ,(ExitRenderProcess, renderHandleExitProcess client processId pageList bufferWrap spawnProcessArgs) ,(UpdateConfig, renderHandleUpdateConfig customizeWrap) ,(InstallConfig, renderHandleInstallConfig bufferWrap) ,(Pong, renderHandlePong pongStatusTVar) @@ -118,7 +145,7 @@ renderHandleClonePage client bufferWrap pageList processId pType (CloneRenderPageArgs pageId sId) = do debugDBusMessage $ "renderHandleClonePage: Catch CloneRenderPage signal. Box id: " ++ show sId - renderPageNew client bufferWrap pageList processId (pageId, pType, sId) False + renderPageNew client bufferWrap pageList processId (pageId, pType, sId) False False debugDBusMessage $ "renderHandleClonePage: Finish clone page. Box id : " ++ show sId @@ -133,46 +160,50 @@ -- Try to re-parent children from old plug. case oldPage of - Just op -> do - -- Create new plug. - newPlug <- plugNew Nothing - let pId = plugId newPlug - pType = pageType op + Just op@(Page {pageView = PageViewWrap oldView}) -> do + -- Save state first. + pageViewSaveState oldView + + -- Create new plug. + newPlug <- plugNew Nothing + let pId = plugId newPlug + pType = pageType op - -- Reparent. - writeTVarIO (pageApplyViewWrap op pageViewPlugId) pId -- update new page plug id - widgetReparent (pageBox op) (plugBody newPlug) - widgetShowAll $ plugBody newPlug + -- Reparent. + writeTVarIO (pageApplyViewWrap op pageViewPlugId) pId -- update new page plug id + widgetReparent (pageBox op) (plugBody newPlug) + widgetShowAll $ plugBody newPlug - -- New page. - page <- pageNew pageId pType newPlug (pageView op) + -- New page. + page <- pageNew pageId sId pType newPlug (pageView op) - -- Add page to page list. - runTVarStateT pageList $ put . Set.insert page + -- Add page to page list. + runTVarStateT pageList $ put . Set.insert page - -- Destroy old plug. - renderHandleDestroyPage pageList (DestroyRenderPageArgs oldPlugId) + -- Destroy old plug. + renderHandleDestroyPage False pageList (DestroyRenderPageArgs oldPlugId) - -- Send `NewRenderPageConfirm` signal. - let modeName = pageModeName $ pageBufferMode buffer - path <- pageBufferGetName buffer - mkDaemonSignal client - NewRenderPageConfirm - (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path False) + -- Send `NewRenderPageConfirm` signal. + let modeName = pageModeName $ pageBufferMode buffer + path <- pageBufferGetName buffer + mkDaemonSignal client + NewRenderPageConfirm + (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path False False) - debugDBusMessage $ "renderHandleReparentPage: Finish reparent page. Box id : " ++ show sId + debugDBusMessage $ "renderHandleReparentPage: Finish reparent page. Box id : " ++ show sId Nothing -> debugDBusMessage $ "Warning (renderHandleReparentPage): Cant find old plug " ++ show oldPlugId ++ " to reparent." -- | Handle new render page signal. -renderPageNew :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> (PageId, PageType, SignalBoxId) -> Bool -> IO () -renderPageNew client (PageBufferWrap buffer) pageList processId (pageId, pType, sId) isFirstPage = do +renderPageNew :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> (PageId, PageType, SignalBoxId) + -> Bool -> Bool -> IO () +renderPageNew client (PageBufferWrap buffer) pageList processId (pageId, pType, sId) isFirstPage isRestore = do -- Create page plug. plug <- plugNew Nothing let pId = plugId plug -- Create page. viewWrap <- pageBufferCreateView buffer pId - page <- pageNew pageId pType plug viewWrap + page <- pageNew pageId sId pType plug viewWrap -- Create page and pageView. plugBody plug `containerAdd` pageBox page @@ -186,41 +217,129 @@ path <- pageBufferGetName buffer mkDaemonSignal client NewRenderPageConfirm - (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path isFirstPage) + (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path isFirstPage isRestore) -- | Handle focus render page signal. renderHandleFocusPage :: TVar PageList -> RenderSignalArgs -> IO () renderHandleFocusPage pageList (FocusRenderPageArgs plugId) = do pl <- readTVarIO pageList maybeFindMin pl (\x -> pagePlugId x == plugId) - ?>= \ page -> pageApplyViewWrap page pageViewFocus + ?>= \ (Page {pageView = PageViewWrap view}) -> + ifM (pageViewIsFocusInteractivebar view) + (pageViewFocusInteractivebar view) + (pageViewFocus view) -- | Handle page view key press signal. renderHandleKeyPress :: TVar PageList -> RenderSignalArgs -> IO () renderHandleKeyPress pageList (PageViewKeyPressArgs plugId keystoke sEvent) = do pl <- readTVarIO pageList maybeFindMin pl (\x -> pagePlugId x == plugId) - ?>= \ (Page {pageView = PageViewWrap view}) -> - case M.lookup keystoke pageViewKeymap of - -- Execute page view common action when match. - Just action -> action view - -- Otherwise pass key to page view instance. - Nothing -> pageViewHandleKeyAction view keystoke sEvent + ?>= \ (Page {pageView = PageViewWrap view}) -> do + isFocusKeymapWindow <- pageViewIsFocusKeymapWindow view + isFocusInteractivebar <- pageViewIsFocusInteractivebar view + if isFocusKeymapWindow + then + M.lookup keystoke helperKeymap + ?>= \ command -> + M.lookup command helperCommandMap + ?>= \ action -> action view + else if isFocusInteractivebar + -- Handle interactive keymap if focus on interactivebar. + then + case M.lookup keystoke interactiveKeymap of + Just command -> + M.lookup command interactiveCommandMap + ?>= \ action -> action view + Nothing -> widgetPropagateEvent (pageViewEntry view) sEvent + -- Otherwise handle page view keymap. + else + case M.lookup keystoke pageViewKeymap of + Just command -> + M.lookup command pageViewCommandMap + ?>= \ action -> action view + Nothing -> + case M.lookup keystoke (pageViewLocalKeymap view) of + Just command -> + case M.lookup command (pageViewLocalCommandMap view) of + Just action -> action view + Nothing -> do + pageViewShowOutputbar view ("Can't find command : " ++ unpack command ++ " propagate event") Nothing + widgetPropagateEvent (pageViewPropagateWidget view) sEvent + Nothing -> widgetPropagateEvent (pageViewPropagateWidget view) sEvent -- | Handle destroy render page signal. -renderHandleDestroyPage :: TVar PageList -> RenderSignalArgs -> IO () -renderHandleDestroyPage pageList (DestroyRenderPageArgs plugId) = +renderHandleDestroyPage :: Bool -> TVar PageList -> RenderSignalArgs -> IO () +renderHandleDestroyPage saveState pageList (DestroyRenderPageArgs plugId) = runTVarStateT pageList $ \pl -> - maybeFindMin pl (\x -> pagePlugId x == plugId) ?>= \page -> do - lift $ debugDBusMessage $ "renderHandleDestroyPage: Catch DestroyRenderPage signal. Plug id : " ++ show plugId - -- Delete page from page list. - put (Set.delete page pl) - -- Destroy page. - lift $ plugDestroy $ pagePlug page + maybeFindMin pl (\x -> pagePlugId x == plugId) + ?>= \page@(Page {pageView = PageViewWrap view}) -> do + lift $ debugDBusMessage $ "renderHandleDestroyPage: Catch DestroyRenderPage signal. Plug id : " ++ show plugId + -- Save state first. + when saveState $ + lift $ pageViewSaveState view + -- Delete page from page list. + put (Set.delete page pl) + -- Destroy page. + lift $ plugDestroy $ pagePlug page + +-- | Restore page state. +renderHandleRestorePageState :: TVar PageList -> RenderSignalArgs -> IO () +renderHandleRestorePageState pageList (RestoreRenderPageStateArgs plugId isRestore) = do + pl <- readTVarIO pageList + maybeFindMin pl (\x -> pagePlugId x == plugId) + ?>= \ (Page {pageView = PageViewWrap view + ,pageId = pId + ,pageSignalBoxId = sId}) -> do + if isRestore + -- Restore from state file. + then do + statePath <- renderGetViewStatePath pId sId + isExist <- doesFileExist statePath + if isExist + then + pageViewReadState view statePath + else do + pageViewRestoreState view + putStrLn $ "Can't found state path " ++ statePath ++ ", load default state." + -- Or restore from last save state. + else + pageViewRestoreState view -- | Handle exit process signal. -renderHandleExitProcess :: Client -> ProcessID -> RenderSignalArgs -> IO () -renderHandleExitProcess client processId (ExitRenderProcessArgs pageId) = do +renderHandleExitProcess :: Client -> ProcessID -> TVar PageList -> PageBufferWrap -> SpawnProcessArgs -> RenderSignalArgs -> IO () +renderHandleExitProcess client + processId + pageList + (PageBufferWrap buffer) + (SpawnRenderProcessArgs pId pType _ _ _ _) + (ExitRenderProcessArgs pageId saveState) = do + -- Save state. + when saveState $ do + -- Get current buffer path. + path <- pageBufferGetName buffer + + -- Get SignalBoxId from page list. + pList <- fmap (Set.toList) $ readTVarIO pageList + let sIds = map pageSignalBoxId pList + + -- Save startup state. + progName <- getProgName + savePath <- renderGetBufferStartupPath pageId + createDirectoryIfMissing True (takeDirectory savePath) + withFile savePath WriteMode $ \x -> + hPutStr x (show (progName, (SpawnRenderProcessArgs pId pType path [] sIds True))) + + -- Save buffer state. + bStatePath <- renderGetBufferStatePath pageId + pageBufferWriteState buffer bStatePath + + -- Save view state. + forM_ pList $ \ (Page {pageView = PageViewWrap view + ,pageId = pId + ,pageSignalBoxId = sId}) -> do + statePath <- renderGetViewStatePath pId sId + pageViewWriteState view statePath + -- Send RenderProcessExitConfirm signal to daemon process. mkDaemonSignal client RenderProcessExitConfirm (RenderProcessExitConfirmArgs pageId processId) @@ -270,3 +389,35 @@ sendDelay return () + +-- | Get buffer state directory. +renderGetBufferStateDir :: PageId -> IO FilePath +renderGetBufferStateDir pageId = do + configDir <- getConfigDirectory + expandFilePath $ configDir statePath show pageId + +-- | Get buffer startup path. +renderGetBufferStartupPath :: PageId -> IO FilePath +renderGetBufferStartupPath pageId = do + stateDir <- renderGetBufferStateDir pageId + return $ stateDir subprocessStartupPath + +-- | Get buffer state path. +renderGetBufferStatePath :: PageId -> IO FilePath +renderGetBufferStatePath pageId = do + stateDir <- renderGetBufferStateDir pageId + return $ stateDir bufferStatePath + +-- | Get view state path. +renderGetViewStatePath :: PageId -> SignalBoxId -> IO FilePath +renderGetViewStatePath pageId signalBoxId = do + stateDir <- renderGetBufferStateDir pageId + return $ stateDir viewStatePath ++ "-" ++ show signalBoxId + +-- | Read state. +renderReadBufferState :: PageBufferWrap -> PageId -> IO () +renderReadBufferState (PageBufferWrap buffer) pageId = do + -- Get buffer state path. + path <- renderGetBufferStatePath pageId + isExist <- doesFileExist path + when isExist (pageBufferReadState buffer path) diff --git a/Manatee/Core/TH.hs b/Manatee/Core/TH.hs --- a/Manatee/Core/TH.hs +++ b/Manatee/Core/TH.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Core/Types.hs b/Manatee/Core/Types.hs --- a/Manatee/Core/Types.hs +++ b/Manatee/Core/Types.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -41,14 +41,22 @@ import Manatee.Core.TH import Manatee.Toolkit.Gtk.ScrolledWindow import Manatee.Toolkit.Gtk.Struct +import Manatee.Toolkit.Widget.Interactivebar +import Manatee.Toolkit.Widget.Outputbar import Manatee.Toolkit.Widget.Plug +import Manatee.Toolkit.Widget.CompletionWindow +import Manatee.Toolkit.Widget.KeymapWindow +import Manatee.Toolkit.Widget.Statusbar import System.Posix.Types (ProcessID) +import qualified Graphics.UI.Gtk as Gtk + -- | Page is widget container for render view. -data Page = Page {pageId :: PageId - ,pageType :: PageType - ,pagePlug :: Plug - ,pageView :: PageViewWrap +data Page = Page {pageId :: PageId + ,pageSignalBoxId :: SignalBoxId + ,pageType :: PageType + ,pagePlug :: Plug + ,pageView :: PageViewWrap } type PagePlug = Plug @@ -93,9 +101,16 @@ deriving (Show, Read, Eq, Ord, Typeable) data ExtensionGloalKeymap = - ExtensionGloalKeymap (Map String (String, String, [String])) + ExtensionGloalKeymap (Map String (String, (String, String, [String]))) deriving (Show, Read, Eq, Ord, Typeable) +data WelcomeApplication = + WelcomeApplication (Map (String, FilePath) -- application name and image path + (PageType, -- page type + String, -- page path + [String]) -- options + ) deriving (Show, Read, Eq, Ord, Typeable) + -- | BufferList newtype BufferList = BufferList (Map PageModeName (Seq Buffer)) @@ -148,20 +163,62 @@ pageBufferCreateView :: a -> PagePlugId -> IO PageViewWrap pageBufferMode :: a -> PageMode pageBufferPackageName :: a -> IO String + pageBufferWriteState :: a -> FilePath -> IO () + pageBufferWriteState _ _ = return () + pageBufferReadState :: a -> FilePath -> IO () + pageBufferReadState _ _ = return () data PageBufferWrap = forall a . PageBuffer a => PageBufferWrap a -- | Page buffer new function. type PageBufferNewFun = FilePath -> [String] -> Client -> PageId -> CustomizeWrap -> IO PageBufferWrap +-- | Interactive type. +data InteractiveType = IDefault + | IChar + | IDir + | IFile + | INum + | IString + -- | ICustomize (String -> [String]) -- customize interactive type + deriving (Show, Eq, Ord) + +-- | Page frame. +data PageFrame = + PageFrame {pageFrameBox :: VBox -- box for contain `PageView' + ,pageFrameInteractivebar :: Interactivebar -- interactivebar + ,pageFrameFrame :: Gtk.Frame -- frame + ,pageFrameScrolledWindow :: ScrolledWindow -- scrolled window + ,pageFrameOutputbar :: Outputbar -- outputbar for display message + ,pageFrameStatusbar :: Statusbar -- statusbar + -- Completion window. + ,pageFrameAutoCompletion :: TVar Bool -- whether auto completion? + ,pageFrameCompletionWindow :: CompletionWindow -- completion window + -- Interactive arguments. + ,pageFrameInteractiveArgs :: TVar [(InteractiveType, String, String)] -- arguments for interactive input + ,pageFrameInteractiveType :: TVar InteractiveType -- interactive type + ,pageFrameInteractiveResult :: TVar [String] -- interactive result + ,pageFrameInteractiveFun :: TVar ([String] -> IO ()) -- interactive function + ,pageFrameKeymapWindow :: KeymapWindow -- keymap window + } + -- | PageView class. class Typeable a => PageView a where pageViewBuffer :: a -> PageBufferWrap pageViewPlugId :: a -> TVar PagePlugId - pageViewBox :: a -> VBox - pageViewScrolledWindow :: a -> ScrolledWindow - pageViewHandleKeyAction :: a -> Text -> SerializedEvent -> IO () + pageViewFrame :: a -> PageFrame + pageViewLocalKeymap :: a -> Map Text Text + pageViewLocalCommandMap :: a -> Map Text (a -> IO ()) pageViewFocus :: a -> IO () + pageViewPropagateWidget :: a -> Widget + pageViewSaveState :: a -> IO () + pageViewSaveState _ = return () + pageViewWriteState :: a -> FilePath -> IO () + pageViewWriteState _ _ = return () + pageViewReadState :: a -> FilePath -> IO () + pageViewReadState _ _ = return () + pageViewRestoreState :: a -> IO () + pageViewRestoreState _ = return () pageViewCopy :: a -> IO Bool pageViewCopy _ = return False pageViewCut :: a -> IO Bool @@ -170,32 +227,33 @@ pageViewPaste _ = return False pageViewScrollToTop :: a -> IO () pageViewScrollToTop = - scrolledWindowScrollToTop . pageViewScrolledWindow + scrolledWindowScrollToTop . pageFrameScrolledWindow . pageViewFrame pageViewScrollToBottom :: a -> IO () pageViewScrollToBottom = - scrolledWindowScrollToBottom . pageViewScrolledWindow + scrolledWindowScrollToBottom . pageFrameScrolledWindow . pageViewFrame pageViewScrollVerticalPage :: Bool -> a -> IO () pageViewScrollVerticalPage isDown a = - scrolledWindowScrollVerticalPage isDown (pageViewScrolledWindow a) + scrolledWindowScrollVerticalPage isDown (pageFrameScrolledWindow $ pageViewFrame a) pageViewScrollVerticalStep :: Bool -> a -> IO () pageViewScrollVerticalStep isDown a = - scrolledWindowScrollVerticalStep isDown (pageViewScrolledWindow a) + scrolledWindowScrollVerticalStep isDown (pageFrameScrolledWindow $ pageViewFrame a) pageViewScrollToLeft :: a -> IO () pageViewScrollToLeft = - scrolledWindowScrollToLeft . pageViewScrolledWindow + scrolledWindowScrollToLeft . pageFrameScrolledWindow . pageViewFrame pageViewScrollToRight :: a -> IO () pageViewScrollToRight = - scrolledWindowScrollToRight . pageViewScrolledWindow + scrolledWindowScrollToRight . pageFrameScrolledWindow . pageViewFrame pageViewScrollHorizontalPage:: Bool -> a -> IO () pageViewScrollHorizontalPage isDown a = - scrolledWindowScrollHorizontalPage isDown (pageViewScrolledWindow a) + scrolledWindowScrollHorizontalPage isDown (pageFrameScrolledWindow $ pageViewFrame a) pageViewScrollHorizontalStep:: Bool -> a -> IO () pageViewScrollHorizontalStep isDown a = - scrolledWindowScrollHorizontalStep isDown (pageViewScrolledWindow a) + scrolledWindowScrollHorizontalStep isDown (pageFrameScrolledWindow $ pageViewFrame a) data PageViewWrap = forall a . PageView a => PageViewWrap a type PageViewKeymap = forall a . PageView a => Map Text (a -> IO ()) +type InteractiveKeymap = PageViewKeymap class Typeable a => Customize a where customizeConfigFile :: a -> FilePath @@ -205,13 +263,7 @@ type CustomizeNewFun = IO CustomizeWrap -data AnythingInteractiveType = GlobalSearch - | GlobalInteractive - | LocalInteractive - deriving (Show, Ord, Eq, Read) - -- | DBus -type AnythingKeyPressId = Int type PageId = Int type PageSocketId = GWindowId type PagePlugId = GWindowId @@ -219,55 +271,55 @@ type SignalBoxId = Int type InteractiveString = (PagePlugId, String) type InteractiveResult = [String] +type GlobalKeymapResult = (Rectangle, [(Text, Text)]) $(derive makeOrd ''Color) $(derive makeRead ''Color) +$(derive makeRead ''Rectangle) -- | Variant instance for serialize value to DBus system. deriveVariable (conT ''ProcessID) deriveVariable (conT ''GWindowId) +deriveVariable (conT ''Rectangle) deriveVariable (conT ''Color) deriveVariable (conT ''Maybe `appT` conT ''Color) deriveVariable (conT ''Int) deriveVariable (conT ''Maybe `appT` conT ''Char) deriveVariable (conT ''Maybe `appT` conT ''Int) +deriveVariable (conT ''Maybe `appT` conT ''FilePath) deriveVariable (conT ''SerializedEvent) deriveVariable (conT ''BufferInfoList) deriveVariable (conT ''BufferHistoryList) deriveVariable (conT ''Maybe `appT` conT ''Point) deriveVariable (conT ''InteractiveString) deriveVariable (conT ''InteractiveResult) -deriveVariable (conT ''AnythingInteractiveType) +deriveVariable (conT ''GlobalKeymapResult) data DaemonMember = NewRenderPageConfirm - | NewAnythingProcessConfirm + | NewRenderProcessConfirm | RenderProcessExit | RenderProcessExitConfirm | RenderProcessException | NewTab - | AnythingViewOutput | LocalInteractivebarExit | SynchronizationPathName | ChangeTabName | SwitchBuffer - | ShowTooltip | LocalInteractiveReturn | GlobalInteractiveReturn | Ping deriving (Show, Eq, Ord) -data DaemonSignalArgs = NewRenderPageConfirmArgs PageId PageType SignalBoxId PagePlugId ProcessID PageModeName String Bool - | NewAnythingProcessConfirmArgs PagePlugId ProcessID +data DaemonSignalArgs = NewRenderPageConfirmArgs PageId PageType SignalBoxId PagePlugId ProcessID PageModeName String Bool Bool + | NewRenderProcessConfirmArgs PageId PageType ProcessID PageModeName String | RenderProcessExitArgs PageId | RenderProcessExitConfirmArgs PageId ProcessID | RenderProcessExceptionArgs PageId | NewTabArgs PageType PagePath [String] - | AnythingViewOutputArgs String String (Maybe Int) AnythingKeyPressId | LocalInteractivebarExitArgs | SynchronizationPathNameArgs PageModeName PageId String | ChangeTabNameArgs PageModeName PageId String | SwitchBufferArgs PageModeName PageId - | ShowTooltipArgs String (Maybe Point) Int (Maybe Color) (Maybe Color) Bool (Maybe PageId) | LocalInteractiveReturnArgs [String] | GlobalInteractiveReturnArgs [String] | PingArgs ProcessID @@ -279,12 +331,10 @@ | PageViewKeyPress | DestroyRenderPage | ExitRenderProcess - | AnythingViewKeyPress - | AnythingViewChangeCandidate - | AnythingViewChangeInteractiveType | UpdateConfig | InstallConfig | Pong + | RestoreRenderPageState deriving (Show, Eq, Ord) data RenderSignalArgs = CloneRenderPageArgs PageId SignalBoxId @@ -292,13 +342,11 @@ | FocusRenderPageArgs PagePlugId | PageViewKeyPressArgs PagePlugId Text SerializedEvent | DestroyRenderPageArgs PagePlugId - | ExitRenderProcessArgs PageId - | AnythingViewKeyPressArgs Text String String AnythingKeyPressId Bool - | AnythingViewChangeCandidateArgs [String] - | AnythingViewChangeInteractiveTypeArgs AnythingInteractiveType + | ExitRenderProcessArgs PageId Bool | UpdateConfigArgs | InstallConfigArgs | PongArgs + | RestoreRenderPageStateArgs PagePlugId Bool deriving (Show, Eq, Ord) data PongStatus = WaitPongMessage @@ -317,12 +365,7 @@ data GenericDaemonSignalArgs = GenericArgs String [String] deriving (Show, Eq, Ord) -data AnythingSearchArgs = GlobalSearchArgs - | InteractiveSearchArgs AnythingInteractiveType [String] - deriving (Show, Eq, Ord, Read) - -data SpawnProcessArgs = SpawnRenderProcessArgs PageId PageType SignalBoxId PagePath [String] - | SpawnAnythingProcessArgs AnythingSearchArgs +data SpawnProcessArgs = SpawnRenderProcessArgs PageId PageType PagePath [String] [SignalBoxId] Bool deriving (Show, Eq, Ord, Read) $(derive makeBinary ''BrowseHistoryList) @@ -332,3 +375,4 @@ $(derive makeBinary ''PageModeRule) $(derive makeBinary ''PageModeDuplicateList) $(derive makeBinary ''ExtensionGloalKeymap) +$(derive makeBinary ''WelcomeApplication) diff --git a/Manatee/Toolkit/Cabal/Utils.hs b/Manatee/Toolkit/Cabal/Utils.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Cabal/Utils.hs @@ -0,0 +1,42 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 ~ 2011 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 . + +module Manatee.Toolkit.Cabal.Utils where + +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription +import Distribution.Package +import System.FilePath +import Data.Version + +-- | Get package's data directory. +-- Because Paths_.hs just generate after parse Setup.hs, +-- So you can't import Paths_.hs and use `getDataDir` in Setup.hs +-- You can use this function in Setup.hs, same as `getDataDir`. :) +getDataDir :: PackageDescription -> LocalBuildInfo -> FilePath +getDataDir pack_des lbi = dir + where (PackageName name) = pkgName $ package pack_des + version = pkgVersion $ package pack_des + subdirName = name ++ "-" ++ showVersion version + prefixDir = substPathTemplate (package pack_des) lbi (prefix $ installDirTemplates lbi) + dir = prefixDir "share" subdirName + +-- | Get file under datadir. +getDataFilePath :: PackageDescription -> LocalBuildInfo -> FilePath -> FilePath +getDataFilePath pack_des lbi file = + getDataDir pack_des lbi file diff --git a/Manatee/Toolkit/Data/ListZipper.hs b/Manatee/Toolkit/Data/ListZipper.hs --- a/Manatee/Toolkit/Data/ListZipper.hs +++ b/Manatee/Toolkit/Data/ListZipper.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Data/SetList.hs b/Manatee/Toolkit/Data/SetList.hs --- a/Manatee/Toolkit/Data/SetList.hs +++ b/Manatee/Toolkit/Data/SetList.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Data/Unique.hs b/Manatee/Toolkit/Data/Unique.hs --- a/Manatee/Toolkit/Data/Unique.hs +++ b/Manatee/Toolkit/Data/Unique.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Date/DateTime.lhs b/Manatee/Toolkit/Date/DateTime.lhs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Date/DateTime.lhs @@ -0,0 +1,157 @@ +> module Manatee.Toolkit.Date.DateTime where + +> import Data.Fixed (div') +> import Data.Function (on) +> import Data.Maybe (fromJust) +> import Data.Time.Clock hiding (getCurrentTime) +> import Data.Time.Format +> import Data.Time.LocalTime +> -- import Database.HDBC +> import Numeric (fromRat) +> import System.Locale +> import System.Time hiding (toClockTime) + +> import qualified Data.Time.Calendar as Calendar +> import qualified Data.Time.Clock as Clock + +Define a local synonym for UTCTime just to get some insulation from +the craziness of the Haskell standard library date and time functions. + +> type DateTime = UTCTime + +So that we can use our DateTime class with HDBC. + +> -- instance SqlType UTCTime where +> -- toSql = toSql . toClockTime +> -- fromSql = fromClockTime . fromSql + +Defined here so that users don't need to know about Data.Time.Clock. + +> getCurrentTime :: IO DateTime +> getCurrentTime = Clock.getCurrentTime + +Conversion back and forth between DateTime and MJD. + +> toMJD :: DateTime -> Rational +> toMJD = getModJulianDate . toUniversalTime + +> toMJD' :: RealFloat a => DateTime -> a +> toMJD' = fromRat . toMJD + +> fromMJD :: Rational -> DateTime +> fromMJD = fromUniversalTime . ModJulianDate + +> fromMJD' :: RealFloat a => a -> DateTime +> fromMJD' = fromMJD . realToFrac + +> invariant f x = f x == x + +> prop_MJD = invariant $ fromMJD . toMJD +> prop_MJD' = invariant $ fromMJD' . toMJD' + +Because UTCTime is opaque, we need to convert to UniversalTime in +order to do anything with it, but these functions are mainly of +interest internally. + +> toUniversalTime :: DateTime -> UniversalTime +> toUniversalTime = localTimeToUT1 0 . utcToLocalTime utc + +> fromUniversalTime :: UniversalTime -> DateTime +> fromUniversalTime = localTimeToUTC utc . ut1ToLocalTime 0 + +> prop_Universal = invariant $ fromUniversalTime . toUniversalTime + +Take apart a DateTime into pieces and parts. + +> toGregorian' :: DateTime -> (Integer, Int, Int) +> toGregorian' dt = (y, m, d) +> where +> (y, m, d, _, _, _) = toGregorian dt + +> toGregorian :: DateTime -> (Integer, Int, Int, Int, Int, Int) +> toGregorian dt = (year, month, day', hours, minutes, seconds `div'` 1) +> where +> LocalTime day tod = utcToLocalTime utc dt +> (year, month, day') = Calendar.toGregorian day +> TimeOfDay hours minutes seconds = tod + +Combine pieces and parts to produce a DateTime. + +> fromGregorian' :: Integer -> Int -> Int -> DateTime +> fromGregorian' y m d = fromGregorian y m d 0 0 0 + +> fromGregorian :: Integer -> Int -> Int -> Int -> Int -> Int -> DateTime +> fromGregorian year month day hours minutes seconds = +> UTCTime day' (secondsToDiffTime . fromIntegral $ seconds') +> where +> day' = Calendar.fromGregorian year month day +> seconds' = 3600 * hours + 60 * minutes + seconds + +Getting closer to the machine: Not all the functionality of +System.Time is available in Data.Time, and the only way we can convert +back and forth is to go through seconds. + +> toSeconds :: DateTime -> Integer +> toSeconds dt = floor $ +> 86400.0 * fromRational (toMJD dt - startOfTimeMJD) + +> fromSeconds :: Integer -> DateTime +> fromSeconds s = fromMJD $ +> fromIntegral s / 86400 + startOfTimeMJD + +> toClockTime :: DateTime -> ClockTime +> toClockTime dt = TOD (toSeconds dt) 0 + +> fromClockTime :: ClockTime -> DateTime +> fromClockTime (TOD s _) = fromSeconds s + +> startOfTime :: DateTime +> startOfTime = fromGregorian' 1970 1 1 + +> prop_StartOfTime _ = toSeconds startOfTime == 0 + +> startOfTimeMJD :: Rational +> startOfTimeMJD = toMJD startOfTime + +Formatting and parsing, with special attention to the format used by +ODBC and MySQL. + +> toSqlString :: DateTime -> String +> toSqlString = formatDateTime sqlFormat + +> fromSqlString :: String -> Maybe DateTime +> fromSqlString = parseDateTime sqlFormat + +> prop_SqlString dt = (fromJust . fromSqlString . toSqlString $ dt') == dt' +> where +> Just dt' = fromSqlString . toSqlString $ dt + +> prop_SqlStartOfTime _ = toSqlString startOfTime == "1970-01-01 00:00:00" + +> formatDateTime :: String -> DateTime -> String +> formatDateTime = formatTime defaultTimeLocale + +> parseDateTime :: String -> String -> Maybe DateTime +> parseDateTime = parseTime defaultTimeLocale + +> sqlFormat = iso8601DateFormat (Just "%T") + +Simple arithmetic. + +> addMinutes' :: Int -> DateTime -> DateTime +> addMinutes' = addMinutes . fromIntegral + +> addMinutes :: Integer -> DateTime -> DateTime +> addMinutes m = addSeconds (60 * m) + +> diffMinutes' :: DateTime -> DateTime -> Int +> diffMinutes' x = fromIntegral . diffMinutes x + +> diffMinutes :: DateTime -> DateTime -> Integer +> diffMinutes x = (`div` 60) . diffSeconds x + +> addSeconds :: Integer -> DateTime -> DateTime +> addSeconds s dt = fromSeconds $ toSeconds dt + s + +> diffSeconds :: DateTime -> DateTime -> Integer +> diffSeconds = (-) `on` toSeconds diff --git a/Manatee/Toolkit/GConf/GConf.hs b/Manatee/Toolkit/GConf/GConf.hs --- a/Manatee/Toolkit/GConf/GConf.hs +++ b/Manatee/Toolkit/GConf/GConf.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Arrow.hs b/Manatee/Toolkit/General/Arrow.hs --- a/Manatee/Toolkit/General/Arrow.hs +++ b/Manatee/Toolkit/General/Arrow.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Basic.hs b/Manatee/Toolkit/General/Basic.hs --- a/Manatee/Toolkit/General/Basic.hs +++ b/Manatee/Toolkit/General/Basic.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/ByteString.hs b/Manatee/Toolkit/General/ByteString.hs --- a/Manatee/Toolkit/General/ByteString.hs +++ b/Manatee/Toolkit/General/ByteString.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Concurrent.hs b/Manatee/Toolkit/General/Concurrent.hs --- a/Manatee/Toolkit/General/Concurrent.hs +++ b/Manatee/Toolkit/General/Concurrent.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/DBus.hs b/Manatee/Toolkit/General/DBus.hs --- a/Manatee/Toolkit/General/DBus.hs +++ b/Manatee/Toolkit/General/DBus.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Either.hs b/Manatee/Toolkit/General/Either.hs --- a/Manatee/Toolkit/General/Either.hs +++ b/Manatee/Toolkit/General/Either.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/FilePath.hs b/Manatee/Toolkit/General/FilePath.hs --- a/Manatee/Toolkit/General/FilePath.hs +++ b/Manatee/Toolkit/General/FilePath.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Functor.hs b/Manatee/Toolkit/General/Functor.hs --- a/Manatee/Toolkit/General/Functor.hs +++ b/Manatee/Toolkit/General/Functor.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/List.hs b/Manatee/Toolkit/General/List.hs --- a/Manatee/Toolkit/General/List.hs +++ b/Manatee/Toolkit/General/List.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -129,6 +129,10 @@ -- | Like `init`, but accept empty list. init_ [] = [] init_ xs = init xs + +-- | Like `tail`, but accept empty list. +tail_ [] = [] +tail_ xs = tail xs -- | Like `foldl1`, but accept empty list. foldl1_ _ [] = [] diff --git a/Manatee/Toolkit/General/Map.hs b/Manatee/Toolkit/General/Map.hs --- a/Manatee/Toolkit/General/Map.hs +++ b/Manatee/Toolkit/General/Map.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Maybe.hs b/Manatee/Toolkit/General/Maybe.hs --- a/Manatee/Toolkit/General/Maybe.hs +++ b/Manatee/Toolkit/General/Maybe.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Misc.hs b/Manatee/Toolkit/General/Misc.hs --- a/Manatee/Toolkit/General/Misc.hs +++ b/Manatee/Toolkit/General/Misc.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Process.hs b/Manatee/Toolkit/General/Process.hs --- a/Manatee/Toolkit/General/Process.hs +++ b/Manatee/Toolkit/General/Process.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/STM.hs b/Manatee/Toolkit/General/STM.hs --- a/Manatee/Toolkit/General/STM.hs +++ b/Manatee/Toolkit/General/STM.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Seq.hs b/Manatee/Toolkit/General/Seq.hs --- a/Manatee/Toolkit/General/Seq.hs +++ b/Manatee/Toolkit/General/Seq.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Set.hs b/Manatee/Toolkit/General/Set.hs --- a/Manatee/Toolkit/General/Set.hs +++ b/Manatee/Toolkit/General/Set.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/State.hs b/Manatee/Toolkit/General/State.hs --- a/Manatee/Toolkit/General/State.hs +++ b/Manatee/Toolkit/General/State.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/String.hs b/Manatee/Toolkit/General/String.hs --- a/Manatee/Toolkit/General/String.hs +++ b/Manatee/Toolkit/General/String.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 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 @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -20,7 +20,7 @@ import Control.Applicative import Control.Monad -import Data.DateTime hiding (getCurrentTime) +import Manatee.Toolkit.Date.DateTime hiding (getCurrentTime) import Data.Time import System.Glib.GDateTime import System.Locale @@ -86,5 +86,4 @@ day = seconds `div` 86400 showTime time unit = if time == 0 then "" else show time ++ unit - diff --git a/Manatee/Toolkit/General/Typeable.hs b/Manatee/Toolkit/General/Typeable.hs --- a/Manatee/Toolkit/General/Typeable.hs +++ b/Manatee/Toolkit/General/Typeable.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/General/Url.hs b/Manatee/Toolkit/General/Url.hs --- a/Manatee/Toolkit/General/Url.hs +++ b/Manatee/Toolkit/General/Url.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gio/Gio.hs b/Manatee/Toolkit/Gio/Gio.hs --- a/Manatee/Toolkit/Gio/Gio.hs +++ b/Manatee/Toolkit/Gio/Gio.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Glib/GError.hs b/Manatee/Toolkit/Glib/GError.hs --- a/Manatee/Toolkit/Glib/GError.hs +++ b/Manatee/Toolkit/Glib/GError.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/Box.hs b/Manatee/Toolkit/Gtk/Box.hs --- a/Manatee/Toolkit/Gtk/Box.hs +++ b/Manatee/Toolkit/Gtk/Box.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/Cairo.hs b/Manatee/Toolkit/Gtk/Cairo.hs --- a/Manatee/Toolkit/Gtk/Cairo.hs +++ b/Manatee/Toolkit/Gtk/Cairo.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/Concurrent.hs b/Manatee/Toolkit/Gtk/Concurrent.hs --- a/Manatee/Toolkit/Gtk/Concurrent.hs +++ b/Manatee/Toolkit/Gtk/Concurrent.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/Container.hs b/Manatee/Toolkit/Gtk/Container.hs --- a/Manatee/Toolkit/Gtk/Container.hs +++ b/Manatee/Toolkit/Gtk/Container.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/DrawWindow.hs b/Manatee/Toolkit/Gtk/DrawWindow.hs --- a/Manatee/Toolkit/Gtk/DrawWindow.hs +++ b/Manatee/Toolkit/Gtk/DrawWindow.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/Editable.hs b/Manatee/Toolkit/Gtk/Editable.hs --- a/Manatee/Toolkit/Gtk/Editable.hs +++ b/Manatee/Toolkit/Gtk/Editable.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -65,9 +65,8 @@ -- | Set bound. editableSetBound :: EditableClass self => self -> (Int, Int) -> IO () -editableSetBound ed (start, end) = do +editableSetBound ed (start, end) = editableSelectRegion ed start end - editableSetPosition ed start -- | Get status. editableGetStatus :: EditableClass self => self -> IO EditableStatus @@ -92,27 +91,109 @@ -- | Delete backward char. editableDeleteBackwardChar :: EditableClass self => self -> IO () editableDeleteBackwardChar ed = do - unselectText <- editableGetUnselectText ed - editableSetText ed (init_ unselectText) + pos <- editableGetPosition ed + editableDeleteText ed (max (pos - 1) 0) pos +-- | Delete forward char. +editableDeleteForwardChar :: EditableClass self => self -> IO () +editableDeleteForwardChar ed = do + pos <- editableGetPosition ed + len <- editableGetLenth ed + editableDeleteText ed pos (min (pos + 1) len) + -- | Delete backward word. editableDeleteBackwardWord :: EditableClass self => self -> IO () editableDeleteBackwardWord ed = do - unselectText <- editableGetUnselectText ed - let (word, restStr) = searchBackwardWord unselectText + (firstStr, secondStr) <- editableGetParts ed + let (word, restStr) = searchBackwardWord firstStr text = if null word -- If not word at last, delete char. - then init_ unselectText + then init_ firstStr -- Otherwise delete word. else restStr - editableSetText ed text + editableSetText ed (text ++ secondStr) + editableSetPosition ed (length text) +-- | Delete to start. +editableDeleteToStart :: EditableClass self => self -> IO () +editableDeleteToStart ed = do + pos <- editableGetPosition ed + editableDeleteText ed 0 pos + +-- | Delete to end. +editableDeleteToEnd :: EditableClass self => self -> IO () +editableDeleteToEnd ed = do + pos <- editableGetPosition ed + editableDeleteText ed pos (-1) + +-- | Move to start. +editableMoveToStart :: EditableClass self => self -> IO () +editableMoveToStart ed = + editableSetPosition ed 0 + +-- | Move to start. +editableMoveToEnd :: EditableClass self => self -> IO () +editableMoveToEnd ed = + editableSetPosition ed (-1) + +-- | Delete forward word. +editableDeleteForwardWord :: EditableClass self => self -> IO () +editableDeleteForwardWord ed = do + (firstStr, secondStr) <- editableGetParts ed + let (word, restStr) = searchForwardWord secondStr + text = if null word + -- If not word at last, delete char. + then tail_ secondStr + -- Otherwise delete word. + else restStr + editableSetText ed (firstStr ++ text) + editableSetPosition ed (length firstStr) + +-- | Backward word. +editableBackwardWord :: EditableClass self => self -> IO () +editableBackwardWord ed = do + pos <- editableGetPosition ed + (firstStr, _) <- editableGetParts ed + let (word, _) = searchBackwardWord firstStr + offset = if null word + -- If not word at last, delete char. + then 1 + -- Otherwise delete word. + else length word + editableSetPosition ed (max (pos - offset) 0) + +-- | Forward word. +editableForwardWord :: EditableClass self => self -> IO () +editableForwardWord ed = do + pos <- editableGetPosition ed + (firstStr, secondStr) <- editableGetParts ed + let (word, _) = searchForwardWord secondStr + offset = if null word + -- If not word at last, delete char. + then 1 + -- Otherwise delete word. + else length word + editableSetPosition ed (min (pos + offset) (length (firstStr ++ secondStr))) + -- | Backward char. editableBackwardChar :: EditableClass self => self -> IO () editableBackwardChar ed = do pos <- editableGetPosition ed - editableSetPosition ed (if pos >= 1 then pos - 1 else 0) + editableSetPosition ed (max (pos - 1) 0) +-- | Forward char. +editableForwardChar :: EditableClass self => self -> IO () +editableForwardChar ed = do + pos <- editableGetPosition ed + len <- editableGetLenth ed + editableSetPosition ed (min (pos + 1) len) + +-- | Get length of editable. +editableGetLenth :: EditableClass self => self -> IO Int +editableGetLenth ed = + editableGetChars ed 0 (-1) + >>= return . length + -- | Whether changed after do editable action? editableIsChanged :: EditableClass self => self -> IO () -> IO Bool editableIsChanged ed action = do @@ -125,3 +206,15 @@ afterState <- getState return (beforeState /= afterState) +-- | Select all. +editableSelectAll :: EditableClass self => self -> IO () +editableSelectAll ed = + editableSelectRegion ed 0 (-1) + +-- | Get parts that before/after cursor. +editableGetParts :: EditableClass self => self -> IO (String, String) +editableGetParts ed = do + pos <- editableGetPosition ed + firstPart <- editableGetChars ed 0 pos + secondPart <- editableGetChars ed pos (-1) + return (firstPart, secondPart) diff --git a/Manatee/Toolkit/Gtk/Event.hs b/Manatee/Toolkit/Gtk/Event.hs --- a/Manatee/Toolkit/Gtk/Event.hs +++ b/Manatee/Toolkit/Gtk/Event.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/Gtk.hs b/Manatee/Toolkit/Gtk/Gtk.hs --- a/Manatee/Toolkit/Gtk/Gtk.hs +++ b/Manatee/Toolkit/Gtk/Gtk.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -125,6 +125,16 @@ height <- screenGetHeight screen return (width, height) +-- | Get default screen size. +getDefaultScreenSize :: IO (Int, Int) +getDefaultScreenSize = do + displayManager <- displayManagerGet + display <- get displayManager displayManagerDefaultDisplay + screen <- displayGetDefaultScreen display + width <- screenGetWidth screen + height <- screenGetHeight screen + return (width, height) + -- | Create image widget with given icon name and size. imageNewFromIcon :: String -> Int -> IO Image imageNewFromIcon iconName size = do @@ -163,3 +173,21 @@ colorToRGB :: Color -> (Double, Double, Double) colorToRGB (Color r g b) = (i2d r / 65535, i2d g / 65535, i2d b / 65535) + +-- | Get pixbuf snapshot of widget. +widgetGetSnapshotPixbuf :: WidgetClass widget => widget -> IO (Maybe Pixbuf) +widgetGetSnapshotPixbuf widget = do + rect@(Rectangle x y w h) <- widgetGetAllocation widget + pixmap <- widgetGetSnapshot widget rect + case pixmap of + Just d -> pixbufGetFromDrawable d (Rectangle 0 0 (w - x) (h - y)) + Nothing -> return Nothing + +-- | Connect widget. +connectWidgets :: (ContainerClass container, WidgetClass widget) => [container] -> widget -> IO () +connectWidgets [] _ = return () +connectWidgets [container] widget = + container `containerAdd` widget +connectWidgets (x:y:z) widget = do + x `containerAdd` y + connectWidgets (y:z) widget diff --git a/Manatee/Toolkit/Gtk/Label.hs b/Manatee/Toolkit/Gtk/Label.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Label.hs @@ -0,0 +1,28 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 ~ 2011 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 . + +module Manatee.Toolkit.Gtk.Label where + +import Graphics.UI.Gtk + +-- | Label with special color. +labelNewWithColor :: String -> Color -> IO Label +labelNewWithColor content color = do + label <- labelNew (Just content) + set label [labelAttributes := [AttrForeground 0 (length content) color]] + return label diff --git a/Manatee/Toolkit/Gtk/ModelView.hs b/Manatee/Toolkit/Gtk/ModelView.hs --- a/Manatee/Toolkit/Gtk/ModelView.hs +++ b/Manatee/Toolkit/Gtk/ModelView.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -333,3 +333,98 @@ currentPath <- treeModelSortConvertPathToChildPath sortModel path liftM Just $ listStoreGetValue listStore (head currentPath) +-- | Icon view select first. +iconViewSelectFirstNode :: IconViewClass iconView => iconView -> IO () +iconViewSelectFirstNode iconView = + iconViewSelectItem iconView [0] + +-- | Icon view select last top node. +iconViewSelectLastNode :: IconViewClass iconView => iconView -> IO () +iconViewSelectLastNode iconView = + iconViewGetModel iconView >?>= \model -> do + lastPath <- treeModelLastToplevelPath model + iconViewSelectItem iconView lastPath + +-- | Icon view select element. +iconViewSelectItem :: IconViewClass iconView => iconView -> TreePath -> IO () +iconViewSelectItem iconView path = do + iconViewSetCursor iconView (Left path :: Either TreePath CellRendererText) False + iconViewSelectPath iconView path + +-- | Select next node. +iconViewSelectNextColumnNode :: IconViewClass iconView => iconView -> IO () +iconViewSelectNextColumnNode iconView = do + path <- iconViewGetSelectPath iconView + case path of + Nothing -> iconViewSelectFirstNode iconView + Just currentPath -> do + number <- iconViewGetNodeCount iconView + let currentRootNode = head currentPath + when (currentRootNode < number - 1) $ + iconViewSelectItem iconView [currentRootNode + 1] + +-- | Select previous node. +iconViewSelectPrevColumnNode :: IconViewClass iconView => iconView -> IO () +iconViewSelectPrevColumnNode iconView = do + path <- iconViewGetSelectPath iconView + case path of + Nothing -> iconViewSelectFirstNode iconView + Just currentPath -> do + let currentRootNode = head currentPath + when (currentRootNode > 0) $ + iconViewSelectItem iconView [currentRootNode - 1] + +-- | Select next row node. +iconViewSelectNextRowNode :: IconViewClass iconView => iconView -> IO () +iconViewSelectNextRowNode iconView = do + path <- iconViewGetSelectPath iconView + case path of + Nothing -> iconViewSelectFirstNode iconView + Just currentPath -> do + number <- iconViewGetNodeCount iconView + columns <- iconViewGetColumns iconView + let currentRootNode = head currentPath + when (currentRootNode + columns <= number - 1) $ + iconViewSelectItem iconView [currentRootNode + columns] + +-- | Select previous node. +iconViewSelectPrevRowNode :: IconViewClass iconView => iconView -> IO () +iconViewSelectPrevRowNode iconView = do + path <- iconViewGetSelectPath iconView + case path of + Nothing -> iconViewSelectFirstNode iconView + Just currentPath -> do + columns <- iconViewGetColumns iconView + let currentRootNode = head currentPath + when (currentRootNode - columns >= 0) $ + iconViewSelectItem iconView [currentRootNode - columns] + +-- | Icon view activated cursor. +iconViewActivatedCursor :: IconViewClass iconView => iconView -> IO () +iconViewActivatedCursor iconView = + iconViewGetSelectPath iconView >?>= \path -> + iconViewItemActivated iconView path + +-- | Icon view get select path. +iconViewGetSelectPath :: IconViewClass iconView => iconView -> IO (Maybe TreePath) +iconViewGetSelectPath iconView = do + (path, _) <- iconViewGetCursor iconView + case path of + [] -> return Nothing + _ -> return $ Just path + +-- | Get number of toplevel node in TreeView. +iconViewGetNodeCount :: IconViewClass iconView => iconView -> IO Int +iconViewGetNodeCount iconView = do + model <- iconViewGetModel iconView + case model of + Just ml -> treeModelGetToplevelNodeCount ml + Nothing -> return 0 + +-- | Icon view focus. +iconViewFocus :: IconViewClass iconView => iconView -> IO () +iconViewFocus iconView = do + path <- iconViewGetSelectPath iconView + case path of + Just p -> iconViewSelectItem iconView p + Nothing -> iconViewSelectFirstNode iconView 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 @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -359,7 +359,7 @@ = lineCount | otherwise = line - -- Line number count from 0, so need increase '1' + -- Line number count from 0, so need decreases '1' iter <- textBufferGetIterAtLine tb (lineNumber - 1) textViewPlaceCursor tv iter @@ -975,6 +975,33 @@ -- Backward line. textViewBackwardLine tv swc +-- | Get cursor align. +textViewGetCursorAlign :: TextViewClass tvc => tvc -> IO (Double, Double) +textViewGetCursorAlign tv = do + -- Get adjustment value. + hAdj <- textViewGetHadjustment tv + vAdj <- textViewGetVadjustment tv + hVal <- adjustmentGetValue hAdj + vVal <- adjustmentGetValue vAdj + hSize <- adjustmentGetPageSize hAdj + vSize <- adjustmentGetPageSize vAdj + + -- Get cursor coordinate. + ti <- textViewGetTextIter tv + (Rectangle ix iy _ _) <- textViewGetIterLocation tv ti + + -- Get cursor alignment. + let xAlign = if hSize == 0 then 0 else (i2d ix - hVal) / hSize + yAlign = if vSize == 0 then 0 else (i2d iy - vVal) / vSize + + return (xAlign, yAlign) + +-- | Set cursor align. +textViewSetCursorAlign :: TextViewClass tvc => tvc -> (Double, Double) -> IO () +textViewSetCursorAlign tv align = do + tm <- (<=<) textBufferGetInsert textViewGetBuffer tv + textViewScrollToMark tv tm 0.0 (Just align) + -- | Move to `first iter` of buffer. textIterBackwardToStart :: TextIter -> IO () textIterBackwardToStart ti = do diff --git a/Manatee/Toolkit/Gtk/Notebook.hs b/Manatee/Toolkit/Gtk/Notebook.hs --- a/Manatee/Toolkit/Gtk/Notebook.hs +++ b/Manatee/Toolkit/Gtk/Notebook.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Gtk/ScrolledWindow.hs b/Manatee/Toolkit/Gtk/ScrolledWindow.hs --- a/Manatee/Toolkit/Gtk/ScrolledWindow.hs +++ b/Manatee/Toolkit/Gtk/ScrolledWindow.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -160,3 +160,11 @@ hSize <- adjustmentGetUpper hAdj vSize <- adjustmentGetUpper vAdj return (hSize, vSize) + +-- | Set upper. +scrolledWindowSetUpper :: ScrolledWindowClass sw => sw -> (Double, Double) -> IO () +scrolledWindowSetUpper sw (w, h) = do + hAdj <- scrolledWindowGetHAdjustment sw + vAdj <- scrolledWindowGetVAdjustment sw + adjustmentSetUpper hAdj w + adjustmentSetUpper vAdj h diff --git a/Manatee/Toolkit/Gtk/Struct.hs b/Manatee/Toolkit/Gtk/Struct.hs --- a/Manatee/Toolkit/Gtk/Struct.hs +++ b/Manatee/Toolkit/Gtk/Struct.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Widget/CompletionWindow.hs b/Manatee/Toolkit/Widget/CompletionWindow.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/CompletionWindow.hs @@ -0,0 +1,114 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 ~ 2011 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 . + +module Manatee.Toolkit.Widget.CompletionWindow where + +import Control.Applicative +import Graphics.UI.Gtk +import Manatee.Toolkit.Widget.PopupWindow +import Manatee.Toolkit.Gtk.ScrolledWindow + +data CompletionWindow = + CompletionWindow {cwWindow :: PopupWindow + ,cwNotebook :: Notebook + ,cwCandidateScrolledWindow :: ScrolledWindow + ,cwCandidateTab :: TreeView + ,cwCommandScrolledWindow :: ScrolledWindow + ,cwCommandTab :: TreeView + } + +-- | Candidate tab index in notebook. +candidateTabIndex :: Int +candidateTabIndex = 0 + +-- | Command tab index in notebook. +commandTabIndex :: Int +commandTabIndex = 0 + +-- | Completion new. +completionWindowNew :: IO CompletionWindow +completionWindowNew = do + -- Create component. + window <- popupWindowNew + + -- Notebook. + notebook <- notebookNew + notebookSetTabPos notebook PosBottom + notebookSetShowTabs notebook False + + -- Candidate tab. + candidateScrolledWindow <- scrolledWindowNew_ + candidateTab <- treeViewNew + + -- Command tab. + commandScrolledWindow <- scrolledWindowNew_ + commandTab <- treeViewNew + + -- Connect component. + pwFrame window `containerAdd` notebook + candidateScrolledWindow `containerAdd` candidateTab + commandScrolledWindow `containerAdd` commandTab + notebookInsertPage notebook candidateScrolledWindow "Candidate Tab" candidateTabIndex + notebookInsertPage notebook commandScrolledWindow "Command Tab" commandTabIndex + + -- Create completion window. + return $ CompletionWindow window notebook candidateScrolledWindow candidateTab commandScrolledWindow commandTab + +-- | Show completion window. +completionWindowShow :: WidgetClass widget => CompletionWindow -> widget -> Rectangle -> IO () +completionWindowShow (CompletionWindow {cwWindow = win}) + parent rect = do + popupWindowStickParent win parent + popupWindowSetAllocation win rect + popupWindowShow win + +-- | Hide completion window. +completionWindowHide :: CompletionWindow -> IO () +completionWindowHide = + popupWindowHide . cwWindow + +-- | Set candidate. +completionWindowSetCandidates :: CompletionWindow -> [(String, [String])] -> IO () +completionWindowSetCandidates window candidates = + return () + +-- | Set command. +completionWindowSetCommands :: CompletionWindow -> [String] -> IO () +completionWindowSetCommands window commands = + return () + +-- | Show candidate tab. +completionWindowShowCandidateTab :: CompletionWindow -> IO () +completionWindowShowCandidateTab window = + notebookSetCurrentPage (cwNotebook window) candidateTabIndex + +-- | Show command tab. +completionWindowShowCommandTab :: CompletionWindow -> IO () +completionWindowShowCommandTab window = + notebookSetCurrentPage (cwNotebook window) commandTabIndex + +-- | Is focus candidate tab. +completionWindowIsFocusCandidateTab :: CompletionWindow -> IO Bool +completionWindowIsFocusCandidateTab window = + (candidateTabIndex ==) <$> notebookGetCurrentPage (cwNotebook window) + +-- | Is focus command tab. +completionWindowIsFocusCommandTab :: CompletionWindow -> IO Bool +completionWindowIsFocusCommandTab window = + (commandTabIndex ==) <$> notebookGetCurrentPage (cwNotebook window) + diff --git a/Manatee/Toolkit/Widget/Interactivebar.hs b/Manatee/Toolkit/Widget/Interactivebar.hs --- a/Manatee/Toolkit/Widget/Interactivebar.hs +++ b/Manatee/Toolkit/Widget/Interactivebar.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -79,6 +79,11 @@ interactivebarSetTitle :: Interactivebar -> String -> IO () interactivebarSetTitle bar = labelSetText (interactivebarTitleLabel bar) + +-- | Get title. +interactivebarGetTitle :: Interactivebar -> IO String +interactivebarGetTitle = + labelGetText . interactivebarTitleLabel -- | Set content. interactivebarSetContent :: Interactivebar -> String -> IO () diff --git a/Manatee/Toolkit/Widget/KeymapWindow.hs b/Manatee/Toolkit/Widget/KeymapWindow.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/KeymapWindow.hs @@ -0,0 +1,119 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 ~ 2011 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 OverloadedStrings #-} +module Manatee.Toolkit.Widget.KeymapWindow where + +import Control.Applicative +import Control.Monad +import Data.Text.Lazy (Text, unpack) +import Graphics.UI.Gtk +import Manatee.Toolkit.Gtk.Container +import Manatee.Toolkit.Gtk.Gtk + +data KeymapWindow = + KeymapWindow {kwWindow :: Window + ,kwScrolledWindow :: ScrolledWindow + ,kwBox :: VBox + } + +-- | Application name column id. +columnId = makeColumnIdString 0 + +-- | Keymap window new. +keymapWindowNew :: IO KeymapWindow +keymapWindowNew = do + -- Init. + window <- windowNew + set window [windowTypeHint := WindowTypeHintDialog + ,windowDecorated := False + ,windowAcceptFocus := False + ,windowResizable := True -- this make window can smaller than last size + ,windowOpacity := 0.9 + ] + scrolledWindow <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scrolledWindow PolicyNever PolicyAutomatic + box <- vBoxNew False 0 + + -- Connect widgets. + connectWidgets [castToContainer window] scrolledWindow + scrolledWindowAddWithViewport scrolledWindow box + + return $ KeymapWindow window scrolledWindow box + +-- | Show keymap window. +keymapWindowShow :: WidgetClass widget + => KeymapWindow + -> widget -- module widget + -> Rectangle -- position and size + -> [(String, [(Text, Text)])] -- keymap + -> IO () +keymapWindowShow (KeymapWindow {kwWindow = window + ,kwBox = box}) + widget + (Rectangle x y w h) + keymap = do + -- Set transient window. + castToWindow <$> widgetGetToplevel widget + >>= windowSetTransientFor window + + -- Set window position and size. + windowMove window x y + widgetSetSizeRequest window w h + windowResize window w h + + -- Add keymap. + forM_ keymap $ \ (keymapTitle, list) -> do + -- Add keymap title. + label <- labelNew Nothing + labelSetMarkup label ("" ++ keymapTitle ++ "") + boxPackStart box label PackNatural 0 + + -- Add keymap content. + let items = map (\ (key, command) -> + "" + ++ concatMap (\c -> if c == ' ' then "Space" else [c]) (unpack key) + ++ "" + ++ " " + ++ unpack command + ++ "") + list + store <- listStoreNew items + customStoreSetColumn store columnId id + iconView <- iconViewNewWithModel store + iconViewSetMarkupColumn iconView columnId + widgetModifyBase iconView StateNormal (Color 15360 15104 14080) + boxPackStart box iconView PackGrow 0 + + -- Show. + widgetShowAll window + +-- | Hide keymap window. +keymapWindowHide :: KeymapWindow -> IO () +keymapWindowHide view = do + widgetHide $ kwWindow view + containerRemoveAll $ kwBox view + +-- | Is visible. +keymapWindowIsVisible :: KeymapWindow -> IO Bool +keymapWindowIsVisible win = get (kwWindow win) widgetVisible + +-- | Exit. +keymapWindowExit :: KeymapWindow -> IO () +keymapWindowExit = widgetDestroy . kwWindow + diff --git a/Manatee/Toolkit/Widget/NotebookTab.hs b/Manatee/Toolkit/Widget/NotebookTab.hs --- a/Manatee/Toolkit/Widget/NotebookTab.hs +++ b/Manatee/Toolkit/Widget/NotebookTab.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Widget/Outputbar.hs b/Manatee/Toolkit/Widget/Outputbar.hs --- a/Manatee/Toolkit/Widget/Outputbar.hs +++ b/Manatee/Toolkit/Widget/Outputbar.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Widget/Plug.hs b/Manatee/Toolkit/Widget/Plug.hs --- a/Manatee/Toolkit/Widget/Plug.hs +++ b/Manatee/Toolkit/Widget/Plug.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/Manatee/Toolkit/Widget/PopupWindow.hs b/Manatee/Toolkit/Widget/PopupWindow.hs --- a/Manatee/Toolkit/Widget/PopupWindow.hs +++ b/Manatee/Toolkit/Widget/PopupWindow.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -43,7 +43,6 @@ ,windowWindowPosition := WinPosCenter ,windowDecorated := False ,windowAcceptFocus := False - ,windowDestroyWithParent := True ,windowResizable := True -- this make window can smaller than last size ] diff --git a/Manatee/Toolkit/Widget/Statusbar.hs b/Manatee/Toolkit/Widget/Statusbar.hs --- a/Manatee/Toolkit/Widget/Statusbar.hs +++ b/Manatee/Toolkit/Widget/Statusbar.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -41,8 +41,17 @@ Statusbar {statusbarBox :: HBox ,statusbarInfoSubitem :: StatusbarSubitem ,statusbarInfoTable :: TVar StatusbarInfoTable + ,statusbarProgressAlign :: Alignment ,statusbarProgressBar :: ProgressBar} +-- | Progress bar padding. +progressPadding :: Int +progressPadding = 3 + +-- | Progress height. +progressHeight :: Int +progressHeight = 3 + -- | Create new statusbar. statusbarNew :: BoxClass b => b -> IO Statusbar statusbarNew b = do @@ -50,10 +59,22 @@ statusBox <- hBoxNew False 0 boxPackStart (toBox b) statusBox PackNatural 0 + -- Progress box. + progressAlign <- alignmentNew 0.0 0.5 1.0 1.0 + alignmentSetPadding progressAlign progressPadding progressPadding progressPadding progressPadding + + -- Progress bar. + progressBar <- progressBarNew + widgetSetSizeRequest progressBar (-1) progressHeight + + -- Connect. + progressAlign `containerAdd` progressBar + Statusbar <$> pure statusBox <*> statusbarSubitemNew statusBox <*> newTVarIO Seq.empty - <*> progressBarNew + <*> pure progressAlign + <*> pure progressBar -- | Clone statusbar. statusbarClone :: BoxClass b => b -> Statusbar -> IO Statusbar @@ -123,12 +144,13 @@ -- | Update progress status. statusbarProgressUpdate :: Statusbar -> Double -> IO () -statusbarProgressUpdate (Statusbar {statusbarBox = box - ,statusbarProgressBar = progressBar}) +statusbarProgressUpdate (Statusbar {statusbarBox = box + ,statusbarProgressAlign = progressAlign + ,statusbarProgressBar = progressBar}) progress = do -- Show progress bar first. - boxTryPack box progressBar PackNatural Nothing Nothing - widgetShowAll progressBar + boxTryPack box progressAlign PackNatural Nothing Nothing + widgetShowAll progressAlign -- Set progress. set progressBar [progressBarFraction := progress / 100] @@ -138,6 +160,6 @@ when (progress == 100.0) $ timeoutAdd (do set progressBar [progressBarFraction := 0] - containerTryRemove box progressBar + containerTryRemove box progressAlign return False) 100 >> return () diff --git a/Manatee/Toolkit/Widget/Tooltip.hs b/Manatee/Toolkit/Widget/Tooltip.hs --- a/Manatee/Toolkit/Widget/Tooltip.hs +++ b/Manatee/Toolkit/Widget/Tooltip.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 @@ -18,40 +18,29 @@ module Manatee.Toolkit.Widget.Tooltip where -import Control.Concurrent.STM +import Control.Applicative import Control.Monad.Trans import Data.Maybe -import Data.Ord -import Data.Set import Graphics.UI.Gtk hiding (Tooltip) -import Manatee.Toolkit.General.Maybe -import Manatee.Toolkit.General.STM -import Manatee.Toolkit.General.Set import Manatee.Toolkit.Gtk.Gtk -import qualified Data.Function as F - data Tooltip = - Tooltip {tooltipId :: Int - ,tooltipWindow :: Window -- window for contain widget + Tooltip {tooltipWindow :: Window -- window for contain widget ,tooltipDependWindow :: Window -- depend window for control display ,tooltipLabel :: Label -- label to container text - ,tooltipTimeout :: Int -- timeout for display (in millisecond) - ,tooltipHideWhenPress :: Bool -- hide when press + ,tooltipTimeout :: Int -- timeout for display (in millisecond) ,tooltipFocusInConnectId :: ConnectId Window ,tooltipFocusOutConnectId:: ConnectId Window } -instance Eq Tooltip where - (==) = (==) `F.on` tooltipId - -instance Ord Tooltip where - compare = comparing tooltipId - -- | Align size. tooltipAlignSize :: Int tooltipAlignSize = 10 +-- | Default tooltip timeout. +tooltipDefaultTimeout :: Int +tooltipDefaultTimeout = 3000 + -- | Default foreground color. tooltipDefaultForegroundColor :: Color tooltipDefaultForegroundColor = Color 0 0 0 @@ -61,17 +50,21 @@ tooltipDefaultBackgroundColor = Color 65335 65335 0 -- | New tooltip. -tooltipNew :: Int -- ^ id - -> Window -- ^ top-level parent window +tooltipNew :: WidgetClass widget + => widget -- ^ top-level parent window -> String -- ^ text -> Maybe Point -- ^ point, 'Nothing' will set right-top corner of screen - -> Int -- ^ timeout + -> Maybe Int -- ^ timeout -> Maybe Color -- ^ foreground color -> Maybe Color -- ^ background color - -> Bool -- ^ weather hide when key press - -> TVar (Set Tooltip) -- ^ set to manage temporary tooltip -> IO Tooltip -tooltipNew tId win text position timeout fColor bColor hideWhenPress tooltipSet = do +tooltipNew widget text position time fColor bColor = do + -- Get window. + win <- castToWindow <$> widgetGetToplevel widget + let timeout = case time of + Just t -> t + Nothing -> tooltipDefaultTimeout + -- Set color. let foregroundColor = fromMaybe tooltipDefaultForegroundColor fColor backgroundColor = fromMaybe tooltipDefaultBackgroundColor bColor @@ -150,36 +143,23 @@ stopEvent -- Create tooltip. - let tooltip = Tooltip tId window win label timeout hideWhenPress focusInConnectId focusOutConnectId + let tooltip = Tooltip window win label timeout focusInConnectId focusOutConnectId -- Destroy tooltip when out of timeout. - timeoutAdd (tooltipExit tooltip tooltipSet >> return False) timeout + timeoutAdd (tooltipExit tooltip >> return False) timeout return tooltip -- | Exit tooltip. -tooltipExit :: Tooltip -> TVar (Set Tooltip) -> IO () -tooltipExit Tooltip {tooltipId = tId - ,tooltipWindow = window - ,tooltipHideWhenPress = hideWhenPress +tooltipExit :: Tooltip -> IO () +tooltipExit Tooltip {tooltipWindow = window ,tooltipFocusInConnectId = focusInConnectId ,tooltipFocusOutConnectId = focusOutConnectId } - tooltipSet = do - let exitAction = do - -- Disconnect signal first. - signalDisconnect focusInConnectId - signalDisconnect focusOutConnectId - - -- Destroy tooltip. - widgetDestroy window + = do + -- Disconnect signal first. + signalDisconnect focusInConnectId + signalDisconnect focusOutConnectId - if hideWhenPress - -- If tooltip will hide after press key, remove from set first. - then do - set <- readTVarIO tooltipSet - maybeFindMin set (\x -> tooltipId x == tId) - ?>= \ tooltip -> do - modifyTVarIO tooltipSet (delete tooltip) - exitAction - else exitAction + -- Destroy tooltip. + widgetDestroy window diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,7 +1,7 @@ -- Author: Andy Stewart -- Maintainer: Andy Stewart -- --- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- Copyright (C) 2010 ~ 2011 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 diff --git a/manatee-core.cabal b/manatee-core.cabal --- a/manatee-core.cabal +++ b/manatee-core.cabal @@ -1,15 +1,15 @@ name: manatee-core -version: 0.0.8 +version: 0.1.0 Cabal-Version: >= 1.6 license: GPL-3 license-file: LICENSE -copyright: (c) 2009 ~ 2010 Andy Stewart +copyright: (c) 2010 ~ 2011 Andy Stewart synopsis: The core of Manatee. description: manatee-core is core package of Manatee (Haskell/Gtk+ Integrated Live Environment) . To provide basic communication protocol and toolkit. . - Video at (Select 720p HD) at : + Video (Select 720p HD) at : . Screenshots at : . @@ -24,7 +24,7 @@ stability: provisional category: Manatee, Operating System, Desktop Environment, IDE -tested-with: GHC==6.12.3 +tested-with: GHC==7.0.2 build-type: Simple Source-Repository head @@ -38,13 +38,12 @@ network >= 2.2.1.5, template-haskell >= 2.4.0.0, gtk-serialized-event >= 0.12.0, 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, + Cabal >= 1.8.0.2, old-locale >= 1.0.0.2, bytestring, split, dataenc, 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 Manatee.Core.PageFrame @@ -55,9 +54,12 @@ Manatee.Core.Types Manatee.Core.Render + Manatee.Toolkit.Cabal.Utils + Manatee.Toolkit.Data.ListZipper Manatee.Toolkit.Data.SetList Manatee.Toolkit.Data.Unique + Manatee.Toolkit.Date.DateTime Manatee.Toolkit.GConf.GConf @@ -82,7 +84,7 @@ Manatee.Toolkit.General.Time Manatee.Toolkit.General.Typeable Manatee.Toolkit.General.Url - + Manatee.Toolkit.Glib.GError Manatee.Toolkit.Gio.Gio @@ -95,17 +97,20 @@ Manatee.Toolkit.Gtk.Editable Manatee.Toolkit.Gtk.Event Manatee.Toolkit.Gtk.Gtk + Manatee.Toolkit.Gtk.Label Manatee.Toolkit.Gtk.ModelView Manatee.Toolkit.Gtk.Multiline Manatee.Toolkit.Gtk.Notebook Manatee.Toolkit.Gtk.ScrolledWindow Manatee.Toolkit.Gtk.Struct + Manatee.Toolkit.Widget.CompletionWindow Manatee.Toolkit.Widget.Interactivebar Manatee.Toolkit.Widget.NotebookTab Manatee.Toolkit.Widget.Outputbar Manatee.Toolkit.Widget.Plug Manatee.Toolkit.Widget.PopupWindow + Manatee.Toolkit.Widget.KeymapWindow Manatee.Toolkit.Widget.Statusbar Manatee.Toolkit.Widget.Tooltip