{-# 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,
        ClipboardException(..)
  ) where

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

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


-- | Clipboard Actions
data Command = GetClipboard 
             | SetClipboard String 


-- | Supported Operating Systems
data Platform = Linux
              | Darwin
              | Windows
              deriving (Show)


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

instance Show ClipboardException where
  show (UnsupportedOS os)     = "Unsupported Operating System: " ++ os
  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 = dispatchCommand GetClipboard


-- | Set clipboard contents.
setClipboard :: String -> IO String
setClipboard = dispatchCommand . SetClipboard


-- | Apply function to clipboard and return its new contents.
modifyClipboard :: (String -> String) -> IO String
modifyClipboard = flip liftM getClipboard >=> setClipboard


-- | Select the supported operating system.
dispatchCommand :: Command -> IO String
dispatchCommand = case os of
  "linux"   -> clipboard Linux
  "darwin"  -> clipboard Darwin
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
  "mingw32" -> clipboard Windows 
#endif
  unknownOS -> const . throwIO $ UnsupportedOS unknownOS


-- | MAC OS: use pbcopy and pbpaste    
clipboard Darwin command = withExternalCommand extCmd command
  where extCmd = case command of
                   GetClipboard   -> "pbpaste"
                   SetClipboard _ -> "pbcopy"


-- | Linux: use xsel or xclip
clipboard Linux command = do
  prog <- chooseFirstCommand ["xsel", "xclip"]
  withExternalCommand (decode prog command) command
  where
    decode "xsel" GetClipboard      = "xsel -o"
    decode "xsel" (SetClipboard _)  = "xsel -i"
    decode "xclip" GetClipboard     = "xclip -selection c -o"
    decode "xclip" (SetClipboard _) = "xclip -selection c"
    

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

clipboard 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 s
  where
    memSize = genericLength s + 1
#endif


-- | Run external command for accessing the system clipboard.
withExternalCommand :: String -> Command -> IO String
withExternalCommand prog command = 
  bracket (runInteractiveCommand prog)
          (\(inp, outp, stderr, pid) -> mapM_ hClose [inp, outp, stderr] >> waitForProcess pid)
          (\(inp, outp, _, _)        -> action command (inp, outp))
  where
    action GetClipboard = hGetContents . stdout
    action (SetClipboard text) = (flip hPutStr text >=> const (return text)) . stdin
    stdin = fst
    stdout = snd


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


-- | Check if cmd is installed 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