PageView.hs

-- 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.PageView where

import Control.Concurrent.STM 
import Control.Exception
import Control.Monad
import DBus.Client hiding (Signal)
import DBus.Message
import DBus.Types
import Manatee.Core.DBus
import Manatee.Core.Interactive
import Manatee.Core.Types
import Manatee.Toolkit.General.Basic
import Manatee.Toolkit.General.Maybe
import Graphics.UI.Gtk.General.General

import qualified Data.Map as M

-- | PageViewKeymap.
pageViewKeymap :: PageViewKeymap
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)
         ]

-- | Basic scroll action.
pageViewScrollStepUp, pageViewScrollStepDown, pageViewScrollPageUp, pageViewScrollPageDown :: PageView a => a -> IO ()
pageViewScrollStepUp   = pageViewScrollVerticalStep True 
pageViewScrollStepDown = pageViewScrollVerticalStep False 
pageViewScrollPageUp   = pageViewScrollVerticalPage True 
pageViewScrollPageDown = pageViewScrollVerticalPage False 

pageViewScrollStepRight, pageViewScrollStepLeft, pageViewScrollPageRight, pageViewScrollPageLeft :: PageView a => a -> IO ()
pageViewScrollStepRight = pageViewScrollHorizontalStep False
pageViewScrollStepLeft  = pageViewScrollHorizontalStep True
pageViewScrollPageRight = pageViewScrollHorizontalPage False
pageViewScrollPageLeft  = pageViewScrollHorizontalPage True

-- | Get plug id of page view.
pageViewGetPlugId :: forall a . PageView a => a -> IO PagePlugId
pageViewGetPlugId = readTVarIO . pageViewPlugId

-- | Get dbus client.
pageViewClient :: forall a . PageView a => a -> Client
pageViewClient view = 
    case pageViewBuffer view of
      (PageBufferWrap b) -> pageBufferClient b

-- | Cut action.
pageViewCutAction :: forall a . PageView a => a -> IO ()
pageViewCutAction view = 
    unlessM (pageViewCut view) $
            putStrLn "pageViewCutAction : Haven't implement pageViewCut."

-- | Copy action.
pageViewCopyAction :: forall a . PageView a => a -> IO ()
pageViewCopyAction view = 
    unlessM (pageViewCopy view) $
            putStrLn "pageViewCopyAction : Haven't implement pageViewCopy."

-- | Paste action.
pageViewPasteAction :: forall a . PageView a => a -> IO ()
pageViewPasteAction view = 
    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)
          (\ 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))