Hclip-3.0.0.0: System/Hclip.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}

--------------------------------------------------------------------
-- |
-- Module : System.Hclip
-- Copyright : (c) Jens Thomas
-- License : BSD3
--
-- Maintainer: Jens Thomas <jetho@gmx.de>
-- Stability : experimental
-- Portability:
--
-- A small cross-platform library for reading and modifying the system clipboard.
-- 
--------------------------------------------------------------------

module System.Hclip (
        getClipboard,
        setClipboard,
        modifyClipboard,
        modifyClipboard_,
        clearClipboard,
        ClipboardException(..)
  ) where


import System.Info (os)
import System.Process (runInteractiveCommand, readProcessWithExitCode, waitForProcess)
import System.IO (Handle, hPutStr, hClose)
import Data.Monoid 
import System.IO.Strict (hGetContents) -- see http://hackage.haskell.org/package/strict
import System.Exit (ExitCode(..))
import Data.List (intercalate)
import Control.Exception (Exception, throw, throwIO, bracket, bracket_)
import Data.Typeable (Typeable)
import Control.Applicative ((<$>))
import Control.Monad ((>=>), liftM)

-- | for Windows support
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
import System.Win32.Mem (globalAlloc, globalLock, globalUnlock, copyMemory, gHND)
import Graphics.Win32.GDI.Clip (openClipboard, closeClipboard, emptyClipboard, getClipboardData,
                                setClipboardData, ClipboardFormat, isClipboardFormatAvailable, cF_TEXT)
import Foreign.C (withCAString, peekCAString)
import Foreign.Ptr (castPtr, nullPtr)
#endif


type StdIn      = Handle
type StdOut     = Handle
type IOAction a = (StdIn, StdOut) -> IO a


-- | Clipboard Commands
data Command a where
    GetClipboard   :: Command (IO String)
    SetClipboard   :: String -> Command (IO ())


-- | Supported Platforms
data Platform = Linux
              | Darwin
              | Windows


-- | Exceptions
data ClipboardException = UnsupportedOS String
                        | NoTextualData
                        | MissingCommands [String]
                        deriving (Typeable)
                    
instance Exception ClipboardException

instance Show ClipboardException where
    show (UnsupportedOS s)     = "Unsupported Operating System: " ++ s
    show NoTextualData          = "Clipboard doesn't contain textual data."
    show (MissingCommands cmds) = "Hclip requires " ++ apps ++ " installed."
        where apps = intercalate " or " cmds


-- | Read clipboard contents.
getClipboard :: IO String
getClipboard = dispatch GetClipboard

-- | Set clipboard contents.
setClipboard :: String -> IO ()
setClipboard = dispatch . SetClipboard

-- | Apply function to clipboard and return its new contents.
modifyClipboard :: (String -> String) -> IO String
modifyClipboard f = do
    modified <- f <$> getClipboard
    setClipboard modified
    return modified

-- | Apply function to clipboard.
modifyClipboard_ :: (String -> String) -> IO ()
modifyClipboard_ = flip liftM getClipboard >=> setClipboard

-- | Delete Clipboard contents.
clearClipboard :: IO ()
clearClipboard = setClipboard ""


-- | Dispatch on the type of the Operating System.
dispatch cmd = execute (resolveOS os) cmd
    where
        resolveOS "linux"   = Linux
        resolveOS "darwin"  = Darwin
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
        resolveOS "mingw32" = Windows
#endif
        resolveOS unknownOS = throw . UnsupportedOS $ unknownOS


-- | Platform-specific execution.
execute :: Platform -> Command a -> a

execute Linux cmd@GetClipboard     = resolveLinuxApp cmd >>= flip withExternalApp readOutHandle
execute Linux cmd@(SetClipboard s) = resolveLinuxApp cmd >>= flip withExternalApp (writeInHandle s)

execute Darwin GetClipboard     = withExternalApp "pbpaste" readOutHandle
execute Darwin (SetClipboard s) = withExternalApp "pbcopy" $ writeInHandle s

-- | Windows: use WinAPI
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
execute Windows GetClipboard =
    bracket_ (openClipboard nullPtr) closeClipboard $ do
        isText <- isClipboardFormatAvailable cF_TEXT
        if isText
            then do
                h <- getClipboardData cF_TEXT
                bracket (globalLock h) globalUnlock $ peekCAString . castPtr
            else throwIO NoTextualData

execute Windows (SetClipboard s) =
    withCAString s $ \cstr -> do
        mem <- globalAlloc gHND memSize
        bracket (globalLock mem) globalUnlock $ \space -> do
            copyMemory space (castPtr cstr) memSize
            bracket_ (openClipboard nullPtr) closeClipboard $ do
                emptyClipboard
                setClipboardData cF_TEXT space
                return ()
    where
        memSize = genericLength s + 1
#endif


-- | Determine the correct Linux command.
resolveLinuxApp :: Command a -> IO String
resolveLinuxApp cmd = decode cmd <$> chooseFirstApp ["xsel", "xclip"] 
    where
        decode GetClipboard "xsel"      = "xsel -o"
        decode (SetClipboard _) "xsel"  = "xsel -i"
        decode GetClipboard "xclip"     = "xclip -selection c -o"
        decode (SetClipboard _) "xclip" = "xclip -selection c"

-- | Run external app and apply action to the file handles.
withExternalApp :: String -> IOAction a -> IO a 
withExternalApp app action = 
    bracket (runInteractiveCommand app)
            (\(inp, outp, stderr, pid) -> mapM_ hClose [inp, outp, stderr] >> waitForProcess pid)
            (\(inp, outp, _, _)        -> action (inp, outp))

-- | Search for installed programs and return the first match.
chooseFirstApp :: [String] -> IO String
chooseFirstApp apps = do
    results <- mapM whichCommand apps
    maybe (throwIO $ MissingCommands apps)
          return
          (getFirst . mconcat $ map First results)

-- | Check if cmd is installed by using the which command.
whichCommand :: String -> IO (Maybe String)
whichCommand cmd = do
  (exitCode,_,_) <- readProcessWithExitCode "which" [cmd] ""
  case exitCode of
    ExitSuccess   -> return $ Just cmd
    ExitFailure _ -> return Nothing

readOutHandle :: IOAction String
readOutHandle = hGetContents . stdout

writeInHandle :: String -> IOAction ()
writeInHandle s = flip hPutStr s . stdin

stdin, stdout :: (StdIn, StdOut) -> Handle
stdin = fst
stdout = snd