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

--------------------------------------------------------------------
-- |
-- Module : System.Hclip
-- Copyright : (c) Jens Thomas
-- License : BSD3
--
-- Maintainer: Jens Thomas <jetho@gmx.de>
-- Stability : experimental
-- Portability: non-portable (GADTs, CPP, DeriveDataTypeable)
--
-- 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, genericLength)
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 :: ClipboardException -> String
show (UnsupportedOS String
s)     = String
"Unsupported Operating System: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    show ClipboardException
NoTextualData          = String
"Clipboard doesn't contain textual data."
    show (MissingCommands [String]
cmds) = String
"Hclip requires " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
apps String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" installed."
        where apps :: String
apps = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" or " [String]
cmds


-- | Read clipboard contents.
getClipboard :: IO String
getClipboard :: IO String
getClipboard = Command (IO String) -> IO String
forall {a}. Command a -> a
dispatch Command (IO String)
GetClipboard

-- | Set clipboard contents.
setClipboard :: String -> IO ()
setClipboard :: String -> IO ()
setClipboard = Command (IO ()) -> IO ()
forall {a}. Command a -> a
dispatch (Command (IO ()) -> IO ())
-> (String -> Command (IO ())) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Command (IO ())
SetClipboard

-- | Apply function to clipboard and return its new contents.
modifyClipboard :: (String -> String) -> IO String
modifyClipboard :: ShowS -> IO String
modifyClipboard ShowS
f = do
    String
modified <- ShowS
f ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getClipboard
    String -> IO ()
setClipboard String
modified
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
modified

-- | Apply function to clipboard.
modifyClipboard_ :: (String -> String) -> IO ()
modifyClipboard_ :: ShowS -> IO ()
modifyClipboard_ = (ShowS -> IO String -> IO String)
-> IO String -> ShowS -> IO String
forall a b c. (a -> b -> c) -> b -> a -> c
flip ShowS -> IO String -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM IO String
getClipboard (ShowS -> IO String) -> (String -> IO ()) -> ShowS -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> IO ()
setClipboard

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


-- | Dispatch on the type of the Operating System.
dispatch :: Command a -> a
dispatch Command a
cmd = Platform -> Command a -> a
forall a. Platform -> Command a -> a
execute (String -> Platform
resolveOS String
os) Command a
cmd
    where
        resolveOS :: String -> Platform
resolveOS String
"linux"   = Platform
Linux
        resolveOS String
"darwin"  = Platform
Darwin
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
        resolveOS "mingw32" = Windows
#endif
        resolveOS String
unknownOS = ClipboardException -> Platform
forall a e. Exception e => e -> a
throw (ClipboardException -> Platform)
-> (String -> ClipboardException) -> String -> Platform
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ClipboardException
UnsupportedOS (String -> Platform) -> String -> Platform
forall a b. (a -> b) -> a -> b
$ String
unknownOS


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

execute :: forall a. Platform -> Command a -> a
execute Platform
Linux cmd :: Command a
cmd@Command a
GetClipboard     = Command a -> IO String
forall a. Command a -> IO String
resolveLinuxApp Command a
cmd IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IOAction String -> IO String)
-> IOAction String -> String -> IO String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> IOAction String -> IO String
forall a. String -> IOAction a -> IO a
withExternalApp IOAction String
readOutHandle
execute Platform
Linux cmd :: Command a
cmd@(SetClipboard String
s) = Command a -> IO String
forall a. Command a -> IO String
resolveLinuxApp Command a
cmd IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IOAction () -> IO ()) -> IOAction () -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> IOAction () -> IO ()
forall a. String -> IOAction a -> IO a
withExternalApp (String -> IOAction ()
writeInHandle String
s)

execute Platform
Darwin Command a
GetClipboard     = String -> IOAction String -> IO String
forall a. String -> IOAction a -> IO a
withExternalApp String
"pbpaste" IOAction String
readOutHandle
execute Platform
Darwin (SetClipboard String
s) = String -> IOAction () -> IO ()
forall a. String -> IOAction a -> IO a
withExternalApp String
"pbcopy" (IOAction () -> IO ()) -> IOAction () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOAction ()
writeInHandle String
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 :: forall a. Command a -> IO String
resolveLinuxApp Command a
cmd = Command a -> ShowS
forall a. Command a -> ShowS
decode Command a
cmd ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO String
chooseFirstApp [String
"wl-copy", String
"xsel", String
"xclip"] 
    where
        decode :: Command a -> String -> String
        decode :: forall a. Command a -> ShowS
decode Command a
GetClipboard     String
"wl-copy" = String
"wl-paste --no-newline"
        decode (SetClipboard String
_) String
"wl-copy" = String
"wl-copy"
        decode Command a
GetClipboard     String
"xsel"  = String
"xsel -b -o"
        decode (SetClipboard String
_) String
"xsel"  = String
"xsel -b -i"
        decode Command a
GetClipboard     String
"xclip" = String
"xclip -selection c -o"
        decode (SetClipboard String
_) String
"xclip" = String
"xclip -selection c"

-- | Run external app and apply action to the file handles.
withExternalApp :: String -> IOAction a -> IO a 
withExternalApp :: forall a. String -> IOAction a -> IO a
withExternalApp String
app IOAction a
action = 
    IO (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO ExitCode)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveCommand String
app)
            (\(Handle
inp, Handle
outp, Handle
stderr, ProcessHandle
pid) -> (Handle -> IO ()) -> [Handle] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
hClose [Handle
inp, Handle
outp, Handle
stderr] IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid)
            (\(Handle
inp, Handle
outp, Handle
_, ProcessHandle
_)        -> IOAction a
action (Handle
inp, Handle
outp))

-- | Search for installed programs and return the first match.
chooseFirstApp :: [String] -> IO String
chooseFirstApp :: [String] -> IO String
chooseFirstApp [String]
apps = do
    [Maybe String]
results <- (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
whichCommand [String]
apps
    IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ClipboardException -> IO String
forall e a. Exception e => e -> IO a
throwIO (ClipboardException -> IO String)
-> ClipboardException -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> ClipboardException
MissingCommands [String]
apps)
          String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return
          (First String -> Maybe String
forall a. First a -> Maybe a
getFirst (First String -> Maybe String)
-> ([First String] -> First String)
-> [First String]
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [First String] -> First String
forall a. Monoid a => [a] -> a
mconcat ([First String] -> Maybe String) -> [First String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Maybe String -> First String) -> [Maybe String] -> [First String]
forall a b. (a -> b) -> [a] -> [b]
map Maybe String -> First String
forall a. Maybe a -> First a
First [Maybe String]
results)

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

readOutHandle :: IOAction String
readOutHandle :: IOAction String
readOutHandle = Handle -> IO String
hGetContents (Handle -> IO String)
-> ((Handle, Handle) -> Handle) -> IOAction String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle, Handle) -> Handle
stdout

writeInHandle :: String -> IOAction ()
writeInHandle :: String -> IOAction ()
writeInHandle String
s = (Handle -> String -> IO ()) -> String -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> String -> IO ()
hPutStr String
s (Handle -> IO ()) -> ((Handle, Handle) -> Handle) -> IOAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle, Handle) -> Handle
stdin

stdin, stdout :: (StdIn, StdOut) -> Handle
stdin :: (Handle, Handle) -> Handle
stdin = (Handle, Handle) -> Handle
forall a b. (a, b) -> a
fst
stdout :: (Handle, Handle) -> Handle
stdout = (Handle, Handle) -> Handle
forall a b. (a, b) -> b
snd