InitialHEADmaster

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 {..}