DouKaku?

{-# LANGUAGE ForeignFunctionInterface #-}

--
--  ghc --make hless.hs -lncurses
--
--  need : hscurses-1.3

import System.IO
import Control.Exception
import System.Environment
import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH

import Foreign
import Foreign.C.Types

--

foreign import ccall unsafe "ncurses.h winsdelln"
    winsdelln :: Curses.Window -> CInt -> IO CInt

deleteln :: Int -> IO CInt
deleteln n = winsdelln Curses.stdScr $ fromIntegral (-n)

insertln :: Int -> IO CInt
insertln n = winsdelln Curses.stdScr $ fromIntegral n

--
data File = File {
    fhandle ::  Handle,
    list    ::  [Integer]
} deriving (Show)

data Info = Info {
    file    ::  File,
    top     ::  Int
} deriving (Show)

--
scanFile :: Handle -> IO [Integer]
scanFile fp = do
    eof <- hIsEOF fp
    if eof
        then return []
        else do
            p <- hTell fp
            l <- hGetLine fp
            flist <- scanFile fp
            return (p : flist)

showLine :: File -> Int -> IO String
showLine f n
    | n >= (length $ list f)    = do return "~"
    | otherwise             = do
        hSeek (fhandle f) AbsoluteSeek $ (list f)!!n
        line <- hGetLine $ fhandle f
        return line
--

getW = do
    (_,w) <- Curses.scrSize
    return w

getH = do
    (h,_) <- Curses.scrSize
    return h

drawLine :: Info -> Int -> IO ()
drawLine info n = do
    str <- showLine (file info) (n + (top info))
    ss <- trim str
    Curses.mvWAddStr Curses.stdScr n 0 ss
    where
        trim s = do
            w <- getW
            if (length s) >= w
                then
                    return ((take (w-2) s) ++ "$")  -- (x_x)
                else
                    return s

redraw :: Info -> IO ()
redraw info = do
    h <- getH
    redraw' h
    Curses.refresh
    where
        redraw' 0 = return ()
        redraw' n = do
            m <- getH
            drawLine info (m-n)
            redraw' (n-1)

--

moveDown :: Info -> IO Info
moveDown info
    | (top info) >= len =   return info
    | otherwise         =   scrollUp
    where
        len = length $ list $ file info
        next = info { top = (top info) + 1 }
        scrollUp = do
            h <- getH
            CursesH.gotoTop
            deleteln 1
            Curses.move (h-1) 0
            drawLine next (h-1)
            Curses.refresh
            return next

moveUp :: Info -> IO Info
moveUp info
    | (top info) == 0   =   return info
    | otherwise         =   scrollDown
    where
        next = info { top = (top info) - 1 }
        scrollDown = do
            CursesH.gotoTop
            insertln 1
            drawLine next 0
            Curses.refresh
            return next

eventLoop :: Info -> IO Info
eventLoop info =
    do
        key <- Curses.getCh
        case key of
            Curses.KeyChar 'l' -> process $ return info
            Curses.KeyChar 'q' -> return info
            Curses.KeyChar 'n' -> process $ moveDown info
            Curses.KeyChar 'p' -> process $ moveUp info
            Curses.KeyUp       -> process $ moveUp info
            Curses.KeyDown     -> process $ moveDown info
            _ -> eventLoop info
        where
            process f = do
                r <- f
                eventLoop r

--

main = do
    (fileName:_) <- getArgs
    fp <- openFile fileName ReadMode
    flist <- scanFile fp
    let info = Info { file = File { fhandle = fp, list = flist}, top = 0}
    runMain info `finally` CursesH.end
    where
        runMain info = do
            CursesH.start
            redraw info
            eventLoop info