module Taskell.UI.Draw.Field where

import ClassyPrelude

import qualified Data.List as L (scanl1)
import qualified Data.Text as T (splitAt, takeEnd)

import qualified Brick                     as B (Location (Location), Size (Fixed), Widget (Widget),
                                                 availWidth, getContext, render, showCursor, txt,
                                                 vBox)
import qualified Brick.Widgets.Core        as B (textWidth)
import qualified Graphics.Text.Width       as V (safeWcwidth)
import qualified Graphics.Vty.Input.Events as V (Event (..), Key (..))

import qualified Taskell.UI.Types as UI (ResourceName (RNCursor))

data Field = Field
    { Field -> Text
_text   :: Text
    , Field -> Int
_cursor :: Int
    } deriving (Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c== :: Field -> Field -> Bool
Eq, Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show)

blankField :: Field
blankField :: Field
blankField = Text -> Int -> Field
Field Text
"" Int
0

event :: V.Event -> Field -> Field
event :: Event -> Field -> Field
event (V.EvKey (V.KChar Char
'\t') [Modifier]
_) Field
f = Field
f
event (V.EvPaste ByteString
bs) Field
f             = Text -> Field -> Field
insertText (ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 ByteString
bs) Field
f
event (V.EvKey Key
V.KBS [Modifier]
_) Field
f          = Field -> Field
backspace Field
f
event (V.EvKey Key
V.KLeft [Modifier]
_) Field
f        = Int -> Field -> Field
updateCursor (-Int
1) Field
f
event (V.EvKey Key
V.KRight [Modifier]
_) Field
f       = Int -> Field -> Field
updateCursor Int
1 Field
f
event (V.EvKey (V.KChar Char
char) [Modifier]
_) Field
f = Char -> Field -> Field
insertCharacter Char
char Field
f
event Event
_ Field
f                          = Field
f

updateCursor :: Int -> Field -> Field
updateCursor :: Int -> Field -> Field
updateCursor Int
dir (Field Text
text Int
cursor) = Text -> Int -> Field
Field Text
text Int
newCursor
  where
    next :: Int
next = Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dir
    limit :: Int
limit = Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
text
    newCursor :: Int
newCursor
        | Int
next Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int
0
        | Int
next Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit = Int
limit
        | Bool
otherwise = Int
next

backspace :: Field -> Field
backspace :: Field -> Field
backspace (Field Text
text Int
cursor) =
    let (Text
start, Text
end) = Int -> Text -> (Text, Text)
T.splitAt Int
cursor Text
text
    in case Text -> Maybe (NonNull Text)
forall mono. MonoFoldable mono => mono -> Maybe (NonNull mono)
fromNullable Text
start of
           Maybe (NonNull Text)
Nothing     -> Text -> Int -> Field
Field Text
end Int
cursor
           Just NonNull Text
start' -> Text -> Int -> Field
Field (NonNull Text -> Text
forall seq. IsSequence seq => NonNull seq -> seq
init NonNull Text
start' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end) (Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

insertCharacter :: Char -> Field -> Field
insertCharacter :: Char -> Field -> Field
insertCharacter Char
char (Field Text
text Int
cursor) = Text -> Int -> Field
Field Text
newText Int
newCursor
  where
    (Text
start, Text
end) = Int -> Text -> (Text, Text)
T.splitAt Int
cursor Text
text
    newText :: Text
newText = Text -> Element Text -> Text
forall seq. SemiSequence seq => seq -> Element seq -> seq
snoc Text
start Char
Element Text
char Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end
    newCursor :: Int
newCursor = Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

insertText :: Text -> Field -> Field
insertText :: Text -> Field -> Field
insertText Text
insert (Field Text
text Int
cursor) = Text -> Int -> Field
Field Text
newText Int
newCursor
  where
    (Text
start, Text
end) = Int -> Text -> (Text, Text)
T.splitAt Int
cursor Text
text
    newText :: Element [Text]
newText = [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
mono -> Element mono
concat [Text
start, Text
insert, Text
end]
    newCursor :: Int
newCursor = Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
insert

widthFold :: [Int] -> Char -> [Int]
widthFold :: [Int] -> Char -> [Int]
widthFold [Int]
l Char
t = [Int]
l [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Char -> Int
V.safeWcwidth Char
t]

cursorPosition :: [Text] -> Int -> Int -> (Int, Int)
cursorPosition :: [Text] -> Int -> Int -> (Int, Int)
cursorPosition [Text]
lns Int
width Int
cursor =
    if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width
        then (Int
0, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -- go to next line if at end of line
        else (Int
x, Int
y)
  where
    parts :: [[Int]]
parts = ([Int] -> Element Text -> [Int]) -> [Int] -> Text -> [Int]
forall mono a.
MonoFoldable mono =>
(a -> Element mono -> a) -> a -> mono -> a
foldl' [Int] -> Char -> [Int]
[Int] -> Element Text -> [Int]
widthFold [] (Text -> [Int]) -> [Text] -> [[Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
lns -- list of list of individual character lengths
    lengths :: [Int]
lengths = [Int] -> Int
forall mono. MonoFoldable mono => mono -> Int
length ([Int] -> Int) -> [[Int]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Int]]
parts -- list of line lengths
    cumulative :: [Int]
cumulative = (Int -> Int -> Int) -> [Int] -> [Int]
forall a. (a -> a -> a) -> [a] -> [a]
L.scanl1 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [Int]
lengths -- cumulative total of line lengths
    above :: [Int]
above = (Element [Int] -> Bool) -> [Int] -> [Int]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cursor) [Int]
cumulative -- lines above the cursor
    y :: Int
y = [Int] -> Int
forall mono. MonoFoldable mono => mono -> Int
length [Int]
above -- number of lines above
    adjustedCursor :: Int
adjustedCursor = Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 ([Int] -> Maybe (Element [Int])
forall mono. MonoFoldable mono => mono -> Maybe (Element mono)
lastMay [Int]
above) -- subtract lines above from cursor position
    cumulativeWidths :: Maybe [Int]
cumulativeWidths = (Int -> Int -> Int) -> [Int] -> [Int]
forall a. (a -> a -> a) -> [a] -> [a]
L.scanl1 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([Int] -> [Int]) -> Maybe [Int] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Int]] -> Index [[Int]] -> Maybe (Element [[Int]])
forall seq.
IsSequence seq =>
seq -> Index seq -> Maybe (Element seq)
index [[Int]]
parts Int
Index [[Int]]
y -- get cumulative widths for current line
    x :: Int
x = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ ([Int] -> Int -> Maybe Int) -> Int -> [Int] -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Int] -> Int -> Maybe Int
forall seq.
IsSequence seq =>
seq -> Index seq -> Maybe (Element seq)
index (Int
adjustedCursor Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Int] -> Maybe Int) -> Maybe [Int] -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Int]
cumulativeWidths

getText :: Field -> Text
getText :: Field -> Text
getText (Field Text
text Int
_) = Text
text

textToField :: Text -> Field
textToField :: Text -> Field
textToField Text
text = Text -> Int -> Field
Field Text
text (Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
text)

field :: Field -> B.Widget UI.ResourceName
field :: Field -> Widget ResourceName
field (Field Text
text Int
cursor) =
    Size
-> Size
-> RenderM ResourceName (Result ResourceName)
-> Widget ResourceName
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed (RenderM ResourceName (Result ResourceName) -> Widget ResourceName)
-> RenderM ResourceName (Result ResourceName)
-> Widget ResourceName
forall a b. (a -> b) -> a -> b
$ do
        Int
width <- Context -> Int
B.availWidth (Context -> Int)
-> ReaderT Context (State (RenderState ResourceName)) Context
-> ReaderT Context (State (RenderState ResourceName)) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context (State (RenderState ResourceName)) Context
forall n. RenderM n Context
B.getContext
        let ([Text]
wrapped, Int
offset) = Int -> Text -> ([Text], Int)
wrap Int
width Text
text
            location :: (Int, Int)
location = [Text] -> Int -> Int -> (Int, Int)
cursorPosition [Text]
wrapped Int
width (Int
cursor Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset)
        Widget ResourceName -> RenderM ResourceName (Result ResourceName)
forall n. Widget n -> RenderM n (Result n)
B.render (Widget ResourceName -> RenderM ResourceName (Result ResourceName))
-> Widget ResourceName
-> RenderM ResourceName (Result ResourceName)
forall a b. (a -> b) -> a -> b
$
            if Text -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null Text
text
                then ResourceName
-> Location -> Widget ResourceName -> Widget ResourceName
forall n. n -> Location -> Widget n -> Widget n
B.showCursor ResourceName
UI.RNCursor ((Int, Int) -> Location
B.Location (Int
0, Int
0)) (Widget ResourceName -> Widget ResourceName)
-> Widget ResourceName -> Widget ResourceName
forall a b. (a -> b) -> a -> b
$ Text -> Widget ResourceName
forall n. Text -> Widget n
B.txt Text
" "
                else ResourceName
-> Location -> Widget ResourceName -> Widget ResourceName
forall n. n -> Location -> Widget n -> Widget n
B.showCursor ResourceName
UI.RNCursor ((Int, Int) -> Location
B.Location (Int, Int)
location) (Widget ResourceName -> Widget ResourceName)
-> ([Widget ResourceName] -> Widget ResourceName)
-> [Widget ResourceName]
-> Widget ResourceName
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Widget ResourceName] -> Widget ResourceName
forall n. [Widget n] -> Widget n
B.vBox ([Widget ResourceName] -> Widget ResourceName)
-> [Widget ResourceName] -> Widget ResourceName
forall a b. (a -> b) -> a -> b
$ Text -> Widget ResourceName
forall n. Text -> Widget n
B.txt (Text -> Widget ResourceName) -> [Text] -> [Widget ResourceName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
wrapped

widgetFromMaybe :: B.Widget UI.ResourceName -> Maybe Field -> B.Widget UI.ResourceName
widgetFromMaybe :: Widget ResourceName -> Maybe Field -> Widget ResourceName
widgetFromMaybe Widget ResourceName
_ (Just Field
f) = Field -> Widget ResourceName
field Field
f
widgetFromMaybe Widget ResourceName
w Maybe Field
Nothing  = Widget ResourceName
w

textField :: Text -> B.Widget UI.ResourceName
textField :: Text -> Widget ResourceName
textField Text
text =
    Size
-> Size
-> RenderM ResourceName (Result ResourceName)
-> Widget ResourceName
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed (RenderM ResourceName (Result ResourceName) -> Widget ResourceName)
-> RenderM ResourceName (Result ResourceName)
-> Widget ResourceName
forall a b. (a -> b) -> a -> b
$ do
        Int
width <- Context -> Int
B.availWidth (Context -> Int)
-> ReaderT Context (State (RenderState ResourceName)) Context
-> ReaderT Context (State (RenderState ResourceName)) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context (State (RenderState ResourceName)) Context
forall n. RenderM n Context
B.getContext
        let ([Text]
wrapped, Int
_) = Int -> Text -> ([Text], Int)
wrap Int
width Text
text
        Widget ResourceName -> RenderM ResourceName (Result ResourceName)
forall n. Widget n -> RenderM n (Result n)
B.render (Widget ResourceName -> RenderM ResourceName (Result ResourceName))
-> Widget ResourceName
-> RenderM ResourceName (Result ResourceName)
forall a b. (a -> b) -> a -> b
$
            if Text -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null Text
text
                then Text -> Widget ResourceName
forall n. Text -> Widget n
B.txt Text
"---"
                else [Widget ResourceName] -> Widget ResourceName
forall n. [Widget n] -> Widget n
B.vBox ([Widget ResourceName] -> Widget ResourceName)
-> [Widget ResourceName] -> Widget ResourceName
forall a b. (a -> b) -> a -> b
$ Text -> Widget ResourceName
forall n. Text -> Widget n
B.txt (Text -> Widget ResourceName) -> [Text] -> [Widget ResourceName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
wrapped

-- wrap
wrap :: Int -> Text -> ([Text], Int)
wrap :: Int -> Text -> ([Text], Int)
wrap Int
width = (([Text], Int) -> Element [Text] -> ([Text], Int))
-> ([Text], Int) -> [Text] -> ([Text], Int)
forall mono a.
MonoFoldable mono =>
(a -> Element mono -> a) -> a -> mono -> a
foldl' (Int -> ([Text], Int) -> Text -> ([Text], Int)
combine Int
width) ([Text
""], Int
0) ([Text] -> ([Text], Int))
-> (Text -> [Text]) -> Text -> ([Text], Int)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Text]
spl

spl' :: [Text] -> Char -> [Text]
spl' :: [Text] -> Char -> [Text]
spl' [Text]
ts Char
c
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = [Text]
ts [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
" "] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
""]
    | Bool
otherwise =
        case [Text] -> Maybe (NonNull [Text])
forall mono. MonoFoldable mono => mono -> Maybe (NonNull mono)
fromNullable [Text]
ts of
            Just NonNull [Text]
ts' -> NonNull [Text] -> [Text]
forall seq. IsSequence seq => NonNull seq -> seq
init NonNull [Text]
ts' [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text -> Element Text -> Text
forall seq. SemiSequence seq => seq -> Element seq -> seq
snoc (NonNull [Text] -> Element [Text]
forall mono. MonoFoldable mono => NonNull mono -> Element mono
last NonNull [Text]
ts') Char
Element Text
c]
            Maybe (NonNull [Text])
Nothing  -> [Element Text -> Text
forall seq. MonoPointed seq => Element seq -> seq
singleton Char
Element Text
c]

spl :: Text -> [Text]
spl :: Text -> [Text]
spl = ([Text] -> Element Text -> [Text]) -> [Text] -> Text -> [Text]
forall mono a.
MonoFoldable mono =>
(a -> Element mono -> a) -> a -> mono -> a
foldl' [Text] -> Char -> [Text]
[Text] -> Element Text -> [Text]
spl' [Text
""]

combine :: Int -> ([Text], Int) -> Text -> ([Text], Int)
combine :: Int -> ([Text], Int) -> Text -> ([Text], Int)
combine Int
width ([Text]
acc, Int
offset) Text
s
    | Bool
newline Bool -> Bool -> Bool
&& Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
" " = ([Text]
acc, Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Int -> Text -> Text
T.takeEnd Int
1 Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
" " Bool -> Bool -> Bool
&& Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
" " = ([Text]
acc, Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Bool
newline = ([Text]
acc [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
s], Int
offset)
    | Bool
otherwise = (Text -> [Text] -> [Text]
append (Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s) [Text]
acc, Int
offset)
  where
    l :: Text
l = Text -> (NonNull [Text] -> Text) -> Maybe (NonNull [Text]) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" NonNull [Text] -> Text
forall mono. MonoFoldable mono => NonNull mono -> Element mono
last ([Text] -> Maybe (NonNull [Text])
forall mono. MonoFoldable mono => mono -> Maybe (NonNull mono)
fromNullable [Text]
acc)
    newline :: Bool
newline = Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width

append :: Text -> [Text] -> [Text]
append :: Text -> [Text] -> [Text]
append Text
s [Text]
l =
    case [Text] -> Maybe (NonNull [Text])
forall mono. MonoFoldable mono => mono -> Maybe (NonNull mono)
fromNullable [Text]
l of
        Just NonNull [Text]
l' -> NonNull [Text] -> [Text]
forall seq. IsSequence seq => NonNull seq -> seq
init NonNull [Text]
l' [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
s]
        Maybe (NonNull [Text])
Nothing -> [Text]
l [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
s]