{-# 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 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
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 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 String
""
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
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
#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 :: 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"
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))
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)
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