In Graham Hutton's "Programming in Haskell" there is an interactive
calculator example using ANSI code to implement the UI on the terminal.
This example doesn't work on MS Windows XP or other MS OSes based on NT
kernel, since their command line does not support ANSI very well.
But, thanks to ansi-terminal on Hackage, I was able to extract minimal
code from the package to make a win32 version of the calculator example
in Hutton's book.
calculatorWin32.lhs and Win32ANSI.hs is an implementation for win32.
I extracted the win32 console API bindings for setting cursor positions
from ansi-terminal project and put them in Win32ANSI.hs. I had to put
this in a separate file because I had an issue with ghci. To run this,
I had to compile the console API bindings with ghc first and then run
ghci as follows
C:\> ghc -c Win32ANSI.hs
C:\> ghci calculatorWin32.lhs
Without compiling the object code, ghci cannot find the proper link for
win32 console API FFI bindings.
C:\> ghci calculatorWin32.lhs
GHCi, version 6.10.1: http://www.haskell.org/ghc/ :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer ... linking ... done.
Loading package base ... linking ... done.
[1 of 3] Compiling Parsing ( Parsing.lhs, interpreted )
[2 of 3] Compiling Win32ANSI ( Win32ANSI.hs, interpreted )
During interactive linking, GHCi couldn't find the following symbol:
getconsolescreenbufferi...@8
This may be due to you not asking GHCi to load extra object files,
archives or DLLs needed by your current session. Restart GHCi, specifying
the missing library using the -L/path/to/object/dir and -lmissinglibname
flags, or simply by naming the relevant files on the GHCi command line.
Alternatively, this link failure might indicate a bug in GHCi.
If you suspect the latter, please send a bug report to:
glasgow-haskell-b...@haskell.org
Is this a bug or a natural behavior of ghci? This is strange to me
since ghci finds the proper link for the functions in the other C
libraries such as getch in conio.h.
In addition, I am attaching a patched calculator.lhs which works
for Unix/Linux on both GHC 6.8.x and GHC 6.10.1. The one currently
on the book homepage only works for GHC 6.8.x but not GHC 6.10.1.
This is due to the bug fix of hSetBuffering in GHC 6.10.1.
To run these calculator example you will also need Parsing.lhs from
the book hompage. http://www.cs.nott.ac.uk/~gmh/Parsing.lhs
--
Ahn, Ki Yung
Calculator example from section 9.6 of Programming in Haskell,
Graham Hutton, Cambridge University Press, 2007.
Note: the definition for getCh in this example works with the
Glasgow Haskell Compiler, but may not work with some Haskell
systems, such as Hugs. Moreover, the use of control characters
may not work on some systems, such as WinHugs.
Note: This code works for both GHC versions 6.8.x and 6.10.1 on Unix/Linux.
Previous code on the webpage only worked on GHC 6.8.x. -- Ahn, Ki Yung
> import Parsing
> import System.IO
Parser for expressions
----------------------
> expr :: Parser Int
> expr = do t <- term
> do symbol "+"
> e <- expr
> return (t + e)
> +++ do symbol "-"
> e <- expr
> return (t - e)
> +++ return t
>
> term :: Parser Int
> term = do f <- factor
> do symbol "*"
> t <- term
> return (f * t)
> +++ do symbol "/"
> t <- term
> return (f `div` t)
> +++ return f
>
> factor :: Parser Int
> factor = do symbol "("
> e <- expr
> symbol ")"
> return e
> +++ integer
Derived primitives
------------------
> getCh :: IO Char
> getCh = do hSetEcho stdin False
> hSetBuffering stdin NoBuffering
> c <- getChar
> hSetEcho stdin True
> hSetBuffering stdin LineBuffering
> return c
>
> beep :: IO ()
> beep = putStr "\BEL"
>
> cls :: IO ()
> cls = putStr "\ESC[2J"
>
> type Pos = (Int,Int)
>
> goto :: Pos -> IO ()
> goto (x,y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")
>
> writeat :: Pos -> String -> IO ()
> writeat p xs = do goto p
> putStr xs
>
> seqn :: [IO a] -> IO ()
> seqn [] = return ()
> seqn (a:as) = do a
> seqn as
The calculator
--------------
> box :: [String]
> box = ["+---------------+",
> "| |",
> "+---+---+---+---+",
> "| q | c | d | = |",
> "+---+---+---+---+",
> "| 1 | 2 | 3 | + |",
> "+---+---+---+---+",
> "| 4 | 5 | 6 | - |",
> "+---+---+---+---+",
> "| 7 | 8 | 9 | * |",
> "+---+---+---+---+",
> "| 0 | ( | ) | / |",
> "+---+---+---+---+"]
>
> buttons :: String
> buttons = standard ++ extra
> where
> standard = "qcd=123+456-789*0()/"
> extra = "QCD \ESC\BS\DEL\n"
>
>
> showbox :: IO ()
> showbox = seqn [writeat (1,y) xs | (y,xs) <- zip [1..13] box]
>
> display xs = do writeat (3,2) " "
> writeat (3,2) (reverse (take 13 (reverse xs)))
>
> calc :: String -> IO ()
> calc xs = do display xs
> c <- getCh
> if elem c buttons then
> process c xs
> else
> do beep
> calc xs
>
> process :: Char -> String -> IO ()
> process c xs
> | elem c "qQ\ESC" = quit
> | elem c "dD\BS\DEL" = delete xs
> | elem c "=\n" = eval xs
> | elem c "cC" = clear
> | otherwise = press c xs
>
> quit :: IO ()
> quit = goto (1,14)
>
> delete :: String -> IO ()
> delete "" = calc ""
> delete xs = calc (init xs)
>
> eval :: String -> IO ()
> eval xs = case parse expr xs of
> [(n,"")] -> calc (show n)
> _ -> do beep
> calc xs
>
> clear :: IO ()
> clear = calc ""
>
> press :: Char -> String -> IO ()
> press c xs = calc (xs ++ [c])
>
> run :: IO ()
> run = do cls
> showbox
> clear
Calculator example from section 9.6 of Programming in Haskell,
Graham Hutton, Cambridge University Press, 2007.
Note: the definition for getCh in this example works with the
Glasgow Haskell Compiler, but may not work with some Haskell
systems, such as Hugs. Moreover, the use of control characters
may not work on some systems, such as WinHugs.
Note: This code works on GHC versions 6.10.1 on MS Windows command line
using the code extracted from ansi-termial-0.5.0 package. You will need
Win32ANSI.hs in addition to Parsing.hs. To run this code you should invoke
the compiler first to compile Win32ANSI.o and then the run ghci as follows:
$ ghc -c Win32ANSI.hs
$ ghci calculatorWin32.lhs
...
Ahn, Ki Yung
> {-# LANGUAGE ForeignFunctionInterface#-}
> import Parsing
> import Win32ANSI (setCursorPosition)
>
> import Monad
> import Char
>
> import System.IO
> import System.Info (os)
> import System.Cmd (system)
>
> import Foreign.C
Parser for expressions
----------------------
> expr :: Parser Int
> expr = do t <- term
> do symbol "+"
> e <- expr
> return (t + e)
> +++ do symbol "-"
> e <- expr
> return (t - e)
> +++ return t
>
> term :: Parser Int
> term = do f <- factor
> do symbol "*"
> t <- term
> return (f * t)
> +++ do symbol "/"
> t <- term
> return (f `div` t)
> +++ return f
>
> factor :: Parser Int
> factor = do symbol "("
> e <- expr
> symbol ")"
> return e
> +++ integer
Derived primitives
------------------
> getCh :: IO Char
> getCh = liftM (chr . fromEnum) c_getch
> foreign import ccall unsafe "conio.h getch" c_getch :: IO CInt
>
> beep :: IO ()
> beep = do putStr "\BEL"
> hFlush stdout
>
> cls :: IO ()
> cls = do system("cls")
> return ()
>
> type Pos = (Int,Int)
>
> goto :: Pos -> IO ()
> goto (x,y) = setCursorPosition (y-1) (x-1)
>
> writeat :: Pos -> String -> IO ()
> writeat p xs = do goto p
> putStr xs
> hFlush stdout
>
> seqn :: [IO a] -> IO ()
> seqn [] = return ()
> seqn (a:as) = do a
> seqn as
The calculator
--------------
> box :: [String]
> box = ["+---------------+",
> "| |",
> "+---+---+---+---+",
> "| q | c | d | = |",
> "+---+---+---+---+",
> "| 1 | 2 | 3 | + |",
> "+---+---+---+---+",
> "| 4 | 5 | 6 | - |",
> "+---+---+---+---+",
> "| 7 | 8 | 9 | * |",
> "+---+---+---+---+",
> "| 0 | ( | ) | / |",
> "+---+---+---+---+"]
>
> buttons :: String
> buttons = standard ++ extra
> where
> standard = "qcd=123+456-789*0()/"
> extra = "QCD \ESC\BS\DEL\n\r"
>
>
> showbox :: IO ()
> showbox = seqn [writeat (1,y) xs | (y,xs) <- zip [1..13] box]
>
> display xs = do writeat (3,2) " "
> writeat (3,2) (reverse (take 13 (reverse xs)))
>
> calc :: String -> IO ()
> calc xs = do display xs
> c <- getCh
> if elem c buttons then
> process c xs
> else
> do beep
> calc xs
>
> process :: Char -> String -> IO ()
> process c xs
> | elem c "qQ\ESC" = quit
> | elem c "dD\BS\DEL" = delete xs
> | elem c "=\n\r" = eval xs
> | elem c "cC" = clear
> | otherwise = press c xs
>
> quit :: IO ()
> quit = goto (1,14)
>
> delete :: String -> IO ()
> delete "" = calc ""
> delete xs = calc (init xs)
>
> eval :: String -> IO ()
> eval xs = case parse expr xs of
> [(n,"")] -> calc (show n)
> _ -> do beep
> calc xs
>
> clear :: IO ()
> clear = calc ""
>
> press :: Char -> String -> IO ()
> press c xs = calc (xs ++ [c])
>
> run :: IO ()
> run = do cls
> showbox
> clear
{-# LANGUAGE ForeignFunctionInterface#-}
module Win32ANSI (setCursorPosition) where
import System.IO
import System.Win32.Types
import Data.Bits
import Foreign.C.Types
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Foreign.StablePtr
import Control.Concurrent.MVar
import Control.Exception (bracket)
import GHC.IOBase (Handle(..), Handle__(..), FD)
hSetCursorPosition :: Handle
-> Int -- ^ 0-based row to move to
-> Int -- ^ 0-based column to move to
-> IO ()
setCursorPosition :: Int -- ^ 0-based row to move to
-> Int -- ^ 0-based column to move to
-> IO ()
setCursorPosition = hSetCursorPosition stdout
withHandle :: Handle -> (HANDLE -> IO a) -> IO a
withHandle handle action = do
-- It's VERY IMPORTANT that we flush before issuing any sort of
-- Windows API call to change the console because on Windows
-- the arrival of API-initiated state changes is not necessarily
-- synchronised with that of the text they are attempting to modify.
hFlush handle
withHandleToHANDLE handle action
adjustCursorPosition :: HANDLE -> (SHORT -> SHORT -> SHORT) -> (SHORT -> SHORT -> SHORT) -> IO ()
adjustCursorPosition handle change_x change_y = do
screen_buffer_info <- getConsoleScreenBufferInfo handle
let window = csbi_window screen_buffer_info
(COORD x y) = csbi_cursor_position screen_buffer_info
cursor_pos' = COORD (change_x (rect_left window) x) (change_y (rect_top window) y)
setConsoleCursorPosition handle cursor_pos'
hSetCursorPosition h y x = withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y)
-- Some Windows types missing from System.Win32
type SHORT = CShort
-- This is a FFI hack. Some of the API calls take a Coord,>
-- but that isn't a built-in FFI type so I can't use it directly.
-- Instead, I use UNPACKED_COORD and marshal COORDs into this manually.
-- Note that we CAN'T just use two SHORTs directly because
-- they get expanded to 4 bytes each instead of just boing 2 lots of 2
-- bytes by the stdcall convention, so linking fails.
type UNPACKED_COORD = CInt
-- Field packing order determined experimentally: I couldn't immediately
-- find a specification for Windows struct layout anywhere.
unpackCOORD :: COORD -> UNPACKED_COORD
unpackCOORD (COORD x y) = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x)
peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b)
peekAndOffset ptr = do
item <- peek ptr
return (item, ptr `plusPtr` sizeOf item)
pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b)
pokeAndOffset ptr item = do
poke ptr item
return (ptr `plusPtr` sizeOf item)
data COORD = COORD {
coord_x :: SHORT,
coord_y :: SHORT
}
instance Show COORD where
show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")"
instance Storable COORD where
sizeOf ~(COORD x y) = sizeOf x + sizeOf y
alignment ~(COORD x _) = alignment x
peek ptr = do
let ptr' = castPtr ptr :: Ptr SHORT
x <- peekElemOff ptr' 0
y <- peekElemOff ptr' 1
return (COORD x y)
poke ptr (COORD x y) = do
let ptr' = castPtr ptr :: Ptr SHORT
pokeElemOff ptr' 0 x
pokeElemOff ptr' 1 y
data SMALL_RECT = SMALL_RECT {
rect_top_left :: COORD,
rect_bottom_right :: COORD
}
rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT
rect_top = coord_y . rect_top_left
rect_left = coord_x . rect_top_left
rect_bottom = coord_y . rect_bottom_right
rect_right = coord_x . rect_bottom_right
instance Show SMALL_RECT where
show (SMALL_RECT tl br) = show tl ++ "-" ++ show br
instance Storable SMALL_RECT where
sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br
alignment ~(SMALL_RECT tl _) = alignment tl
peek ptr = do
let ptr' = castPtr ptr :: Ptr COORD
tl <- peekElemOff ptr' 0
br <- peekElemOff ptr' 1
return (SMALL_RECT tl br)
poke ptr (SMALL_RECT tl br) = do
let ptr' = castPtr ptr :: Ptr COORD
pokeElemOff ptr' 0 tl
pokeElemOff ptr' 1 br
data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO {
csbi_size :: COORD,
csbi_cursor_position :: COORD,
csbi_attributes :: WORD,
csbi_window :: SMALL_RECT,
csbi_maximum_window_size :: COORD
}
deriving (Show)
instance Storable CONSOLE_SCREEN_BUFFER_INFO where
sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size)
= sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size
alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size
peek ptr = do
(size, ptr1) <- peekAndOffset (castPtr ptr)
(cursor_position, ptr2) <- peekAndOffset ptr1
(attributes, ptr3) <- peekAndOffset ptr2
(window, ptr4) <- peekAndOffset ptr3
maximum_window_size <- peek ptr4
return (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size)
poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do
ptr1 <- pokeAndOffset (castPtr ptr) size
ptr2 <- pokeAndOffset ptr1 cursor_position
ptr3 <- pokeAndOffset ptr2 attributes
ptr4 <- pokeAndOffset ptr3 window
poke ptr4 maximum_window_size
foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL
foreign import stdcall unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL
foreign import stdcall unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL
getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO
getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do
failIfFalse_ "getConsoleScreenBufferInfo" $ cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info
peek ptr_console_screen_buffer_info
setConsoleCursorPosition :: HANDLE -> COORD -> IO ()
setConsoleCursorPosition handle cursor_position = failIfFalse_ "setConsoleCursorPosition" $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position)
-- This essential function comes from msvcrt. It's OK to depend on msvcrt since GHC's base package does.
foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: FD -> IO HANDLE
-- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing
-- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able
-- to extract one of those from the Haskell Handle.
--
-- This code accomplishes this, albeit at the cost of only being compatible with GHC.
withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE haskell_handle action =
-- Create a stable pointer to the Handle. This prevents the garbage collector
-- getting to it while we are doing horrible manipulations with it, and hence
-- stops it being finalized (and closed).
withStablePtr haskell_handle $ const $ do
-- Grab the write handle variable from the Handle
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one
-- Get the FD from the algebraic data type
fd <- fmap haFD $ readMVar write_handle_mvar
-- Finally, turn that (C-land) FD into a HANDLE using msvcrt
windows_handle <- cget_osfhandle fd
-- Do what the user originally wanted
action windows_handle
withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
