{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
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)
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)
#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
data Command a where
GetClipboard :: Command (IO String)
SetClipboard :: String -> Command (IO ())
data Platform = Linux
| Darwin
| Windows
data ClipboardException = UnsupportedOS String
| NoTextualData
| MissingCommands [String]
deriving (Typeable)
instance Exception ClipboardException
instance Show ClipboardException where
show :: ClipboardException -> String
show (UnsupportedOS s :: String
s) = "Unsupported Operating System: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
show NoTextualData = "Clipboard doesn't contain textual data."
show (MissingCommands cmds :: [String]
cmds) = "Hclip requires " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
apps String -> ShowS
forall a. [a] -> [a] -> [a]
++ " installed."
where apps :: String
apps = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " or " [String]
cmds
getClipboard :: IO String
getClipboard :: IO String
getClipboard = Command (IO String) -> IO String
forall a. Command a -> a
dispatch Command (IO String)
GetClipboard
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
modifyClipboard :: (String -> String) -> IO String
modifyClipboard :: ShowS -> IO String
modifyClipboard f :: 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
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
clearClipboard :: IO ()
clearClipboard :: IO ()
clearClipboard = String -> IO ()
setClipboard ""
dispatch :: Command a -> a
dispatch cmd :: 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 "linux" = Platform
Linux
resolveOS "darwin" = Platform
Darwin
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
resolveOS "mingw32" = Windows
#endif
resolveOS unknownOS :: 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
execute :: Platform -> Command a -> a
execute :: Platform -> Command a -> a
execute 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 Linux cmd :: Command a
cmd@(SetClipboard s :: 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 Darwin GetClipboard = String -> IOAction String -> IO String
forall a. String -> IOAction a -> IO a
withExternalApp "pbpaste" IOAction String
readOutHandle
execute Darwin (SetClipboard s :: String
s) = String -> IOAction () -> IO ()
forall a. String -> IOAction a -> IO a
withExternalApp "pbcopy" (IOAction () -> a) -> IOAction () -> a
forall a b. (a -> b) -> a -> b
$ String -> IOAction ()
writeInHandle String
s
#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
resolveLinuxApp :: Command a -> IO String
resolveLinuxApp :: Command a -> IO String
resolveLinuxApp cmd :: 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 ["xsel", "xclip"]
where
decode :: Command a -> String -> String
decode :: Command a -> ShowS
decode GetClipboard "xsel" = "xsel -b -o"
decode (SetClipboard _) "xsel" = "xsel -b -i"
decode GetClipboard "xclip" = "xclip -selection c -o"
decode (SetClipboard _) "xclip" = "xclip -selection c"
withExternalApp :: String -> IOAction a -> IO a
withExternalApp :: String -> IOAction a -> IO a
withExternalApp app :: String
app action :: 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)
(\(inp :: Handle
inp, outp :: Handle
outp, stderr :: Handle
stderr, pid :: 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)
(\(inp :: Handle
inp, outp :: Handle
outp, _, _) -> IOAction a
action (Handle
inp, Handle
outp))
chooseFirstApp :: [String] -> IO String
chooseFirstApp :: [String] -> IO String
chooseFirstApp apps :: [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)
whichCommand :: String -> IO (Maybe String)
whichCommand :: String -> IO (Maybe String)
whichCommand cmd :: String
cmd = do
(exitCode :: ExitCode
exitCode,_,_) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode "which" [String
cmd] ""
case ExitCode
exitCode of
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 _ -> 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 s :: 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