5e35722 · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

WIP: Add pane', separate dynamic widths and heights

commit5e357224c9f5f7083da3dfe674b77213513f29ac authorAli Abrar <aliabrar@gmail.com> dateSat 16 Feb 2019, 21:00 (8 years ago) parent7a3b28a

3 files changed+137−54

compare with develop

unifiedsplit

src-bin/example.hs+44−19 src/Reflex/Vty/Widget.hs+76−27 src/Reflex/Vty/Widget/Input/Text.hs+17−8

src-bin/example.hs+44−19

@@ -11,9 +11,10 @@

1111{-# OPTIONS_GHC -threaded #-}

1212

1313import Control.Applicative

14−import Control.Monad (void)

14+import Control.Monad

1515import Control.Monad.Fix

1616import Data.Map (Map)

17+import Data.Maybe

1718import qualified Data.Map as Map

1819import Data.Text (Text)

1920import qualified Data.Text as T

@@ -32,7 +33,9 @@ data Example = Example_TextEditor

3233main :: IO ()

3334main = mainWidget $ do

3435 inp <- input

35− size <- displaySize

36+ taskList

37+

38+{-

3639 let buttons = do

3740 text $ pure "Select an example. Esc will bring you back here. Ctrl+c to quit."

3841 let region1 = ffor size $ \(w,h) ->

@@ -55,6 +58,8 @@ main = mainWidget $ do

5558 Left Example_TextEditor -> escapable testBoxes

5659 Left Example_Todo -> escapable taskList

5760 Right () -> buttons

61+

62+-}

5863 return $ fforMaybe inp $ \case

5964 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()

6065 _ -> Nothing

@@ -75,15 +80,18 @@ taskList = do

7580 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)

7681 return ()

7782

83+{-

7884testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()

7985testBoxes = do

80− size <- displaySize

81− let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size

82− region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size

86+ dw <- displayWidth

87+ dh <- displayHeight

88+ let region1 = liftA2 (\w h -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) dw dh

89+ region2 = liftA2 (\w h -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) dw dh

8390 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput

8491 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $

8592 splitVDrag (hRule doubleBoxStyle) (boxStatic roundedBoxStyle $ multilineTextInput def) (boxStatic roundedBoxStyle dragTest)

8693 return ()

94+-}

8795

8896debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()

8997debugFocus = do

@@ -113,12 +121,14 @@ data Todo = Todo

113121data TodoOutput t = TodoOutput

114122 { _todoOutput_todo :: Dynamic t Todo

115123 , _todoOutput_delete :: Event t ()

124+ , _todoOutput_height :: Dynamic t Int

116125 }

117126

118127instance Reflex t => Switchable t (TodoOutput t) where

119128 switching t0 e = TodoOutput

120129 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)

121130 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)

131+ <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)

122132

123133todo

124134 :: (MonadHold t m, MonadFix m, Reflex t)

@@ -126,18 +136,23 @@ todo

126136 -> VtyWidget t m (TodoOutput t)

127137todo t0 = do

128138 w <- displayWidth

129− let checkboxWidth = 3

130− checkboxRegion = pure $ Region 0 0 checkboxWidth 1

131− labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1

132− value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0

133− (label, d) <- pane labelRegion (pure True) $ do

134− i <- input

135− v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }

136− let deleteSelf = attachWithMaybe backspaceOnEmpty (current v) i

137− return (v, deleteSelf)

139+ rec let checkboxWidth = 3

140+ checkboxRegion = pure $ Region 0 0 checkboxWidth 1

141+ labelHeight = _textInput_lines ti

142+ labelWidth = ffor w $ \w' -> w' - 1 - checkboxWidth

143+ labelLeft = constDyn $ checkboxWidth + 1

144+ labelTop = constDyn 0

145+ -- labelRegion = liftA2 (\w' h -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) h) w (_textInput_lines ti)

146+ value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0

147+ (ti, d) <- pane' labelLeft labelTop labelWidth labelHeight (pure True) $ do

148+ i <- input

149+ v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }

150+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i

151+ return (v, deleteSelf)

138152 return $ TodoOutput

139− { _todoOutput_todo = Todo <$> label <*> value

153+ { _todoOutput_todo = Todo <$> (_textInput_value ti) <*> value

140154 , _todoOutput_delete = d

155+ , _todoOutput_height = _textInput_lines ti

141156 }

142157 where

143158 backspaceOnEmpty v = \case

@@ -156,10 +171,20 @@ todos todos0 newTodo = do

156171 let reg = zipDynWith (\w' ts ->

157172 let l = Map.size $ Map.takeWhileAntitone (<row) ts

158173 in Region 0 l w' 1) w todosMap

159− pane reg (fmap (==row) selected) $ do

160− e <- mouseUp

161− r <- todo t

162− return (row <$ e, r)

174+ pane'

175+ (pure 0)

176+ (fromMaybe 0 . Map.lookup row <$> offsets)

177+ w

178+ (fromMaybe 1 . Map.lookup row <$> heights)

179+ (fmap (==row) selected) $ do

180+ e <- mouseUp

181+ r <- todo t

182+ return (row <$ e, r)

183+ let heights :: Dynamic t (Map Int Int) = joinDynThroughMap $ fmap (fmap (_todoOutput_height . snd)) listOut

184+ offsets :: Dynamic t (Map Int Int) = ffor heights $ \m ->

185+ let l = Map.toList m

186+ o = scanl (+) 0 $ map snd l

187+ in Map.fromList $ zipWith (\(k, _) o' -> (k, o')) l o

163188 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut

164189 selected <- holdDyn 0 $ leftmost

165190 [ selectionClick

src/Reflex/Vty/Widget.hs+76−27

@@ -23,8 +23,6 @@ module Reflex.Vty.Widget

2323 , mainWidget

2424 , mainWidgetWithHandle

2525 , HasDisplaySize(..)

26− , displayWidth

27− , displayHeight

2826 , HasFocus(..)

2927 , HasVtyInput(..)

3028 , Region(..)

@@ -37,9 +35,10 @@ module Reflex.Vty.Widget

3735 , mouseDown

3836 , mouseUp

3937 , pane

38+ , pane'

4039 , tellImages

4140 , splitV

42− , splitVDrag

41+ -- , splitVDrag TODO

4342 , box

4443 , boxStatic

4544 , RichTextConfig(..)

@@ -76,8 +75,10 @@ import Reflex.Vty.Host

7675

7776-- | The context within which a 'VtyWidget' runs

7877data VtyWidgetCtx t = VtyWidgetCtx

79− { _vtyWidgetCtx_size :: Dynamic t (Int,Int)

80− -- ^ The width and height of the region allocated to the widget.

78+ { _vtyWidgetCtx_width :: Dynamic t Int

79+ -- ^ The width of the region allocated to the widget.

80+ , _vtyWidgetCtx_height :: Dynamic t Int

81+ -- ^ The height of the region allocated to the widget.

8182 , _vtyWidgetCtx_focus :: Dynamic t Bool

8283 -- ^ Whether the widget should behave as if it has focus for keyboard input.

8384 , _vtyWidgetCtx_input :: Event t VtyEvent

@@ -130,7 +131,8 @@ mainWidgetWithHandle vty child =

130131 V.EvResize {} -> Nothing

131132 x -> Just x

132133 let ctx = VtyWidgetCtx

133− { _vtyWidgetCtx_size = size

134+ { _vtyWidgetCtx_width = fmap fst size

135+ , _vtyWidgetCtx_height = fmap snd size

134136 , _vtyWidgetCtx_input = inp'

135137 , _vtyWidgetCtx_focus = constDyn True

136138 }

@@ -152,18 +154,14 @@ mainWidget child = do

152154

153155-- | A class for things that know their own display size dimensions

154156class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where

155− displaySize :: m (Dynamic t (Int, Int))

157+ -- | Retrieve the display width (columns)

158+ displayWidth :: m (Dynamic t Int)

159+ -- | Retrieve the display height (rows)

160+ displayHeight :: m (Dynamic t Int)

156161

157162instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where

158− displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size

159−

160−-- | Retrieve the display width (columns)

161−displayWidth :: HasDisplaySize t m => m (Dynamic t Int)

162−displayWidth = fmap fst <$> displaySize

163−

164−-- | Retrieve the display height (rows)

165−displayHeight :: HasDisplaySize t m => m (Dynamic t Int)

166−displayHeight = fmap snd <$> displaySize

163+ displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width

164+ displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height

167165

168166-- | A class for things that can receive vty events as input

169167class HasVtyInput t m | m -> t where

@@ -238,7 +236,9 @@ pane reg foc child = VtyWidget $ do

238236 (_vtyWidgetCtx_input ctx)

239237 ]

240238 , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc

241− , _vtyWidgetCtx_size = fmap regionSize reg }

239+ , _vtyWidgetCtx_width = fmap (fst . regionSize) reg

240+ , _vtyWidgetCtx_height = fmap (snd . regionSize) reg

241+ }

242242 (result, images) <- lift . lift $ runVtyWidget ctx' child

243243 let images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images

244244 tellImages images'

@@ -259,6 +259,51 @@ pane reg foc child = VtyWidget $ do

259259 | otherwise =

260260 Just (con (x - l) (y - t))

261261

262+pane'

263+ :: (Reflex t, Monad m)

264+ => Dynamic t Int

265+ -> Dynamic t Int

266+ -> Dynamic t Int

267+ -> Dynamic t Int

268+ -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.

269+ -> VtyWidget t m a

270+ -> VtyWidget t m a

271+pane' l t w h foc child = VtyWidget $ do

272+ ctx <- lift ask

273+ let reg = Region <$> l <*> t <*> w <*> h

274+ let ctx' = VtyWidgetCtx

275+ { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.

276+ [ fmapMaybe id $

277+ attachWith (\(r,f) e -> filterInput r f e)

278+ (liftA2 (,) (current reg) (current foc))

279+ (_vtyWidgetCtx_input ctx)

280+ ]

281+ , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc

282+ , _vtyWidgetCtx_width = w

283+ , _vtyWidgetCtx_height = h

284+ }

285+ (result, images) <- lift . lift $ runVtyWidget ctx' child

286+ let images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images

287+ tellImages images'

288+ return result

289+ where

290+ filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

291+ filterInput (Region l t w h) focused e = case e of

292+ V.EvKey _ _ | not focused -> Nothing

293+ V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y

294+ V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y

295+ _ -> Just e

296+ where

297+ mouse con x y

298+ | or [ x < l

299+ , y < t

300+ , x >= l + w

301+ , y >= t + h ] = Nothing

302+ | otherwise =

303+ Just (con (x - l) (y - t))

304+

305+

306+

262307-- | Information about a drag operation

263308data Drag = Drag

264309 { _drag_from :: (Int, Int) -- ^ Where the drag began

@@ -351,13 +396,15 @@ splitV :: (Reflex t, Monad m)

351396 -- ^ Widget for second pane

352397 -> VtyWidget t m (a,b)

353398splitV sizeFunD focD wA wB = do

354− sz <- displaySize

355− let regA = (\f (w,h) -> Region 0 0 w (f h)) <$> sizeFunD <*> sz

356− regB = (\(w,h) (Region _ _ _ hA) -> Region 0 hA w (h - hA)) <$> sz <*> regA

399+ dw <- displayWidth

400+ dh <- displayHeight

401+ let regA = (\f w h -> Region 0 0 w (f h)) <$> sizeFunD <*> dw <*> dh

402+ regB = (\w h (Region _ _ _ hA) -> Region 0 hA w (h - hA)) <$> dw <*> dh <*> regA

357403 ra <- pane regA (fst <$> focD) wA

358404 rb <- pane regB (snd <$> focD) wB

359405 return (ra,rb)

360406

407+{-

361408-- | A split of the available space into two parts with a draggable separator.

362409-- Starts with half the space allocated to each, and the first pane has focus.

363410-- Clicking in a pane switches focus.

@@ -396,12 +443,13 @@ splitVDrag wS wA wB = do

396443 m <- mouseDown V.BLeft

397444 x' <- x

398445 return (m, x')

399−

446+-}

400447-- | Fill the background with a particular character.

401448fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()

402449fill c = do

403− sz <- displaySize

404− let fillImg = ffor (current sz) $ \(w,h) -> [V.charFill V.defAttr c w h]

450+ dw <- displayWidth

451+ dh <- displayHeight

452+ let fillImg = current $ liftA2 (\w h -> [V.charFill V.defAttr c w h]) dw dh

405453 tellImages fillImg

406454

407455-- | Fill the background with the bottom

@@ -451,10 +499,11 @@ box :: (Monad m, Reflex t)

451499 -> VtyWidget t m a

452500 -> VtyWidget t m a

453501box boxStyle child = do

454− sz <- displaySize

455− let boxReg = ffor (current sz) $ \(w,h) -> Region 0 0 w h

456− innerReg = ffor sz $ \(w,h) -> Region 1 1 (w - 2) (h - 2)

457− tellImages (boxImages <$> boxStyle <*> boxReg)

502+ dh <- displayHeight

503+ dw <- displayWidth

504+ let boxReg = liftA2 (\w h -> Region 0 0 w h) dw dh

505+ innerReg = liftA2 (\w h -> Region 1 1 (w - 2) (h - 2)) dw dh

506+ tellImages (boxImages <$> boxStyle <*> current boxReg)

458507 tellImages (fmap (\r -> [regionBlankImage r]) (current innerReg))

459508 pane innerReg (pure True) child

460509 where

src/Reflex/Vty/Widget/Input/Text.hs+17−8

@@ -6,6 +6,7 @@ Description: Widgets for accepting text input from users and manipulating text w

66{-# LANGUAGE LambdaCase #-}

77{-# LANGUAGE OverloadedStrings #-}

88{-# LANGUAGE RecursiveDo #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

910module Reflex.Vty.Widget.Input.Text

1011 ( module Reflex.Vty.Widget.Input.Text

1112 , def

@@ -31,11 +32,16 @@ data TextInputConfig t = TextInputConfig

3132instance Reflex t => Default (TextInputConfig t) where

3233 def = TextInputConfig empty never 4

3334

35+data TextInput t = TextInput

36+ { _textInput_value :: Dynamic t Text

37+ , _textInput_lines :: Dynamic t Int

38+ }

39+

3440-- | A widget that allows text input

3541textInput

3642 :: (Reflex t, MonadHold t m, MonadFix m)

3743 => TextInputConfig t

38− -> VtyWidget t m (Dynamic t Text)

44+ -> VtyWidget t m (TextInput t)

3945textInput cfg = do

4046 i <- input

4147 f <- focus

@@ -44,8 +50,8 @@ textInput cfg = do

4450 rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)

4551 [ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i

4652 , _textInputConfig_modify cfg

47− , let displayInfo = (,) <$> rows <*> scrollTop

48− in ffor (attach (current displayInfo) click) $ \((dl, st), MouseDown _ (mx, my) _) ->

53+ , let displayInfo = (,) <$> current rows <*> scrollTop

54+ in ffor (attach displayInfo click) $ \((dl, st), MouseDown _ (mx, my) _) ->

4955 goToDisplayLinePosition mx (st + my) dl

5056 ]

5157 click <- mouseDown V.BLeft

@@ -58,16 +64,19 @@ textInput cfg = do

5864 | cursorY < st = cursorY

5965 | cursorY >= st + h = cursorY - h + 1

6066 | otherwise = st

61− rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y

62− scrollTop <- holdDyn 0 hy

63− tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop

64− return $ value <$> v

67+ let hy = attachWith newScrollTop scrollTop $ updated $ zipDyn dh y

68+ scrollTop <- hold 0 hy

69+ tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> scrollTop

70+ return $ TextInput

71+ { _textInput_value = value <$> v

72+ , _textInput_lines = length . _displayLines_spans <$> rows

73+ }

6574

6675-- | A widget that allows multiline text input

6776multilineTextInput

6877 :: (Reflex t, MonadHold t m, MonadFix m)

6978 => TextInputConfig t

70− -> VtyWidget t m (Dynamic t Text)

79+ -> VtyWidget t m (TextInput t)

7180multilineTextInput cfg = do

7281 i <- input

7382 textInput $ cfg