manatee-core 0.0.8 → 0.1.0

raw patch · 67 files changed

+1712/−338 lines, 67 filesdep −datetimesetup-changed

Dependencies removed: datetime

Files

Manatee/Core/Config.hs +38/−4
Manatee/Core/DBus.hs +1/−1
Manatee/Core/Debug.hs +1/−1
Manatee/Core/Dynload.hs +2/−2
Manatee/Core/FileOpenRule.hs +1/−1
Manatee/Core/Interactive.hs +0/−48
Manatee/Core/Page.hs +5/−4
Manatee/Core/PageFrame.hs +77/−10
Manatee/Core/PageMode.hs +1/−1
Manatee/Core/PageView.hs +447/−47
Manatee/Core/Render.hs +204/−53
Manatee/Core/TH.hs +1/−1
Manatee/Core/Types.hs +88/−44
Manatee/Toolkit/Cabal/Utils.hs +42/−0
Manatee/Toolkit/Data/ListZipper.hs +1/−1
Manatee/Toolkit/Data/SetList.hs +1/−1
Manatee/Toolkit/Data/Unique.hs +1/−1
Manatee/Toolkit/Date/DateTime.lhs +157/−0
Manatee/Toolkit/GConf/GConf.hs +1/−1
Manatee/Toolkit/General/Arrow.hs +1/−1
Manatee/Toolkit/General/Basic.hs +1/−1
Manatee/Toolkit/General/ByteString.hs +1/−1
Manatee/Toolkit/General/Concurrent.hs +1/−1
Manatee/Toolkit/General/DBus.hs +1/−1
Manatee/Toolkit/General/Either.hs +1/−1
Manatee/Toolkit/General/FilePath.hs +1/−1
Manatee/Toolkit/General/Functor.hs +1/−1
Manatee/Toolkit/General/List.hs +5/−1
Manatee/Toolkit/General/Map.hs +1/−1
Manatee/Toolkit/General/Maybe.hs +1/−1
Manatee/Toolkit/General/Misc.hs +1/−1
Manatee/Toolkit/General/Process.hs +1/−1
Manatee/Toolkit/General/STM.hs +1/−1
Manatee/Toolkit/General/Seq.hs +1/−1
Manatee/Toolkit/General/Set.hs +1/−1
Manatee/Toolkit/General/State.hs +1/−1
Manatee/Toolkit/General/String.hs +1/−1
Manatee/Toolkit/General/Time.hs +2/−3
Manatee/Toolkit/General/Typeable.hs +1/−1
Manatee/Toolkit/General/Url.hs +1/−1
Manatee/Toolkit/Gio/Gio.hs +1/−1
Manatee/Toolkit/Glib/GError.hs +1/−1
Manatee/Toolkit/Gtk/Box.hs +1/−1
Manatee/Toolkit/Gtk/Cairo.hs +1/−1
Manatee/Toolkit/Gtk/Concurrent.hs +1/−1
Manatee/Toolkit/Gtk/Container.hs +1/−1
Manatee/Toolkit/Gtk/DrawWindow.hs +1/−1
Manatee/Toolkit/Gtk/Editable.hs +103/−10
Manatee/Toolkit/Gtk/Event.hs +1/−1
Manatee/Toolkit/Gtk/Gtk.hs +29/−1
Manatee/Toolkit/Gtk/Label.hs +28/−0
Manatee/Toolkit/Gtk/ModelView.hs +96/−1
Manatee/Toolkit/Gtk/Multiline.hs +29/−2
Manatee/Toolkit/Gtk/Notebook.hs +1/−1
Manatee/Toolkit/Gtk/ScrolledWindow.hs +9/−1
Manatee/Toolkit/Gtk/Struct.hs +1/−1
Manatee/Toolkit/Widget/CompletionWindow.hs +114/−0
Manatee/Toolkit/Widget/Interactivebar.hs +6/−1
Manatee/Toolkit/Widget/KeymapWindow.hs +119/−0
Manatee/Toolkit/Widget/NotebookTab.hs +1/−1
Manatee/Toolkit/Widget/Outputbar.hs +1/−1
Manatee/Toolkit/Widget/Plug.hs +1/−1
Manatee/Toolkit/Widget/PopupWindow.hs +1/−2
Manatee/Toolkit/Widget/Statusbar.hs +29/−7
Manatee/Toolkit/Widget/Tooltip.hs +28/−48
Setup.hs +1/−1
manatee-core.cabal +12/−7

Manatee/Core/Config.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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-

Manatee/Core/DBus.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/Debug.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/Dynload.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/FileOpenRule.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

− Manatee/Core/Interactive.hs

@@ -1,48 +0,0 @@--- Author:     Andy Stewart <lazycat.manatee@gmail.com>--- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>--- --- 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 <http://www.gnu.org/licenses/>.--{-# 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"-

Manatee/Core/Page.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/PageFrame.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/PageMode.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/PageView.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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 ()+

Manatee/Core/Render.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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 <http://www.gnu.org/licenses/>. +{-# 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)

Manatee/Core/TH.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Core/Types.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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)

+ Manatee/Toolkit/Cabal/Utils.hs view

@@ -0,0 +1,42 @@+-- Author:     Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- 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 <http://www.gnu.org/licenses/>.++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_<pkg>.hs just generate after parse Setup.hs,+-- So you can't import Paths_<pkg>.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

Manatee/Toolkit/Data/ListZipper.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Data/SetList.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Data/Unique.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

+ Manatee/Toolkit/Date/DateTime.lhs view

@@ -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

Manatee/Toolkit/GConf/GConf.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Arrow.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Basic.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/ByteString.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Concurrent.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/DBus.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Either.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/FilePath.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Functor.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/List.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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_ _ [] = []

Manatee/Toolkit/General/Map.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Maybe.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Misc.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Process.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/STM.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Seq.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Set.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/State.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/String.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Time.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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-

Manatee/Toolkit/General/Typeable.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/General/Url.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gio/Gio.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Glib/GError.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Box.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Cairo.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Concurrent.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Container.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/DrawWindow.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Editable.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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)

Manatee/Toolkit/Gtk/Event.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Gtk.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

+ Manatee/Toolkit/Gtk/Label.hs view

@@ -0,0 +1,28 @@+-- Author:     Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- 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 <http://www.gnu.org/licenses/>.++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

Manatee/Toolkit/Gtk/ModelView.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Multiline.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Notebook.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/ScrolledWindow.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Manatee/Toolkit/Gtk/Struct.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

@@ -0,0 +1,114 @@+-- Author:     Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- 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 <http://www.gnu.org/licenses/>.++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)+

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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 ()

@@ -0,0 +1,119 @@+-- Author:     Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- 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 <http://www.gnu.org/licenses/>.++{-# 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 ("<span foreground='#000000'><big>" ++ keymapTitle ++ "</big></span>")+    boxPackStart box label PackNatural 0 ++    -- Add keymap content.+    let items = map (\ (key, command) -> +                         "<span foreground='#FF7E00' weight='bold'>" +                         ++ concatMap (\c -> if c == ' ' then "Space" else [c]) (unpack key)+                         ++ "</span>" +                         ++ " <span foreground='#FFFFFF'>" +                         ++ unpack command +                         ++ "</span>")+                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+

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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              ]

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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 ()

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

Setup.hs view

@@ -1,7 +1,7 @@ -- Author:     Andy Stewart <lazycat.manatee@gmail.com> -- Maintainer: Andy Stewart <lazycat.manatee@gmail.com> -- --- 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

manatee-core.cabal view

@@ -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 : <http://www.youtube.com/watch?v=weS6zys3U8k> <http://www.youtube.com/watch?v=A3DgKDVkyeM> <http://v.youku.com/v_show/id_XMjI2MDMzODI4.html>+ Video (Select 720p HD) at : <http://www.youtube.com/watch?v=weS6zys3U8k> <http://www.youtube.com/watch?v=A3DgKDVkyeM> <http://v.youku.com/v_show/id_XMjI2MDMzODI4.html>  .  Screenshots at : <http://goo.gl/MkVw>  .@@ -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