module Main where

import Control.Monad
import Data.Monoid
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable (peek,poke)
import System.Environment (getEnv)
import System.IO.Unsafe (unsafePerformIO)
import System.IO
import Control.Exception.Extensible
import Data.Typeable


-------
-- Preliminaries of setting up the terminal; all seems to be OK...
data TERMINAL
newtype Terminal = Terminal (ForeignPtr TERMINAL)

foreign import ccall "&" cur_term :: Ptr (Ptr TERMINAL)
foreign import ccall set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL)
foreign import ccall "&" del_curterm :: FunPtr (Ptr TERMINAL -> IO ())

foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO ()

-- | Initialize the terminfo library to the given terminal entry.
-- 
-- Throws a 'SetupTermError' if the terminfo database could not be read.
setupTerm :: String -> IO Terminal
setupTerm term = bracket (peek cur_term) (poke cur_term) $ \_ -> 
    withCString term $ \c_term ->
    with 0 $ \ret_ptr -> do
        -- NOTE: I believe that for the way we use terminfo
        -- (i.e. custom output function)
        -- this parameter does not affect anything.
        let stdOutput = 1
        {-- Force ncurses to return a new struct rather than
        a copy of the current one (which it would do if the
        terminal names are the same).  This prevents problems
        when calling del_term on a struct shared by more than one
        Terminal. --}
        poke cur_term nullPtr
        -- Call setupterm and check the return value.
        setupterm c_term stdOutput ret_ptr
        ret <- peek ret_ptr
        if (ret /=1)
            then throwIO $ SetupTermError
                $ "Couldn't look up terminfo entry " ++ show term
            else do
                cterm <- peek cur_term
                fmap Terminal $ newForeignPtr del_curterm cterm

data SetupTermError = SetupTermError String
                        deriving Typeable

instance Show SetupTermError where
    show (SetupTermError str) = "setupTerm: " ++ str

instance Exception SetupTermError where

-- | Initialize the terminfo library, using the @TERM@ environmental variable.
-- If @TERM@ is not set, we use the generic, minimal entry @dumb@.
-- 
-- Throws a 'SetupTermError' if the terminfo database could not be read.
setupTermFromEnv :: IO Terminal
setupTermFromEnv = do
    env_term <- handle handleBadEnv $ getEnv "TERM" 
    let term = if null env_term then "dumb" else env_term
    print ("Setting up:",env_term)
    setupTerm term
  where
    handleBadEnv :: IOException -> IO String
    handleBadEnv _ = return ""

-- TODO: this isn't really thread-safe...
withCurTerm :: Terminal -> IO a -> IO a
withCurTerm (Terminal term) f = withForeignPtr term $ \cterm -> do
        old_term <- peek cur_term
        if old_term /= cterm
            then do
                    _ <- set_curterm cterm
                    x <- f
                    _ <- set_curterm old_term
                    return x
            else f


----------------------
-- Test the foreign functions

-- this seems to be OK
foreign import ccall tigetstr :: CString -> IO CString

foreign import ccall tparm ::
    CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong 
    -> CLong -> CLong -> CLong -- p1,...,p9
    -> IO CString

foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput)

foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO ()

type CharOutput = CInt -> IO CInt



testCap :: Terminal -> String -> [Int] -> IO ()
testCap term cap ps = withCurTerm term $ do
    putStrLn "------------"
    print ("testing capability:", cap,ps)
    s1 <- tiGetStr cap
    print ("tiGetStr result:",s1)
    s2 <- tParm s1 ps
    print ("tiParm result:",s2)
    tPuts s2
    putStrLn "testCap done."


tiGetStr :: String -> IO String
tiGetStr cap = do
    putStrLn "About to call tigetstr"
    result <- withCString cap tigetstr
    print ("tiGetStr: pointer result", result)
    if result==nullPtr || result == neg1Ptr
        then error $ "tiGetStr: capability " ++ show cap ++ " not found"
        else peekCString result
  where
    neg1Ptr = nullPtr `plusPtr` (-1)
  

tParm :: String -> [Int] -> IO String
tParm cap ps = case (map toEnum ps ++ repeat 0) of
                (p1:p2:p3:p4:p5:p6:p7:p8:p9:_) ->
                    withCString cap $ \c_cap -> do
                        putStrLn "About to call tparm"
                        result <- tparm c_cap p1 p2 p3 p4 p5 p6 p7 p8 p9
                        print ("tParm pointer result:",result)
                        if result == nullPtr
                            then return ""
                            else peekCString result

tPuts :: String -> IO ()
tPuts s = do
    withCString s $ \c_str -> do
    putStrLn "Making the callback function"
    putc_ptr <- mkCallback putc
    putStrLn "Callback created."
    tputs c_str 1 putc_ptr
    putStrLn "Called tputs."
    freeHaskellFunPtr putc_ptr
    putStrLn "Freed callback."
  where
    putc c = do
        print ("Outputting:",c,toEnum (fromEnum c)::Char)
        return c
    

---------
-- main

main = do
    hSetBuffering stdout LineBuffering
    t <- setupTermFromEnv
    testCap t "smkx" []
    testCap t "cuu" [3]