mirror of
https://github.com/ilyakooo0/reflex-vty.git
synced 2024-11-22 10:53:32 +03:00
Merge branch 'develop' into TextAlignConsolidate
This commit is contained in:
Ali Abrar
commit
5b9f91df43
112
.travis.yml
112
.travis.yml
@ -1,112 +0,0 @@
|
||||
# This Travis job script has been generated by a script via
|
||||
#
|
||||
# haskell-ci 'reflex-vty.cabal' '--output' '.travis.yml'
|
||||
#
|
||||
# For more information, see https://github.com/haskell-CI/haskell-ci
|
||||
#
|
||||
# version: 0.3
|
||||
#
|
||||
language: c
|
||||
dist: xenial
|
||||
|
||||
git:
|
||||
submodules: false # whether to recursively clone submodules
|
||||
|
||||
cache:
|
||||
directories:
|
||||
- $HOME/.cabal/packages
|
||||
- $HOME/.cabal/store
|
||||
|
||||
before_cache:
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
|
||||
# remove files that are regenerated by 'cabal update'
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
|
||||
|
||||
- rm -rfv $CABALHOME/packages/head.hackage
|
||||
|
||||
matrix:
|
||||
include:
|
||||
- compiler: "ghc-8.8.3"
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.8.3], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-8.6.5"
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-8.4.4"
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}
|
||||
|
||||
|
||||
before_install:
|
||||
- HC=/opt/ghc/bin/${CC}
|
||||
- HCPKG=${HC/ghc/ghc-pkg}
|
||||
- unset CC
|
||||
- CABAL=/opt/ghc/bin/cabal
|
||||
- CABALHOME=$HOME/.cabal
|
||||
- export PATH="$CABALHOME/bin:$PATH"
|
||||
- ROOTDIR=$(pwd)
|
||||
- HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
|
||||
- echo $HCNUMVER
|
||||
|
||||
install:
|
||||
- ${CABAL} --version
|
||||
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
||||
- TEST=--enable-tests
|
||||
- BENCH=--enable-benchmarks
|
||||
- GHCHEAD=${GHCHEAD-false}
|
||||
- travis_retry ${CABAL} update -v
|
||||
- sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config
|
||||
- rm -fv cabal.project cabal.project.local
|
||||
- grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'
|
||||
- rm -f cabal.project
|
||||
- touch cabal.project
|
||||
- "printf 'packages: \".\"\\n' >> cabal.project"
|
||||
- "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
|
||||
- touch cabal.project.local
|
||||
- "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"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
|
||||
- rm -f cabal.project.freeze
|
||||
- ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry
|
||||
- "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
|
||||
- rm "cabal.project.freeze"
|
||||
- ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
|
||||
- ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
|
||||
- rm -rf .ghc.environment.* "."/dist
|
||||
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
||||
|
||||
# Here starts the actual work to be performed for the package under test;
|
||||
# any command which exits with a non-zero exit code causes the build to fail.
|
||||
script:
|
||||
# test that source-distributions can be generated
|
||||
- ${CABAL} new-sdist all
|
||||
- mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
|
||||
- cd ${DISTDIR} || false
|
||||
- find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
|
||||
- rm -f cabal.project
|
||||
- touch cabal.project
|
||||
- "printf 'packages: \"reflex-vty-*/*.cabal\"\\n' >> cabal.project"
|
||||
- "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
|
||||
- touch cabal.project.local
|
||||
- "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"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
# this builds all libraries and executables (without tests/benchmarks)
|
||||
- ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all
|
||||
|
||||
# build & run tests, build benchmarks
|
||||
- ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all
|
||||
|
||||
# cabal check
|
||||
- (cd reflex-vty-* && ${CABAL} check)
|
||||
|
||||
# haddock
|
||||
- ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all
|
||||
|
||||
# Build without installed constraints for packages in global-db
|
||||
- rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all
|
||||
|
||||
# REGENDATA ["reflex-vty.cabal","--output",".travis.yml"]
|
||||
# EOF
|
||||
30
ChangeLog.md
30
ChangeLog.md
@ -33,6 +33,8 @@
|
||||
* Introduce a `FocusReader` monad transformer
|
||||
* Replace `HasVtyInput` with `HasInput`
|
||||
* Introduce an `Input` monad transformer
|
||||
* Introduce `HasTheme` reader class to allow setting Vty attributes of all built-in widgets
|
||||
* Introduce `ThemeReader` monad transformer
|
||||
* Remove `DynRegion` and `currentRegion`. Use `Dynamic t Region` and `current` instead. This also changes the type of `pane`'s argument.
|
||||
* `CheckboxConfig` now has a field taking an `Event` to set the value of the checkbox.
|
||||
* `checkbox` now accepts keyboard input (spacebar to check and uncheck) and is displayed in bold when focused.
|
||||
@ -54,24 +56,24 @@
|
||||
* `splitH`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
|
||||
* `splitVDrag`: Now requires `HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m`
|
||||
* `fill`: Now requires `HasImageWriter` and `HasDisplayRegion`
|
||||
* `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m`
|
||||
* `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m`
|
||||
* `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m`
|
||||
* `boxTitle`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
|
||||
* `box`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
|
||||
* `boxStatic`: Now requires `HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m`
|
||||
* `richText`: Now requires `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `scrollableText`: Now requires `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `scrollableText`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `blank`: Now requires `Monad`
|
||||
* `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `link`: Now requires `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `button`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `textButton`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `textButtonStatic`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `link`: Now requires `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `checkbox`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, and `HasDisplayRegion`
|
||||
* `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, and `HasFocus`
|
||||
* TextZipper interface changes
|
||||
* `_displayLines_offsetMap` type changed to `OffsetMapWithAlignment`
|
||||
* `_displayLines_cursorY` replaced with `_displayLines_cursorPos` which include X position
|
||||
* some exposed methods intended for internal use only have been removed
|
||||
* `textInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `multilineTextInput`: Now requires `HasFocusReader`, `HasInput`, `HasImageWriter`, `HasTheme`, and `HasDisplayRegion`
|
||||
* `textInputTile`: Now requires `HasFocusReader`, `HasInput`, `HasLayout`, `HasTheme`, and `HasFocus`
|
||||
* _Misc_:
|
||||
* (#40 Add alignment support to TextZipper)[https://github.com/reflex-frp/reflex-vty/pull/40]
|
||||
* Add alignment (left/center/right) support to TextZipper
|
||||
@ -84,6 +86,12 @@
|
||||
* Add various `MFunctor` instances
|
||||
* Add a CPU usage indicator to the example executable
|
||||
|
||||
## 0.1.4.2
|
||||
|
||||
* Wider bounds for GHC 8.10 support
|
||||
|
||||
## 0.1.4.1
|
||||
|
||||
## 0.1.4.1
|
||||
* Migrate to new dependent-sum / dependent-map (after the "some" package split)
|
||||
|
||||
|
||||
@ -12,7 +12,7 @@ maintainer: maintainer@obsidian.systems
|
||||
copyright: 2020 Obsidian Systems LLC
|
||||
category: FRP
|
||||
build-type: Simple
|
||||
cabal-version: >=1.18
|
||||
cabal-version: 1.18
|
||||
extra-source-files:
|
||||
README.md
|
||||
ChangeLog.md
|
||||
|
||||
@ -100,7 +100,7 @@ cpuStats
|
||||
, HasLayout t m
|
||||
, HasFocus t m
|
||||
, HasInput t m
|
||||
, HasFocusReader t m
|
||||
, HasFocusReader t m, HasTheme t m
|
||||
)
|
||||
=> m ()
|
||||
cpuStats = do
|
||||
@ -122,7 +122,7 @@ chart
|
||||
, HasImageWriter t m
|
||||
, HasInput t m
|
||||
, HasDisplayRegion t m
|
||||
, HasFocusReader t m
|
||||
, HasFocusReader t m, HasTheme t m
|
||||
)
|
||||
=> Dynamic t (Ratio Word64) -> m ()
|
||||
chart pct = do
|
||||
|
||||
@ -23,7 +23,7 @@ type VtyExample t m =
|
||||
, HasImageWriter t m
|
||||
, HasDisplayRegion t m
|
||||
, HasFocus t m
|
||||
, HasFocusReader t m
|
||||
, HasFocusReader t m, HasTheme t m
|
||||
)
|
||||
|
||||
type Manager t m =
|
||||
@ -46,6 +46,14 @@ withCtrlC f = do
|
||||
V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
|
||||
_ -> Nothing
|
||||
|
||||
darkTheme :: V.Attr
|
||||
darkTheme = V.Attr {
|
||||
V.attrStyle = V.SetTo V.standout
|
||||
, V.attrForeColor = V.SetTo V.black
|
||||
, V.attrBackColor = V.Default
|
||||
, V.attrURL = V.Default
|
||||
}
|
||||
|
||||
main :: IO ()
|
||||
main = mainWidget $ withCtrlC $ do
|
||||
initManager_ $ do
|
||||
@ -77,7 +85,7 @@ main = mainWidget $ withCtrlC $ do
|
||||
_ -> Nothing
|
||||
rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
|
||||
Left Example_Todo -> escapable taskList
|
||||
Left Example_TextEditor -> escapable testBoxes
|
||||
Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
|
||||
Left Example_ScrollableTextDisplay -> escapable scrolling
|
||||
Left Example_ClickButtonsGetEmojis -> escapable easyExample
|
||||
Left Example_CPUStat -> escapable cpuStats
|
||||
|
||||
@ -35,6 +35,7 @@ mainWidgetWithHandle
|
||||
, HasDisplayRegion t m
|
||||
, HasFocusReader t m
|
||||
, HasInput t m
|
||||
, HasTheme t m
|
||||
) => m (Event t ()))
|
||||
-> IO ()
|
||||
mainWidgetWithHandle vty child =
|
||||
@ -45,12 +46,14 @@ mainWidgetWithHandle vty child =
|
||||
let inp' = fforMaybe inp $ \case
|
||||
V.EvResize {} -> Nothing
|
||||
x -> Just x
|
||||
(shutdown, images) <- runFocusReader (pure True) $ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
|
||||
runImageWriter $
|
||||
runNodeIdT $
|
||||
runInput inp' $ do
|
||||
tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
|
||||
child
|
||||
(shutdown, images) <- runThemeReader (constant V.defAttr) $
|
||||
runFocusReader (pure True) $
|
||||
runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
|
||||
runImageWriter $
|
||||
runNodeIdT $
|
||||
runInput inp' $ do
|
||||
tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
|
||||
child
|
||||
return $ VtyResult
|
||||
{ _vtyResult_picture = fmap (V.picForLayers . reverse) images
|
||||
, _vtyResult_shutdown = shutdown
|
||||
@ -69,6 +72,7 @@ mainWidget
|
||||
, MonadNodeId m
|
||||
, HasDisplayRegion t m
|
||||
, HasFocusReader t m
|
||||
, HasTheme t m
|
||||
, HasInput t m
|
||||
) => m (Event t ()))
|
||||
-> IO ()
|
||||
@ -233,9 +237,9 @@ regionSize :: Region -> (Int, Int)
|
||||
regionSize (Region _ _ w h) = (w, h)
|
||||
|
||||
-- | Produces an 'Image' that fills a region with space characters
|
||||
regionBlankImage :: Region -> Image
|
||||
regionBlankImage r@(Region _ _ width height) =
|
||||
withinImage r $ V.charFill V.defAttr ' ' width height
|
||||
regionBlankImage :: V.Attr -> Region -> Image
|
||||
regionBlankImage attr r@(Region _ _ width height) =
|
||||
withinImage r $ V.charFill attr ' ' width height
|
||||
|
||||
-- | A class for things that know their own display size dimensions
|
||||
class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
|
||||
@ -441,6 +445,75 @@ runImageWriter
|
||||
-> m (a, Behavior t [Image])
|
||||
runImageWriter = runBehaviorWriterT . unImageWriter
|
||||
|
||||
-- * Theming
|
||||
|
||||
-- | A class for things that can be visually styled
|
||||
class (Reflex t, Monad m) => HasTheme t m | m -> t where
|
||||
theme :: m (Behavior t V.Attr)
|
||||
default theme :: (f m' ~ m, Monad m', MonadTrans f, HasTheme t m') => m (Behavior t V.Attr)
|
||||
theme = lift theme
|
||||
localTheme :: (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
|
||||
default localTheme :: (f m' ~ m, Monad m', MFunctor f, HasTheme t m') => (Behavior t V.Attr -> Behavior t V.Attr) -> m a -> m a
|
||||
localTheme f = hoist (localTheme f)
|
||||
|
||||
instance HasTheme t m => HasTheme t (ReaderT x m)
|
||||
instance HasTheme t m => HasTheme t (BehaviorWriterT t x m)
|
||||
instance HasTheme t m => HasTheme t (DynamicWriterT t x m)
|
||||
instance HasTheme t m => HasTheme t (EventWriterT t x m)
|
||||
instance HasTheme t m => HasTheme t (NodeIdT m)
|
||||
instance HasTheme t m => HasTheme t (Input t m)
|
||||
instance HasTheme t m => HasTheme t (ImageWriter t m)
|
||||
instance HasTheme t m => HasTheme t (DisplayRegion t m)
|
||||
instance HasTheme t m => HasTheme t (FocusReader t m)
|
||||
|
||||
-- | A widget that has access to theme information
|
||||
newtype ThemeReader t m a = ThemeReader
|
||||
{ unThemeReader :: ReaderT (Behavior t V.Attr) m a }
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadFix
|
||||
, MonadHold t
|
||||
, MonadIO
|
||||
, MonadRef
|
||||
, MonadSample t
|
||||
)
|
||||
|
||||
instance (Monad m, Reflex t) => HasTheme t (ThemeReader t m) where
|
||||
theme = ThemeReader ask
|
||||
localTheme f = ThemeReader . local f . unThemeReader
|
||||
|
||||
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ThemeReader t m)
|
||||
deriving instance NotReady t m => NotReady t (ThemeReader t m)
|
||||
deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)
|
||||
deriving instance PostBuild t m => PostBuild t (ThemeReader t m)
|
||||
deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)
|
||||
instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)
|
||||
|
||||
instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where
|
||||
runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e
|
||||
traverseIntMapWithKeyWithAdjust f m e = ThemeReader $ traverseIntMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
|
||||
traverseDMapWithKeyWithAdjust f m e = ThemeReader $ traverseDMapWithKeyWithAdjust (\k v -> unThemeReader $ f k v) m e
|
||||
traverseDMapWithKeyWithAdjustWithMove f m e = ThemeReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unThemeReader $ f k v) m e
|
||||
|
||||
instance MonadTrans (ThemeReader t) where
|
||||
lift = ThemeReader . lift
|
||||
|
||||
instance MFunctor (ThemeReader t) where
|
||||
hoist f = ThemeReader . hoist f . unThemeReader
|
||||
|
||||
instance MonadNodeId m => MonadNodeId (ThemeReader t m)
|
||||
|
||||
-- | Run a 'ThemeReader' action with the given focus value
|
||||
runThemeReader
|
||||
:: (Reflex t, Monad m)
|
||||
=> Behavior t V.Attr
|
||||
-> ThemeReader t m a
|
||||
-> m a
|
||||
runThemeReader b = flip runReaderT b . unThemeReader
|
||||
|
||||
|
||||
-- ** Manipulating images
|
||||
|
||||
-- | Translates and crops an 'Image' so that it is contained by
|
||||
|
||||
@ -13,7 +13,7 @@ import Reflex.Vty.Widget
|
||||
import Reflex.Vty.Widget.Text
|
||||
|
||||
-- | Fill the background with the bottom box style
|
||||
hRule :: (HasDisplayRegion t m, HasImageWriter t m) => BoxStyle -> m ()
|
||||
hRule :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => BoxStyle -> m ()
|
||||
hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)
|
||||
|
||||
-- | Defines a set of symbols to use to draw the outlines of boxes
|
||||
@ -54,7 +54,7 @@ roundedBoxStyle :: BoxStyle
|
||||
roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
|
||||
|
||||
-- | Draws a titled box in the provided style and a child widget inside of that box
|
||||
boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m)
|
||||
boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
|
||||
=> Behavior t BoxStyle
|
||||
-> Behavior t Text
|
||||
-> m a
|
||||
@ -62,36 +62,39 @@ boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInp
|
||||
boxTitle boxStyle title child = do
|
||||
dh <- displayHeight
|
||||
dw <- displayWidth
|
||||
bt <- theme
|
||||
let boxReg = Region 0 0 <$> dw <*> dh
|
||||
innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)
|
||||
tellImages (boxImages <$> title <*> boxStyle <*> current boxReg)
|
||||
tellImages (fmap (\r -> [regionBlankImage r]) (current innerReg))
|
||||
|
||||
tellImages (boxImages <$> bt <*> title <*> boxStyle <*> current boxReg)
|
||||
tellImages (ffor2 (current innerReg) bt (\r attr -> [regionBlankImage attr r]))
|
||||
|
||||
pane innerReg (pure True) child
|
||||
where
|
||||
boxImages :: Text -> BoxStyle -> Region -> [Image]
|
||||
boxImages title' style (Region left top width height) =
|
||||
boxImages :: V.Attr -> Text -> BoxStyle -> Region -> [Image]
|
||||
boxImages attr title' style (Region left top width height) =
|
||||
let right = left + width - 1
|
||||
bottom = top + height - 1
|
||||
sides =
|
||||
[ withinImage (Region (left + 1) top (width - 2) 1) $
|
||||
V.text' V.defAttr $
|
||||
V.text' attr $
|
||||
hPadText title' (_boxStyle_n style) (width - 2)
|
||||
, withinImage (Region right (top + 1) 1 (height - 2)) $
|
||||
V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)
|
||||
V.charFill attr (_boxStyle_e style) 1 (height - 2)
|
||||
, withinImage (Region (left + 1) bottom (width - 2) 1) $
|
||||
V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1
|
||||
V.charFill attr (_boxStyle_s style) (width - 2) 1
|
||||
, withinImage (Region left (top + 1) 1 (height - 2)) $
|
||||
V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)
|
||||
V.charFill attr (_boxStyle_w style) 1 (height - 2)
|
||||
]
|
||||
corners =
|
||||
[ withinImage (Region left top 1 1) $
|
||||
V.char V.defAttr (_boxStyle_nw style)
|
||||
V.char attr (_boxStyle_nw style)
|
||||
, withinImage (Region right top 1 1) $
|
||||
V.char V.defAttr (_boxStyle_ne style)
|
||||
V.char attr (_boxStyle_ne style)
|
||||
, withinImage (Region right bottom 1 1) $
|
||||
V.char V.defAttr (_boxStyle_se style)
|
||||
V.char attr (_boxStyle_se style)
|
||||
, withinImage (Region left bottom 1 1) $
|
||||
V.char V.defAttr (_boxStyle_sw style)
|
||||
V.char attr (_boxStyle_sw style)
|
||||
]
|
||||
in sides ++ if width > 1 && height > 1 then corners else []
|
||||
hPadText :: T.Text -> Char -> Int -> T.Text
|
||||
@ -106,7 +109,7 @@ boxTitle boxStyle title child = do
|
||||
right = mkHalf delta
|
||||
|
||||
-- | A box without a title
|
||||
box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m)
|
||||
box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
|
||||
=> Behavior t BoxStyle
|
||||
-> m a
|
||||
-> m a
|
||||
@ -114,7 +117,7 @@ box boxStyle = boxTitle boxStyle mempty
|
||||
|
||||
-- | A box whose style is static
|
||||
boxStatic
|
||||
:: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m)
|
||||
:: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
|
||||
=> BoxStyle
|
||||
-> m a
|
||||
-> m a
|
||||
|
||||
@ -34,7 +34,7 @@ instance Reflex t => Default (ButtonConfig t) where
|
||||
|
||||
-- | A button widget that contains a sub-widget
|
||||
button
|
||||
:: (Reflex t, Monad m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
|
||||
:: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
|
||||
=> ButtonConfig t
|
||||
-> m ()
|
||||
-> m (Event t ())
|
||||
@ -52,7 +52,7 @@ button cfg child = do
|
||||
|
||||
-- | A button widget that displays text that can change
|
||||
textButton
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasImageWriter t m, HasInput t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
|
||||
=> ButtonConfig t
|
||||
-> Behavior t Text
|
||||
-> m (Event t ())
|
||||
@ -60,7 +60,7 @@ textButton cfg = button cfg . text -- TODO Centering etc.
|
||||
|
||||
-- | A button widget that displays a static bit of text
|
||||
textButtonStatic
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasImageWriter t m, HasInput t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
|
||||
=> ButtonConfig t
|
||||
-> Text
|
||||
-> m (Event t ())
|
||||
@ -70,19 +70,20 @@ textButtonStatic cfg = textButton cfg . pure
|
||||
|
||||
-- | A clickable link widget
|
||||
link
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m)
|
||||
=> Behavior t Text
|
||||
-> m (Event t MouseUp)
|
||||
link t = do
|
||||
bt <- theme
|
||||
let cfg = RichTextConfig
|
||||
{ _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline
|
||||
{ _richTextConfig_attributes = fmap (\attr -> V.withStyle attr V.underline) bt
|
||||
}
|
||||
richText cfg t
|
||||
mouseUp
|
||||
|
||||
-- | A clickable link widget with a static label
|
||||
linkStatic
|
||||
:: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m)
|
||||
:: (Reflex t, Monad m, HasImageWriter t m, HasDisplayRegion t m, HasInput t m, HasTheme t m)
|
||||
=> Text
|
||||
-> m (Event t MouseUp)
|
||||
linkStatic = link . pure
|
||||
@ -115,6 +116,7 @@ checkboxStyleTick = CheckboxStyle
|
||||
-- | Configuration options for a checkbox
|
||||
data CheckboxConfig t = CheckboxConfig
|
||||
{ _checkboxConfig_checkboxStyle :: Behavior t CheckboxStyle
|
||||
-- TODO DELETE and use HasTheme instead
|
||||
, _checkboxConfig_attributes :: Behavior t V.Attr
|
||||
, _checkboxConfig_setValue :: Event t Bool
|
||||
}
|
||||
@ -128,7 +130,7 @@ instance (Reflex t) => Default (CheckboxConfig t) where
|
||||
|
||||
-- | A checkbox widget
|
||||
checkbox
|
||||
:: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m)
|
||||
:: (MonadHold t m, MonadFix m, Reflex t, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasFocusReader t m, HasTheme t m)
|
||||
=> CheckboxConfig t
|
||||
-> Bool
|
||||
-> m (Dynamic t Bool)
|
||||
|
||||
@ -43,7 +43,7 @@ data TextInput t = TextInput
|
||||
|
||||
-- | A widget that allows text input
|
||||
textInput
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasDisplayRegion t m)
|
||||
:: (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)
|
||||
=> TextInputConfig t
|
||||
-> m (TextInput t)
|
||||
textInput cfg = do
|
||||
@ -51,6 +51,8 @@ textInput cfg = do
|
||||
f <- focus
|
||||
dh <- displayHeight
|
||||
dw <- displayWidth
|
||||
bt <- theme
|
||||
attr0 <- sample bt
|
||||
rec v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
|
||||
[ uncurry (updateTextZipper (_textInputConfig_tabWidth cfg)) <$> attach (current dh) i
|
||||
, _textInputConfig_modify cfg
|
||||
@ -59,11 +61,18 @@ textInput cfg = do
|
||||
goToDisplayLinePosition mx (st + my) dl
|
||||
]
|
||||
click <- mouseDown V.BLeft
|
||||
let cursorAttrs = ffor f $ \x -> if x then cursorAttributes else V.defAttr
|
||||
let rows = (\w s c -> displayLines w V.defAttr c s)
|
||||
|
||||
-- TODO reverseVideo is prob not what we want. Does not work with `darkTheme` in example.hs (cursor is dark rather than light bg)
|
||||
let toCursorAttrs attr = V.withStyle attr V.reverseVideo
|
||||
rowInputDyn = (,,)
|
||||
<$> dw
|
||||
<*> (mapZipper <$> _textInputConfig_display cfg <*> v)
|
||||
<*> cursorAttrs
|
||||
<*> f
|
||||
toDisplayLines attr (w, s, x) =
|
||||
let c = if x then toCursorAttrs attr else attr
|
||||
in displayLines w attr c s
|
||||
attrDyn <- holdDyn attr0 $ pushAlways (\_ -> sample bt) (updated rowInputDyn)
|
||||
let rows = ffor2 attrDyn rowInputDyn toDisplayLines
|
||||
img = images . _displayLines_spans <$> rows
|
||||
y <- holdUniqDyn $ fmap snd _displayLines_cursorPos <$> rows
|
||||
let newScrollTop :: Int -> (Int, Int) -> Int
|
||||
@ -81,7 +90,7 @@ textInput cfg = do
|
||||
|
||||
-- | A widget that allows multiline text input
|
||||
multilineTextInput
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
:: (Reflex t, MonadHold t m, MonadFix m, HasInput t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
=> TextInputConfig t
|
||||
-> m (TextInput t)
|
||||
multilineTextInput cfg = do
|
||||
@ -99,7 +108,7 @@ multilineTextInput cfg = do
|
||||
-- the computed line count to greedily size the tile when vertically
|
||||
-- oriented, and uses the fallback width when horizontally oriented.
|
||||
textInputTile
|
||||
:: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
|
||||
:: (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)
|
||||
=> m (TextInput t)
|
||||
-> Dynamic t Int
|
||||
-> m (TextInput t)
|
||||
@ -111,10 +120,6 @@ textInputTile txt width = do
|
||||
Orientation_Row -> width
|
||||
return t
|
||||
|
||||
-- | Default attributes for the text cursor
|
||||
cursorAttributes :: V.Attr
|
||||
cursorAttributes = V.withStyle V.defAttr V.reverseVideo
|
||||
|
||||
-- | Turn a set of display line rows into a list of images (one per line)
|
||||
images :: [[Span V.Attr]] -> [V.Image]
|
||||
images = map (V.horizCat . map spanToImage)
|
||||
|
||||
@ -133,6 +133,8 @@ instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
|
||||
|
||||
instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
|
||||
|
||||
instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)
|
||||
|
||||
instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where
|
||||
makeFocus = do
|
||||
fid <- FocusId <$> lift getNextNodeId
|
||||
@ -430,6 +432,8 @@ instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWrite
|
||||
|
||||
instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)
|
||||
|
||||
instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)
|
||||
|
||||
instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where
|
||||
axis o c (Layout x) = Layout $ do
|
||||
nodeId <- getNextNodeId
|
||||
|
||||
@ -14,13 +14,15 @@ import Reflex.Vty.Widget
|
||||
import Reflex.Vty.Widget.Input.Mouse
|
||||
|
||||
-- | Fill the background with a particular character.
|
||||
fill :: (HasDisplayRegion t m, HasImageWriter t m) => Behavior t Char -> m ()
|
||||
fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()
|
||||
fill bc = do
|
||||
dw <- displayWidth
|
||||
dh <- displayHeight
|
||||
bt <- theme
|
||||
let fillImg =
|
||||
(\w h c -> [V.charFill V.defAttr c w h])
|
||||
<$> current dw
|
||||
(\attr w h c -> [V.charFill attr c w h])
|
||||
<$> bt
|
||||
<*> current dw
|
||||
<*> current dh
|
||||
<*> bc
|
||||
tellImages fillImg
|
||||
@ -33,9 +35,11 @@ data RichTextConfig t = RichTextConfig
|
||||
instance Reflex t => Default (RichTextConfig t) where
|
||||
def = RichTextConfig $ pure V.defAttr
|
||||
|
||||
|
||||
-- TODO delete this and use new local theming
|
||||
-- | A widget that displays text with custom time-varying attributes
|
||||
richText
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
|
||||
=> RichTextConfig t
|
||||
-> Behavior t Text
|
||||
-> m ()
|
||||
@ -53,15 +57,17 @@ richText cfg t = do
|
||||
|
||||
-- | Renders text, wrapped to the container width
|
||||
text
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
|
||||
:: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
|
||||
=> Behavior t Text
|
||||
-> m ()
|
||||
text = richText def
|
||||
text t = do
|
||||
bt <- theme
|
||||
richText (RichTextConfig bt) t
|
||||
|
||||
-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
|
||||
-- that are hidden)
|
||||
scrollableText
|
||||
:: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m)
|
||||
:: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)
|
||||
=> Event t Int
|
||||
-- ^ Number of lines to scroll by
|
||||
-> Behavior t Text
|
||||
@ -69,7 +75,8 @@ scrollableText
|
||||
-- ^ (Current scroll position, total number of lines)
|
||||
scrollableText scrollBy t = do
|
||||
dw <- displayWidth
|
||||
let imgs = wrap <$> current dw <*> t
|
||||
bt <- theme
|
||||
let imgs = wrap <$> bt <*> current dw <*> t
|
||||
kup <- key V.KUp
|
||||
kdown <- key V.KDown
|
||||
m <- mouseScroll
|
||||
@ -88,12 +95,12 @@ scrollableText scrollBy t = do
|
||||
tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
|
||||
return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
|
||||
where
|
||||
wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
|
||||
wrap attr maxWidth = concatMap (fmap (V.string attr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
|
||||
|
||||
-- | Renders any behavior whose value can be converted to
|
||||
-- 'String' as text
|
||||
display
|
||||
:: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m)
|
||||
:: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
|
||||
=> Behavior t a
|
||||
-> m ()
|
||||
display a = text $ T.pack . show <$> a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user