    {-# 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 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

    -- | 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 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

    -- | 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 ""

    -- | Dispatch on the type of the Operating System.
    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

    -- | Platform-specific execution.
    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

    -- | 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 :: 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"

    -- | Run external app and apply action to the file handles.
    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))

    -- | Search for installed programs and return the first match.
    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)

    -- | Check if cmd is installed by using the which command.
    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