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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
import Control.Monad (when, forM_)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Char (ord)
import Data.Word (Word8)
import qualified Numeric
import System.IO.Terminal
import Optparse
showHex :: Integral a => a -> String
showHex n = Numeric.showHex n ""
padLeft :: a -> Int -> [a] -> [a]
padLeft c n s = replicate (n - length s) c ++ s
data Buffer = Buffer
{ bFpath :: FilePath
, bData :: LBS.ByteString
, bCursor :: Int
, bViewTop :: Int -- line number
}
deriving (Show)
data State = State
{ sFile1 :: Buffer
, sFile2 :: Maybe Buffer }
deriving (Show)
openBuffer :: FilePath -> IO Buffer
openBuffer fpath = do
dat <- LBS.fromStrict <$> BS.readFile fpath
return Buffer { bFpath = fpath
, bData = dat
, bCursor = 0
, bViewTop = 0 }
makeState :: Options -> IO State
makeState opts = do
sFile1 <- openBuffer (optsFpath1 opts)
sFile2 <- traverse openBuffer (optsFpath2 opts)
return State {..}
data Requests = Requests
{ reqRedrawFull :: Bool
, reqQuit :: Bool
, reqBel :: Bool }
deriving (Show)
instance Semigroup Requests where
Requests a b c <> Requests a' b' c' = Requests (a || a') (b || b') (c || c')
instance Monoid Requests where mempty = Requests False False False
eventLoop :: Key -> State -> IO (State, Requests)
eventLoop inKey st = case inKey of
KMod False False False k -> eventLoop k st
KMod False True False (KChar 'l') -> return (st, mempty { reqRedrawFull = True })
KEsc -> return (st, mempty { reqQuit = True })
_ -> return (st, mempty { reqBel = True })
-- with coordinates relative to the containing box
writeAt :: (Int, Int) -> (Int, Int) -> Int -> Int -> String -> TUI ()
writeAt (xmin, ymin) (xmax, ymax) x y s =
let (x', y') = (xmin + x, ymin + y)
in when (x >= 0 && y >= 0 && x' <= xmax && y' <= ymax) $
write (x', y') (take (xmax + 1 - x') s)
background :: Style
background = defaultStyle
{ sFg = Just (240, 240, 240)
, sBg = Just (20, 20, 20) }
byteColour :: Word8 -> (Word8, Word8, Word8)
byteColour 0 = (150, 150, 150)
byteColour 255 = (255, 150, 0)
byteColour (fromIntegral -> c)
| or [ord 'a' <= c && c <= ord 'z'
,ord 'A' <= c && c <= ord 'A'
,c `elem` map ord "\t\n\r "]
= (230, 219, 116)
| 33 <= c && c <= 126
= (240, 240, 240)
| otherwise
= (255, 100, 100)
renderBufferLine :: Buffer -> Int -> (Int, Int) -> Int -> TUI ()
renderBufferLine Buffer{..} linenum (xmin, y) xmax = do
let buflen = fromIntegral (LBS.length bData) :: Int
offset = 16 * linenum
forM_ [0 .. min 15 (buflen - offset - 1)] $ \i -> do
let byte = bData `LBS.index` fromIntegral (offset + i)
let styles = concat $
[if offset + i == bCursor then [setBg (Just (80, 80, 80)), setUnderline True] else []
,[setFg (Just (byteColour byte))]]
savingStyle $ do
sequence_ styles
writeAt (xmin, y) (xmax, y) (2 * i + i `div` 2) 0 (padLeft '0' 2 (showHex byte))
renderBuffer :: Buffer -> (Int, Int) -> (Int, Int) -> TUI ()
renderBuffer buffer@Buffer{..} (xmin, ymin) (xmax, ymax) = do
let buflen = fromIntegral (LBS.length bData) :: Int
bufnumlines = (buflen + 15) `div` 16
lastlinestart = buflen - buflen `mod` 16
lnumwid = length (showHex lastlinestart)
screennumlines = ymax - ymin -- one less than what fits on screen to make room for header
setStyle background
writeAt (xmin, ymin) (xmax, ymax) 0 0 bFpath
forM_ [0, 1 .. min (screennumlines - 1) (bufnumlines - 1 - bViewTop)] $ \y -> do
setStyle background { sFg = Just (150, 150, 150) }
writeAt (xmin, ymin) (xmax, ymax) 0 (y + 1) (padLeft '0' lnumwid (showHex (16 * (bViewTop + y))))
renderBufferLine buffer (bViewTop + y) (xmin + lnumwid + 1, ymin + y + 1) xmax
renderState :: State -> TUI ()
renderState st = do
(w, h) <- getTermSize
clearScreen
setStyle background
let buf1 = sFile1 st
case sFile2 st of
Just buf2 -> do
let c = boxChar (BoxSingle, BoxNone, BoxSingle, BoxNone)
xmid = w `div` 2
renderBuffer buf1 (0, 0) (xmid - 1, h - 1)
setStyle background >> fillRect (xmid, 0) (xmid, h - 1) c
renderBuffer buf2 (xmid + 1, 0) (w - 1, h - 1)
Nothing -> do
renderBuffer buf1 (0, 0) (w - 1, h - 1)
main :: IO ()
main = do
opts <- parseOptions
state0 <- makeState opts
withTUI $ do
let loop s = do
key <- readKey
(s', reqs) <- liftIO $ eventLoop key s
renderState s'
if reqRedrawFull reqs then redrawFull else redraw
when (reqBel reqs) $ bel
when (not (reqQuit reqs)) $ loop s'
renderState state0
redraw
loop state0
|
