Skip to content

Commit

Permalink
fix multiline render
Browse files Browse the repository at this point in the history
  • Loading branch information
@ners
ners committed Jul 28, 2024
1 parent 81a29ab commit 4e3f3a1
Show file tree
Hide file tree
Showing 6 changed files with 116 additions and 96 deletions.
12 changes: 6 additions & 6 deletions flake.lock
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

65 changes: 65 additions & 0 deletions src/Prettyprinter/Extra.hs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,8 @@
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Prettyprinter.Extra where

import Data.Text qualified as Text
import Prettyprinter
import Prelude

Expand Down Expand Up @@ -44,3 +47,65 @@ tokenLenS (SText len _ _) = len
tokenLenS (SLine len _) = len
tokenLenS (SAnnPush _ _) = 0
tokenLenS (SAnnPop _) = 0

takeLineS
:: SimpleDocStream ann
-> (SimpleDocStream ann, SimpleDocStream ann, SimpleDocStream ann)
takeLineS SFail = (SFail, SEmpty, SEmpty)
takeLineS SEmpty = (SEmpty, SEmpty, SEmpty)
takeLineS (SLine len rest) = (SEmpty, SLine 0 SEmpty, rest')
where
rest' =
if len > 0
then SText len (Text.replicate len " ") rest
else rest
takeLineS s = (s', newLine, rest)
where
(line, newLine, rest) = takeLineS (s ^. tailS)
s' = s & tailS .~ line

lineLenS :: forall ann. SimpleDocStream ann -> Int
lineLenS = go 0
where
go :: Int -> SimpleDocStream ann -> Int
go n SFail = n
go n SEmpty = n
go n SLine{} = n
go n s = go (n + tokenLenS s) (s ^. tailS)

lastLineLenS :: forall ann. SimpleDocStream ann -> Int
lastLineLenS = go 0
where
go :: Int -> SimpleDocStream ann -> Int
go n SFail = n
go n SEmpty = n
go _ (SLine len rest) = go len rest
go n s = go (n + tokenLenS s) (s ^. tailS)

type DifferenceStream ann = SimpleDocStream ann -> SimpleDocStream ann

findCommonPrefixS
:: forall ann
. (Eq ann)
=> SimpleDocStream ann
-> SimpleDocStream ann
-> (SimpleDocStream ann, SimpleDocStream ann, SimpleDocStream ann)
findCommonPrefixS a b = let (acc, a', b') = go id a b in (acc SEmpty, a', b')
where
go
:: DifferenceStream ann
-> SimpleDocStream ann
-> SimpleDocStream ann
-> (DifferenceStream ann, SimpleDocStream ann, SimpleDocStream ann)
go acc (SChar c rest1) (SChar ((== c) -> True) rest2) = go (acc . SChar c) rest1 rest2
go acc (SText len1 t1 rest1) (SText len2 t2 rest2)
| len1 == len2, t1 == t2 = go (acc . SText len1 t1) rest1 rest2
| Just (common, s1, s2) <- Text.commonPrefixes t1 t2 =
go (acc . prepend common) (prepend s1 rest1) (prepend s2 rest2)
go acc (SLine len rest1) (SLine ((== len) -> True) rest2) = go (acc . SLine len) rest1 rest2
go acc (SAnnPush ann rest1) (SAnnPush ((== ann) -> True) rest2) = go (acc . SAnnPush ann) rest1 rest2
go acc (SAnnPop rest1) (SAnnPop rest2) = go (acc . SAnnPop) rest1 rest2
go acc a b = (acc, a, b)
prepend :: Text -> SimpleDocStream ann -> SimpleDocStream ann
prepend "" = id
prepend t = SText (Text.length t) t
115 changes: 30 additions & 85 deletions src/System/Terminal/Render.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,6 @@
module System.Terminal.Render where

import Control.Monad.State.Strict qualified as State
import Data.Text qualified as Text
import Prettyprinter (Doc, SimpleDocStream (..))
import Prettyprinter qualified
import Prettyprinter.Extra
Expand Down Expand Up @@ -37,52 +36,61 @@ render
=> Maybe (Position, Doc (Attribute m))
-> (Position, Doc (Attribute m))
-> m ()
render (fromMaybe (Position{row = 0, col = 0}, "") -> (oldPos, oldDoc)) (newPos, newDoc) = do
render (fromMaybe (Position{row = 0, col = 0}, "") -> (oldPos, oldDoc)) (newPos, newDoc) =
flip evalStateT oldPos do
goLine 0 (layoutPretty oldDoc, mempty) (layoutPretty newDoc, mempty)
goLine 0 0 (layoutPretty oldDoc, mempty) (layoutPretty newDoc, mempty)
moveToPosition newPos
where
goLine
:: (MonadCursor t m' m)
=> Int
-> Int
-> (SimpleDocStream (Attribute m), AttributeStack m)
-> (SimpleDocStream (Attribute m), AttributeStack m)
-> m' ()
goLine _ (nullS -> True, _) (nullS -> True, _) = do
pure ()
goLine _ (nullS -> True, _) (newStream, _) = do
putSimpleDocStream newStream
goLine _ _ (nullS -> True, _) = do
goLine _ _ (nullS -> True, _) (nullS -> True, _) = pure ()
goLine _ _ (nullS -> True, _) (newStream, _) = putSimpleDocStream newStream
goLine line col _ (nullS -> True, _) = do
moveToPosition Position{row = line - 1, col}
lift $ eraseInDisplay EraseForward
goLine line (oldStream, oldStack) (newStream, newStack) = do
let (oldLine, oldNewLine, oldRest) = takeLine oldStream
(newLine, newNewLine, newRest) = takeLine newStream
goLine line _ (oldStream, oldStack) (newStream, newStack) = do
let (oldLine, oldNewLine, oldRest) = takeLineS oldStream
(newLine, newNewLine, newRest) = takeLineS newStream
(commonPrefix, oldSuffix, newSuffix) =
if oldStack == newStack
then findCommonPrefix oldLine newLine
then findCommonPrefixS oldLine newLine
else (SEmpty, oldLine, newLine)
commonPrefixLen = lineLen commonPrefix
oldSuffixLen = lineLen oldSuffix
newSuffixLen = lineLen newSuffix
commonPrefixLen = lineLenS commonPrefix
oldSuffixLen = lineLenS oldSuffix
newSuffixLen = lineLenS newSuffix
oldStackAfterPrefix = applyAnnotations commonPrefix oldStack
newStackAfterPrefix = applyAnnotations commonPrefix newStack
if nullS oldSuffix && nullS newSuffix
then do
when (newNewLine /= SEmpty && oldNewLine == SEmpty) putLn
goLine (line + 1) (oldRest, oldStackAfterPrefix) (newRest, newStackAfterPrefix)
goLine
(line + 1)
commonPrefixLen
(oldRest, oldStackAfterPrefix)
(newRest, newStackAfterPrefix)
else do
moveToPosition Position{row = line, col = commonPrefixLen}
-- not sure if newStackAfterPrefix is the right thing to use here ...
unless (nullS newSuffix)
. putSimpleDocStream
. attributeStackToDocStream newStackAfterPrefix
$ newSuffix
when (oldSuffixLen > newSuffixLen) . lift $ eraseInLine EraseForward
putSimpleDocStream newNewLine
when (newRest /= SEmpty) do
let oldStackAfterSuffix = applyAnnotations oldSuffix oldStackAfterPrefix
newStackAfterSuffix = applyAnnotations newSuffix newStackAfterPrefix
goLine (line + 1) (oldRest, oldStackAfterSuffix) (newRest, newStackAfterSuffix)
if nullS newRest
then lift $ eraseInDisplay EraseForward
else do
let oldStackAfterSuffix = applyAnnotations oldSuffix oldStackAfterPrefix
newStackAfterSuffix = applyAnnotations newSuffix newStackAfterPrefix
goLine
(line + 1)
(commonPrefixLen + newSuffixLen)
(oldRest, oldStackAfterSuffix)
(newRest, newStackAfterSuffix)
applyAnnotations
:: SimpleDocStream (Attribute m)
-> AttributeStack m
Expand Down Expand Up @@ -124,7 +132,7 @@ putSimpleDocStream s = do
else #col %~ (+ len)
where
numLines = countLinesS s
len = lastLineLen s
len = lastLineLenS s

putDoc
:: forall t m m'
Expand All @@ -137,66 +145,3 @@ putLn :: forall t m m'. (MonadCursor t m m') => m ()
putLn = do
lift Prelude.putLn
State.modify $ #row %~ (+ 1) >>> #col .~ 0

takeLine
:: SimpleDocStream ann
-> (SimpleDocStream ann, SimpleDocStream ann, SimpleDocStream ann)
takeLine SFail = (SFail, SEmpty, SEmpty)
takeLine SEmpty = (SEmpty, SEmpty, SEmpty)
takeLine (SLine len rest) = (SEmpty, SLine 0 SEmpty, rest')
where
rest' =
if len > 0
then SText len (Text.replicate len " ") rest
else rest
takeLine s = (s', newLine, rest)
where
(line, newLine, rest) = takeLine (s ^. tailS)
s' = s & tailS .~ line

lineLen :: forall ann. SimpleDocStream ann -> Int
lineLen = go 0
where
go :: Int -> SimpleDocStream ann -> Int
go n SFail = n
go n SEmpty = n
go n SLine{} = n
go n s = go (n + tokenLenS s) (s ^. tailS)

lastLineLen :: forall ann. SimpleDocStream ann -> Int
lastLineLen = go 0
where
go :: Int -> SimpleDocStream ann -> Int
go n SFail = n
go n SEmpty = n
go _ (SLine len rest) = go len rest
go n s = go (n + tokenLenS s) (s ^. tailS)

type DifferenceStream ann = SimpleDocStream ann -> SimpleDocStream ann

textStream :: Text -> SimpleDocStream ann -> SimpleDocStream ann
textStream "" = id
textStream t = SText (Text.length t) t

findCommonPrefix
:: forall ann
. (Eq ann)
=> SimpleDocStream ann
-> SimpleDocStream ann
-> (SimpleDocStream ann, SimpleDocStream ann, SimpleDocStream ann)
findCommonPrefix a b = let (acc, a', b') = go id a b in (acc SEmpty, a', b')
where
go
:: DifferenceStream ann
-> SimpleDocStream ann
-> SimpleDocStream ann
-> (DifferenceStream ann, SimpleDocStream ann, SimpleDocStream ann)
go acc (SChar c rest1) (SChar ((== c) -> True) rest2) = go (acc . SChar c) rest1 rest2
go acc (SText len1 t1 rest1) (SText len2 t2 rest2)
| len1 == len2, t1 == t2 = go (acc . SText len1 t1) rest1 rest2
| Just (common, s1, s2) <- Text.commonPrefixes t1 t2 =
go (acc . textStream common) (textStream s1 rest1) (textStream s2 rest2)
go acc (SLine len rest1) (SLine ((== len) -> True) rest2) = go (acc . SLine len) rest1 rest2
go acc (SAnnPush ann rest1) (SAnnPush ((== ann) -> True) rest2) = go (acc . SAnnPush ann) rest1 rest2
go acc (SAnnPop rest1) (SAnnPop rest2) = go (acc . SAnnPop) rest1 rest2
go acc a b = (acc, a, b)
11 changes: 9 additions & 2 deletions src/System/Terminal/Widgets/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,11 @@ class Widget w where
. layoutPretty defaultLayoutOptions
. toDoc @_ @(TerminalT LocalTerminal IO)
render
:: forall m. (MonadTerminal m) => Maybe w -> w -> m ()
:: forall m
. (MonadTerminal m)
=> Maybe w
-> w
-> m ()
render = defaultRender

defaultRender
Expand Down Expand Up @@ -94,7 +98,10 @@ runWidgetIO :: forall m w. (MonadIO m, Widget w) => w -> m w
runWidgetIO = liftIO . withTerminal . runTerminalT . runWidget

runWidget
:: forall m w. (MonadTerminal m, Widget w) => w -> m w
:: forall m w
. (MonadTerminal m, Widget w)
=> w
-> m w
runWidget = runWidget' setup preRender postRender cleanup
where
setup :: w -> m ()
Expand Down
7 changes: 5 additions & 2 deletions src/System/Terminal/Widgets/TextInput.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,13 +18,16 @@ data TextInput = TextInput
}
deriving stock (Generic)

withPromptLength :: Int -> Iso' Position Position
withPromptLength len = iso (#col %~ (+) len) (#col %~ subtract len)

instance Widget TextInput where
cursor = lens getter setter
where
getter :: TextInput -> Position
getter TextInput{..} = value ^. #cursor & #col %~ (+ Text.length prompt)
getter TextInput{..} = value ^. #cursor . withPromptLength (Text.length prompt)
setter :: TextInput -> Position -> TextInput
setter t p = t & #value . #cursor .~ (p & #col %~ subtract (Text.length t.prompt))
setter t p = t & #value . #cursor . withPromptLength (Text.length t.prompt) .~ p
handleEvent (KeyEvent BackspaceKey []) = #value %~ RopeZipper.deleteBefore
handleEvent (KeyEvent DeleteKey []) = #value %~ RopeZipper.deleteAfter
handleEvent (KeyEvent (CharKey k) []) = #value %~ RopeZipper.insertText (Text.singleton k)
Expand Down
2 changes: 1 addition & 1 deletion terminal-widgets.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,7 +51,6 @@ common common
ViewPatterns
build-depends:
base >= 4.16 && < 5,
extra,
generic-lens,
terminal,
text,
Expand All @@ -73,6 +72,7 @@ library
Prettyprinter.Extra,
build-depends:
exceptions,
extra,
fuzzy,
mtl,
prettyprinter,
Expand Down

0 comments on commit 4e3f3a1

Please sign in to comment.