{- | This module provides a wrapper for I/O encoding for the "old" and "new" ways.
The "old" way uses iconv+utf8-string.
The "new" way uses the base library's built-in encoding functionality.
For the "new" way, we require ghc>=7.4.1 due to GHC bug #5436.

This module exports opaque Encoder/Decoder datatypes, along with several helper
functions that wrap the old/new ways.
-}
module System.Console.Haskeline.Backend.Posix.Encoder (
        Encoder,
        Decoder,
        newEncoders,
        ExternalHandle(eH),
        externalHandle,
        withCodingMode,
        openInCodingMode,
        putEncodedStr,
#ifdef TERMINFO
        getTermText,
#endif
        getBlockOfChars,
        getDecodedChar,
        getDecodedLine,
                ) where

import System.IO
import System.Console.Haskeline.Monads
import System.Console.Haskeline.Term
#ifdef TERMINFO
import qualified System.Console.Terminfo.Base as Terminfo
#endif

-- Way-dependent imports
#ifdef USE_GHC_ENCODINGS
import GHC.IO.Encoding (initLocaleEncoding)
import System.Console.Haskeline.Recover
#else
import System.Console.Haskeline.Backend.Posix.IConv
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
#ifdef TERMINFO
import qualified Data.ByteString.Char8 as BC
#endif
import Control.Monad (liftM2)
#endif



#ifdef USE_GHC_ENCODINGS
data Encoder = Encoder
data Decoder = Decoder
#else
type Decoder = PartialDecoder
type Encoder = String -> IO ByteString
#endif

newEncoders :: IO (Encoder,Decoder)
#ifdef USE_GHC_ENCODINGS
newEncoders = return (Encoder,Decoder)
#else
newEncoders = do
    codeset <- bracket (setLocale (Just "")) setLocale $ const $ getCodeset
    liftM2 (,) (openEncoder codeset)
                (openPartialDecoder codeset)
#endif

-- | An 'ExternalHandle' is a handle which may or may not be in the correct
-- mode for Unicode input/output.  When the POSIX backend opens a file
-- (or /dev/tty) it sets it permanently to the correct mode.
-- However, when it uses an existing handle like stdin, it only temporarily
-- sets it to the correct mode (e.g., for the duration of getInputLine);
-- otherwise, we might interfere with the rest of the Haskell program.
--
-- For the legacy backend, the correct mode is BinaryMode.
-- For the new backend, the correct mode is the locale encoding, set to
-- transliterate errors (rather than crashing, as is the base library's
-- default.)  (See Posix/Recover.hs)
data ExternalHandle = ExternalHandle
                        { externalMode :: ExternalMode
                        , eH :: Handle
                        }

data ExternalMode = CodingMode | OtherMode

externalHandle :: Handle -> ExternalHandle
externalHandle = ExternalHandle OtherMode

-- | Use to ensure that an external handle is in the correct mode
-- for the duration of the given action.
withCodingMode :: ExternalHandle -> IO a -> IO a
withCodingMode ExternalHandle {externalMode=CodingMode} act = act
#ifdef USE_GHC_ENCODINGS
withCodingMode (ExternalHandle OtherMode h) act = do
    bracket (liftIO $ hGetEncoding h)
            (liftIO . hSetBinOrEncoding h)
            $ const $ do
                hSetEncoding h haskelineEncoding
                act

hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO ()
hSetBinOrEncoding h Nothing = hSetBinaryMode h True
hSetBinOrEncoding h (Just enc) = hSetEncoding h enc
#else
withCodingMode (ExternalHandle OtherMode h) act = hWithBinaryMode h act
#endif

#ifdef USE_GHC_ENCODINGS
haskelineEncoding :: TextEncoding
haskelineEncoding = transliterateFailure initLocaleEncoding
#endif

-- Open a file and permanently set it to the correct mode.
openInCodingMode :: FilePath -> IOMode -> IO ExternalHandle
#ifdef USE_GHC_ENCODINGS
openInCodingMode path iomode = do
    h <- openFile path iomode
    hSetEncoding h haskelineEncoding
    return $ ExternalHandle CodingMode h
#else
openInCodingMode path iomode
    = fmap (ExternalHandle CodingMode) $ openBinaryFile path iomode
#endif



-----------------------
-- Output
putEncodedStr :: Encoder -> Handle -> String -> IO ()
#ifdef USE_GHC_ENCODINGS
putEncodedStr _ h = hPutStr h
#else
putEncodedStr enc h s = enc s >>= B.hPutStr h
#endif

#ifdef TERMINFO
getTermText :: Encoder -> String -> IO Terminfo.TermOutput
#ifdef USE_GHC_ENCODINGS
getTermText _ = return . Terminfo.termText
#else
getTermText enc s = enc s >>= return . Terminfo.termText . BC.unpack
#endif
#endif



-- Read at least one character of input, and more if immediately
-- available.  In particular the characters making up a control sequence
-- will all be available at once, so they can be processed together
-- (with Posix.lexKeys).
getBlockOfChars :: Handle -> Decoder -> IO String
#ifdef USE_GHC_ENCODINGS
getBlockOfChars h _ = do
    c <- hGetChar h
    loop [c]
  where
    loop cs = do
        isReady <- hReady h
        if not isReady
            then return $ reverse cs
            else do
                    c <- hGetChar h
                    loop (c:cs)
#else
getBlockOfChars h decode = do
    let bufferSize = 32
    blockUntilInput h
    bs <- B.hGetNonBlocking h bufferSize
    decodeAndMore decode h bs

#endif

-- Read in a single character, or Nothing if eof.
-- Assumes the handle is "prepared".
getDecodedChar :: Handle -> Decoder -> MaybeT IO Char
#ifdef USE_GHC_ENCODINGS
getDecodedChar h _ = guardedEOF hGetChar h
#else
getDecodedChar h decode = do
    b <- hGetByte h
    cs <- liftIO $ decodeAndMore decode h (B.pack [b])
    case cs of
        [] -> return '?' -- shouldn't happen, but doesn't hurt to be careful.
        (c:_) -> return c
#endif

-- Read in a single line, or Nothing if eof.
getDecodedLine :: Handle -> Decoder -> MaybeT IO String
#ifdef USE_GHC_ENCODINGS
getDecodedLine h _ = guardedEOF hGetLine h
#else
getDecodedLine h decode
    = hGetLocaleLine h >>= liftIO . decodeAndMore decode h

#endif

-- Helper functions for iconv encoding
#ifndef USE_GHC_ENCODINGS
blockUntilInput :: Handle -> IO ()
#if __GLASGOW_HASKELL__ >= 611
-- threadWaitRead doesn't work with the new (ghc-6.12) IO library,
-- because it keeps a buffer even when NoBuffering is set.
blockUntilInput h = hWaitForInput h (-1) >> return ()
#else
-- hWaitForInput doesn't work with -threaded on ghc < 6.10
-- (#2363 in ghc's trac)
blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd
#endif

#endif