{-# 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