From 4b41e11d6116c5552f396ea1cc261b95bfc81222 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 9 Jul 2023 16:23:40 +0200
Subject: Initial
---
src/Main.hs | 153 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Optparse.hs | 31 ++++++++++++
2 files changed, 184 insertions(+)
create mode 100644 src/Main.hs
create mode 100644 src/Optparse.hs
(limited to 'src')
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..875dccf
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,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
diff --git a/src/Optparse.hs b/src/Optparse.hs
new file mode 100644
index 0000000..784bf81
--- /dev/null
+++ b/src/Optparse.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RecordWildCards #-}
+module Optparse (
+ Options(..),
+ parseOptions,
+) where
+
+import Options.Applicative
+
+
+data Options = Options
+ { optsFpath1 :: FilePath
+ , optsFpath2 :: Maybe FilePath
+ }
+ deriving (Show)
+
+parseOptions :: IO Options
+parseOptions = execParser $ info (pOptions <**> helper)
+ ( fullDesc
+ <> progDesc "View, edit and diff binary files"
+ <> header "hhexed - haskell hex editor" )
+
+pOptions :: Parser Options
+pOptions = do
+ optsFpath1 <- strArgument
+ (metavar "FILE"
+ <> help "File to display")
+ optsFpath2 <- optional (strArgument
+ (metavar "FILE2"
+ <> help "File to diff against (optional)"))
+ return Options {..}
--
cgit v1.2.3-70-g09d2