1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
{-# LANGUAGE OverloadedStrings #-}
module TextViewport
( Item(..)
, Buffer(..)
, WrapMode(..)
, RenderedLine(..)
, RenderedBuffer
, renderBuffer
, flatten
, modifyItem
, updateRenderedItem
, Viewport(..)
, defaultViewport
, scrollUp
, scrollDown
, visibleLines
, lookupPosition
) where
import Data.Text (Text)
import qualified Data.Text as T
--------------------------------------------------------------------------------
-- Logical model
--------------------------------------------------------------------------------
newtype Item = Item { unItem :: Text }
newtype Buffer = Buffer { unBuffer :: [Item] }
modifyItem :: Int -> (Item -> Item) -> Buffer -> Buffer
modifyItem ix f (Buffer xs) =
Buffer (take ix xs ++ [f (xs !! ix)] ++ drop (ix+1) xs)
--------------------------------------------------------------------------------
-- Rendering with provenance
--------------------------------------------------------------------------------
data WrapMode = NoWrap | Wrap
deriving (Eq, Show)
-- | A physical line with provenance.
data RenderedLine = RenderedLine
{ rlText :: !Text
, rlItemIx :: !Int
, rlLineIx :: !Int
, rlCharStart :: !Int
} deriving (Eq, Show)
-- | RenderedBuffer keeps per-item blocks so we can update only one item.
type RenderedBuffer = [[RenderedLine]]
flatten :: RenderedBuffer -> [RenderedLine]
flatten = concat
renderBuffer :: WrapMode -> Int -> Buffer -> RenderedBuffer
renderBuffer mode w (Buffer items) =
zipWith (renderItem mode w) [0..] items
renderItem :: WrapMode -> Int -> Int -> Item -> [RenderedLine]
renderItem mode w itemIx (Item t) =
concat $ zipWith (renderLogicalLine mode w itemIx) [0..] (T.splitOn "\n" t)
renderLogicalLine :: WrapMode -> Int -> Int -> Int -> Text -> [RenderedLine]
renderLogicalLine mode w itemIx lineIx txt =
case mode of
NoWrap ->
[ RenderedLine (T.take w txt) itemIx lineIx 0 ]
Wrap ->
let chunks = chunk w txt
in zipWith mkChunk [0, w ..] chunks
where
mkChunk off chunkTxt =
RenderedLine chunkTxt itemIx lineIx off
chunk :: Int -> Text -> [Text]
chunk w t
| T.null t = [""]
| otherwise = go t
where
go s
| T.null s = []
| otherwise =
let (c, r) = T.splitAt w s
in c : go r
--------------------------------------------------------------------------------
-- Incremental re-rendering
--------------------------------------------------------------------------------
updateRenderedItem
:: WrapMode
-> Int
-> Int
-> Buffer
-> RenderedBuffer
-> RenderedBuffer
updateRenderedItem mode w itemIx (Buffer items) rb =
let newBlock = renderItem mode w itemIx (items !! itemIx)
in take itemIx rb ++ [newBlock] ++ drop (itemIx+1) rb
--------------------------------------------------------------------------------
-- Viewport
--------------------------------------------------------------------------------
data Viewport = Viewport
{ vpWidth :: !Int
, vpHeight :: !Int
, vpOffset :: !Int
} deriving (Eq, Show)
defaultViewport :: Int -> Int -> [RenderedLine] -> Viewport
defaultViewport w h rendered =
let total = length rendered
off = max 0 (total - h)
in Viewport w h off
scrollUp :: Int -> Viewport -> Viewport
scrollUp k vp =
vp { vpOffset = max 0 (vpOffset vp - k) }
scrollDown :: Int -> [RenderedLine] -> Viewport -> Viewport
scrollDown k rendered vp =
let total = length rendered
maxOff = max 0 (total - vpHeight vp)
newOff = min maxOff (vpOffset vp + k)
in vp { vpOffset = newOff }
visibleLines :: [RenderedLine] -> Viewport -> [RenderedLine]
visibleLines rendered vp =
take (vpHeight vp) . drop (vpOffset vp) $ rendered
--------------------------------------------------------------------------------
-- Coordinate lookup
--------------------------------------------------------------------------------
lookupPosition
:: Int -- ^ x coordinate
-> Int -- ^ y coordinate
-> Viewport
-> [RenderedLine]
-> Maybe (Int, Int) -- ^ (itemIx, charOffsetInLogicalLine)
lookupPosition x y vp rendered = do
let lineIx = vpOffset vp + y
rl <- renderedAt lineIx rendered
pure (rlItemIx rl, rlCharStart rl + x)
where
renderedAt ix rs
| ix < 0 || ix >= length rs = Nothing
| otherwise = Just (rs !! ix)
|
