-----------------------------------------------------------------------------
-- Library for simple interactive programs:
--
-- Suitable for use with Hugs 98
-----------------------------------------------------------------------------

module Interact(
        Interact,
        end,
        readChar, peekChar, unreadChar, pressAnyKey,
        writeChar, writeStr,
        readLine,
        ringBell
        ) where

--- Interactive program combining forms:

type Interact = String -> String

end                      :: Interact
readChar, peekChar       :: Interact -> (Char -> Interact) -> Interact
pressAnyKey              :: Interact -> Interact
unreadChar               :: Char -> Interact -> Interact
writeChar                :: Char -> Interact -> Interact
writeStr                 :: String -> Interact -> Interact
ringBell                 :: Interact -> Interact
readLine                 :: String -> (String -> Interact) -> Interact

end _                    = ""

readChar eof _ []       = eof []
readChar _ use (c:cs)   = use c cs

peekChar eof _ []       = eof []     -- like readChar, but character is
peekChar _ use cs@(c:_) = use c cs   -- not removed from input stream

pressAnyKey prog          = readChar prog (\_ -> prog)

unreadChar c prog cs      = prog (c:cs)

writeChar c prog cs       = c : prog cs

writeStr s prog cs        = s ++ prog cs

ringBell                  = writeChar '\BEL'

readLine prompt g is  = prompt ++ lineOut 0 line ++ "\n"
                               ++ g (noBackSpaces line) input'
 where line     = before '\n' is
       input'   = after  '\n' is
       after x  = tail . dropWhile (x/=)
       before x = takeWhile (x/=)

       rubout  :: Char -> Bool
       rubout c = (c=='\DEL' || c=='\BS')

       lineOut                      :: Int -> String -> String
       lineOut _ ""                  = ""
       lineOut n (c:cs)
                 | n>0  && rubout c  = "\BS \BS" ++ lineOut (n-1) cs
                 | n==0 && rubout c  = lineOut 0 cs
                 | otherwise         = c:lineOut (n+1) cs

       noBackSpaces :: String -> String
       noBackSpaces  = reverse . delete (0::Int) . reverse
                       where delete _ ""          = ""
                             delete n (c:cs)
                                      | rubout c  = delete (n+1) cs
                                      | n>0       = delete (n-1) cs
                                      | otherwise = c:delete 0 cs

-----------------------------------------------------------------------------