4780fe7 · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

on develop help sign in

Add keypress widgets; Refactor StackWidget

4780fe7Ali Abrar8 years ago

src-bin/example.hs+4−6

compare with develop

unifiedsplit

@@ -42,14 +42,12 @@ main = mainWidget $ do

42 w <- displayWidth

43 h <- displayHeight

45− row $ sized (div' w 2) $ col $ do

45+ row $ {- sized (div' w 2) $ col $ -} do

46− sized 5 $ display (current w)

47 sized 5 $ textButtonStatic def "A"

46 sized 5 $ textButtonStatic def "A"

48 sized 5 $ textButtonStatic def "B"

47 sized 5 $ textButtonStatic def "B"

49− -- (th, label) <- StackWidget $ \_ -> do

48+ TextInput value lines <- sized 10 $ multilineTextInput def

50− -- (TextInput value lines) <- multilineTextInput def

49+ TextInput value' lines' <- sized 10 $ multilineTextInput def

51− -- return (lines, (lines, value))

52− -- sized (th+4) $ textButton def ("\n" <> current label)

50+ sized 10 $ textButton def ("\n" <> current value)

53 sized 5 $ textButtonStatic def "E"

51 sized 5 $ textButtonStatic def "E"

54 sized 1 $ text "asdf"

52 sized 1 $ text "asdf"

55 sized 1 $ text "zxcv"

53 sized 1 $ text "zxcv"

src/Reflex/Vty/Widget.hs+45−12

@@ -64,6 +64,10 @@ module Reflex.Vty.Widget

64 , doubleBoxStyle

65 , fill

66 , hRule

67+ , KeyCombo

68+ , key

69+ , keys

70+ , keyCombos

67 ) where

71 ) where

69import Control.Applicative (liftA2)

73import Control.Applicative (liftA2)

@@ -72,6 +76,9 @@ import Control.Monad.Fix (MonadFix)

72import Control.Monad.Trans (lift)

76import Control.Monad.Trans (lift)

73import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)

77import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)

74import Data.Default (Default(..))

78import Data.Default (Default(..))

79+import Data.Monoid (Sum(..))

80+import Data.Set (Set)

81+import qualified Data.Set as Set

75import Data.Text (Text)

82import Data.Text (Text)

76import qualified Data.Text as T

83import qualified Data.Text as T

77import qualified Data.Text.Zipper as TZ

84import qualified Data.Text.Zipper as TZ

@@ -364,6 +371,26 @@ data MouseUp = MouseUp

364 }

371 }

365 deriving (Eq, Ord, Show)

372 deriving (Eq, Ord, Show)

366

373

374+type KeyCombo = (V.Key, [V.Modifier])

375+

376+key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)

377+key = keyCombos . Set.singleton . (,[])

378+

379+keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)

380+keys = keyCombos . Set.fromList . fmap (,[])

381+

382+keyCombos

383+ :: (Reflex t, Monad m)

384+ => Set KeyCombo

385+ -> VtyWidget t m (Event t KeyCombo)

386+keyCombos ks = do

387+ i <- input

388+ return $ fforMaybe i $ \case

389+ V.EvKey k m -> if Set.member (k, m) ks

390+ then Just (k, m)

391+ else Nothing

392+ _ -> Nothing

393+

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

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

368-- No visual separator is built in here.

395-- No visual separator is built in here.

369splitV :: (Reflex t, Monad m)

396splitV :: (Reflex t, Monad m)

@@ -577,33 +604,37 @@ data Direction = Direction_Column

577 | Direction_Row

604 | Direction_Row

578 deriving (Show, Read, Eq, Ord)

605 deriving (Show, Read, Eq, Ord)

579

606

580−newtype StackWidget t m a = StackWidget { unStackWidget :: Direction -> VtyWidget t m (Dynamic t Int, a) }

607+newtype StackWidget t m a = StackWidget { unStackWidget :: ReaderT Direction (DynamicWriterT t (Sum Int) (VtyWidget t m)) a }

581− deriving (Functor)

608+ deriving (Functor, MonadSample t, MonadHold t, MonadFix, NotReady t)

582

609

583instance (Reflex t, MonadFix m) => Applicative (StackWidget t m) where

610instance (Reflex t, MonadFix m) => Applicative (StackWidget t m) where

584 pure = return

611 pure = return

585 (<*>) = ap

612 (<*>) = ap

586

613

587−instance (MonadFix m, Reflex t) => Monad (StackWidget t m) where

588− w >>= g = StackWidget $ \dir -> do

589− (sz, r) <- runStackWidget dir 0 w

590− (sz', r') <- runStackWidget dir sz (g r)

591− return (sz + sz', r')

592− return x = StackWidget $ \_ -> return (0, x)

593−

594runStackWidget

614runStackWidget

595 :: (Reflex t, MonadFix m)

615 :: (Reflex t, MonadFix m)

596 => Direction

616 => Direction

597 -> Dynamic t Int

617 -> Dynamic t Int

598 -> StackWidget t m a

618 -> StackWidget t m a

599− -> VtyWidget t m (Dynamic t Int, a)

619+ -> VtyWidget t m (Dynamic t (Sum Int), a)

600runStackWidget dir offset x = do

620runStackWidget dir offset x = do

601 mkRegion <- case dir of

621 mkRegion <- case dir of

602 Direction_Column -> (\w sz -> DynRegion 0 offset w sz) <$> displayWidth

622 Direction_Column -> (\w sz -> DynRegion 0 offset w sz) <$> displayWidth

603 Direction_Row -> (\h sz -> DynRegion offset 0 sz h) <$> displayHeight

623 Direction_Row -> (\h sz -> DynRegion offset 0 sz h) <$> displayHeight

604− rec (h, a) <- pane (mkRegion h) (pure True) $ unStackWidget x dir

624+ rec (a, h) <- pane (mkRegion h') (pure True) $ runDynamicWriterT $ runReaderT (unStackWidget x) dir

625+ let h' = getSum <$> h

605 return (h, a)

626 return (h, a)

606

627

628+instance (MonadFix m, Reflex t) => Monad (StackWidget t m) where

629+ w >>= g = StackWidget $ do

630+ dir <- ask

631+ (sz, r) <- lift $ lift $ runStackWidget dir 0 w

632+ tellDyn sz

633+ (sz', r') <- lift $ lift $ runStackWidget dir (getSum <$> sz) (g r)

634+ tellDyn sz'

635+ return r'

636+ return x = StackWidget $ return x

637+

607stack

638stack

608 :: (Reflex t, MonadFix m)

639 :: (Reflex t, MonadFix m)

609 => Direction

640 => Direction

@@ -628,4 +659,6 @@ sized

628 => Dynamic t Int

659 => Dynamic t Int

629 -> VtyWidget t m a

660 -> VtyWidget t m a

630 -> StackWidget t m a

661 -> StackWidget t m a

631−sized sz w = StackWidget $ \_ -> (sz,) <$> w

662+sized sz w = StackWidget $ do

663+ tellDyn $ Sum <$> sz

664+ lift $ lift w

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

@@ -23,27 +23,36 @@ import Reflex.Vty.Widget

23-- | Configuration options for the 'button' widget

24data ButtonConfig t = ButtonConfig

25 { _buttonConfig_boxStyle :: Behavior t BoxStyle

26+ , _buttonConfig_focusStyle :: Behavior t BoxStyle

26 }

27 }

28instance Reflex t => Default (ButtonConfig t) where

29instance Reflex t => Default (ButtonConfig t) where

29− def = ButtonConfig (pure def)

30+ def = ButtonConfig (pure singleBoxStyle) (pure thickBoxStyle)

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

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

32button

33button

33 :: (Reflex t, Monad m)

34 :: (Reflex t, Monad m)

34 => ButtonConfig t

35 => ButtonConfig t

35 -> VtyWidget t m ()

36 -> VtyWidget t m ()

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

37+ -> VtyWidget t m (Event t ())

37button cfg child = do

38button cfg child = do

39+ f <- focus

40+ let style = do

41+ isFocused <- current f

42+ if isFocused

43+ then _buttonConfig_focusStyle cfg

38− box (_buttonConfig_boxStyle cfg) child

44+ else _buttonConfig_boxStyle cfg

45+ box style child

39− mouseUp

46+ m <- mouseUp

47+ k <- key V.KEnter

48+ return $ leftmost [() <$ k, () <$ m]

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

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

42textButton

51textButton

43 :: (Reflex t, Monad m)

52 :: (Reflex t, Monad m)

44 => ButtonConfig t

53 => ButtonConfig t

45 -> Behavior t Text

54 -> Behavior t Text

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

55+ -> VtyWidget t m (Event t ())

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

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

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

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

@@ -51,7 +60,7 @@ textButtonStatic

51 :: (Reflex t, Monad m)

60 :: (Reflex t, Monad m)

52 => ButtonConfig t

61 => ButtonConfig t

53 -> Text

62 -> Text

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

63+ -> VtyWidget t m (Event t ())

55textButtonStatic cfg = textButton cfg . pure

64textButtonStatic cfg = textButton cfg . pure

57-- | A clickable link widget

66-- | A clickable link widget