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

git.iko.soy/reflex-vty

on develop help sign in

WIP: Add pane', separate dynamic widths and heights

5e35722Ali Abrar8 years ago

src-bin/example.hs+44−19

compare with develop

unifiedsplit

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

11{-# OPTIONS_GHC -threaded #-}

13import Control.Applicative

14−import Control.Monad (void)

14+import Control.Monad

15import Control.Monad.Fix

16import Data.Map (Map)

17+import Data.Maybe

17import qualified Data.Map as Map

18import qualified Data.Map as Map

18import Data.Text (Text)

19import Data.Text (Text)

19import qualified Data.Text as T

20import qualified Data.Text as T

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

32main :: IO ()

33main :: IO ()

33main = mainWidget $ do

34main = mainWidget $ do

34 inp <- input

35 inp <- input

35− size <- displaySize

36+ taskList

37+

38+{-

36 let buttons = do

39 let buttons = do

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

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

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

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

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

55 Left Example_TextEditor -> escapable testBoxes

58 Left Example_TextEditor -> escapable testBoxes

56 Left Example_Todo -> escapable taskList

59 Left Example_Todo -> escapable taskList

57 Right () -> buttons

60 Right () -> buttons

61+

62+-}

58 return $ fforMaybe inp $ \case

63 return $ fforMaybe inp $ \case

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

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

60 _ -> Nothing

65 _ -> Nothing

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

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

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

76 return ()

81 return ()

83+{-

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

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

79testBoxes = do

85testBoxes = do

80− size <- displaySize

86+ dw <- displayWidth

87+ dh <- displayHeight

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

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

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

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

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

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

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

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

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

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

86 return ()

93 return ()

94+-}

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

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

89debugFocus = do

97debugFocus = do

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

113data TodoOutput t = TodoOutput

121data TodoOutput t = TodoOutput

114 { _todoOutput_todo :: Dynamic t Todo

122 { _todoOutput_todo :: Dynamic t Todo

115 , _todoOutput_delete :: Event t ()

123 , _todoOutput_delete :: Event t ()

124+ , _todoOutput_height :: Dynamic t Int

116 }

125 }

117

126

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

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

119 switching t0 e = TodoOutput

128 switching t0 e = TodoOutput

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

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

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

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

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

122

132

123todo

133todo

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

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

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

126 -> VtyWidget t m (TodoOutput t)

136 -> VtyWidget t m (TodoOutput t)

127todo t0 = do

137todo t0 = do

128 w <- displayWidth

138 w <- displayWidth

129− let checkboxWidth = 3

139+ rec let checkboxWidth = 3

130− checkboxRegion = pure $ Region 0 0 checkboxWidth 1

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

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

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

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

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

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

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

134− i <- input

148+ i <- input

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

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

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

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

137− return (v, deleteSelf)

151+ return (v, deleteSelf)

138 return $ TodoOutput

152 return $ TodoOutput

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

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

140 , _todoOutput_delete = d

154 , _todoOutput_delete = d

155+ , _todoOutput_height = _textInput_lines ti

141 }

156 }

142 where

157 where

143 backspaceOnEmpty v = \case

158 backspaceOnEmpty v = \case

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

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

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

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

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

158 in Region 0 l w' 1) w todosMap

173 in Region 0 l w' 1) w todosMap

174+ pane'

175+ (pure 0)

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

177+ w

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

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

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

160− e <- mouseUp

180+ e <- mouseUp

161− r <- todo t

181+ r <- todo t

162− return (row <$ e, r)

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

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

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

164 selected <- holdDyn 0 $ leftmost

189 selected <- holdDyn 0 $ leftmost

165 [ selectionClick

190 [ selectionClick

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

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

23 , mainWidget

24 , mainWidgetWithHandle

25 , HasDisplaySize(..)

26− , displayWidth

27− , displayHeight

28 , HasFocus(..)

26 , HasFocus(..)

29 , HasVtyInput(..)

27 , HasVtyInput(..)

30 , Region(..)

28 , Region(..)

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

37 , mouseDown

35 , mouseDown

38 , mouseUp

36 , mouseUp

39 , pane

37 , pane

38+ , pane'

40 , tellImages

39 , tellImages

41 , splitV

40 , splitV

42− , splitVDrag

41+ -- , splitVDrag TODO

43 , box

42 , box

44 , boxStatic

43 , boxStatic

45 , RichTextConfig(..)

44 , RichTextConfig(..)

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

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

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

78data VtyWidgetCtx t = VtyWidgetCtx

77data VtyWidgetCtx t = VtyWidgetCtx

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

78+ { _vtyWidgetCtx_width :: Dynamic t Int

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

80+ , _vtyWidgetCtx_height :: Dynamic t Int

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

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

81 , _vtyWidgetCtx_focus :: Dynamic t Bool

82 , _vtyWidgetCtx_focus :: Dynamic t Bool

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

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

83 , _vtyWidgetCtx_input :: Event t VtyEvent

84 , _vtyWidgetCtx_input :: Event t VtyEvent

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

130 V.EvResize {} -> Nothing

131 V.EvResize {} -> Nothing

131 x -> Just x

132 x -> Just x

132 let ctx = VtyWidgetCtx

133 let ctx = VtyWidgetCtx

133− { _vtyWidgetCtx_size = size

134+ { _vtyWidgetCtx_width = fmap fst size

135+ , _vtyWidgetCtx_height = fmap snd size

134 , _vtyWidgetCtx_input = inp'

136 , _vtyWidgetCtx_input = inp'

135 , _vtyWidgetCtx_focus = constDyn True

137 , _vtyWidgetCtx_focus = constDyn True

136 }

138 }

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

152

154

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

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

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

156class (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)

156

161

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

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

158− displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size

163+ displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width

159−

164+ displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height

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

167

165

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

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

169class HasVtyInput t m | m -> t where

167class HasVtyInput t m | m -> t where

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

238 (_vtyWidgetCtx_input ctx)

236 (_vtyWidgetCtx_input ctx)

239 ]

237 ]

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

238 , _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+ }

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

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

244 tellImages images'

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

259 | otherwise =

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

261

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+

262-- | Information about a drag operation

307-- | Information about a drag operation

263data Drag = Drag

308data Drag = Drag

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

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

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

351 -- ^ Widget for second pane

396 -- ^ Widget for second pane

352 -> VtyWidget t m (a,b)

397 -> VtyWidget t m (a,b)

353splitV sizeFunD focD wA wB = do

398splitV sizeFunD focD wA wB = do

354− sz <- displaySize

399+ dw <- displayWidth

400+ dh <- displayHeight

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

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

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

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

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

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

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

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

359 return (ra,rb)

405 return (ra,rb)

360

406

407+{-

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

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

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

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

363-- Clicking in a pane switches focus.

410-- Clicking in a pane switches focus.

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

396 m <- mouseDown V.BLeft

443 m <- mouseDown V.BLeft

397 x' <- x

444 x' <- x

398 return (m, x')

445 return (m, x')

399−

446+-}

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

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

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

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

402fill c = do

449fill c = do

403− sz <- displaySize

450+ dw <- displayWidth

451+ dh <- displayHeight

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

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

405 tellImages fillImg

453 tellImages fillImg

406

454

407-- | Fill the background with the bottom

455-- | Fill the background with the bottom

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

451 -> VtyWidget t m a

499 -> VtyWidget t m a

452 -> VtyWidget t m a

500 -> VtyWidget t m a

453box boxStyle child = do

501box boxStyle child = do

454− sz <- displaySize

502+ dh <- displayHeight

503+ dw <- displayWidth

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

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

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

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

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

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

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

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

459 pane innerReg (pure True) child

508 pane innerReg (pure True) child

460 where

509 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

6{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE RecursiveDo #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

9module Reflex.Vty.Widget.Input.Text

10module Reflex.Vty.Widget.Input.Text

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

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

11 , def

12 , def

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

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

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

32 def = TextInputConfig empty never 4

33 def = TextInputConfig empty never 4

35+data TextInput t = TextInput

36+ { _textInput_value :: Dynamic t Text

37+ , _textInput_lines :: Dynamic t Int

38+ }

39+

34-- | A widget that allows text input

40-- | A widget that allows text input

35textInput

41textInput

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

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

37 => TextInputConfig t

43 => TextInputConfig t

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

44+ -> VtyWidget t m (TextInput t)

39textInput cfg = do

45textInput cfg = do

40 i <- input

46 i <- input

41 f <- focus

47 f <- focus

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

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

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

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

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

46 , _textInputConfig_modify cfg

52 , _textInputConfig_modify cfg

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

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

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

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

49 goToDisplayLinePosition mx (st + my) dl

55 goToDisplayLinePosition mx (st + my) dl

50 ]

56 ]

51 click <- mouseDown V.BLeft

57 click <- mouseDown V.BLeft

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

58 | cursorY < st = cursorY

64 | cursorY < st = cursorY

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

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

60 | otherwise = st

66 | otherwise = st

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

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

62− scrollTop <- holdDyn 0 hy

68+ scrollTop <- hold 0 hy

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

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

64− return $ value <$> v

70+ return $ TextInput

71+ { _textInput_value = value <$> v

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

73+ }

66-- | A widget that allows multiline text input

75-- | A widget that allows multiline text input

67multilineTextInput

76multilineTextInput

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

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

69 => TextInputConfig t

78 => TextInputConfig t

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

79+ -> VtyWidget t m (TextInput t)

71multilineTextInput cfg = do

80multilineTextInput cfg = do

72 i <- input

81 i <- input

73 textInput $ cfg

82 textInput $ cfg