{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module BearUI where
import Control.Monad (void)
import Control.Monad.State (StateT, gets, liftIO)
import Data.Char (chr, ord)
import qualified BearLibTerminal as B
import BearLibTerminal.Keycodes ()
import qualified Data.Map.Strict as M
import CStyle
import Geometry
import Window
import qualified CPos as CP
import qualified KeyBindings as KB
import qualified TermM as TM
data UIState = UIState
{ uiKeyBindings :: KB.KeyBindings
, asciiOnly :: Bool
}
type UIM = StateT UIState IO
nullUIState :: UIState
nullUIState = UIState [] False
getWin :: Window -> WinDim
getWin win = M.findWithDefault (WinDim 0 0 0 0) win geometry
getBindings :: UIM KB.KeyBindings
getBindings = gets $ (<> KB.defaultBindings) . uiKeyBindings
charify :: B.Keycode -> Maybe Char
charify key = case key of
B.TkBackspace -> Just '\b'
B.TkLeft -> Just '←'
B.TkRight -> Just '→'
B.TkDown -> Just '↓'
B.TkUp -> Just '↑'
B.TkMinus -> Just '-'
B.TkEscape -> Just '\ESC'
B.TkSpace -> Just ' '
B.TkReturn -> Just '\r'
B.TkEnter -> Just '\n'
c | B.TkA <= c && c <= B.TkZ -> Just $ chr (ord 'A' + (fromEnum c - fromEnum B.TkA))
B.Tk0 -> Just '0'
c | B.Tk1 <= c && c <= B.Tk9 -> Just $ chr (ord '1' + (fromEnum c - fromEnum B.Tk1))
B.TkKp0 -> Just '0'
c | B.TkKp1 <= c && c <= B.TkKp9 -> Just $ chr (ord '1' + (fromEnum c - fromEnum B.TkKp1))
_ -> Nothing
wSetStyle :: Window -> CStyle -> UIM ()
wSetStyle _ (CStyle col b) = do
let (bg,fg) = col `divMod` 8
liftIO . B.terminalColorUInt $ colour fg b
liftIO . B.terminalBkColorUInt $ colour (bgTrans bg) False
where
bgTrans :: Int -> Int
bgTrans 1 = 4 -- blue
bgTrans 2 = 1 -- red
bgTrans 3 = 5 -- magenta
bgTrans _ = 7 -- black
colour c False = case c of
0 -> 0xffafafaf -- grey
1 -> 0xffaf0000 -- red
2 -> 0xff00af00 -- green
3 -> 0xffafaf00 -- yellow
4 -> 0xff0000af -- blue
5 -> 0xffaf008f -- magenta
6 -> 0xff00afaf -- cyan
_ -> 0xff000000 -- black
colour c True = case c of
0 -> 0xffffffff -- white
1 -> 0xffff0000 -- bold red
2 -> 0xff00ff00 -- bold green
3 -> 0xffffff00 -- bold yellow
4 -> 0xff0000ff -- bold blue
5 -> 0xffff00bf -- bold magenta
6 -> 0xff00ffff -- bold cyan
_ -> 0xff303030 -- dark grey
withStyle :: Window -> CStyle -> (UIM a -> UIM a)
withStyle w style m = wSetStyle w style >> (m <* wSetStyle w style0)
subCharAscii :: Bool -> Char -> Char
subCharAscii True = \case
'·' -> '+'
'┌' -> '+'
'┐' -> '+'
'└' -> '+'
'┘' -> '+'
'│' -> '|'
'║' -> '}'
'─' -> '-'
'═' -> '='
c -> c
subCharAscii False = id
drawHighlightBoxChars :: CP.CPos -> [Glyph] -> UIM ()
drawHighlightBoxChars p gls = do
let w = 2 + length gls
liftIO $ B.terminalLayer 1
sub <- gets $ subCharAscii . asciiOnly
withStyle TutorialWin (CStyle magenta True) . liftIO $ drawBorder sub (3,w)
liftIO $ B.terminalLayer 0
where
-- Draw border manually rather than using C.wBorder:
-- default border characters are ugly on e.g. windows PuTTY,
-- and trying to set C.Border to use box-drawing chars doesn't work.
drawBorder :: (Char -> Char) -> (Int,Int) -> IO ()
drawBorder sub (h,w) = do
let add y x s = drawStrByChar (p' <> CP.CPos x y) $ sub <$> s
add 0 0 $ '╔':replicate (w-2) '═' <> "╗"
sequence_ [ add y' 0 "║" >> add y' (w-1) "║" | y' <- [1..h-2] ]
add (h-1) 0 $ '╚':replicate (w-2) '═' <> "╝"
p' = p <> CP.CPos (-1) (-1)
drawStr :: Window -> CStyle -> CP.CPos -> String -> UIM ()
drawStr w style (CP.CPos x y) s = do
sub <- gets $ subCharAscii . asciiOnly
let WinDim dx dy _ _ = getWin w
withStyle w style . liftIO $ drawStrByChar (CP.CPos (x+dx) (y+dy)) (sub <$> s)
drawStrByChar :: CP.CPos -> String -> IO ()
drawStrByChar (CP.CPos x y) s =
-- B.terminalPrintString seems to have problems with unicode chars,
-- so use B.terminalPut instead.
sequence_ [ B.terminalPut (x+dx) y ch | (dx,ch) <- zip [0..] s ]
drawGlyph :: Window -> CP.CPos -> Glyph -> UIM ()
drawGlyph w (CP.CPos x y) (Glyph ch style) = do
sub <- gets $ subCharAscii . asciiOnly
let WinDim dx dy _ _ = getWin w
withStyle w style . liftIO $ B.terminalPut (x+dx) (y+dy) (sub ch)
erase :: UIM ()
erase = B.terminalClear
wErase, wRefresh :: Window -> UIM ()
wErase win = do
let WinDim x y w h = getWin win
void . liftIO $ B.terminalClearArea x y w h
wRefresh _ = liftIO B.terminalRefresh -- no per-win version
instance TM.TermM UIM where
drawStr = drawStr
drawGlyph = drawGlyph
wErase = wErase
wRefresh = wRefresh
drawHighlightBoxChars = drawHighlightBoxChars
asciiOnly = gets asciiOnly