module System.Console.Haskeline.Backend.Win32(
                win32Term
                )where


import System.IO
import qualified System.IO.UTF8 as UTF8
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.C.Types
import Foreign.Marshal.Utils
import System.Win32.Types
import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE)
import System.Win32.File
import Data.List(intercalate)
import Control.Concurrent
import Control.Concurrent.STM
import Data.Bits
import Control.Exception (throwDynTo)

import System.Console.Haskeline.Command
import System.Console.Haskeline.Monads
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Term

#include "win_console.h"

foreign import stdcall "windows.h ReadConsoleInputW" c_ReadConsoleInput
    :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool
    
foreign import stdcall "windows.h WaitForSingleObject" c_WaitForSingleObject
    :: HANDLE -> DWORD -> IO DWORD

getEvent :: HANDLE -> IO Event
getEvent h = newTChanIO >>= keyEventLoop eventIntoChan
  where
    eventIntoChan tchan = eventLoop h >>= atomically . writeTChan tchan

eventLoop :: HANDLE -> IO Event
eventLoop h = do
    let waitTime = 500 -- milliseconds
    ret <- c_WaitForSingleObject h waitTime
    yield -- otherwise, the above foreign call causes the loop to never 
          -- respond to the killThread
    if ret /= (#const WAIT_OBJECT_0)
        then eventLoop h
        else do
            e <- readEvent h
            case eventToKey e of
	        Just k -> return (KeyInput k)
    	        Nothing -> eventLoop h
                       
getConOut :: IO (Maybe HANDLE)
getConOut = handle (\_ -> return Nothing) $ fmap Just
    $ createFile "CONOUT$" (gENERIC_READ .|. gENERIC_WRITE)
                        (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing
                    oPEN_EXISTING 0 Nothing


eventToKey :: InputEvent -> Maybe Key
eventToKey KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc,
                    controlKeyState = cstate}
        = if isMeta then fmap KeyMeta maybeKey else maybeKey
  where
    maybeKey = if c /= '\NUL' 
                    then Just (KeyChar c)
                    else keyFromCode vc
    isMeta = 0 /= (cstate .&. (#const RIGHT_ALT_PRESSED
                                    .|. #const LEFT_ALT_PRESSED) )
eventToKey _ = Nothing

keyFromCode :: WORD -> Maybe Key
keyFromCode (#const VK_BACK) = Just Backspace
keyFromCode (#const VK_LEFT) = Just KeyLeft
keyFromCode (#const VK_RIGHT) = Just KeyRight
keyFromCode (#const VK_UP) = Just KeyUp
keyFromCode (#const VK_DOWN) = Just KeyDown
keyFromCode (#const VK_DELETE) = Just DeleteForward
-- TODO: KillLine
keyFromCode _ = Nothing
    
data InputEvent = KeyEvent {keyDown :: BOOL,
                          repeatCount :: WORD,
                          virtualKeyCode :: WORD,
                          virtualScanCode :: WORD,
                          unicodeChar :: Char,
                          controlKeyState :: DWORD}
            -- TODO: WINDOW_BUFFER_SIZE_RECORD
            -- I cant figure out how the user generates them.
           | OtherEvent
                        deriving Show

readEvent :: HANDLE -> IO InputEvent
readEvent h = allocaBytes (#size INPUT_RECORD) $ \pRecord -> 
                        alloca $ \numEventsPtr -> do
    failIfFalse_ "ReadConsoleInput" 
        $ c_ReadConsoleInput h pRecord 1 numEventsPtr
    -- useful? numEvents <- peek numEventsPtr
    eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord
    let eventPtr = (#ptr INPUT_RECORD, Event) pRecord
    case eventType of
        (#const KEY_EVENT) -> getKeyEvent eventPtr
        _ -> return OtherEvent
        
getKeyEvent :: Ptr () -> IO InputEvent
getKeyEvent p = do
    kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p
    repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p
    keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p
    scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p
    char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p
    state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p
    return KeyEvent {keyDown = kDown',
                            repeatCount = repeat',
                            virtualKeyCode = keyCode,
                            virtualScanCode = scanCode,
                            unicodeChar = toEnum (fromEnum char),
                            controlKeyState = state}

data Coord = Coord {coordX, coordY :: Int}
                deriving Show
                
instance Storable Coord where
    sizeOf _ = (#size COORD)
    alignment = undefined -- ???
    peek p = do
        x :: CShort <- (#peek COORD, X) p
        y :: CShort <- (#peek COORD, Y) p
        return Coord {coordX = fromEnum x, coordY = fromEnum y}
    poke p c = do
        (#poke COORD, X) p (toEnum (coordX c) :: CShort)
        (#poke COORD, Y) p (toEnum (coordY c) :: CShort)
                
                            
foreign import ccall "SetPosition"
    c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool
    
setPosition :: HANDLE -> Coord -> IO ()
setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" 
                    . c_SetPosition h
                    
foreign import stdcall "windows.h GetConsoleScreenBufferInfo"
    c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool
    
getPosition :: HANDLE -> IO Coord
getPosition = withScreenBufferInfo $ 
    (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition)

withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a
withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO)
                                $ \infoPtr -> do
        failIfFalse_ "GetConsoleScreenBufferInfo"
            $ c_GetScreenBufferInfo h infoPtr
        f infoPtr


getDisplayWindow :: HANDLE -> IO (Coord,Coord)
getDisplayWindow = withScreenBufferInfo $ \p -> do
    let windowPtr = (#ptr CONSOLE_SCREEN_BUFFER_INFO, srWindow) p
    left <- (#peek SMALL_RECT, Left) windowPtr
    top <- (#peek SMALL_RECT, Top) windowPtr
    right <- (#peek SMALL_RECT, Right) windowPtr
    bottom <- (#peek SMALL_RECT, Bottom) windowPtr
    return (Coord (cvt left) (cvt top), Coord (cvt right) (cvt bottom))
  where
    cvt :: CShort -> Int
    cvt = fromEnum

foreign import stdcall "windows.h WriteConsoleW" c_WriteConsoleW
    :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool

writeConsole :: HANDLE -> String -> IO ()
-- For some reason, Wine returns False when WriteConsoleW is called on an empty
-- string.  Easiest fix: just don't call that function.
writeConsole _ "" = return ()
writeConsole h str = withArray tstr $ \t_arr -> alloca $ \numWritten -> do
    failIfFalse_ "WriteConsole" 
        $ c_WriteConsoleW h t_arr (toEnum $ length str) numWritten nullPtr
  where
    tstr = map (toEnum . fromEnum) str

foreign import stdcall "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool

messageBeep :: IO ()
messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures.

----------------------------
-- Drawing

newtype Draw m a = Draw {runDraw :: ReaderT HANDLE m a}
    deriving (Monad,MonadIO,MonadException, MonadReader HANDLE)

instance MonadTrans Draw where
    lift = Draw . lift

instance MonadReader Layout m => MonadReader Layout (Draw m) where
    ask = lift ask
    local r = Draw . local r . runDraw

getDisplaySize :: HANDLE -> IO Layout
getDisplaySize h = do
    (topLeft,bottomRight) <- getDisplayWindow h
    return Layout {width = coordX bottomRight - coordX topLeft+1, 
                    height = coordY bottomRight - coordY topLeft+1 }
    
getPos :: MonadIO m => Draw m Coord
getPos = ask >>= liftIO . getPosition
    
setPos :: MonadIO m => Coord -> Draw m ()
setPos c = do
    h <- ask
    liftIO (setPosition h c)

printText :: MonadIO m => String -> Draw m ()
printText txt = do
    h <- ask
    liftIO (writeConsole h txt)
    
printAfter :: MonadLayout m => String -> Draw m ()
printAfter str = do
    p <- getPos
    printText str
    setPos p
    
drawLineDiffWin :: MonadLayout m => LineChars -> LineChars -> Draw m ()
drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
    ([],[])     | ys1 == ys2            -> return ()
    (xs1',[])   | xs1' ++ ys1 == ys2    -> movePos $ negate $ length xs1'
    ([],xs2')   | ys1 == xs2' ++ ys2    -> movePos $ length xs2'
    (xs1',xs2')                         -> do
        movePos (negate $ length xs1')
        let m = length xs1' + length ys1 - (length xs2' + length ys2)
        let deadText = replicate m ' '
        printText xs2'
        printAfter (ys2 ++ deadText)

movePos :: MonadLayout m => Int -> Draw m ()
movePos n = do
    Coord {coordX = x, coordY = y} <- getPos
    w <- asks width
    let (h,x') = divMod (x+n) w
    setPos Coord {coordX = x', coordY = y+h}

crlf :: String
crlf = "\r\n"

instance (MonadException m, MonadLayout m) => Term (Draw m) where
    drawLineDiff = drawLineDiffWin
    reposition _ _ = return () -- TODO when we capture resize events.

    printLines [] = return ()
    printLines ls = printText $ intercalate crlf ls ++ crlf
    
    clearLayout = do
        lay <- ask
        setPos (Coord 0 0)
        printText (replicate (width lay * height lay) ' ')
        setPos (Coord 0 0)
    
    moveToNextLine s = do
        movePos (lengthToEnd s)
        printText "\r\n" -- make the console take care of creating a new line
    
    ringBell True = liftIO messageBeep
    ringBell False = return () -- TODO

win32Term :: IO RunTerm
win32Term = do
    inIsTerm <- hIsTerminalDevice stdin
    putter <- putOut
    if not inIsTerm
        then fileRunTerm
        else do
            oterm <- getConOut
            case oterm of
                Nothing -> fileRunTerm
                Just h -> return RunTerm {
                            putStrOut = putter,
                            wrapInterrupt = withCtrlCHandler,
                            termOps = Just TermOps {
                                            getLayout = getDisplaySize h,
                                            runTerm = consoleRunTerm h},
                            closeTerm = closeHandle h}

consoleRunTerm :: HANDLE -> RunTermType
consoleRunTerm conOut f = do
    inH <- liftIO $ getStdHandle sTD_INPUT_HANDLE
    runReaderT' conOut $ runDraw $ f $ liftIO $ getEvent inH

-- stdin is not a terminal, but we still need to check the right way to output unicode to stdout.
fileRunTerm :: IO RunTerm
fileRunTerm = do
    putter <- putOut
    return RunTerm {termOps = Nothing,
                    closeTerm = return (),
                    putStrOut = putter,
                    wrapInterrupt = withCtrlCHandler}

-- On Windows, Unicode written to the console must be written with the WriteConsole API call.
-- And to make the API cross-platform consistent, Unicode to a file should be UTF-8.
putOut :: IO (String -> IO ())
putOut = do
    outIsTerm <- hIsTerminalDevice stdout
    if outIsTerm
        then do
            h <- getStdHandle sTD_OUTPUT_HANDLE
            return (writeConsole h)
        else return $ \str -> UTF8.putStr str >> hFlush stdout
                
    

type Handler = DWORD -> IO BOOL

foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler)

foreign import stdcall "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler
    :: FunPtr Handler -> BOOL -> IO BOOL

-- sets the tv to True when ctrl-c is pressed.
withCtrlCHandler :: MonadException m => m a -> m a
withCtrlCHandler f = bracket (liftIO $ do
                                    tid <- myThreadId
                                    fp <- wrapHandler (handler tid)
                                    c_SetConsoleCtrlHandler fp True
                                    return fp)
                                (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False)
                                (const f)
  where
    handler tid (#const CTRL_C_EVENT) = do
        throwDynTo tid Interrupt
        return True
    handler _ _ = return False