{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonadContrib.IXPromptLib
-- Copyright   :  (C) 2007 Andrea Rossato
-- License     :  BSD3
-- 
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A module for writing graphical prompts for XMonad
-- This code comes from John Meacham's HsLocale
-----------------------------------------------------------------------------

module XMonadContrib.IXPromptLib (
                             -- * Usage
                             -- $usage
                             fromLocale
                             , toLocale
                             , setupLocale
                             ) where

import Prelude hiding (catch)
import Control.Exception
import Control.Monad
import Data.Char
import Foreign
import Foreign.C

-- $usage
-- In order to use XPrompt you need to add XMonadContrib.XPromptLib to
-- the "other-modules" list in xmonad.cabal:
--
-- > other-modules:      Config Operations StackSet XMonad XMonadContrib.IXPromptLib
--
-- For usage examples see "XMonadContrib.IShellPrompt" 

-- This code comes from John Meacham's HsLocale
-- http://repetae.net/john/repos/HsLocale/
toLocale :: String -> IO String
toLocale s = catch (stringToBytes s >>= return . map (chr . fromIntegral))
                   (const $ return "invalid\\ character\\ sequence")

fromLocale :: String -> IO String
fromLocale s = bytesToString (map (fromIntegral . ord) s) 
                  `catch` \_ ->  return "invalid\\ character\\ sequence"

stringToBytes :: String -> IO [Word8]
stringToBytes cs = (withIConv "" "UTF-32" $ \ic -> convertRaw ic cs) 

bytesToString :: [Word8] -> IO String
bytesToString bs =  (withIConv "UTF-32" "" $ \ic ->  convertRaw ic bs) >>= return . f where
    f ('\65279':xs) = xs   -- discard byte order marker
    f xs = xs

newtype IConv = IConv (#type intptr_t)
    deriving(Num,Eq,Show)

foreign import ccall unsafe "iconv.h iconv_open"
  iconv_open :: Ptr CChar -> Ptr CChar -> IO IConv
foreign import ccall unsafe "iconv.h iconv_close"
  iconv_close :: IConv -> IO CInt
foreign import ccall unsafe "iconv.h iconv" 
  iconv :: IConv -> Ptr (Ptr CChar) -> Ptr CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt

withIConv :: String -> String -> (IConv -> IO a) -> IO a 
withIConv to from action = bracket open close action where
    close ic = throwErrnoIfMinus1_ "iconv_close" (iconv_close ic)
    open = throwErrnoIfMinus1 "iconv_open" iopen
    iopen = do
        withCAString to $ \t -> do
        withCAString from $ \f -> do
        iconv_open t f

convertRaw :: (Storable a, Storable b) => IConv -> [a] -> IO [b]
convertRaw ic xs = do 
    with (fromIntegral $ sizeOf (head xs) * length xs) $ \inptrSz -> do
    withArray xs $ \arr -> do  
    with (castPtr arr) $ \inptr -> do
    allocaBytes (1024) $ \outptr -> do
    with outptr $ \outptrptr -> do
    with 1024 $ \outptrSz -> do
    let outSz = fromIntegral $ sizeOf $ unsafePerformIO (peek outptr) 
    let go = do 
          ret <- iconv ic inptr inptrSz (castPtr outptrptr) outptrSz 
          err <- getErrno
          case (ret,err) of
            (-1,_) | err == e2BIG -> do
                           oz <- peek outptrSz
                           x <- peekArray ((1024 - fromIntegral oz) `div` outSz) (castPtr outptr) 
                           poke outptrptr outptr
                           poke outptrSz 1024
                           y <- go
                           return $ x ++ y
            (-1,_) -> throwErrno "iconv"
            (_,_) -> do
                     oz <- peek outptrSz
                     peekArray ((1024 - fromIntegral oz) `div` outSz) outptr 
    go

#include <locale.h>
foreign import ccall unsafe "locale.h setlocale"
    setlocale :: CInt -> CString -> IO CString

setupLocale :: IO ()
setupLocale = withCString "" $ \s -> do
                setlocale (#const LC_ALL) s
                return ()