AWin32Console-1.1: System/Win32/AWin32Console.hsc
{-# 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