9bb4bc2 · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

on develop help sign in

Sublayout and subfocus support; Make widgets more polymorphic

9bb4bc2Ali Abrar6 years ago

src/Reflex/Vty/Widget.hs+61−49

compare with develop

unifiedsplit

@@ -15,6 +15,7 @@ module Reflex.Vty.Widget

15 , HasDisplaySize(..)

16 , HasFocus(..)

17 , HasVtyInput(..)

18+ , HasVtyWidgetCtx(..)

18 , Region(..)

19 , Region(..)

19 , regionSize

20 , regionSize

20 , regionBlankImage

21 , regionBlankImage

@@ -57,7 +58,8 @@ module Reflex.Vty.Widget

57import Control.Applicative (liftA2)

58import Control.Applicative (liftA2)

58import Control.Monad.Fix (MonadFix)

59import Control.Monad.Fix (MonadFix)

59import Control.Monad.IO.Class (MonadIO)

60import Control.Monad.IO.Class (MonadIO)

61+import Control.Monad.NodeId

60−import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)

62+import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)

61import Control.Monad.Trans (MonadTrans, lift)

63import Control.Monad.Trans (MonadTrans, lift)

62import Data.Default (Default(..))

64import Data.Default (Default(..))

63import Data.Set (Set)

65import Data.Set (Set)

@@ -70,11 +72,8 @@ import qualified Graphics.Vty as V

70import Reflex

72import Reflex

71import Reflex.Class ()

73import Reflex.Class ()

72import Reflex.Host.Class (MonadReflexCreateTrigger)

74import Reflex.Host.Class (MonadReflexCreateTrigger)

73−

74import Reflex.Vty.Host

75import Reflex.Vty.Host

76−import Control.Monad.NodeId

77−

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

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

79data VtyWidgetCtx t = VtyWidgetCtx

78data VtyWidgetCtx t = VtyWidgetCtx

80 { _vtyWidgetCtx_width :: Dynamic t Int

79 { _vtyWidgetCtx_width :: Dynamic t Int

@@ -131,6 +130,19 @@ instance MonadNodeId m => MonadNodeId (VtyWidget t m) where

131 getNextNodeId = VtyWidget $ do

130 getNextNodeId = VtyWidget $ do

132 lift $ lift getNextNodeId

131 lift $ lift getNextNodeId

133

132

133+class HasVtyWidgetCtx t m | m -> t where

134+ askCtx :: m (VtyWidgetCtx t)

135+ default askCtx :: (f m' ~ m, Monad m', MonadTrans f, HasVtyWidgetCtx t m') => m (VtyWidgetCtx t)

136+ askCtx = lift askCtx

137+ localCtx :: (VtyWidgetCtx t -> VtyWidgetCtx t) -> (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a

138+

139+instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where

140+ askCtx = VtyWidget $ lift ask

141+ localCtx f g (VtyWidget x) = VtyWidget $ do

142+ (a, images) :: (a, Behavior t [Image]) <- lift $ local f $ runBehaviorWriterT x

143+ tellImages $ g images

144+ pure a

145+

134-- | Runs a 'VtyWidget' with a given context

146-- | Runs a 'VtyWidget' with a given context

135runVtyWidget

147runVtyWidget

136 :: (Reflex t, MonadNodeId m)

148 :: (Reflex t, MonadNodeId m)

@@ -208,6 +220,8 @@ instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where

208-- | A class for things that can dynamically gain and lose focus

220-- | A class for things that can dynamically gain and lose focus

209class HasFocus t m | m -> t where

221class HasFocus t m | m -> t where

210 focus :: m (Dynamic t Bool)

222 focus :: m (Dynamic t Bool)

223+ default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocus t m') => m (Dynamic t Bool)

224+ focus = lift focus

211

225

212instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where

226instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where

213 focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus

227 focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus

@@ -216,6 +230,8 @@ instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where

216class (Reflex t, Monad m) => ImageWriter t m | m -> t where

230class (Reflex t, Monad m) => ImageWriter t m | m -> t where

217 -- | Send images upstream for rendering

231 -- | Send images upstream for rendering

218 tellImages :: Behavior t [Image] -> m ()

232 tellImages :: Behavior t [Image] -> m ()

233+ default tellImages :: (f m' ~ m, Monad m', MonadTrans f, ImageWriter t m') => Behavior t [Image] -> m ()

234+ tellImages = lift . tellImages

219

235

220instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where

236instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where

221 tellImages = tellBehavior

237 tellImages = tellBehavior

@@ -255,18 +271,16 @@ withinImage (Region left top width height)

255-- * mouse inputs outside the region are ignored

271-- * mouse inputs outside the region are ignored

256-- * mouse inputs inside the region have their coordinates translated such

272-- * mouse inputs inside the region have their coordinates translated such

257-- that (0,0) is the top-left corner of the region

273-- that (0,0) is the top-left corner of the region

258−-- TODO make this polymorphic

259pane

274pane

260− :: (Reflex t, Monad m, MonadNodeId m)

275+ :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m)

261 => Dynamic t Region

276 => Dynamic t Region

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

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

263− -> VtyWidget t m a

278+ -> m a

264− -> VtyWidget t m a

279+ -> m a

265−pane dr foc child = VtyWidget $ do

280+pane dr foc child = do

266− ctx <- lift ask

267 let reg = current dr

281 let reg = current dr

268− let ctx' = VtyWidgetCtx

282+ let subContext ctx = VtyWidgetCtx

269− { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.

283+ { _vtyWidgetCtx_input = leftmost

270 [ fmapMaybe id $

284 [ fmapMaybe id $

271 attachWith (\(r,f) e -> filterInput r f e)

285 attachWith (\(r,f) e -> filterInput r f e)

272 (liftA2 (,) reg (current foc))

286 (liftA2 (,) reg (current foc))

@@ -276,10 +290,8 @@ pane dr foc child = VtyWidget $ do

276 , _vtyWidgetCtx_width = _region_width <$> dr

290 , _vtyWidgetCtx_width = _region_width <$> dr

277 , _vtyWidgetCtx_height = _region_height <$> dr

291 , _vtyWidgetCtx_height = _region_height <$> dr

278 }

292 }

279− (result, images) <- lift . lift $ runVtyWidget ctx' child -- TODO can we use a local-based implementation?

280− let images' = liftA2 (\r is -> map (withinImage r) is) reg images

293+ let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg

281− tellImages images'

294+ localCtx subContext imagesWithinRegion child

282− return result

283 where

295 where

284 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

296 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

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

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

@@ -424,16 +436,16 @@ keyCombos ks = do

424

436

425-- | A plain split of the available space into vertically stacked panes.

437-- | A plain split of the available space into vertically stacked panes.

426-- No visual separator is built in here.

438-- No visual separator is built in here.

427−splitV :: (Reflex t, Monad m, MonadNodeId m)

439+splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplaySize t m)

428 => Dynamic t (Int -> Int)

440 => Dynamic t (Int -> Int)

429 -- ^ Function used to determine size of first pane based on available size

441 -- ^ Function used to determine size of first pane based on available size

430 -> Dynamic t (Bool, Bool)

442 -> Dynamic t (Bool, Bool)

431 -- ^ How to focus the two sub-panes, given that we are focused.

443 -- ^ How to focus the two sub-panes, given that we are focused.

432− -> VtyWidget t m a

444+ -> m a

433 -- ^ Widget for first pane

445 -- ^ Widget for first pane

434− -> VtyWidget t m b

446+ -> m b

435 -- ^ Widget for second pane

447 -- ^ Widget for second pane

436− -> VtyWidget t m (a,b)

448+ -> m (a,b)

437splitV sizeFunD focD wA wB = do

449splitV sizeFunD focD wA wB = do

438 dw <- displayWidth

450 dw <- displayWidth

439 dh <- displayHeight

451 dh <- displayHeight

@@ -445,16 +457,16 @@ splitV sizeFunD focD wA wB = do

445

457

446-- | A plain split of the available space into horizontally stacked panes.

458-- | A plain split of the available space into horizontally stacked panes.

447-- No visual separator is built in here.

459-- No visual separator is built in here.

448−splitH :: (Reflex t, Monad m, MonadNodeId m)

460+splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasVtyWidgetCtx t m)

449 => Dynamic t (Int -> Int)

461 => Dynamic t (Int -> Int)

450 -- ^ Function used to determine size of first pane based on available size

462 -- ^ Function used to determine size of first pane based on available size

451 -> Dynamic t (Bool, Bool)

463 -> Dynamic t (Bool, Bool)

452 -- ^ How to focus the two sub-panes, given that we are focused.

464 -- ^ How to focus the two sub-panes, given that we are focused.

453− -> VtyWidget t m a

465+ -> m a

454 -- ^ Widget for first pane

466 -- ^ Widget for first pane

455− -> VtyWidget t m b

467+ -> m b

456 -- ^ Widget for second pane

468 -- ^ Widget for second pane

457− -> VtyWidget t m (a,b)

469+ -> m (a,b)

458splitH sizeFunD focD wA wB = do

470splitH sizeFunD focD wA wB = do

459 dw <- displayWidth

471 dw <- displayWidth

460 dh <- displayHeight

472 dh <- displayHeight

@@ -465,11 +477,11 @@ splitH sizeFunD focD wA wB = do

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

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

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

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

467-- Clicking in a pane switches focus.

479-- Clicking in a pane switches focus.

468−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)

480+splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m, HasDisplaySize t m, HasVtyInput t m, HasVtyWidgetCtx t m)

469− => VtyWidget t m ()

481+ => m ()

470− -> VtyWidget t m a

482+ -> m a

471− -> VtyWidget t m b

483+ -> m b

472− -> VtyWidget t m (a,b)

484+ -> m (a,b)

473splitVDrag wS wA wB = do

485splitVDrag wS wA wB = do

474 dh <- displayHeight

486 dh <- displayHeight

475 dw <- displayWidth

487 dw <- displayWidth

@@ -503,7 +515,7 @@ splitVDrag wS wA wB = do

503 return (m, x')

515 return (m, x')

504

516

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

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

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

518+fill :: (HasDisplaySize t m, ImageWriter t m) => Char -> m ()

507fill c = do

519fill c = do

508 dw <- displayWidth

520 dw <- displayWidth

509 dh <- displayHeight

521 dh <- displayHeight

@@ -511,7 +523,7 @@ fill c = do

511 tellImages fillImg

523 tellImages fillImg

512

524

513-- | Fill the background with the bottom

525-- | Fill the background with the bottom

514−hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()

526+hRule :: (HasDisplaySize t m, ImageWriter t m) => BoxStyle -> m ()

515hRule boxStyle = fill (_boxStyle_s boxStyle)

527hRule boxStyle = fill (_boxStyle_s boxStyle)

516

528

517-- | Defines a set of symbols to use to draw the outlines of boxes

529-- | Defines a set of symbols to use to draw the outlines of boxes

@@ -552,11 +564,11 @@ roundedBoxStyle :: BoxStyle

552roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'

564roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'

553

565

554-- | Draws a titled box in the provided style and a child widget inside of that box

566-- | Draws a titled box in the provided style and a child widget inside of that box

555−boxTitle :: (Monad m, Reflex t, MonadNodeId m)

567+boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)

556 => Behavior t BoxStyle

568 => Behavior t BoxStyle

557 -> Text

569 -> Text

558− -> VtyWidget t m a

570+ -> m a

559− -> VtyWidget t m a

571+ -> m a

560boxTitle boxStyle title child = do

572boxTitle boxStyle title child = do

561 dh <- displayHeight

573 dh <- displayHeight

562 dw <- displayWidth

574 dw <- displayWidth

@@ -604,18 +616,18 @@ boxTitle boxStyle title child = do

604 right = mkHalf delta

616 right = mkHalf delta

605

617

606-- | A box without a title

618-- | A box without a title

607−box :: (Monad m, Reflex t, MonadNodeId m)

619+box :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)

608 => Behavior t BoxStyle

620 => Behavior t BoxStyle

609− -> VtyWidget t m a

621+ -> m a

610− -> VtyWidget t m a

622+ -> m a

611box boxStyle = boxTitle boxStyle mempty

623box boxStyle = boxTitle boxStyle mempty

612

624

613-- | A box whose style is static

625-- | A box whose style is static

614boxStatic

626boxStatic

615− :: (Reflex t, Monad m, MonadNodeId m)

627+ :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)

616 => BoxStyle

628 => BoxStyle

617− -> VtyWidget t m a

629+ -> m a

618− -> VtyWidget t m a

630+ -> m a

619boxStatic = box . pure

631boxStatic = box . pure

620

632

621-- | Configuration options for displaying "rich" text

633-- | Configuration options for displaying "rich" text

@@ -628,10 +640,10 @@ instance Reflex t => Default (RichTextConfig t) where

628

640

629-- | A widget that displays text with custom time-varying attributes

641-- | A widget that displays text with custom time-varying attributes

630richText

642richText

631− :: (Reflex t, Monad m)

643+ :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)

632 => RichTextConfig t

644 => RichTextConfig t

633 -> Behavior t Text

645 -> Behavior t Text

634− -> VtyWidget t m ()

646+ -> m ()

635richText cfg t = do

647richText cfg t = do

636 dw <- displayWidth

648 dw <- displayWidth

637 let img = (\w a s -> [wrapText w a s])

649 let img = (\w a s -> [wrapText w a s])

@@ -646,19 +658,19 @@ richText cfg t = do

646

658

647-- | Renders text, wrapped to the container width

659-- | Renders text, wrapped to the container width

648text

660text

649− :: (Reflex t, Monad m)

661+ :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)

650 => Behavior t Text

662 => Behavior t Text

651− -> VtyWidget t m ()

663+ -> m ()

652text = richText def

664text = richText def

653

665

654-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those

666-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those

655-- that are hidden)

667-- that are hidden)

656scrollableText

668scrollableText

657− :: forall t m. (Reflex t, MonadHold t m, MonadFix m)

669+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplaySize t m, HasVtyInput t m, ImageWriter t m)

658 => Event t Int

670 => Event t Int

659 -- ^ Number of lines to scroll by

671 -- ^ Number of lines to scroll by

660 -> Behavior t Text

672 -> Behavior t Text

661− -> VtyWidget t m (Behavior t (Int, Int))

673+ -> m (Behavior t (Int, Int))

662 -- ^ (Current scroll position, total number of lines)

674 -- ^ (Current scroll position, total number of lines)

663scrollableText scrollBy t = do

675scrollableText scrollBy t = do

664 dw <- displayWidth

676 dw <- displayWidth

@@ -686,11 +698,11 @@ scrollableText scrollBy t = do

686-- | Renders any behavior whose value can be converted to

698-- | Renders any behavior whose value can be converted to

687-- 'String' as text

699-- 'String' as text

688display

700display

689− :: (Reflex t, Monad m, Show a)

701+ :: (Reflex t, Monad m, Show a, HasDisplaySize t m, ImageWriter t m)

690 => Behavior t a

702 => Behavior t a

691− -> VtyWidget t m ()

703+ -> m ()

692display a = text $ T.pack . show <$> a

704display a = text $ T.pack . show <$> a

693

705

694-- | A widget that draws nothing

706-- | A widget that draws nothing

695−blank :: Monad m => VtyWidget t m ()

707+blank :: Monad m => m ()

696blank = return ()

708blank = return ()

src/Reflex/Vty/Widget/Input.hs+16−16

@@ -30,10 +30,10 @@ instance Reflex t => Default (ButtonConfig t) where

31-- | A button widget that contains a sub-widget

32button

33− :: (Reflex t, Monad m, MonadNodeId m)

33+ :: (Reflex t, Monad m, MonadNodeId m, HasFocus t m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)

34 => ButtonConfig t

35− -> VtyWidget t m ()

35+ -> m ()

36− -> VtyWidget t m (Event t ())

36+ -> m (Event t ())

37button cfg child = do

38 f <- focus

39 let style = do

@@ -48,25 +48,25 @@ button cfg child = do

49-- | A button widget that displays text that can change

50textButton

51− :: (Reflex t, Monad m, MonadNodeId m)

51+ :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)

52 => ButtonConfig t

53 -> Behavior t Text

54− -> VtyWidget t m (Event t ())

54+ -> m (Event t ())

55textButton cfg = button cfg . text -- TODO Centering etc.

57-- | A button widget that displays a static bit of text

58textButtonStatic

59− :: (Reflex t, Monad m, MonadNodeId m)

59+ :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)

60 => ButtonConfig t

61 -> Text

62− -> VtyWidget t m (Event t ())

62+ -> m (Event t ())

63textButtonStatic cfg = textButton cfg . pure

65-- | A clickable link widget

66link

67− :: (Reflex t, Monad m)

67+ :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m, HasVtyInput t m)

68 => Behavior t Text

69− -> VtyWidget t m (Event t MouseUp)

69+ -> m (Event t MouseUp)

70link t = do

71 let cfg = RichTextConfig

72 { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline

@@ -76,9 +76,9 @@ link t = do

77-- | A clickable link widget with a static label

78linkStatic

79− :: (Reflex t, Monad m)

79+ :: (Reflex t, Monad m, ImageWriter t m, HasDisplaySize t m, HasVtyInput t m)

80 => Text

81− -> VtyWidget t m (Event t MouseUp)

81+ -> m (Event t MouseUp)

82linkStatic = link . pure

84-- | Characters used to render checked and unchecked textboxes

@@ -118,10 +118,10 @@ instance (Reflex t) => Default (CheckboxConfig t) where

118

119-- | A checkbox widget

120checkbox

121− :: (MonadHold t m, MonadFix m, Reflex t)

121+ :: (MonadHold t m, MonadFix m, Reflex t, HasVtyInput t m, HasDisplaySize t m, ImageWriter t m)

122 => CheckboxConfig t

123 -> Bool

124− -> VtyWidget t m (Dynamic t Bool)

124+ -> m (Dynamic t Bool)

125checkbox cfg v0 = do

126 md <- mouseDown V.BLeft

127 mu <- mouseUp

@@ -130,9 +130,9 @@ checkbox cfg v0 = do

130 [ V.withStyle mempty V.bold <$ md

131 , mempty <$ mu

132 ]

133− let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed

133+ let attrs = (<>) <$> _checkboxConfig_attributes cfg <*> depressed

134 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->

135 if checked

136− then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg

136+ then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg

137− else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg

137+ else _checkboxStyle_unchecked <$> _checkboxConfig_checkboxStyle cfg

138 return v

src/Reflex/Vty/Widget/Input/Text.hs+6−6

@@ -81,9 +81,9 @@ textInput cfg = do

82-- | A widget that allows multiline text input

83multilineTextInput

84− :: (Reflex t, MonadHold t m, MonadFix m)

84+ :: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplaySize t m, ImageWriter t m)

85 => TextInputConfig t

86− -> VtyWidget t m (TextInput t)

86+ -> m (TextInput t)

87multilineTextInput cfg = do

88 i <- input

89 textInput $ cfg

@@ -99,13 +99,13 @@ multilineTextInput cfg = do

99-- the computed line count to greedily size the tile when vertically

100-- oriented, and uses the fallback width when horizontally oriented.

101textInputTile

102− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)

102+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m, MonadLayout t m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m)

103− => VtyWidget t m (TextInput t)

103+ => m (TextInput t)

104 -> Dynamic t Int

105− -> Layout t (Focus t (VtyWidget t m)) (TextInput t)

105+ -> m (TextInput t)

106textInputTile txt width = do

107 o <- askOrientation

108− rec (_, t) <- tileC (Constraint_Fixed <$> sz) txt

108+ rec (_, t) <- tile (Constraint_Fixed <$> sz) txt

109 let sz = join $ ffor o $ \case

110 Orientation_Column -> _textInput_lines t

111 Orientation_Row -> width

src/Reflex/Vty/Widget/Layout.hs+139−54

@@ -6,9 +6,10 @@ Description: Monad transformer and tools for arranging widgets and building scre

7module Reflex.Vty.Widget.Layout where

9+import Control.Applicative (liftA2)

9import Control.Monad.NodeId (MonadNodeId(..), NodeId)

10import Control.Monad.NodeId (MonadNodeId(..), NodeId)

10import Control.Monad.Reader

11import Control.Monad.Reader

11−import Data.List

12+import Data.List (mapAccumL)

12import Data.Map.Ordered (OMap)

13import Data.Map.Ordered (OMap)

13import qualified Data.Map.Ordered as OMap

14import qualified Data.Map.Ordered as OMap

14import Data.Ratio ((%))

15import Data.Ratio ((%))

@@ -46,7 +47,7 @@ data Refocus = Refocus_Shift Int

47newtype Focus t m a = Focus

48newtype Focus t m a = Focus

48 { unFocus :: DynamicWriterT t FocusSet

49 { unFocus :: DynamicWriterT t FocusSet

49− (ReaderT (Demux t (Maybe FocusId))

50+ (ReaderT (Dynamic t (Maybe FocusId)) -- TODO Demux?

50 (EventWriterT t (First Refocus) m)) a

51 (EventWriterT t (First Refocus) m)) a

51 }

52 }

52 deriving

53 deriving

@@ -69,6 +70,16 @@ instance MonadTrans (Focus t) where

69 lift = Focus . lift . lift . lift

70 lift = Focus . lift . lift . lift

71instance (HasVtyInput t m, Monad m) => HasVtyInput t (Focus t m)

72instance (HasVtyInput t m, Monad m) => HasVtyInput t (Focus t m)

73+instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where

74+ localCtx f g (Focus w) = Focus $ do

75+ d <- ask

76+ ((a, fs), e) <- lift $ lift $ lift $ localCtx f g $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w

77+ tellEvent e

78+ tellDyn fs

79+ return a

80+

81+instance ImageWriter t m => ImageWriter t (Focus t m)

82+instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)

73newtype FocusId = FocusId NodeId

84newtype FocusId = FocusId NodeId

74 deriving (Eq, Ord)

85 deriving (Eq, Ord)

@@ -77,8 +88,10 @@ class (Monad m, Reflex t) => MonadFocus t m | m -> t where

77 focusId :: m FocusId

88 focusId :: m FocusId

78 requestFocus :: Event t Refocus -> m ()

89 requestFocus :: Event t Refocus -> m ()

79 isFocused :: FocusId -> m (Dynamic t Bool)

90 isFocused :: FocusId -> m (Dynamic t Bool)

91+ subFoci :: m a -> m (a, Dynamic t FocusSet)

92+ focusedId :: m (Dynamic t (Maybe FocusId))

81−instance (Reflex t, Monad m, MonadNodeId m) => MonadFocus t (Focus t m) where

94+instance (Reflex t, MonadFix m, MonadNodeId m) => MonadFocus t (Focus t m) where

82 focusId = do

95 focusId = do

83 fid <- FocusId <$> lift getNextNodeId

96 fid <- FocusId <$> lift getNextNodeId

84 Focus $ tellDyn $ pure $ singletonFS fid

97 Focus $ tellDyn $ pure $ singletonFS fid

@@ -86,14 +99,19 @@ instance (Reflex t, Monad m, MonadNodeId m) => MonadFocus t (Focus t m) where

86 requestFocus = Focus . tellEvent . fmap First

99 requestFocus = Focus . tellEvent . fmap First

87 isFocused fid = do

100 isFocused fid = do

88 sel <- Focus ask

101 sel <- Focus ask

89− pure $ demuxed sel $ Just fid

102+ pure $ (== Just fid) <$> sel

103+ subFoci (Focus child) = Focus $ do

104+ (a, fs) <- lift $ runDynamicWriterT child

105+ tellDyn fs

106+ return (a, fs)

107+ focusedId = Focus ask

108

91runFocus

109runFocus

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

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

93 => Focus t m a

111 => Focus t m a

94 -> m (a, Dynamic t FocusSet)

112 -> m (a, Dynamic t FocusSet)

95runFocus (Focus x) = do

113runFocus (Focus x) = do

96− rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT (demux sel) $ runDynamicWriterT x

114+ rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x

97 sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests

115 sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests

98 pure (a, focusIds)

116 pure (a, focusIds)

99 where

117 where

@@ -103,40 +121,41 @@ runFocus (Focus x) = do

103 Refocus_Id fid -> Just fid

121 Refocus_Id fid -> Just fid

104 Refocus_Shift n -> shiftFS fs mf n

122 Refocus_Shift n -> shiftFS fs mf n

105

123

106−-- TODO unify this with tile, perhaps

124+tile

107−tileC

108− :: (MonadNodeId m, MonadFix m, Reflex t)

125+ :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

109 => Dynamic t Constraint

126 => Dynamic t Constraint

110− -> VtyWidget t m a

127+ -> m a

111− -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)

128+ -> m (FocusId, a)

112−tileC c w = do

129+tile c w = do

113 fid <- focusId

130 fid <- focusId

114− focused <- isFocused fid

115 r <- leaf c

131 r <- leaf c

132+ fid' <- focusedId

133+ parentFocused <- isFocused fid

116− (click, result) <- lift $ lift $ pane r focused $ do

134+ rec (click, result, subs) <- pane r focused $ do

117− click <- mouseDown V.BLeft

135+ m <- mouseDown V.BLeft

118− result <- w

136+ (x, sf) <- subFoci w

119− pure (click, result)

137+ pure (m, x, sf)

138+ let childFocused = liftA2 (\f s -> case f of

139+ Nothing -> False

140+ Just f' -> OSet.member f' $ unFocusSet s) fid' subs

141+ let focused = (||) <$> parentFocused <*> childFocused

120 requestFocus $ Refocus_Id fid <$ click

142 requestFocus $ Refocus_Id fid <$ click

121 pure (fid, result)

143 pure (fid, result)

122

144

123−tile

124− :: (MonadNodeId m, MonadFix m, Reflex t)

125− => VtyWidget t m a

126− -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)

127−tile = tileC (pure $ Constraint_Min 0)

128−

129tile_

145tile_

130− :: (MonadNodeId m, MonadFix m, Reflex t)

146+ :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

131− => VtyWidget t m a

147+ => Dynamic t Constraint

132− -> Layout t (Focus t (VtyWidget t m)) a

148+ -> m a

149+ -> m a

133−tile_ = fmap snd . tile

150+tile_ c = fmap snd . tile c

134

151

135-- * Layout

152-- * Layout

136

153

137data LTree a = LTree a (LForest a)

154data LTree a = LTree a (LForest a)

155+ deriving (Show)

138

156

139newtype LForest a = LForest { unLForest :: OMap NodeId (LTree a) }

157newtype LForest a = LForest { unLForest :: OMap NodeId (LTree a) }

158+ deriving (Show)

140

159

141instance Semigroup (LForest a) where

160instance Semigroup (LForest a) where

142 LForest a <> LForest b = LForest $ a OMap.|<> b

161 LForest a <> LForest b = LForest $ a OMap.|<> b

@@ -182,7 +201,19 @@ newtype Layout t m a = Layout

182instance MonadTrans (Layout t) where

201instance MonadTrans (Layout t) where

183 lift = Layout . lift . lift

202 lift = Layout . lift . lift

184

203

204+instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Layout t m) where

205+ localCtx f g x = do

206+ solution <- Layout ask

207+ let orientation = snd . ltreeRoot <$> solution

208+ lift $ localCtx f g $ do

209+ dw <- displayWidth

210+ dh <- displayHeight

211+ let region = Region 0 0 <$> dw <*> dh

212+ runLayout orientation region x

213+

185instance (HasVtyInput t m, Monad m) => HasVtyInput t (Layout t m)

214instance (HasVtyInput t m, Monad m) => HasVtyInput t (Layout t m)

215+instance ImageWriter t m => ImageWriter t (Layout t m)

216+instance (HasFocus t m, Monad m) => HasFocus t (Layout t m)

186

217

187-- TODO Naming: To Has or not to Has?

218-- TODO Naming: To Has or not to Has?

188class Monad m => MonadLayout t m | m -> t where

219class Monad m => MonadLayout t m | m -> t where

@@ -200,13 +231,19 @@ instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => MonadLayout t (Layout

200 nodeId <- lift getNextNodeId

231 nodeId <- lift getNextNodeId

201 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty

232 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty

202 solutions <- Layout ask

233 solutions <- Layout ask

203− pure $ maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions

234+ pure $ maybe (error "leaf: could not find layout solution") (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions

204 askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)

235 askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)

205

236

206−instance MonadFocus t m => MonadFocus t (Layout t m) where

237+instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where

207 focusId = lift focusId

238 focusId = lift focusId

208 requestFocus = lift . requestFocus

239 requestFocus = lift . requestFocus

209 isFocused = lift . isFocused

240 isFocused = lift . isFocused

241+ focusedId = lift focusedId

242+ subFoci (Layout x) = Layout $ do

243+ y <- ask

244+ ((a, w), sf) <- lift $ lift $ subFoci $ flip runReaderT y $ runDynamicWriterT x

245+ tellDyn w

246+ pure (a, sf)

210

247

211-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')

248-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')

212data Constraint = Constraint_Fixed Int

249data Constraint = Constraint_Fixed Int

@@ -220,24 +257,51 @@ data Orientation = Orientation_Column

220

257

221

258

222row, col

259row, col

223− :: (Reflex t, MonadLayout t m)

260+ :: (Reflex t, MonadNodeId m, MonadFix m, MonadLayout t m)

224 => m a

261 => m a

225 -> m a

262 -> m a

226row = axis (pure Orientation_Row) (pure $ Constraint_Min 0)

263row = axis (pure Orientation_Row) (pure $ Constraint_Min 0)

227col = axis (pure Orientation_Column) (pure $ Constraint_Min 0)

264col = axis (pure Orientation_Column) (pure $ Constraint_Min 0)

228

265

229−-- TODO possibly get rid of this and stretch

230fixed

266fixed

231− :: (Reflex t, MonadLayout t m)

267+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

232 => Dynamic t Int

268 => Dynamic t Int

269+ -> m a

270+ -> m (FocusId, a)

271+fixed n = tile (Constraint_Fixed <$> n)

272+

273+fixed_

274+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

233− -> m (Dynamic t Region)

275+ => Dynamic t Int

234−fixed = leaf . fmap Constraint_Fixed

276+ -> m a

277+ -> m a

278+fixed_ n = fmap snd . fixed n

235

279

236stretch

280stretch

237− :: (Reflex t, MonadLayout t m)

281+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

238 => Dynamic t Int

282 => Dynamic t Int

239− -> m (Dynamic t Region)

283+ -> m a

284+ -> m (FocusId, a)

285+stretch minSz = tile (Constraint_Min <$> minSz)

286+

287+stretch_

288+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

289+ => Dynamic t Int

290+ -> m a

291+ -> m a

240−stretch minSz = leaf (Constraint_Min <$> minSz)

292+stretch_ minSz = fmap snd . tile (Constraint_Min <$> minSz)

293+

294+flex

295+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

296+ => m a

297+ -> m (FocusId, a)

298+flex = tile (pure $ Constraint_Min 0)

299+

300+flex_

301+ :: (Reflex t,MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)

302+ => m a

303+ -> m a

304+flex_ = fmap snd . flex

241

305

242ltreeConstraint :: LTree (Constraint, a) -> Constraint

306ltreeConstraint :: LTree (Constraint, a) -> Constraint

243ltreeConstraint (LTree (c, _) _) = c

307ltreeConstraint (LTree (c, _) _) = c

@@ -281,7 +345,7 @@ computeSizes available constraints =

281 (_, Constraint_Min n) -> n

345 (_, Constraint_Min n) -> n

282 leftover = max 0 (available - minTotal)

346 leftover = max 0 (available - minTotal)

283 numStretch = length $ filter (isMin . snd) constraints

347 numStretch = length $ filter (isMin . snd) constraints

284− szStretch = floor $ leftover % (max numStretch 1)

348+ szStretch = floor $ leftover % max numStretch 1

285 adjustment = max 0 $ available - minTotal - szStretch * numStretch

349 adjustment = max 0 $ available - minTotal - szStretch * numStretch

286 in snd $ mapAccumL (\adj (a, c) -> case c of

350 in snd $ mapAccumL (\adj (a, c) -> case c of

287 Constraint_Fixed n -> (adj, (a, n))

351 Constraint_Fixed n -> (adj, (a, n))

@@ -314,25 +378,46 @@ tabNavigation = do

314test :: IO ()

378test :: IO ()

315test = mainWidget $ do

379test = mainWidget $ do

316 inp <- input

380 inp <- input

317− dw <- displayWidth

381+ let box' w = do

318− dh <- displayHeight

382+ f <- focus

319− let r = Region <$> 0 <*> 0 <*> dw <*> dh

383+ box (ffor (current f) $ \x -> if x then doubleBoxStyle else singleBoxStyle) $ w

320 text' t = do

384 text' t = do

321 f <- focus

385 f <- focus

322− richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.bold else V.defAttr) <$> f) t

386+ box' $ richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.underline else V.defAttr) <$> f) t

323− rec (_, _) <- runFocus $ do

387+ initManager_ $ do

324− tabNavigation

388+ tabNavigation

325− runLayout (pure Orientation_Column) r $ do

326− col $ do

389+ col $ do

390+ fixed_ 5 $ box' $ row $ do

391+ flex_ $ do

327− tile_ $ text' "asdf"

392+ text' "asdf"

393+ flex_ $ text' "xyz"

394+ fixed_ 5 $ do

328− tile_ $ text' "asdf"

395+ text' " 1"

329− row $ do

396+ row $ do

397+ tile_ (pure $ Constraint_Min 0) $ do

330− tile_ $ text' "xyz"

398+ text' "2"

331− tile_ $ text' "xyz"

399+ flex_ $ text' "3"

332− tile_ $ text' "xyz"

400+ flex_ $ text' "xyz"

333− tile_ $ text' "xyz"

401+ flex_ $ text' "xyz"

334− tile_ $ text' "asdf"

402+ flex_ $ text' "asdf"

335− tile_ $ text' "asdf"

403+ flex_ $ text' "asdf"

336 return $ fforMaybe inp $ \case

404 return $ fforMaybe inp $ \case

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

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

338 _ -> Nothing

406 _ -> Nothing

407+

408+-- TODO: 'Manager'? as in "window manager"

409+initManager

410+ :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)

411+ => Layout t (Focus t m) a

412+ -> m (a, Dynamic t FocusSet)

413+initManager f = do

414+ dw <- displayWidth

415+ dh <- displayHeight

416+ let r = Region 0 0 <$> dw <*> dh

417+ runFocus $ runLayout (pure Orientation_Column) r f

418+

419+initManager_

420+ :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)

421+ => Layout t (Focus t m) a

422+ -> m a

423+initManager_ = fmap fst . initManager