{-# OPTIONS_GHC -fglasgow-exts -O2 -optc-O3 -optc-ffast-math -fvia-C #-}

{-
   Copyright (c) 2010 - Harald Wolfsgruber
   All rights reserved.

   Name:                AWin32Console
   Version:             1.1
   Description:         ANSI escape code 
   License:             BSD3
   License-file:        LICENSE
   Author:              Harald Wolfsgruber
-}

module System.Win32.AWin32Console (aPutStr, aPutStrLn) where
import Data.Bits
import Data.IORef
import Text.Regex
import System.IO
import System.IO.Unsafe
import System.Win32.Types

#include <windows.h>

type SHORT = USHORT
data A = AForm {bold :: Bool, underline :: Bool, 
                revideo :: Bool, concealed :: Bool, 
                foreground :: WORD, background :: WORD}

foreign import ccall unsafe "BWin32Console.h SetAttr"
	setAttr :: WORD -> IO ()
foreign import ccall unsafe "BWin32Console.h SetPos"
	setPos :: SHORT -> SHORT -> IO ()
foreign import ccall unsafe "BWin32Console.h SetCls"
	setCls :: IO ()
foreign import ccall unsafe "BWin32Console.h SetScroll"
	setScroll :: SHORT -> SHORT -> 
               SHORT -> SHORT -> SHORT -> SHORT -> 
               IO ()
foreign import ccall unsafe "BWin32Console.h GetPosX"
	getPosX :: IO SHORT
foreign import ccall unsafe "BWin32Console.h GetPosY"
	getPosY :: IO SHORT
foreign import ccall unsafe "BWin32Console.h GetSizeX"
	getSizeX :: IO SHORT
foreign import ccall unsafe "BWin32Console.h GetSizeY"
	getSizeY :: IO SHORT
foreign import ccall unsafe "BWin32Console.h GetAttr"
	getAttr :: IO WORD

aPutStrLn :: String -> IO ()
aPutStrLn str = puts str >> putChar '\n' >> hFlush stdout
aPutStr :: String -> IO ()
aPutStr str = puts str >> hFlush stdout

globalAttrSt :: IORef A
{-# NOINLINE globalAttrSt #-}
globalAttrSt = unsafePerformIO (newIORef aFn)

globalPosSt :: IORef (SHORT,SHORT)
{-# NOINLINE globalPosSt #-}
globalPosSt = unsafePerformIO (newIORef (0,0))

splitC :: String -> Char -> [String]
splitC []     _ = [""]
splitC (c:cs) d | c == d    = "" : r
                | otherwise = (c : head r) : tail r
  where
  r = splitC cs d

aFn = AForm {bold=False, underline=False, 
             revideo=False, concealed=False, 
             foreground=7, background=0}

puts :: String -> IO ()
puts x = f x
  where
  a = mkRegex "\ESC\\[([0-9\\;\\=]*)([a-zA-Z@])"
  fB = 0x01
  fG = 0x02
  fR = 0x04
  fi = 0x08
  bB = 0x10
  bG = 0x20
  bR = 0x40
  bi = 0x80
  color :: WORD -> WORD
  color 30 = 0
  color 31 = fR
  color 32 = fG
  color 33 = fR .|. fG
  color 34 = fB
  color 35 = fB .|. fR
  color 36 = fB .|. fG
  color 37 = fR .|. fG .|. fB
  color 40 = 0
  color 41 = bR
  color 42 = bG
  color 43 = bR .|. bG
  color 44 = bB
  color 45 = bB .|. bR
  color 46 = bB .|. bG
  color 47 = bR .|. bG .|. bB
  z  x = map (\xx -> if xx == "" then 0 else read xx) $ splitC x ';'
  z1 x = map (\xx -> if xx == "" then 1 else read xx) $ splitC x ';'
  zZ x = if x == "" then 1 else read x
  g' x = let xs = z1 x in case length xs of
    0 -> setPos 0 0
    1 -> setPos 0 (xs!!0-1)
    _ -> setPos (xs!!1-1) (xs!!0-1)
  f [] = return ()
  f x  = maybe (putStr x) (\(k,_,n,m) -> putStr k >> 
         hFlush stdout >> g m >> f n) aa
    where aa = matchRegexAll a x
  g [x,"m"] = readIORef globalAttrSt >>= 
              \aFxx -> return (foldr h aFxx (reverse $ z x)) >>=
              \aFyy -> writeIORef globalAttrSt aFyy >> 
              (setAttr $ k $ aFyy)
    where
    h x a = i
      where
      i | x == 1  = a {bold=True}
        | x == 21 = a {bold=False}
        | x == 4  = a {underline=True}
        | x == 24 = a {underline=False}
        | x == 7  = a {revideo=True}
        | x == 27 = a {revideo=False}
        | x == 8  = a {concealed=True}
        | x == 28 = a {concealed=False}
        | x >= 30 && x <= 37 = a {foreground=x-30} 
        | x >= 40 && x <= 47 = a {background=x-40}
        | otherwise = aFn
    k x = attr'' $ attr' attr
      where
      attr | revideo x  = color (40+foreground x) .|. 
                          color (30+background x)
           | otherwise  = color (30+foreground x) .|.
                          color (40+background x)
      attr' a  | bold x      = a .|. fi
               | otherwise   = a
      attr'' a | underline x = a .|. bi
               | otherwise   = a
  g [x,"J"] = hFlush stdout >> case x of
    "1" -> do
      i0 <- getSizeX
      i2 <- getPosX
      i3 <- getPosY
      setPos 0 0
      putStr (replicate (fromEnum (i3*i0+i2+1)) ' ')
      hFlush stdout
    "2" -> do
      setCls
      setPos 0 0
      hFlush stdout
    _ -> do
      i0 <- getSizeX
      i1 <- getSizeY
      i2 <- getPosX
      i3 <- getPosY
      putStr (replicate (fromEnum ((i1-i3)*i0-i2-1)) ' ')
      hFlush stdout
      setPos i2 i3
  g [x,"K"] = hFlush stdout >> case x of
    "1" -> do
      i0 <- getSizeX
      i2 <- getPosX
      i3 <- getPosY
      setPos 0 i3
      putStr (replicate (fromEnum (i2+1)) ' ')
      hFlush stdout
      setPos i2 i3
    "2" -> do
      i0 <- getSizeX
      i2 <- getPosX
      i3 <- getPosY
      setPos 0 i3
      putStr (replicate (fromEnum (i0+1)) ' ')
      hFlush stdout
      setPos i2 i3
    _ -> do
      i0 <- getSizeX
      i2 <- getPosX
      i3 <- getPosY
      putStr (replicate (fromEnum (i0-i2+1)) ' ')
      hFlush stdout
      setPos i2 i3
  g [x,"L"] = do
    i0 <- getSizeX
    i1 <- getSizeY
    i2 <- getPosX
    i3 <- getPosY
    setScroll 0 (i3+zZ x)
              0 i3 (i0-1) (i1-1)
    setPos i2 i3
  g [x,"M"] =  do
    i0 <- getSizeX
    i1 <- getSizeY
    i2 <- getPosX
    i3 <- getPosY
    setScroll 0 i3
              0 (i3+zZ x) (i0-1) (i1-1)
    setPos i2 i3
  g [x,"P"] = do
    i0 <- getSizeX
    i1 <- getSizeY
    i2 <- getPosX
    i3 <- getPosY
    setScroll i2 i3
              (i2+xx i0 i2) i3 (i0-1) i3
    setPos i2 i3
      where
      xx i0 i2 | i2+z>i0-1 = i0-i2
               | otherwise = z
        where z = zZ x
  g [x,"@"] = do
    i0 <- getSizeX
    i1 <- getSizeY
    i2 <- getPosX
    i3 <- getPosY
    setScroll (i2+xx i0 i2) i3
              i2 i3 (i0-1) i3
    setPos i2 i3
      where
      xx i0 i2 | i2+z>i0-1 = i0-i2
               | otherwise = z
        where z = zZ x
  g [x,"f"] = g' x
  g [x,"H"] = g' x
  g [x,"A"] = do
    i2 <- getPosX
    i3 <- getPosY
    setPos i2 (i3-zZ x)
  g [x,"B"] = do
    i2 <- getPosX
    i3 <- getPosY
    setPos i2 (i3+zZ x)
  g [x,"C"] = do
    i2 <- getPosX
    i3 <- getPosY
    setPos (i2+zZ x) i3
  g [x,"D"] = do
    i2 <- getPosX
    i3 <- getPosY
    setPos (i2-zZ x) i3
  g [x,"E"] = do
    i3 <- getPosY
    setPos 0 (i3+zZ x)
  g [x,"F"] = do
    i3 <- getPosY
    setPos 0 (i3-zZ x)
  g [x,"G"] = do
    i3 <- getPosY
    setPos (zZ x-1) i3
  g [x,"s"] = do
    i2 <- getPosX
    i3 <- getPosY
    writeIORef globalPosSt (i2,i3)
  g [x,"u"] = do
    (i2,i3) <- readIORef globalPosSt
    setPos i2 i3
  g xs = putStr $ "\ESC[" ++ concat xs