diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 153 | ||||
| -rw-r--r-- | src/Optparse.hs | 31 |
2 files changed, 184 insertions, 0 deletions
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 {..} |