module Graphics.Vty.Widgets.Edit
( Edit
, editWidget
, multiLineEditWidget
, getEditText
, getEditCurrentLine
, setEditText
, getEditCursorPosition
, setEditCursorPosition
, setEditLineLimit
, getEditLineLimit
, setEditMaxLength
, getEditMaxLength
, applyEdit
, onActivate
, onChange
, onCursorMove
#ifdef TESTING
, doClipping
, indicatorChar
#endif
)
where
import Control.Applicative ((<$>))
import Control.Monad
import Data.Maybe (isJust)
import qualified Data.Text as T
import Graphics.Vty
import Graphics.Vty.Widgets.Core
import Graphics.Vty.Widgets.Events
import Graphics.Vty.Widgets.Util
import Graphics.Vty.Widgets.TextClip
import qualified Graphics.Vty.Widgets.TextZipper as Z
data Edit = Edit { contents :: Z.TextZipper T.Text
, clipRect :: ClipRect
, activateHandlers :: Handlers (Widget Edit)
, changeHandlers :: Handlers T.Text
, cursorMoveHandlers :: Handlers (Int, Int)
, lineLimit :: Maybe Int
, maxLength :: Maybe Int
}
instance Show Edit where
show e = concat [ "Edit { "
, "contents = ", show $ contents e
, ", lineLimit = ", show $ lineLimit e
, ", clipRect = ", show $ clipRect e
, " }"
]
editWidget' :: IO (Widget Edit)
editWidget' = do
ahs <- newHandlers
chs <- newHandlers
cmhs <- newHandlers
let initSt = Edit { contents = Z.textZipper []
, clipRect = ClipRect { clipLeft = 0
, clipWidth = 0
, clipTop = 0
, clipHeight = 1
}
, activateHandlers = ahs
, changeHandlers = chs
, cursorMoveHandlers = cmhs
, lineLimit = Nothing
, maxLength = Nothing
}
wRef <- newWidget initSt $ \w ->
w { growHorizontal_ = const $ return True
, growVertical_ =
\this -> do
case lineLimit this of
Just v | v == 1 -> return False
_ -> return True
, getCursorPosition_ = internalGetCursorPosition
, render_ = renderEditWidget
, keyEventHandler = editKeyEvent
}
return wRef
internalGetCursorPosition :: Widget Edit -> IO (Maybe DisplayRegion)
internalGetCursorPosition this = do
st <- getState this
f <- focused <~ this
pos <- getCurrentPosition this
let (cursorRow, _) = Z.cursorPosition (contents st)
Phys offset = physCursorCol st clipLeft (clipRect st)
newPos = pos
`withWidth` (toEnum ((fromEnum $ region_width pos) + offset))
`plusHeight` (toEnum (cursorRow (fromEnum $ clipTop $ clipRect st)))
return $ if f then Just newPos else Nothing
renderEditWidget :: Widget Edit -> DisplayRegion -> RenderContext -> IO Image
renderEditWidget this size ctx = do
resize this ( Phys $ fromEnum $ region_height size
, Phys $ fromEnum $ region_width size )
st <- getState this
isFocused <- focused <~ this
let nAttr = mergeAttrs [ overrideAttr ctx
, normalAttr ctx
]
attr = if isFocused then focusAttr ctx else nAttr
clipped = doClipping (Z.getText $ contents st) (clipRect st)
totalAllowedLines = fromEnum $ region_height size
numEmptyLines = lim length clipped
where
lim = case lineLimit st of
Just v -> min v totalAllowedLines
Nothing -> totalAllowedLines
emptyLines = replicate numEmptyLines ""
lineWidget s = let Phys physLineLength = sum $ chWidth <$> s
in string attr s <|>
char_fill attr ' ' (region_width size toEnum physLineLength) 1
return $ vert_cat $ lineWidget <$> (clipped ++ emptyLines)
doClipping :: [T.Text] -> ClipRect -> [String]
doClipping ls rect =
let sliced True = [indicatorChar]
sliced False = ""
truncatedLines = clip2d rect ls
in [ sliced lslice ++ (T.unpack r) ++ sliced rslice
| (r, lslice, rslice) <- truncatedLines ]
toPhysical :: Int -> [Char] -> Phys
toPhysical col line = sum $ chWidth <$> take col line
indicatorChar :: Char
indicatorChar = '$'
editWidget :: IO (Widget Edit)
editWidget = do
wRef <- editWidget'
setNormalAttribute wRef $ style underline
setFocusAttribute wRef $ style underline
setEditLineLimit wRef $ Just 1
return wRef
multiLineEditWidget :: IO (Widget Edit)
multiLineEditWidget = do
wRef <- editWidget'
setEditLineLimit wRef Nothing
return wRef
setEditLineLimit :: Widget Edit -> Maybe Int -> IO ()
setEditLineLimit _ (Just v) | v <= 0 = return ()
setEditLineLimit w v = updateWidgetState w $ \st -> st { lineLimit = v }
getEditLineLimit :: Widget Edit -> IO (Maybe Int)
getEditLineLimit = (lineLimit <~~)
setEditMaxLength :: Widget Edit -> Maybe Int -> IO ()
setEditMaxLength _ (Just v) | v <= 0 = return ()
setEditMaxLength w v = updateWidgetState w $ \st -> st { maxLength = v }
getEditMaxLength :: Widget Edit -> IO (Maybe Int)
getEditMaxLength = (maxLength <~~)
resize :: Widget Edit -> (Phys, Phys) -> IO ()
resize e (newHeight, newWidth) = do
updateWidgetState e $ \st ->
let newRect = (clipRect st) { clipHeight = newHeight
, clipWidth = newWidth
}
(cursorRow, _) = Z.cursorPosition $ contents st
adjusted = updateRect (Phys cursorRow, physCursorCol st) newRect
in st { clipRect = adjusted }
updateWidgetState e $ \s ->
let r = clipRect s
(_, cursorColumn) = Z.cursorPosition $ contents s
curLine = T.unpack $ Z.currentLine $ contents s
(_, _, ri) = clip1d (clipLeft r) (clipWidth r) (T.pack curLine)
newCharLen = if cursorColumn >= 0 && cursorColumn < length curLine
then chWidth $ curLine !! cursorColumn
else Phys 1
newPhysCol = toPhysical cursorColumn curLine
extra = if ri && newPhysCol >= ((clipLeft r) + (clipWidth r) Phys 1)
then newCharLen 1
else 0
newLeft = clipLeft (clipRect s) + extra
in s { clipRect = (clipRect s) { clipLeft = newLeft
}
}
onActivate :: Widget Edit -> (Widget Edit -> IO ()) -> IO ()
onActivate = addHandler (activateHandlers <~~)
notifyActivateHandlers :: Widget Edit -> IO ()
notifyActivateHandlers wRef = fireEvent wRef (activateHandlers <~~) wRef
notifyChangeHandlers :: Widget Edit -> IO ()
notifyChangeHandlers wRef = do
s <- getEditText wRef
fireEvent wRef (changeHandlers <~~) s
notifyCursorMoveHandlers :: Widget Edit -> IO ()
notifyCursorMoveHandlers wRef = do
pos <- getEditCursorPosition wRef
fireEvent wRef (cursorMoveHandlers <~~) pos
onChange :: Widget Edit -> (T.Text -> IO ()) -> IO ()
onChange = addHandler (changeHandlers <~~)
onCursorMove :: Widget Edit -> ((Int, Int) -> IO ()) -> IO ()
onCursorMove = addHandler (cursorMoveHandlers <~~)
getEditText :: Widget Edit -> IO T.Text
getEditText = (((T.intercalate (T.pack "\n")) . Z.getText . contents) <~~)
getEditCurrentLine :: Widget Edit -> IO T.Text
getEditCurrentLine = ((Z.currentLine . contents) <~~)
setEditText :: Widget Edit -> T.Text -> IO ()
setEditText wRef str = do
lim <- lineLimit <~~ wRef
maxL <- maxLength <~~ wRef
let ls1 = case lim of
Nothing -> T.lines str
Just l -> take l $ T.lines str
ls2 = case maxL of
Nothing -> ls1
Just l -> ((T.take l) <$>) $ T.lines str
updateWidgetState wRef $ \st -> st { contents = Z.textZipper ls2
}
notifyChangeHandlers wRef
getEditCursorPosition :: Widget Edit -> IO (Int, Int)
getEditCursorPosition = ((Z.cursorPosition . contents) <~~)
setEditCursorPosition :: (Int, Int) -> Widget Edit -> IO ()
setEditCursorPosition pos = applyEdit (Z.moveCursor pos)
physCursorCol :: Edit -> Phys
physCursorCol s =
let curLine = T.unpack $ Z.currentLine $ contents s
(_, cursorColumn) = Z.cursorPosition $ contents s
in toPhysical cursorColumn curLine
applyEdit :: (Z.TextZipper T.Text -> Z.TextZipper T.Text)
-> Widget Edit
-> IO ()
applyEdit f this = do
old <- contents <~~ this
llim <- lineLimit <~~ this
maxL <- maxLength <~~ this
let checkLines tz = case llim of
Nothing -> Just tz
Just l -> if length (Z.getText tz) > l
then Nothing
else Just tz
checkLength tz = case maxL of
Nothing -> Just tz
Just l -> if or ((> l) <$> (Z.lineLengths tz))
then Nothing
else Just tz
newContents = checkLength =<< checkLines (f old)
when (isJust newContents) $ do
let Just new = newContents
updateWidgetState this $ \s -> s { contents = new }
when (Z.getText old /= Z.getText new) $
notifyChangeHandlers this
when (Z.cursorPosition old /= Z.cursorPosition new) $
notifyCursorMoveHandlers this
editKeyEvent :: Widget Edit -> Key -> [Modifier] -> IO Bool
editKeyEvent this k mods = do
let run f = applyEdit f this >> return True
case (k, mods) of
(KASCII 'a', [MCtrl]) -> run Z.gotoBOL
(KASCII 'k', [MCtrl]) -> run Z.killToEOL
(KASCII 'e', [MCtrl]) -> run Z.gotoEOL
(KASCII 'd', [MCtrl]) -> run Z.deleteChar
(KLeft, []) -> run Z.moveLeft
(KRight, []) -> run Z.moveRight
(KUp, []) -> run Z.moveUp
(KDown, []) -> run Z.moveDown
(KBS, []) -> do
v <- run Z.deletePrevChar
when (v) $ do
updateWidgetState this $ \st ->
let r = clipRect st
in if clipLeft r > 0
then st { clipRect = r { clipLeft = clipLeft r Phys 1 } }
else st
return v
(KDel, []) -> run Z.deleteChar
(KASCII ch, []) -> run (Z.insertChar ch)
(KHome, []) -> run Z.gotoBOL
(KEnd, []) -> run Z.gotoEOL
(KEnter, []) -> do
lim <- lineLimit <~~ this
case lim of
Just 1 -> notifyActivateHandlers this >> return True
_ -> run Z.breakLine
_ -> return False