{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Simple.UI.Widgets.Edit (
Edit,
EditClass,
castToEdit,
editNew,
text
) where
import Control.Lens (makeLensesFor, (.=))
import Control.Monad
import qualified Graphics.Vty as Vty
import Simple.UI.Core.Attribute
import Simple.UI.Core.Draw
import Simple.UI.Core.Internal.UIApp
import Simple.UI.Core.ListenerList
import Simple.UI.Utils
import Simple.UI.Widgets.Text
import Simple.UI.Widgets.Widget
data Edit = Edit
{ _editParent :: Text
, _editCursorPos :: Attribute Int
, _editXOffset :: Attribute Int
, _editWidth :: Attribute Int
}
makeLensesFor [("_editParent", "editParent")] ''Edit
class TextClass w => EditClass w where
castToEdit :: w -> Edit
instance EditClass Edit where
castToEdit = id
instance TextClass Edit where
castToText = _editParent
instance WidgetClass Edit where
castToWidget = castToWidget . _editParent
overrideWidget = overrideWidgetHelper editParent
editNew :: Maybe String -> UIApp u Edit
editNew s = do
edit <- editNewOverride s
on_ edit draw $ editDraw edit
on_ edit keyPressed $ \key _ ->
case key of
Vty.KChar c -> do
pos <- get edit _editCursorPos
offset <- get edit _editXOffset
modify edit text $ \case
Nothing -> Just [c]
Just x -> Just $ insertAt (pos + offset) x c
cursorGoRight edit
Vty.KBS -> do
pos <- get edit _editCursorPos
offset <- get edit _editXOffset
modify edit text $ \case
Nothing -> Nothing
Just x -> do
let x' = removeAt (pos + offset - 1) x
if null x' then Nothing else Just x'
cursorGoLeft edit
Vty.KDel -> do
pos <- get edit _editCursorPos
offset <- get edit _editXOffset
modify edit text $ \case
Nothing -> Nothing
Just x -> do
let x' = removeAt (pos + offset) x
if null x' then Nothing else Just x'
Vty.KHome -> do
modify edit _editCursorPos $ const 0
modify edit _editXOffset $ const 0
Vty.KEnd -> do
_text <- get edit text
forM_ _text $ \x -> do
width <- pred <$> get edit _editWidth
if length x > width
then do
modify edit _editCursorPos $ const width
modify edit _editXOffset $ const (length x - width)
else do
modify edit _editCursorPos $ const (length x)
modify edit _editXOffset $ const 0
Vty.KLeft ->
cursorGoLeft edit
Vty.KRight ->
cursorGoRight edit
_ ->
return ()
return edit
where
cursorGoRight edit = do
_text <- get edit text
forM_ _text $ \x -> do
width <- pred <$> get edit _editWidth
pos <- get edit _editCursorPos
offset <- get edit _editXOffset
let (newPos, newOffset) =
if pos + 1 > width
then
if pos + offset + 1 > length x
then
(pos, offset)
else
(pos, offset + 1)
else
(pos + 1, offset)
set edit _editCursorPos newPos
set edit _editXOffset newOffset
cursorGoLeft edit = do
_text <- get edit text
forM_ _text $ \_ -> do
pos <- get edit _editCursorPos
offset <- get edit _editXOffset
let (newPos, newOffset) =
if pos - 1 < 0
then
if offset > 0
then
(0, offset - 1)
else
(0, 0)
else
(pos - 1, offset)
set edit _editCursorPos newPos
set edit _editXOffset newOffset
editNewOverride :: Maybe String -> UIApp u Edit
editNewOverride s = override <$> editNewDefault s
where
editComputeSize edit = do
maybeText <- get edit text
case maybeText of
Nothing -> return (1, 1)
Just _text -> do
let width = if length _text < 2 then 2 else length _text
return (width ,1)
override edit = overrideWidget edit $ do
virtualWidgetName .= "edit"
virtualWidgetComputeSize .= editComputeSize edit
editNewDefault :: Maybe String -> UIApp u Edit
editNewDefault s = do
parent <- textNew s
pos <- attributeNew $ length s
offset <- attributeNew 0
width <- attributeNew 1
return Edit
{ _editParent = parent
, _editCursorPos = pos
, _editXOffset = offset
, _editWidth = width
}
editDraw :: Edit -> Drawing -> Int -> Int -> UIApp u ()
editDraw edit drawing width _ = do
set edit _editWidth width
maybeText <- get edit text
fg <- get edit colorForeground
bg <- get edit colorBackground
style <- get edit colorStyle
drawingRun drawing $ do
drawingSetAttrs fg bg style
drawingClear
case maybeText of
Just _text -> do
pos <- get edit _editCursorPos
offset <- get edit _editXOffset
let s = drop offset _text
forM_ (zip (s ++ " ") [0..]) $ \(c, i) ->
if pos == i
then drawingPutCharWithAttr bg fg style i 0 c
else drawingPutChar i 0 c
Nothing ->
drawingPutCharWithAttr bg fg style 0 0 ' '