efe7df8 · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

on develop help sign in

Add StackWidget

efe7df8Ali Abrar8 years ago

reflex-vty.cabal+1

compare with develop

unifiedsplit

@@ -45,6 +45,7 @@ library

45 vty

46 hs-source-dirs: src

47 default-language: Haskell2010

48+ ghc-options: -Wall

49executable example

50executable example

50 hs-source-dirs: src-bin

51 hs-source-dirs: src-bin

src-bin/example.hs+17−10

@@ -27,19 +27,12 @@ import Reflex.Class.Switchable

27import Reflex.NotReady.Class

28import Reflex.Vty

30−import Data.Tree

31−

32−-- Unlimited Stack

33− -- Parent provides orientation and maximum cross-dimension size

34− -- Each child takes as much main-dimension space as it wants and reports what it took

35− -- Parent offsets each child so that it does not overlap with other children

36− -- If parent runs of out space, parent provides a scroll bar

37−

38data Example = Example_TextEditor

30data Example = Example_TextEditor

39 | Example_Todo

31 | Example_Todo

32+ | Example_Stack

40 deriving (Show, Read, Eq, Ord, Enum, Bounded)

33 deriving (Show, Read, Eq, Ord, Enum, Bounded)

42−div' :: (Integral a, Applicative f) => f a ->f a -> f a

35+div' :: (Integral a, Applicative f) => f a -> f a -> f a

43div' = liftA2 div

36div' = liftA2 div

45main :: IO ()

38main :: IO ()

@@ -48,6 +41,20 @@ main = mainWidget $ do

49 w <- displayWidth

42 w <- displayWidth

50 h <- displayHeight

43 h <- displayHeight

44+

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

46+ sized 5 $ display (current w)

47+ sized 5 $ textButtonStatic def "A"

48+ sized 5 $ textButtonStatic def "B"

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

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

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

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

53+ sized 5 $ textButtonStatic def "E"

54+ sized 1 $ text "asdf"

55+ sized 1 $ text "zxcv"

56+

57+ {-

51 let buttons = do

58 let buttons = do

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

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

53 let w' = fmap (`div`6) w

60 let w' = fmap (`div`6) w

@@ -70,7 +77,7 @@ main = mainWidget $ do

70 Left Example_TextEditor -> escapable testBoxes

77 Left Example_TextEditor -> escapable testBoxes

71 Left Example_Todo -> escapable taskList

78 Left Example_Todo -> escapable taskList

72 Right () -> buttons

79 Right () -> buttons

73−

80+ -}

74 return $ fforMaybe inp $ \case

81 return $ fforMaybe inp $ \case

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

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

76 _ -> Nothing

83 _ -> Nothing

src/Reflex/Class/Orphans.hs+1

@@ -2,6 +2,7 @@

2Module: Reflex.Class.Orphans

3Description: Orphan instances for Dynamic. These should be upstreamed.

4-}

5+{-# OPTIONS_GHC -fno-warn-orphans #-}

5module Reflex.Class.Orphans where

6module Reflex.Class.Orphans where

7import Control.Applicative

8import Control.Applicative

src/Reflex/Vty/Widget.hs+75−7

@@ -2,6 +2,7 @@

2Module: Reflex.Vty.Widget

3Description: Basic set of widgets and building blocks for reflex-vty applications

4-}

5+{-# LANGUAGE DeriveFunctor #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE FunctionalDependencies #-}

@@ -13,6 +14,7 @@ Description: Basic set of widgets and building blocks for reflex-vty application

13{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15{-# LANGUAGE ScopedTypeVariables #-}

15{-# LANGUAGE StandaloneDeriving #-}

16{-# LANGUAGE StandaloneDeriving #-}

17+{-# LANGUAGE TupleSections #-}

16{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE UndecidableInstances #-}

19{-# LANGUAGE UndecidableInstances #-}

18module Reflex.Vty.Widget

20module Reflex.Vty.Widget

@@ -23,6 +25,14 @@ module Reflex.Vty.Widget

23 , runVtyWidget

25 , runVtyWidget

24 , mainWidget

26 , mainWidget

25 , mainWidgetWithHandle

27 , mainWidgetWithHandle

28+

29+ , StackWidget(..)

30+ , stack

31+ , Direction(..)

32+ , col

33+ , row

34+ , sized

35+

26 , HasDisplaySize(..)

36 , HasDisplaySize(..)

27 , HasFocus(..)

37 , HasFocus(..)

28 , HasVtyInput(..)

38 , HasVtyInput(..)

@@ -57,6 +67,7 @@ module Reflex.Vty.Widget

57 ) where

67 ) where

59import Control.Applicative (liftA2)

69import Control.Applicative (liftA2)

70+import Control.Monad (ap)

60import Control.Monad.Fix (MonadFix)

71import Control.Monad.Fix (MonadFix)

61import Control.Monad.Trans (lift)

72import Control.Monad.Trans (lift)

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

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

@@ -67,7 +78,7 @@ import qualified Data.Text.Zipper as TZ

67import Graphics.Vty (Image)

78import Graphics.Vty (Image)

68import qualified Graphics.Vty as V

79import qualified Graphics.Vty as V

69import Reflex

80import Reflex

70−import Reflex.Class.Orphans

81+import Reflex.Class.Orphans ()

71import Reflex.NotReady.Class

82import Reflex.NotReady.Class

72import Reflex.NotReady.Class.Orphans ()

83import Reflex.NotReady.Class.Orphans ()

@@ -238,22 +249,22 @@ pane

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

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

239 -> VtyWidget t m a

250 -> VtyWidget t m a

240 -> VtyWidget t m a

251 -> VtyWidget t m a

241−pane (DynRegion l t w h) foc child = VtyWidget $ do

252+pane dr foc child = VtyWidget $ do

242 ctx <- lift ask

253 ctx <- lift ask

243− let reg = Region <$> l <*> t <*> w <*> h

254+ let reg = currentRegion dr

244 let ctx' = VtyWidgetCtx

255 let ctx' = VtyWidgetCtx

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

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

246 [ fmapMaybe id $

257 [ fmapMaybe id $

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

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

248− (liftA2 (,) (current reg) (current foc))

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

249 (_vtyWidgetCtx_input ctx)

260 (_vtyWidgetCtx_input ctx)

250 ]

261 ]

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

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

252− , _vtyWidgetCtx_width = w

263+ , _vtyWidgetCtx_width = _dynRegion_width dr

253− , _vtyWidgetCtx_height = h

264+ , _vtyWidgetCtx_height = _dynRegion_height dr

254 }

265 }

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

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

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

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

257 tellImages images'

268 tellImages images'

258 return result

269 return result

259 where

270 where

@@ -561,3 +572,60 @@ display

561 => Behavior t a

572 => Behavior t a

562 -> VtyWidget t m ()

573 -> VtyWidget t m ()

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

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

575+

576+data Direction = Direction_Column

577+ | Direction_Row

578+ deriving (Show, Read, Eq, Ord)

579+

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

581+ deriving (Functor)

582+

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

584+ pure = return

585+ (<*>) = ap

586+

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+

594+runStackWidget

595+ :: (Reflex t, MonadFix m)

596+ => Direction

597+ -> Dynamic t Int

598+ -> StackWidget t m a

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

600+runStackWidget dir offset x = do

601+ mkRegion <- case dir of

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

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

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

605+ return (h, a)

606+

607+stack

608+ :: (Reflex t, MonadFix m)

609+ => Direction

610+ -> StackWidget t m a

611+ -> VtyWidget t m a

612+stack dir w = fmap snd $ runStackWidget dir 0 w

613+

614+col

615+ :: (Reflex t, MonadFix m)

616+ => StackWidget t m a

617+ -> VtyWidget t m a

618+col = stack Direction_Column

619+

620+row

621+ :: (Reflex t, MonadFix m)

622+ => StackWidget t m a

623+ -> VtyWidget t m a

624+row = stack Direction_Row

625+

626+sized

627+ :: (Reflex t, MonadFix m)

628+ => Dynamic t Int

629+ -> VtyWidget t m a

630+ -> StackWidget t m a

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