{-|
  Description: Text- and character-rendering widgets
-}
module Reflex.Vty.Widget.Text where

import Control.Monad.Fix
import Data.Default
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Zipper as TZ
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget
import Reflex.Vty.Widget.Input.Mouse

-- | Fill the background with a particular character.
fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()
fill :: forall {k} (t :: k) (m :: * -> *).
(HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) =>
Behavior t Char -> m ()
fill Behavior t Char
bc = do
  Dynamic t Int
dw <- m (Dynamic t Int)
forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
  Dynamic t Int
dh <- m (Dynamic t Int)
forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  Behavior t Attr
bt <- m (Behavior t Attr)
forall {k} (t :: k) (m :: * -> *).
HasTheme t m =>
m (Behavior t Attr)
theme
  let fillImg :: Behavior t [Image]
fillImg =
        (\Attr
attr Int
w Int
h Char
c -> [Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
V.charFill Attr
attr Char
c Int
w Int
h])
        (Attr -> Int -> Int -> Char -> [Image])
-> Behavior t Attr -> Behavior t (Int -> Int -> Char -> [Image])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Attr
bt
        Behavior t (Int -> Int -> Char -> [Image])
-> Behavior t Int -> Behavior t (Int -> Char -> [Image])
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int -> Behavior t Int
forall a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dw
        Behavior t (Int -> Char -> [Image])
-> Behavior t Int -> Behavior t (Char -> [Image])
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int -> Behavior t Int
forall a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dh
        Behavior t (Char -> [Image])
-> Behavior t Char -> Behavior t [Image]
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Char
bc
  Behavior t [Image] -> m ()
forall {k} (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages Behavior t [Image]
fillImg

-- | Configuration options for displaying "rich" text
data RichTextConfig t = RichTextConfig
  { forall {k} (t :: k). RichTextConfig t -> Behavior t Attr
_richTextConfig_attributes :: Behavior t V.Attr
  }

instance Reflex t => Default (RichTextConfig t) where
  def :: RichTextConfig t
def = Behavior t Attr -> RichTextConfig t
forall {k} (t :: k). Behavior t Attr -> RichTextConfig t
RichTextConfig (Behavior t Attr -> RichTextConfig t)
-> Behavior t Attr -> RichTextConfig t
forall a b. (a -> b) -> a -> b
$ Attr -> Behavior t Attr
forall a. a -> Behavior t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
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, HasTheme t m)
  => RichTextConfig t
  -> Behavior t Text
  -> m ()
richText :: forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
RichTextConfig t -> Behavior t Text -> m ()
richText RichTextConfig t
cfg Behavior t Text
t = do
  Dynamic t Int
dw <- m (Dynamic t Int)
forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
  let img :: Behavior t [Image]
img = (\Int
w Attr
a Text
s -> [Int -> Attr -> Text -> Image
wrapText Int
w Attr
a Text
s])
        (Int -> Attr -> Text -> [Image])
-> Behavior t Int -> Behavior t (Attr -> Text -> [Image])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int -> Behavior t Int
forall a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dw
        Behavior t (Attr -> Text -> [Image])
-> Behavior t Attr -> Behavior t (Text -> [Image])
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RichTextConfig t -> Behavior t Attr
forall {k} (t :: k). RichTextConfig t -> Behavior t Attr
_richTextConfig_attributes RichTextConfig t
cfg
        Behavior t (Text -> [Image])
-> Behavior t Text -> Behavior t [Image]
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Text
t
  Behavior t [Image] -> m ()
forall {k} (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages Behavior t [Image]
img
  where
    wrapText :: Int -> Attr -> Text -> Image
wrapText Int
maxWidth Attr
attrs = [Image] -> Image
V.vertCat
      ([Image] -> Image) -> (Text -> [Image]) -> Text -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Image]) -> [Text] -> [Image]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Text -> Image) -> [Text] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attr -> String -> Image
V.string Attr
attrs (String -> Image) -> (Text -> String) -> Text -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> [Image]) -> (Text -> [Text]) -> Text -> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Text -> [Text]
TZ.wrapWithOffset Int
maxWidth Int
0)
      ([Text] -> [Image]) -> (Text -> [Text]) -> Text -> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')

-- | Renders text, wrapped to the container width
text
  :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
  => Behavior t Text
  -> m ()
text :: forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text Behavior t Text
t = do
  Behavior t Attr
bt <- m (Behavior t Attr)
forall {k} (t :: k) (m :: * -> *).
HasTheme t m =>
m (Behavior t Attr)
theme
  RichTextConfig t -> Behavior t Text -> m ()
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
RichTextConfig t -> Behavior t Text -> m ()
richText (Behavior t Attr -> RichTextConfig t
forall {k} (t :: k). Behavior t Attr -> RichTextConfig t
RichTextConfig Behavior t Attr
bt) Behavior t Text
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, HasTheme t m)
  => Event t Int
  -- ^ Number of lines to scroll by
  -> Behavior t Text
  -> m (Behavior t (Int, Int))
  -- ^ (Current scroll position, total number of lines)
scrollableText :: forall {k} (t :: k) (m :: * -> *).
(Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m,
 HasInput t m, HasImageWriter t m, HasTheme t m) =>
Event t Int -> Behavior t Text -> m (Behavior t (Int, Int))
scrollableText Event t Int
scrollBy Behavior t Text
t = do
  Dynamic t Int
dw <- m (Dynamic t Int)
forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth
  Behavior t Attr
bt <- m (Behavior t Attr)
forall {k} (t :: k) (m :: * -> *).
HasTheme t m =>
m (Behavior t Attr)
theme
  let imgs :: Behavior t [Image]
imgs = Attr -> Int -> Text -> [Image]
wrap (Attr -> Int -> Text -> [Image])
-> Behavior t Attr -> Behavior t (Int -> Text -> [Image])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Attr
bt Behavior t (Int -> Text -> [Image])
-> Behavior t Int -> Behavior t (Text -> [Image])
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Int -> Behavior t Int
forall a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
dw Behavior t (Text -> [Image])
-> Behavior t Text -> Behavior t [Image]
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Text
t
  Event t KeyCombo
kup <- Key -> m (Event t KeyCombo)
forall {k} (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KUp
  Event t KeyCombo
kdown <- Key -> m (Event t KeyCombo)
forall {k} (m :: * -> *) (t :: k).
(Monad m, Reflex t, HasInput t m) =>
Key -> m (Event t KeyCombo)
key Key
V.KDown
  Event t ScrollDirection
m <- m (Event t ScrollDirection)
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
m (Event t ScrollDirection)
mouseScroll
  let requestedScroll :: Event t Int
      requestedScroll :: Event t Int
requestedScroll = [Event t Int] -> Event t Int
forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
        [ Int
1 Int -> Event t KeyCombo -> Event t Int
forall a b. a -> Event t b -> Event t a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kdown
        , (-Int
1) Int -> Event t KeyCombo -> Event t Int
forall a b. a -> Event t b -> Event t a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t KeyCombo
kup
        , Event t ScrollDirection -> (ScrollDirection -> Int) -> Event t Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t ScrollDirection
m ((ScrollDirection -> Int) -> Event t Int)
-> (ScrollDirection -> Int) -> Event t Int
forall a b. (a -> b) -> a -> b
$ \case
            ScrollDirection
ScrollDirection_Up -> (-Int
1)
            ScrollDirection
ScrollDirection_Down -> Int
1
        , Event t Int
scrollBy
        ]
      updateLine :: a -> a -> a -> a
updateLine a
maxN a
delta a
ix = a -> a -> a
forall a. Ord a => a -> a -> a
min (a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a
ix a -> a -> a
forall a. Num a => a -> a -> a
+ a
delta)) a
maxN
  Dynamic t Int
lineIndex :: Dynamic t Int <- ((Int, Int) -> Int -> Int)
-> Int -> Event t (Int, Int) -> m (Dynamic t Int)
forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (\(Int
maxN, Int
delta) Int
ix -> Int -> Int -> Int -> Int
forall {a}. (Ord a, Num a) => a -> a -> a -> a
updateLine (Int
maxN Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
delta Int
ix) Int
0 (Event t (Int, Int) -> m (Dynamic t Int))
-> Event t (Int, Int) -> m (Dynamic t Int)
forall a b. (a -> b) -> a -> b
$
    Behavior t Int -> Event t Int -> Event t (Int, Int)
forall {k} (t :: k) a b.
Reflex t =>
Behavior t a -> Event t b -> Event t (a, b)
attach ([Image] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Image] -> Int) -> Behavior t [Image] -> Behavior t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t [Image]
imgs) Event t Int
requestedScroll
  Behavior t [Image] -> m ()
forall {k} (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages (Behavior t [Image] -> m ()) -> Behavior t [Image] -> m ()
forall a b. (a -> b) -> a -> b
$ ([Image] -> [Image]) -> Behavior t [Image] -> Behavior t [Image]
forall a b. (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Image -> [Image] -> [Image]
forall a. a -> [a] -> [a]
:[]) (Image -> [Image]) -> ([Image] -> Image) -> [Image] -> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Image] -> Image
V.vertCat) (Behavior t [Image] -> Behavior t [Image])
-> Behavior t [Image] -> Behavior t [Image]
forall a b. (a -> b) -> a -> b
$ Int -> [Image] -> [Image]
forall a. Int -> [a] -> [a]
drop (Int -> [Image] -> [Image])
-> Behavior t Int -> Behavior t ([Image] -> [Image])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int -> Behavior t Int
forall a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
lineIndex Behavior t ([Image] -> [Image])
-> Behavior t [Image] -> Behavior t [Image]
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t [Image]
imgs
  Behavior t (Int, Int) -> m (Behavior t (Int, Int))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Behavior t (Int, Int) -> m (Behavior t (Int, Int)))
-> Behavior t (Int, Int) -> m (Behavior t (Int, Int))
forall a b. (a -> b) -> a -> b
$ (,) (Int -> Int -> (Int, Int))
-> Behavior t Int -> Behavior t (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> Behavior t Int -> Behavior t (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Int -> Behavior t Int
forall a. Dynamic t a -> Behavior t a
forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Int
lineIndex Behavior t (Int -> Int) -> Behavior t Int -> Behavior t Int
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Behavior t Int
forall a. a -> Behavior t a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1) Behavior t (Int -> (Int, Int))
-> Behavior t Int -> Behavior t (Int, Int)
forall a b. Behavior t (a -> b) -> Behavior t a -> Behavior t b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Image] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Image] -> Int) -> Behavior t [Image] -> Behavior t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t [Image]
imgs)
  where
    wrap :: Attr -> Int -> Text -> [Image]
wrap Attr
attr Int
maxWidth = (Text -> [Image]) -> [Text] -> [Image]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Text -> Image) -> [Text] -> [Image]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attr -> String -> Image
V.string Attr
attr (String -> Image) -> (Text -> String) -> Text -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> [Image]) -> (Text -> [Text]) -> Text -> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Text -> [Text]
TZ.wrapWithOffset Int
maxWidth Int
0) ([Text] -> [Image]) -> (Text -> [Text]) -> Text -> [Image]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\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, HasTheme t m)
  => Behavior t a
  -> m ()
display :: forall {k} (t :: k) (m :: * -> *) a.
(Reflex t, Monad m, Show a, HasDisplayRegion t m,
 HasImageWriter t m, HasTheme t m) =>
Behavior t a -> m ()
display Behavior t a
a = Behavior t Text -> m ()
forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text (Behavior t Text -> m ()) -> Behavior t Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> Text) -> Behavior t a -> Behavior t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t a
a