97e0c65...develop · reflex-vty

git.iko.soy/reflex-vty

14 files changed+310−279

since splitsnapshots

unifiedsplit

.github/workflows/haskell.yml+12−10 .travis.yml−112 ChangeLog.md+19−11 reflex-vty.cabal+9−8 src-bin/Example/CPU.hs+2−2 src-bin/example.hs+11−3 src/Data/Text/Zipper.hs+27−16 src/Reflex/Vty/Widget.hs+83−10 src/Reflex/Vty/Widget/Box.hs+19−16 src/Reflex/Vty/Widget/Input.hs+9−7 src/Reflex/Vty/Widget/Input/Text.hs+15−10 src/Reflex/Vty/Widget/Layout.hs+4 src/Reflex/Vty/Widget/Text.hs+17−10 test/Data/Text/ZipperSpec.hs+83−64

.github/workflows/haskell.yml+12−10

@@ -1,33 +1,33 @@

1−name: Haskell CI

1+name: github-action

33on: [push, pull_request]

55jobs:

66 build:

7−

8− runs-on: ${{ matrix.os }}

97 strategy:

108 matrix:

11− ghc: ['8.4.4', '8.6.5', '8.8.4']

9+ ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']

1210 os: ['ubuntu-latest', 'macos-latest']

11+ runs-on: ${{ matrix.os }}

12+

13+ name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}

1314 steps:

1415 - uses: actions/checkout@v2

1516 - uses: actions/setup-haskell@v1

1617 with:

1718 ghc-version: ${{ matrix.ghc }}

18− cabal-version: '3.0'

19−

2019 - name: Cache

2120 uses: actions/cache@v1

2221 env:

2322 cache-name: cache-cabal

2423 with:

2524 path: ~/.cabal

26− key: ${{ runner.os }}-1-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}

25+ key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}

2726 restore-keys: |

28− ${{ runner.os }}-1-build-${{ env.cache-name }}-

29− ${{ runner.os }}-1-build-

30− ${{ runner.os }}-1-

27+ ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-

28+ ${{ runner.os }}-${{ matrix.ghc }}-build-

29+ ${{ runner.os }}-${{ matrix.ghc }}-

30+ ${{ runner.os }}

3131

3232 - name: Install dependencies

3333 run: |

@@ -37,3 +37,5 @@ jobs:

3737 run: cabal build --enable-tests --enable-benchmarks all

3838 - name: Run tests

3939 run: cabal test all

40+ - name: Build Docs

41+ run: cabal haddock

.travis.ymldeleted−112

@@ -1,112 +0,0 @@

1−# This Travis job script has been generated by a script via

2−#

3−# haskell-ci 'reflex-vty.cabal' '--output' '.travis.yml'

4−#

5−# For more information, see https://github.com/haskell-CI/haskell-ci

6−#

7−# version: 0.3

8−#

9−language: c

10−dist: xenial

11−

12−git:

13− submodules: false # whether to recursively clone submodules

14−

15−cache:

16− directories:

17− - $HOME/.cabal/packages

18− - $HOME/.cabal/store

19−

20−before_cache:

21− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

22− # remove files that are regenerated by 'cabal update'

23− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

24− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

28−

29− - rm -rfv $CABALHOME/packages/head.hackage

30−

31−matrix:

32− include:

33− - compiler: "ghc-8.8.3"

34− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.8.3], sources: [hvr-ghc]}}

35− - compiler: "ghc-8.6.5"

36− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

37− - compiler: "ghc-8.4.4"

38− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}

39−

40−

41−before_install:

42− - HC=/opt/ghc/bin/${CC}

43− - HCPKG=${HC/ghc/ghc-pkg}

44− - unset CC

45− - CABAL=/opt/ghc/bin/cabal

46− - CABALHOME=$HOME/.cabal

47− - export PATH="$CABALHOME/bin:$PATH"

48− - ROOTDIR=$(pwd)

49− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))

50− - echo $HCNUMVER

51−

52−install:

53− - ${CABAL} --version

54− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

55− - TEST=--enable-tests

56− - BENCH=--enable-benchmarks

57− - GHCHEAD=${GHCHEAD-false}

58− - travis_retry ${CABAL} update -v

59− - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config

60− - rm -fv cabal.project cabal.project.local

61− - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'

62− - rm -f cabal.project

63− - touch cabal.project

64− - "printf 'packages: \".\"\\n' >> cabal.project"

65− - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"

66− - touch cabal.project.local

67− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(reflex-vty)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

68− - cat cabal.project || true

69− - cat cabal.project.local || true

70− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

71− - rm -f cabal.project.freeze

72− - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry

73− - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

74− - rm "cabal.project.freeze"

75− - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

76− - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

77− - rm -rf .ghc.environment.* "."/dist

78− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

79−

80−# Here starts the actual work to be performed for the package under test;

81−# any command which exits with a non-zero exit code causes the build to fail.

82−script:

83− # test that source-distributions can be generated

84− - ${CABAL} new-sdist all

85− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

86− - cd ${DISTDIR} || false

87− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

88− - rm -f cabal.project

89− - touch cabal.project

90− - "printf 'packages: \"reflex-vty-*/*.cabal\"\\n' >> cabal.project"

91− - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"

92− - touch cabal.project.local

93− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(reflex-vty)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

94− - cat cabal.project || true

95− - cat cabal.project.local || true

96− # this builds all libraries and executables (without tests/benchmarks)

97− - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all

98−

99− # build & run tests, build benchmarks

100− - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all

101−

102− # cabal check

103− - (cd reflex-vty-* && ${CABAL} check)

104−

105− # haddock

106− - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all

107−

108− # Build without installed constraints for packages in global-db

109− - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all

110−

111−# REGENDATA ["reflex-vty.cabal","--output",".travis.yml"]

112−# EOF

ChangeLog.md+19−11

@@ -33,6 +33,8 @@

3333 * Introduce a `FocusReader` monad transformer

3434 * Replace `HasVtyInput` with `HasInput`

3535 * Introduce an `Input` monad transformer

36+ * Introduce `HasTheme` reader class to allow setting Vty attributes of all built-in widgets

37+ * Introduce `ThemeReader` monad transformer

3638 * Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.

3739 * `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.

3840 * `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.

@@ -54,24 +56,24 @@

5456 * `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`

5557 * `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`

5658 * `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`

57− * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m`

58− * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m`

59− * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m`

59+ * `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`

60+ * `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`

61+ * `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`

6062 * `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`

61− * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

63+ * `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

6264 * `blank`: Now requires `Monad`

63− * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

64− * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

65− * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

66− * `link`: Now requires `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

65+ * `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

66+ * `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

67+ * `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

68+ * `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

6769 * `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

68− * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

69− * `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`

70− * `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, and `HasFocus`

7170 * TextZipper interface changes

7271 * `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`

7372 * `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position

7473 * some exposed methods intended for internal use only have been removed

74+ * `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

75+ * `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`

76+ * `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, `HasTheme`, and `HasFocus`

7577* _Misc_:

7678 * (#40 Add alignment support to TextZipper)[https://github.com/reflex-frp/reflex-vty/pull/40]

7779 * Add alignment (left/center/right) support to TextZipper

@@ -84,6 +86,12 @@

8486 * Add various `MFunctor` instances

8587 * Add a CPU usage indicator to the example executable

8688

89+## 0.1.4.2

90+

91+* Wider bounds for GHC 8.10 support

92+

93+## 0.1.4.1

94+

8795## 0.1.4.1

8896* Migrate to new dependent-sum / dependent-map (after the "some" package split)

8997

reflex-vty.cabal+9−8

@@ -12,12 +12,17 @@ maintainer: maintainer@obsidian.systems

1212copyright: 2020 Obsidian Systems LLC

1313category: FRP

1414build-type: Simple

15−cabal-version: >=1.18

15+cabal-version: 1.18

1616extra-source-files:

1717 README.md

1818 ChangeLog.md

1919extra-doc-files: doc/tasks.png

20−tested-with: GHC ==8.8.4 || ==8.6.5 || ==8.4.4

20+tested-with:

21+ GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2

22+

23+source-repository head

24+ type: git

25+ location: https://github.com/reflex-frp/reflex-vty

2126

2227library

2328 exposed-modules: Reflex.Vty

@@ -34,8 +39,8 @@ library

3439 , Reflex.Spider.Orphans

3540 , Control.Monad.NodeId

3641 build-depends:

37− base >= 4.10.0 && < 4.14,

38− bimap >= 0.3.3 && < 0.4,

42+ base >= 4.10.0 && < 4.15,

43+ bimap >= 0.3.3 && < 0.5,

3944 containers >= 0.5.0 && < 0.7,

4045 mtl >= 2.2.2 && < 2.3,

4146 transformers >= 0.5.5 && < 0.6,

@@ -147,7 +152,3 @@ test-suite reflex-vty-test

147152 extra,

148153 hspec >= 2.7 && < 2.8

149154 default-language: Haskell2010

150−

151−source-repository head

152− type: git

153− location: https://github.com/reflex-frp/reflex-vty

src-bin/Example/CPU.hs+2−2

@@ -100,7 +100,7 @@ cpuStats

100100 , HasLayout t m

101101 , HasFocus t m

102102 , HasInput t m

103− , HasFocusReader t m

103+ , HasFocusReader t m, HasTheme t m

104104 )

105105 => m ()

106106cpuStats = do

@@ -122,7 +122,7 @@ chart

122122 , HasImageWriter t m

123123 , HasInput t m

124124 , HasDisplayRegion t m

125− , HasFocusReader t m

125+ , HasFocusReader t m, HasTheme t m

126126 )

127127 => Dynamic t (Ratio Word64) -> m ()

128128chart pct = do

src-bin/example.hs+11−3

@@ -23,7 +23,7 @@ type VtyExample t m =

2323 , HasImageWriter t m

2424 , HasDisplayRegion t m

2525 , HasFocus t m

26− , HasFocusReader t m

26+ , HasFocusReader t m, HasTheme t m

2727 )

2828

2929type Manager t m =

@@ -46,12 +46,20 @@ withCtrlC f = do

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

4747 _ -> Nothing

4848

49+darkTheme :: V.Attr

50+darkTheme = V.Attr {

51+ V.attrStyle = V.SetTo V.standout

52+ , V.attrForeColor = V.SetTo V.black

53+ , V.attrBackColor = V.Default

54+ , V.attrURL = V.Default

55+}

56+

4957main :: IO ()

5058main = mainWidget $ withCtrlC $ do

5159 initManager_ $ do

5260 tabNavigation

5361 let gf = grout . fixed

54− t = tile flex

62+ t = tile flex

5563 buttons = col $ do

5664 gf 3 $ col $ do

5765 gf 1 $ text "Select an example."

@@ -77,7 +85,7 @@ main = mainWidget $ withCtrlC $ do

7785 _ -> Nothing

7886 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case

7987 Left Example_Todo -> escapable taskList

80− Left Example_TextEditor -> escapable testBoxes

88+ Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes

8189 Left Example_ScrollableTextDisplay -> escapable scrolling

8290 Left Example_ClickButtonsGetEmojis -> escapable easyExample

8391 Left Example_CPUStat -> escapable cpuStats

src/Data/Text/Zipper.hs+27−16

@@ -12,7 +12,7 @@ module Data.Text.Zipper where

1212import Prelude

1313

1414import Control.Exception (assert)

15−import Control.Monad.State (evalState, forM, get, put, join)

15+import Control.Monad.State (evalState, forM, get, put)

1616import Data.Char (isSpace)

1717import Data.Map (Map)

1818import Data.Maybe (fromMaybe)

@@ -170,7 +170,7 @@ deleteLeftWord (TextZipper lb b a la) =

170170-- | Insert up to n spaces to get to the next logical column that is a multiple of n

171171tab :: Int -> TextZipper -> TextZipper

172172tab n z@(TextZipper _ b _ _) =

173− insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z

173+ insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z

174174

175175-- | The plain text contents of the zipper

176176value :: TextZipper -> Text

@@ -314,9 +314,7 @@ wordsWithWhitespace :: Text -> [Text]

314314wordsWithWhitespace t@(Text arr off len) = loop 0 0 False

315315 where

316316 loop !start !n !wasSpace

317− | n >= len = if start == n

318− then []

319− else [Text arr (start+off) (n-start)]

317+ | n >= len = [Text arr (start+off) (n-start) | not (start == n)]

320318 | isSpace c = loop start (n+d) True

321319 | wasSpace = Text arr (start+off) (n-start) : loop n n False

322320 | otherwise = loop start (n+d) False

@@ -367,7 +365,8 @@ wrapWithOffsetAndAlignment

367365 -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)

368366wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []

369367wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where

370− r' = splitWordsAtDisplayWidth maxWidth $ T.replicate n " " : wordsWithWhitespace txt

368+ -- we pad by offset amount with any non-space character which we will remove later so that no changes need to be made to splitWordsAtDisplayWidth

369+ r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)

371370 fmapfn (t,b) = case alignment of

372371 TextAlignment_Left -> WrappedLine t b 0

373372 TextAlignment_Right -> WrappedLine t b (maxWidth-l)

@@ -380,7 +379,7 @@ wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r w

380379

381380-- converts deleted eol spaces into logical lines

382381eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]

383−eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . join . fmap (L.groupBy (\(WrappedLine _ b _) _ -> not b))

382+eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))

384383

385384offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment

386385offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines

@@ -419,10 +418,13 @@ displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =

419418 linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb

420419 linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line

421420 linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la

421+

422+ -- simulate trailing cursor character when computing OffsetMap

423+ afterWithCursor = if T.null a then " " else a

422424 offsets :: OffsetMapWithAlignment

423425 offsets = offsetMapWithAlignmentInternal $ mconcat

424426 [ linesBefore

425− , [wrapWithOffsetAndAlignment alignment width 0 $ b <> a]

427+ , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]

426428 , linesAfter

427429 ]

428430 flattenLines = concatMap (fmap _wrappedLines_text)

@@ -432,9 +434,8 @@ displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =

432434 -- * spans that are on earlier display lines (though on the same logical line), and

433435 -- * spans that are on the same display line

434436

435− -- TODO cursor goes here if align right

436437 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $

437− initLast $ map ((:[]) . Span tag) $ fmap _wrappedLines_text $ (wrapWithOffsetAndAlignment alignment width 0 b)

438+ initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b)

438439 -- Calculate the number of columns on the cursor's display line before the cursor

439440 curLineOffset = spansWidth spansCurLineBefore

440441 -- Check whether the spans on the current display line are long enough that

@@ -448,17 +449,29 @@ displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =

448449 -- * spans that are on the same display line, and

449450 -- * spans that are on later display lines (though on the same logical line)

450451

451− -- TODO do not show cursor if align right

452452 (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $

453453 headTail $ case T.uncons a of

454454 Nothing -> [[Span cursorTag " "]]

455455 Just (c, rest) ->

456456 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth

457457 cursor = Span cursorTag (T.singleton c)

458− in case map ((:[]) . Span tag) $ fmap _wrappedLines_text $ (wrapWithOffsetAndAlignment alignment width o rest) of

458+ in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of

459459 [] -> [[cursor]]

460460 (l:ls) -> (cursor : l) : ls

461461

462+ curLineSpanNormalCase = if cursorAfterEOL

463+ then [ spansCurLineBefore, spansCurLineAfter ]

464+ else [ spansCurLineBefore <> spansCurLineAfter ]

465+

466+ -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position

467+ curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL

468+ then case reverse spansCurLineBefore of

469+ [] -> curLineSpanNormalCase

470+ (Span _ x):xs -> case spansCurLineAfter of

471+ [] -> error "should not be possible" -- curLineSpanNormalCase

472+ (Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]

473+ else curLineSpanNormalCase

474+

462475 cursorY = sum

463476 [ length spansBefore

464477 , length spansCurrentBefore

@@ -471,9 +484,7 @@ displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =

471484 { _displayLines_spans = concat

472485 [ spansBefore

473486 , spansCurrentBefore

474− , if cursorAfterEOL

475− then [ spansCurLineBefore, spansCurLineAfter ]

476− else [ spansCurLineBefore <> spansCurLineAfter ]

487+ , curLineSpan

477488 , spansCurrentAfter

478489 , spansAfter

479490 ]

@@ -531,4 +542,4 @@ wrapWithOffset

531542 -> Int -- ^ Offset for first line

532543 -> Text -- ^ Text to be wrapped

533544 -> [Text]

534−wrapWithOffset maxWidth n xs = fmap _wrappedLines_text $ wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs

545+wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs

src/Reflex/Vty/Widget.hs+83−10

@@ -35,6 +35,7 @@ mainWidgetWithHandle

3535 , HasDisplayRegion t m

3636 , HasFocusReader t m

3737 , HasInput t m

38+ , HasTheme t m

3839 ) => m (Event t ()))

3940 -> IO ()

4041mainWidgetWithHandle vty child =

@@ -45,12 +46,14 @@ mainWidgetWithHandle vty child =

4546 let inp' = fforMaybe inp $ \case

4647 V.EvResize {} -> Nothing

4748 x -> Just x

48− (shutdown, images) <- runFocusReader (pure True) $ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $

49− runImageWriter $

50− runNodeIdT $

51− runInput inp' $ do

52− tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]

53− child

49+ (shutdown, images) <- runThemeReader (constant V.defAttr) $

50+ runFocusReader (pure True) $

51+ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $

52+ runImageWriter $

53+ runNodeIdT $

54+ runInput inp' $ do

55+ tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]

56+ child

5457 return $ VtyResult

5558 { _vtyResult_picture = fmap (V.picForLayers . reverse) images

5659 , _vtyResult_shutdown = shutdown

@@ -69,6 +72,7 @@ mainWidget

6972 , MonadNodeId m

7073 , HasDisplayRegion t m

7174 , HasFocusReader t m

75+ , HasTheme t m

7276 , HasInput t m

7377 ) => m (Event t ()))

7478 -> IO ()

@@ -233,9 +237,9 @@ regionSize :: Region -> (Int, Int)

233237regionSize (Region _ _ w h) = (w, h)

234238

235239-- | Produces an 'Image' that fills a region with space characters

236−regionBlankImage :: Region -> Image

237−regionBlankImage r@(Region _ _ width height) =

238− withinImage r $ V.charFill V.defAttr ' ' width height

240+regionBlankImage :: V.Attr -> Region -> Image

241+regionBlankImage attr r@(Region _ _ width height) =

242+ withinImage r $ V.charFill attr ' ' width height

239243

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

241245class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where

@@ -403,7 +407,7 @@ newtype ImageWriter t m a = ImageWriter

403407 , NotReady t

404408 , PerformEvent t

405409 , PostBuild t

406− , TriggerEvent t

410+ , TriggerEvent t

407411 )

408412

409413instance MonadTrans (ImageWriter t) where

@@ -441,6 +445,75 @@ runImageWriter

441445 -> m (a, Behavior t [Image])

442446runImageWriter = runBehaviorWriterT . unImageWriter

443447

448+-- * Theming

449+

450+-- | A class for things that can be visually styled

451+class (Reflex t, Monad m) => HasTheme t m | m -> t where

452+ theme :: m (Behavior t V.Attr)

453+ default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)

454+ theme = lift theme

455+ localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a

456+ default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a

457+ localTheme f = hoist (localTheme f)

458+

459+instance HasTheme t m => HasTheme t (ReaderT x m)

460+instance HasTheme t m => HasTheme t (BehaviorWriterT t x m)

461+instance HasTheme t m => HasTheme t (DynamicWriterT t x m)

462+instance HasTheme t m => HasTheme t (EventWriterT t x m)

463+instance HasTheme t m => HasTheme t (NodeIdT m)

464+instance HasTheme t m => HasTheme t (Input t m)

465+instance HasTheme t m => HasTheme t (ImageWriter t m)

466+instance HasTheme t m => HasTheme t (DisplayRegion t m)

467+instance HasTheme t m => HasTheme t (FocusReader t m)

468+

469+-- | A widget that has access to theme information

470+newtype ThemeReader t m a = ThemeReader

471+ { unThemeReader :: ReaderT (Behavior t V.Attr) m a }

472+ deriving

473+ ( Functor

474+ , Applicative

475+ , Monad

476+ , MonadFix

477+ , MonadHold t

478+ , MonadIO

479+ , MonadRef

480+ , MonadSample t

481+ )

482+

483+instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where

484+ theme = ThemeReader ask

485+ localTheme f = ThemeReader . local f . unThemeReader

486+

487+deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)

488+deriving instance NotReady t m => NotReady t (ThemeReader t m)

489+deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)

490+deriving instance PostBuild t m => PostBuild t (ThemeReader t m)

491+deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)

492+instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)

493+

494+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where

495+ runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e

496+ traverseIntMapWithKeyWithAdjust f m e = ThemeReader $ traverseIntMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e

497+ traverseDMapWithKeyWithAdjust f m e = ThemeReader $ traverseDMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e

498+ traverseDMapWithKeyWithAdjustWithMove f m e = ThemeReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unThemeReader $ f k v) m e

499+

500+instance MonadTrans (ThemeReader t) where

501+ lift = ThemeReader . lift

502+

503+instance MFunctor (ThemeReader t) where

504+ hoist f = ThemeReader . hoist f . unThemeReader

505+

506+instance MonadNodeId m => MonadNodeId (ThemeReader t m)

507+

508+-- | Run a 'ThemeReader' action with the given focus value

509+runThemeReader

510+ :: (Reflex t, Monad m)

511+ => Behavior t V.Attr

512+ -> ThemeReader t m a

513+ -> m a

514+runThemeReader b = flip runReaderT b . unThemeReader

515+

516+

444517-- ** Manipulating images

445518

446519-- | Translates and crops an 'Image' so that it is contained by

src/Reflex/Vty/Widget/Box.hs+19−16

@@ -13,7 +13,7 @@ import Reflex.Vty.Widget

1313import Reflex.Vty.Widget.Text

1414

1515-- | Fill the background with the bottom box style

16−hRule :: (HasDisplayRegion t m, HasImageWriter t m) => BoxStyle -> m ()

16+hRule :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => BoxStyle -> m ()

1717hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)

1818

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

@@ -54,7 +54,7 @@ roundedBoxStyle :: BoxStyle

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

5555

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

57−boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m)

57+boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)

5858 => Behavior t BoxStyle

5959 -> Behavior t Text

6060 -> m a

@@ -62,36 +62,39 @@ boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInp

6262boxTitle boxStyle title child = do

6363 dh <- displayHeight

6464 dw <- displayWidth

65+ bt <- theme

6566 let boxReg = Region 0 0 <$> dw <*> dh

6667 innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)

67− tellImages (boxImages <$> title <*> boxStyle <*> current boxReg)

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

68+

69+ tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg)

70+ tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r]))

71+

6972 pane innerReg (pure True) child

7073 where

71− boxImages :: Text -> BoxStyle -> Region -> [Image]

72− boxImages title' style (Region left top width height) =

74+ boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image]

75+ boxImages attr title' style (Region left top width height) =

7376 let right = left + width - 1

7477 bottom = top + height - 1

7578 sides =

7679 [ withinImage (Region (left + 1) top (width - 2) 1) $

77− V.text' V.defAttr $

80+ V.text' attr $

7881 hPadText title' (_boxStyle_n style) (width - 2)

7982 , withinImage (Region right (top + 1) 1 (height - 2)) $

80− V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)

83+ V.charFill attr (_boxStyle_e style) 1 (height - 2)

8184 , withinImage (Region (left + 1) bottom (width - 2) 1) $

82− V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1

85+ V.charFill attr (_boxStyle_s style) (width - 2) 1

8386 , withinImage (Region left (top + 1) 1 (height - 2)) $

84− V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)

87+ V.charFill attr (_boxStyle_w style) 1 (height - 2)

8588 ]

8689 corners =

8790 [ withinImage (Region left top 1 1) $

88− V.char V.defAttr (_boxStyle_nw style)

91+ V.char attr (_boxStyle_nw style)

8992 , withinImage (Region right top 1 1) $

90− V.char V.defAttr (_boxStyle_ne style)

93+ V.char attr (_boxStyle_ne style)

9194 , withinImage (Region right bottom 1 1) $

92− V.char V.defAttr (_boxStyle_se style)

95+ V.char attr (_boxStyle_se style)

9396 , withinImage (Region left bottom 1 1) $

94− V.char V.defAttr (_boxStyle_sw style)

97+ V.char attr (_boxStyle_sw style)

9598 ]

9699 in sides ++ if width > 1 && height > 1 then corners else []

97100 hPadText :: T.Text -> Char -> Int -> T.Text

@@ -106,7 +109,7 @@ boxTitle boxStyle title child = do

106109 right = mkHalf delta

107110

108111-- | A box without a title

109−box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m)

112+box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)

110113 => Behavior t BoxStyle

111114 -> m a

112115 -> m a

@@ -114,7 +117,7 @@ box boxStyle = boxTitle boxStyle mempty

114117

115118-- | A box whose style is static

116119boxStatic

117− :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m)

120+ :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)

118121 => BoxStyle

119122 -> m a

120123 -> m a

src/Reflex/Vty/Widget/Input.hs+9−7

@@ -34,7 +34,7 @@ instance Reflex t => Default (ButtonConfig t) where

3434

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

3636button

37− :: (Reflex t, Monad m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)

37+ :: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)

3838 => ButtonConfig t

3939 -> m ()

4040 -> m (Event t ())

@@ -52,7 +52,7 @@ button cfg child = do

5252

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

5454textButton

55− :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasImageWriter t m, HasInput t m)

55+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)

5656 => ButtonConfig t

5757 -> Behavior t Text

5858 -> m (Event t ())

@@ -60,7 +60,7 @@ textButton cfg = button cfg . text -- TODO Centering etc.

6060

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

6262textButtonStatic

63− :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasImageWriter t m, HasInput t m)

63+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)

6464 => ButtonConfig t

6565 -> Text

6666 -> m (Event t ())

@@ -70,19 +70,20 @@ textButtonStatic cfg = textButton cfg . pure

7070

7171-- | A clickable link widget

7272link

73− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)

73+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m)

7474 => Behavior t Text

7575 -> m (Event t MouseUp)

7676link t = do

77+ bt <- theme

7778 let cfg = RichTextConfig

78− { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline

79+ { _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt

7980 }

8081 richText cfg t

8182 mouseUp

8283

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

8485linkStatic

85− :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m)

86+ :: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)

8687 => Text

8788 -> m (Event t MouseUp)

8889linkStatic = link . pure

@@ -115,6 +116,7 @@ checkboxStyleTick = CheckboxStyle

115116-- | Configuration options for a checkbox

116117data CheckboxConfig t = CheckboxConfig

117118 { _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle

119+ -- TODO DELETE and use HasTheme instead

118120 , _checkboxConfig_attributes :: Behavior t V.Attr

119121 , _checkboxConfig_setValue :: Event t Bool

120122 }

@@ -128,7 +130,7 @@ instance (Reflex t) => Default (CheckboxConfig t) where

128130

129131-- | A checkbox widget

130132checkbox

131− :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m)

133+ :: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)

132134 => CheckboxConfig t

133135 -> Bool

134136 -> m (Dynamic t Bool)

src/Reflex/Vty/Widget/Input/Text.hs+15−10

@@ -43,7 +43,7 @@ data TextInput t = TextInput

4343

4444-- | A widget that allows text input

4545textInput

46− :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)

46+ :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)

4747 => TextInputConfig t

4848 -> m (TextInput t)

4949textInput cfg = do

@@ -51,6 +51,8 @@ textInput cfg = do

5151 f <- focus

5252 dh <- displayHeight

5353 dw <- displayWidth

54+ bt <- theme

55+ attr0 <- sample bt

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

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

5658 , _textInputConfig_modify cfg

@@ -59,11 +61,18 @@ textInput cfg = do

5961 goToDisplayLinePosition mx (st + my) dl

6062 ]

6163 click <- mouseDown V.BLeft

62− let cursorAttrs = ffor f $ \x -> if x then cursorAttributes else V.defAttr

63− let rows = (\w s c -> displayLines w V.defAttr c s)

64+

65+ -- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)

66+ let toCursorAttrs attr = V.withStyle attr V.reverseVideo

67+ rowInputDyn = (,,)

6468 <$> dw

6569 <*> (mapZipper <$> _textInputConfig_display cfg <*> v)

66− <*> cursorAttrs

70+ <*> f

71+ toDisplayLines attr (w, s, x) =

72+ let c = if x then toCursorAttrs attr else attr

73+ in displayLines w attr c s

74+ attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)

75+ let rows = ffor2 attrDyn rowInputDyn toDisplayLines

6776 img = images . _displayLines_spans <$> rows

6877 y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows

6978 let newScrollTop :: Int -> (Int, Int) -> Int

@@ -81,7 +90,7 @@ textInput cfg = do

8190

8291-- | A widget that allows multiline text input

8392multilineTextInput

84− :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m)

93+ :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)

8594 => TextInputConfig t

8695 -> m (TextInput t)

8796multilineTextInput cfg = do

@@ -99,7 +108,7 @@ multilineTextInput cfg = do

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

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

101110textInputTile

102− :: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)

111+ :: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)

103112 => m (TextInput t)

104113 -> Dynamic t Int

105114 -> m (TextInput t)

@@ -111,10 +120,6 @@ textInputTile txt width = do

111120 Orientation_Row -> width

112121 return t

113122

114−-- | Default attributes for the text cursor

115−cursorAttributes :: V.Attr

116−cursorAttributes = V.withStyle V.defAttr V.reverseVideo

117−

118123-- | Turn a set of display line rows into a list of images (one per line)

119124images :: [[Span V.Attr]] -> [V.Image]

120125images = map (V.horizCat . map spanToImage)

src/Reflex/Vty/Widget/Layout.hs+4

@@ -133,6 +133,8 @@ instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where

133133

134134instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)

135135

136+instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)

137+

136138instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where

137139 makeFocus = do

138140 fid <- FocusId <$> lift getNextNodeId

@@ -430,6 +432,8 @@ instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWrite

430432

431433instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)

432434

435+instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)

436+

433437instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where

434438 axis o c (Layout x) = Layout $ do

435439 nodeId <- getNextNodeId

src/Reflex/Vty/Widget/Text.hs+17−10

@@ -14,13 +14,15 @@ import Reflex.Vty.Widget

1414import Reflex.Vty.Widget.Input.Mouse

1515

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

17−fill :: (HasDisplayRegion t m, HasImageWriter t m) => Behavior t Char -> m ()

17+fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()

1818fill bc = do

1919 dw <- displayWidth

2020 dh <- displayHeight

21+ bt <- theme

2122 let fillImg =

22− (\w h c -> [V.charFill V.defAttr c w h])

23− <$> current dw

23+ (\attr w h c -> [V.charFill attr c w h])

24+ <$> bt

25+ <*> current dw

2426 <*> current dh

2527 <*> bc

2628 tellImages fillImg

@@ -33,9 +35,11 @@ data RichTextConfig t = RichTextConfig

3335instance Reflex t => Default (RichTextConfig t) where

3436 def = RichTextConfig $ pure V.defAttr

3537

38+

39+-- TODO delete this and use new local theming

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

3741richText

38− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)

42+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)

3943 => RichTextConfig t

4044 -> Behavior t Text

4145 -> m ()

@@ -53,15 +57,17 @@ richText cfg t = do

5357

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

5559text

56− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)

60+ :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)

5761 => Behavior t Text

5862 -> m ()

59−text = richText def

63+text t = do

64+ bt <- theme

65+ richText (RichTextConfig bt) t

6066

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

6268-- that are hidden)

6369scrollableText

64− :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m)

70+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)

6571 => Event t Int

6672 -- ^ Number of lines to scroll by

6773 -> Behavior t Text

@@ -69,7 +75,8 @@ scrollableText

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

7076scrollableText scrollBy t = do

7177 dw <- displayWidth

72− let imgs = wrap <$> current dw <*> t

78+ bt <- theme

79+ let imgs = wrap <$> bt <*> current dw <*> t

7380 kup <- key V.KUp

7481 kdown <- key V.KDown

7582 m <- mouseScroll

@@ -88,12 +95,12 @@ scrollableText scrollBy t = do

8895 tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs

8996 return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)

9097 where

91− wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')

98+ wrap attr maxWidth = concatMap (fmap (V.string attr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')

9299

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

94101-- 'String' as text

95102display

96− :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m)

103+ :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)

97104 => Behavior t a

98105 -> m ()

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

test/Data/Text/ZipperSpec.hs+83−64

@@ -9,77 +9,96 @@ import Prelude

99import Test.Hspec

1010

1111import qualified Data.Map as Map

12−import Data.Text

12+import qualified Data.Text as T

13+import Control.Monad

1314

1415import Data.Text.Zipper

1516

1617

1718someSentence = "12345 1234 12"

1819

19−splitSentenceAtDisplayWidth :: Int -> Text -> [(Text, Bool)]

20+splitSentenceAtDisplayWidth :: Int -> T.Text -> [(T.Text, Bool)]

2021splitSentenceAtDisplayWidth w t = splitWordsAtDisplayWidth w (wordsWithWhitespace t)

2122

2223spec :: Spec

23−spec = do

24+spec =

2425 describe "Zipper" $ do

25− it "wordsWithWhitespace" $ do

26− wordsWithWhitespace "" `shouldBe` []

27− wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]

28− wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"]

29− wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "]

30− it "splitWordsAtDisplayWidth" $ do

31− fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"]

32− fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"]

33− fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"]

34− fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"]

35− fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 "," 56"]

36− fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4","5 6 7 8", "9 1"]

37− it "wrapWithOffsetAndAlignment" $ do

38− wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]

39− wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]

40− wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]

41− it "eolSpacesToLogicalLines" $ do

42− eolSpacesToLogicalLines

43− [

44− [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]

45− , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]

46− ]

47− `shouldBe`

48− [

49− [ ("😱",1) ]

50− , [ ("😱",2), ("😱",3) ]

51− , [ ("aa",1) ]

52− , [ ("aa",2) ]

53− , [ ("aa",3) ]

54− ]

55− it "offsetMapWithAlignmentInternal" $ do

56− offsetMapWithAlignmentInternal

57− [

58− [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]

59− , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]

60− ]

61− `shouldBe`

62− Map.fromList

63− [ (0, (1,0))

64− , (1, (2,2)) -- jump by 1 for char and 1 for space

65− , (2, (3,3)) -- jump by 1 for char

66− , (3, (1,5)) -- jump by 1 for char and 1 for newline

67− , (4, (2,8)) -- jump by 2 for char and 1 for space

68− , (5, (3,11)) -- jump by 2 for char and 1 for space

69− ]

70− it "displayLines - cursorPos" $ do

71− let

72− dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")

73− dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu")

74− dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n")

75− dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "0123456789")

76− dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (insertChar 'a' $ fromText "aoeu")

77− dl5 = displayLinesWithAlignment TextAlignment_Right 10 () () (left $ insertChar 'a' $ fromText "aoeu")

78− dl6 = displayLinesWithAlignment TextAlignment_Right 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")

79− _displayLines_cursorPos dl0 `shouldBe` (0,0)

80− _displayLines_cursorPos dl1 `shouldBe` (4,0)

81− _displayLines_cursorPos dl2 `shouldBe` (0,1)

82− _displayLines_cursorPos dl3 `shouldBe` (0,1)

83− _displayLines_cursorPos dl4 `shouldBe` (5,0)

84− _displayLines_cursorPos dl5 `shouldBe` (4,0)

85− _displayLines_cursorPos dl6 `shouldBe` (4,0)

26+ it "wordsWithWhitespace" $ do

27+ wordsWithWhitespace "" `shouldBe` []

28+ wordsWithWhitespace "😱😱😱" `shouldBe` ["😱😱😱"]

29+ wordsWithWhitespace "abcd efgf f" `shouldBe` ["abcd ","efgf ", "f"]

30+ wordsWithWhitespace "aoeu " `shouldBe` ["aoeu "]

31+ it "splitWordsAtDisplayWidth" $ do

32+ fmap fst (splitSentenceAtDisplayWidth 5 "123456") `shouldBe` ["12345","6"]

33+ fmap fst (splitSentenceAtDisplayWidth 5 "12345 6") `shouldBe` ["12345","6"]

34+ fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234","56"]

35+ fmap fst (splitSentenceAtDisplayWidth 5 "12345678912345") `shouldBe` ["12345","67891","2345"]

36+ fmap fst (splitSentenceAtDisplayWidth 5 "1234 56") `shouldBe` ["1234 "," 56"]

37+ fmap fst (splitSentenceAtDisplayWidth 8 "1 2 3 4 5 6 7 8 9 1") `shouldBe` ["1 2 3 4","5 6 7 8", "9 1"]

38+ it "wrapWithOffsetAndAlignment" $ do

39+ wrapWithOffsetAndAlignment TextAlignment_Left 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]

40+ wrapWithOffsetAndAlignment TextAlignment_Right 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 1), (WrappedLine "12" False 3)]

41+ wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)]

42+ wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]

43+

44+ -- leading spaces and offset case

45+ wrapWithOffsetAndAlignment TextAlignment_Left 5 1 (" " <> someSentence) `shouldBe` [(WrappedLine " " True 0), (WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)]

46+ it "eolSpacesToLogicalLines" $ do

47+ eolSpacesToLogicalLines

48+ [

49+ [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]

50+ , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]

51+ ]

52+ `shouldBe`

53+ [

54+ [ ("😱",1) ]

55+ , [ ("😱",2), ("😱",3) ]

56+ , [ ("aa",1) ]

57+ , [ ("aa",2) ]

58+ , [ ("aa",3) ]

59+ ]

60+ it "offsetMapWithAlignmentInternal" $ do

61+ offsetMapWithAlignmentInternal

62+ [

63+ [ (WrappedLine "😱" True 1), (WrappedLine "😱" False 2), (WrappedLine "😱" False 3) ]

64+ , [ (WrappedLine "aa" True 1), (WrappedLine "aa" True 2), (WrappedLine "aa" False 3) ]

65+ ]

66+ `shouldBe`

67+ Map.fromList

68+ [ (0, (1,0))

69+ , (1, (2,2)) -- jump by 1 for char and 1 for space

70+ , (2, (3,3)) -- jump by 1 for char

71+ , (3, (1,5)) -- jump by 1 for char and 1 for newline

72+ , (4, (2,8)) -- jump by 2 for char and 1 for space

73+ , (5, (3,11)) -- jump by 2 for char and 1 for space

74+ ]

75+ it "displayLines - cursorPos" $ do

76+ let

77+ dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")

78+ dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu")

79+ dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n")

80+ dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "0123456789")

81+ dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (insertChar 'a' $ fromText "aoeu")

82+ dl5 = displayLinesWithAlignment TextAlignment_Right 10 () () (left $ insertChar 'a' $ fromText "aoeu")

83+ dl6 = displayLinesWithAlignment TextAlignment_Right 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")

84+ _displayLines_cursorPos dl0 `shouldBe` (0,0)

85+ _displayLines_cursorPos dl1 `shouldBe` (4,0)

86+ _displayLines_cursorPos dl2 `shouldBe` (0,1)

87+ _displayLines_cursorPos dl3 `shouldBe` (0,1)

88+ _displayLines_cursorPos dl4 `shouldBe` (5,0)

89+ _displayLines_cursorPos dl5 `shouldBe` (4,0)

90+ _displayLines_cursorPos dl6 `shouldBe` (4,0)

91+ it "displayLines - offsetMap" $ do

92+ let

93+ dl0 = displayLinesWithAlignment TextAlignment_Left 5 () () (end $ fromText "aoeku")

94+ _displayLines_cursorPos dl0 `shouldBe` (0,1)

95+ Map.size (_displayLines_offsetMap dl0) `shouldBe` 2 -- cursor character is on second line

96+ it "displayLinesWithAlignment - spans" $ do

97+ let

98+ someText = top $ fromText "0123456789abcdefgh"

99+ -- outer span length should be invariant when changing TextAlignment and CursorPosition

100+ forM_ [0..4] $ \x -> do

101+ forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do

102+ let t = rightN x $ someText

103+ length (_displayLines_spans $ (displayLinesWithAlignment ta 5 () () t)) `shouldBe` 4

104+ length (_displayLines_spans $ (displayLinesWithAlignment ta 10 () () t)) `shouldBe` 2