{-|
Module      : Data.UI
Description : Minimalistic console UI (getLine), arrow key support
               (edit, browse cmd history).
Copyright   : (c) dr. Jonas Birch, 2024
License     : MIT
Maintainer  : dr. Jonas Birch <mnt@doctorbirch.com>
Stability   : stable
Portability : POSIX

The __UI library__ provides a more modern /getLine/ style function for making console based CLIs (command line interfaces). The library provides editing capabilities through the use of arrow keys, as well as browsing through the command history.

It is very minimalistic, does only export two functions and doesn't require its own monad (only IO).
-}
module Data.UI (
    -- * Data types

    --

    Term(..), TermRes(..), Line,
    -- * Functions

    --

    init, input
) where

import Prelude hiding (init, Left, Right, log)
import GHC.IO.Handle (
    hIsTerminalDevice, hSetBuffering, hSetEcho,
    hGetBuf, hFlush
 )
import Control.Monad (unless)
import Data.Char (chr)
import Data.Word (Word16)
import Foreign.Marshal.Alloc (allocaBytes)
import GHC.IO.Handle.Types (BufferMode(..))
import GHC.IO.Handle.FD (stdin,stdout)
import GHC.Storable (writeIntOffPtr, readIntOffPtr)
import Text.Printf (printf)

import Data.Util (
    Vector,
    betw, filter3, inject, vnew, (§), (§:)
 )

maxcols :: Int
maxcols :: Int
maxcols = Int
80

a :: String -> IO ()
a :: String -> IO ()
a = String -> IO ()
putstr (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\x1b[%s"
a' :: String -> String
a' :: String -> String
a' = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"\x1b[%s"

erasel,scrmode :: IO ()
erasel :: IO ()
erasel  = String -> IO ()
a String
"2K\r"
scrmode :: IO ()
scrmode = String -> IO ()
a (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"=3h" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
a' String
"=7hl"

col  :: Int -> IO ()
col :: Int -> IO ()
col  Int
n = String -> IO ()
a (Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"G")
col' :: Int -> String
col' :: Int -> String
col' Int
n = String -> String
a' (Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"G")
-- mup  :: Int -> IO ()

-- mup n = if n == 0 then

--     return ()

--  else

--     a (show (n - 1) <> "A")


-- | Line is the datatype of the returned text string when

--  the user presses enter. This type can easily be changed

--  from the default (String) to Text or anything else. Change

--  it in the type alias and it will be used everywhere.

type Line = String
type Key  = Word16

-- | Term is the internal state of the library.

data Term = Term
 { Term -> Bool
initialized  :: Bool
 , Term -> Vector String
log          :: Vector Line
 , Term -> Int
logpos       :: Int
 , Term -> Int
loglen       :: Int
 , Term -> String
buf          :: Line
 , Term -> Int
len          :: Int
 , Term -> Int
pos          :: Int
 , Term -> String
prompt       :: Line
 }
 deriving stock Int -> Term -> String -> String
[Term] -> String -> String
Term -> String
(Int -> Term -> String -> String)
-> (Term -> String) -> ([Term] -> String -> String) -> Show Term
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Term -> String -> String
showsPrec :: Int -> Term -> String -> String
$cshow :: Term -> String
show :: Term -> String
$cshowList :: [Term] -> String -> String
showList :: [Term] -> String -> String
Show

mkterm :: Line -> Term
mkterm :: String -> Term
mkterm String
pr =
    Bool
-> Vector String
-> Int
-> Int
-> String
-> Int
-> Int
-> String
-> Term
Term Bool
False (Int -> String -> Vector String
forall a. Int -> a -> Vector a
vnew Int
2 String
"") Int
0 Int
2 String
"" Int
0 (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
pr

-- | TermRes is the result of the input. Returned whenever the user presses a key.

data TermRes =
    TKey Key        -- ^ Returns the numeric value on each key press (except enter).

    | TLine Line    -- ^ Returns the line of data when user presses enter.

instance Show TermRes where
    show :: TermRes -> String
show (TKey Key
k)  = String -> Key -> String
forall r. PrintfType r => String -> r
printf String
"0x%.04hx" Key
k
    show (TLine String
s) = String
s

data Arrow =
    Up
    | Right
    | Down
    | Left
    deriving stock Int -> Arrow -> String -> String
[Arrow] -> String -> String
Arrow -> String
(Int -> Arrow -> String -> String)
-> (Arrow -> String) -> ([Arrow] -> String -> String) -> Show Arrow
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Arrow -> String -> String
showsPrec :: Int -> Arrow -> String -> String
$cshow :: Arrow -> String
show :: Arrow -> String
$cshowList :: [Arrow] -> String -> String
showList :: [Arrow] -> String -> String
Show

toarrow :: Key -> Arrow
toarrow :: Key -> Arrow
toarrow Key
0x415b = Arrow
Up
toarrow Key
0x435b = Arrow
Right
toarrow Key
0x425b = Arrow
Down
toarrow Key
0x445b = Arrow
Left
toarrow Key
_      = String -> Arrow
forall a. HasCallStack => String -> a
error String
"Non arrow value passed to toarrow."

-- | __init__ /initial_prompt/

--

-- Initializes the terminal. Returns a handle which you pass

-- on to the __input__ function.

init :: Line -> IO Term
init :: String -> IO Term
init String
pr = do
    let
        term :: Term
term = String -> Term
mkterm String
pr
    hastty <- Handle -> IO Bool
hIsTerminalDevice Handle
stdin
    unless hastty $
        error "No valid tty"
    _ <- hSetBuffering stdin NoBuffering
    _ <- hSetEcho stdin False
    _ <- scrmode
    _ <- col 0
    _ <- erasel
    let
        term' = Term
term { initialized = True }
    return term'

putstr :: String -> IO ()
putstr :: String -> IO ()
putstr String
s = do
    _ <- String -> IO ()
putStr String
s
    hFlush stdout

-- split :: Int -> String -> String

-- split = split' []


-- split' :: String -> Int -> String -> String

-- split' acc _ [] = acc

-- split' [] n xs

--  | length xs < n = xs

-- split' !acc n xs

--  | length xs < n = acc <> ('\r':xs)

-- split' [] n xs =

--     split' (take n xs) n (drop n xs)

-- split' !acc n xs =

--     split' (acc <> "\r" <> take n xs) n (drop n xs)


-- | __input__ /handle/

--

-- Reads one character from the keyboard. You give it the handle

-- from the last function call. It returns the string when pressed

-- enter and returns the key code otherwise.

--

-- __Example:__

--

-- >> 

-- >> import qualified Data.UI (init, input)

-- >> import Data.UI (TermRes(..))

-- >> 

-- >> example :: IO ()

-- >> example = do

-- >>     t <- Data.UI.init "prompt> "

-- >>     go t

-- >>     where

-- >>      go t' = do

-- >>         (res,newstate) <- Data.UI.input t'

-- >>         case res of

-- >>             TLine x  -> do

-- >>                          _ <- putStrLn $ "\nResult: '" <> x <> "'"

-- >>                          go newstate

-- >>             _        -> go newstate

-- >> 

-- 

input :: Term -> IO (TermRes,Term)
input :: Term -> IO (TermRes, Term)
input Term
t = do
    _ <- IO ()
erasel
    _ <- putstr $ t.prompt <> t.buf -- (split maxcols t.buf)

    _ <- col t.pos
    c <- allocaBytes 4 $ \Ptr Int
p -> do
        _ <- Ptr Int -> Int -> Int -> IO ()
writeIntOffPtr Ptr Int
p Int
0 Int
0
        n <- hGetBuf stdin p 1
        if n /= 1 then
            return 0
        else do
            c <- readIntOffPtr p 0
            let
                c' = Int -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c :: Key
            case c' of
                Key
0x1b -> do
                    _ <- Ptr Int -> Int -> Int -> IO ()
writeIntOffPtr Ptr Int
p Int
0 Int
0
                    n' <- hGetBuf stdin p 2
                    if n' /= 2 then
                        return 0
                    else do
                        c_ <- readIntOffPtr p 0
                        let
                            c'' = Int -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c_ :: Key
                        return c''
                Key
_       -> Key -> IO Key
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Key
c'
    let
        (mr,t',ansi) = case c of
            Key
n | Int -> Int -> Int -> Bool
betw Int
0x20 Int
0x7e Int
n'   -> Term -> Char -> (Maybe TermRes, Term, String)
addchar Term
t (Char -> (Maybe TermRes, Term, String))
-> Char -> (Maybe TermRes, Term, String)
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
n'
             where
                n' :: Int
n' = Key -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
n :: Int
            Key
0x7f                    -> Term -> (Maybe TermRes, Term, String)
delchar Term
t
            Key
0x0a                    -> Term -> (Maybe TermRes, Term, String)
execute Term
t
            Key
n | Key
n Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key]
arrs       -> Term -> Arrow -> (Maybe TermRes, Term, String)
arr Term
t (Arrow -> (Maybe TermRes, Term, String))
-> Arrow -> (Maybe TermRes, Term, String)
forall a b. (a -> b) -> a -> b
$ Key -> Arrow
toarrow Key
n
            Key
_                       -> (Maybe TermRes
forall a. Maybe a
Nothing,Term
t,String
"")
        ret = case Maybe TermRes
mr of
            Just TermRes
x  -> TermRes
x
            Maybe TermRes
Nothing -> Key -> TermRes
TKey Key
c
        arrs = [Key
0x415b, Key
0x435b, Key
0x425b, Key
0x445b]
    _ <- putstr ansi
    return (ret,t')
 where
    addchar :: Term -> Char -> (Maybe TermRes,Term,String)
    delchar,execute :: Term -> (Maybe TermRes,Term,String)
    arr    :: Term -> Arrow -> (Maybe TermRes,Term,String)
    addchar :: Term -> Char -> (Maybe TermRes, Term, String)
addchar Term
trm =
        case Term
trm.len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Term
trm.prompt of
            Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxcols -> (Maybe TermRes, Term, String)
-> Char -> (Maybe TermRes, Term, String)
forall a b. a -> b -> a
const (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm,String
"\x07")
            Int
_               ->
                  if Term -> Bool
rightmost Term
trm then Term -> Char -> (Maybe TermRes, Term, String)
naiveaddchar Term
trm else Term -> Char -> (Maybe TermRes, Term, String)
caddchar Term
trm
    delchar :: Term -> (Maybe TermRes, Term, String)
delchar Term
trm = if Term -> Bool
rightmost Term
trm then Term -> (Maybe TermRes, Term, String)
naivedelchar Term
trm else Term -> (Maybe TermRes, Term, String)
cdelchar Term
trm

    rightmost :: Term -> Bool
    rightmost :: Term -> Bool
rightmost Term
trm = let
        pos' :: Int
pos' = Term
trm.len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Term
trm.prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
     in
        Term
trm.pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pos'

    execute :: Term -> (Maybe TermRes, Term, String)
execute Term
trm = let
        trm' :: Term
trm' = if Term
trm.len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Term
trm else Term
trm {
            buf = "",
            len = 0,
            pos = length trm.prompt + 1,
            loglen = trm.loglen + 1,
            logpos = 0,
            log = trm.buf§:trm.log
        }
     in
        (TermRes -> Maybe TermRes
forall a. a -> Maybe a
Just (TermRes -> Maybe TermRes) -> TermRes -> Maybe TermRes
forall a b. (a -> b) -> a -> b
$ String -> TermRes
TLine Term
trm.buf,Term
trm',Int -> String
col' Term
trm'.pos)

    arr :: Term -> Arrow -> (Maybe TermRes, Term, String)
arr Term
trm Arrow
Left = let
        trm' :: Term
trm' = if Term
trm.pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Term
trm.prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) then Term
trm else Term
trm {
            pos = trm.pos - 1
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)
    arr Term
trm Arrow
Right = let
        trm' :: Term
trm' = if Term -> Bool
rightmost Term
trm then Term
trm else Term
trm {
            pos = trm.pos + 1
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)
    arr Term
trm Arrow
Up
     | Term
trm.logpos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Term
trm.loglen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) = (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm,String
"")
    arr Term
trm Arrow
Up = let
        trm' :: Term
trm' = Term
trm {
            logpos = newpos,
            buf = newbuf,
            len = length newbuf,
            pos = (length trm.prompt + 1) + newlen
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)
     where
        newpos :: Int
newpos = Term
trm.logpos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        newbuf :: String
newbuf = Term
trm.log Vector String -> Int -> String
forall a. Vector a -> Int -> a
§ Int
newpos
        newlen :: Int
newlen = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
newbuf
    arr Term
trm Arrow
Down
     | Term
trm.logpos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm,String
"")
    arr Term
trm Arrow
Down = let
        trm' :: Term
trm' = Term
trm {
            logpos = newpos,
            buf = newbuf,
            len = length newbuf,
            pos = (length trm.prompt + 1) + newlen
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)
     where
        newpos :: Int
newpos = Term
trm.logpos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        newbuf :: String
newbuf = Term
trm.log Vector String -> Int -> String
forall a. Vector a -> Int -> a
§ Int
newpos
        newlen :: Int
newlen = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
newbuf

    naiveaddchar :: Term -> Char -> (Maybe TermRes,Term,String)
    naiveaddchar :: Term -> Char -> (Maybe TermRes, Term, String)
naiveaddchar Term
trm Char
ch = let
        trm' :: Term
trm' = Term
trm {
            buf = (reverse . (ch:) . reverse) trm.buf,
            len = trm.len + 1,
            pos = trm.pos + 1
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)
    
    caddchar :: Term -> Char -> (Maybe TermRes,Term,String)
    caddchar :: Term -> Char -> (Maybe TermRes, Term, String)
caddchar Term
trm Char
ch = let
        trm' :: Term
trm' = Term
trm {
            len = trm.len + 1,
            pos = trm.pos + 1,
            buf = inject ch (trm.pos - length trm.prompt - 1) trm.buf
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)
    
    naivedelchar :: Term -> (Maybe TermRes,Term,String)
    naivedelchar :: Term -> (Maybe TermRes, Term, String)
naivedelchar Term
trm = let
        trm' :: Term
trm' = if Term
trm.pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Term
trm.prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 then Term
trm else Term
trm {
            buf = take (trm.len - 1) trm.buf,
            len = trm.len - 1,
            pos = trm.pos - 1
        }
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)

-- sh int status

    
    cdelchar :: Term -> (Maybe TermRes,Term,String)
    cdelchar :: Term -> (Maybe TermRes, Term, String)
cdelchar Term
trm = let
        trm' :: Term
trm' = if Term
trm.pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Term
trm.prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 then Term
trm else Term
trm {
            len = trm.len - 1,
            pos = trm.pos - 1,
            buf = filter3 f trm.buf
        }
        f :: a -> Int -> [a] -> Bool
        f :: forall a. a -> Int -> [a] -> Bool
f a
_ Int
n [a]
_ = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Term
trm.pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Term
trm.prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
     in
        (Maybe TermRes
forall a. Maybe a
Nothing,Term
trm',Int -> String
col' Term
trm'.pos)