path: root/jterm.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.State
import Data.Bits
import qualified Data.ByteString.UTF8 as B
import Data.Function
import Data.Maybe
import Data.String.AnsiEscapeCodes.Strip.Text
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Text.Rope (Position (..), Rope)
import qualified Data.Text.Rope as R
import Foreign.C.String
import Foreign.C.Types
import GHC.IO.Encoding
import Graphics.X11.Types
import Graphics.X11.Xft
import Graphics.X11.Xlib hiding (Buffer, Position)
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrender
import qualified Streamly.Data.Fold as F
import qualified Streamly.Data.Stream.Prelude as S
import System.Environment
import System.IO.Unsafe
import System.Posix.Pty

doubleClickDelay = 300

data Buffer = Buffer
  { pos :: Word,
    content :: Rope,
    cursor :: (Word, Word),
    selection :: Maybe (CInt, CInt),
    pty :: Pty,
    lastLeftClick :: Time
  }

expandAround :: Rope -> Word -> (Word, Word)
expandAround rp p =
  case (getc p, getc (p+2)) of
    ("(", _) -> (p, searchFor True 0 (=="(") (==")") (p+1))
    (_, ")") -> (searchFor False 0 (==")") (=="(") p, p+1)
    ("[", _) -> (p, searchFor True 0 (=="[") (=="]") (p+1))
    (_, "]") -> (searchFor False 0 (=="]") (=="[") p, p + 1)
    ("{", _) -> (p, searchFor True 0 (=="{") (=="}") (p+1))
    (_, "}") -> (searchFor False 0 (=="}") (=="{") p, p + 1)
    ("'", _) -> (p, searchFor True 0 (=="'") (=="'") (p + 1))
    (_, "'") -> (searchFor False 0 (=="'") (=="'") p, p + 1)
    ("\"", _) -> (p, searchFor True 0 (=="\"") (=="\"") (p + 1))
    (_, "\"") -> (searchFor False 0 (=="\"") (=="\"") p, p + 1)
    ("`", _) -> (p, searchFor True 0 (=="`") (=="`") (p + 1))
    (_, "`") -> (searchFor False 0 (=="`") (=="`") p, p + 1)
    _ -> (searchFor False 0 ws ws p, searchFor True 0 ws ws p)

  where
    l = R.length rp

    ws x = x `elem` [" ", "\t", "(", ")", "[", "]", "{", "}", "\n", "'", "\"", ",", ";", ":", "|"]

    getc i
      | i == 0 = let (sel, _) = R.splitAt 1 rp in R.toText sel
      | i < l = let (R.splitAt (i-1) -> (_, sel), _) = R.splitAt i rp in R.toText sel
    getc _ = ""

    searchFor fwd n a b p =
      case getc p of
        "" -> if fwd then p - 1 else p
        c -> if b c && n == 0
               then if fwd then p - 1 else p
               else searchFor fwd (n + if a c then 1 else if b c then -1 else 0) a b (if fwd then p + 1 else p - 1)

drawWin display win bgcolour fgcolour linecolour selcolour font = do
  buf <- get
  lift $ do
    (_, _, _, n, m, _, _) <- getGeometry display win
    resizePty (pty buf) (fromIntegral n `div` fromIntegral width, fromIntegral m `div` fromIntegral height)
    bracket (createGC display win) (freeGC display) $ \gc -> do
      bracket (createPixmap display win n m (defaultDepthOfScreen (defaultScreenOfDisplay display))) (freePixmap display) $ \p -> do
        withXftDraw display p (defaultVisualOfScreen (defaultScreenOfDisplay display)) (defaultColormap display 0) $ \draw -> do
          xftDrawRect draw bgcolour 0 0 n m

          -- Get rope covering window area
          let winlines = fromIntegral m `div` fromIntegral height
          let (pre, R.splitAtLine winlines -> (vis, _)) = R.splitAtLine (pos buf) (content buf)

          -- relative cursor position
          let (s, e) = cursor buf
              s' :: Int = fromIntegral s - fromIntegral (R.length pre)
              e' :: Int = fromIntegral (max e $ s + 1) - fromIntegral (R.length pre)

          let (R.splitAt (fromIntegral $ max 0 s') -> (presel, sel), postsel) = R.splitAt (fromIntegral $ max 0 e') vis
              Position l1 c1 = R.lengthAsPosition presel
              Position l2 c2 = R.lengthAsPosition (presel <> sel)

          xftDrawRect draw linecolour 0 (l1 * fromIntegral height + 4) n height
          drawRope False draw fgcolour bgcolour 0 height (R.lines presel)
          drawRope True draw fgcolour selcolour (fromIntegral c1 * width) (fromIntegral (l1 + 1) * height) (R.lines sel)
          drawRope False draw fgcolour bgcolour (fromIntegral c2 * width) (fromIntegral (l2 + 1) * height)