1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
{-# 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