├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── run-tests.sh ├── src └── Data │ └── Text │ ├── Zipper.hs │ └── Zipper │ ├── Generic.hs │ ├── Generic │ └── Words.hs │ └── Vector.hs ├── tests ├── Main.hs └── WordsSpec.hs └── text-zipper.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | dist 4 | .*.swp 5 | dist-newstyle 6 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | 0.13 3 | ---- 4 | 5 | Bug fixes: 6 | * The zipper constructors now ignores non-printable characters (see 7 | also #13) 8 | * `insertMany` now no longer drops the input following a non-printable 9 | character (#13) 10 | 11 | 0.12 12 | ---- 13 | 14 | API changes: 15 | * Added `moveCursorClosest` to allow cursor placement as near as 16 | possible to a specified location. 17 | 18 | 0.11 19 | ---- 20 | 21 | API changes: 22 | * Added `gotoBOF`, `gotoEOF`, `killToBOF`, and `killToEOF` functions 23 | (thanks Itai Y. Efrat) 24 | 25 | 0.10.1 26 | ------ 27 | 28 | * WordSpec: fix a test verification bug (fixed #11) 29 | * WordSpec: generation of random text should never include newlines 30 | 31 | 0.10 32 | ---- 33 | 34 | - Integrated word editing and navigation functions 35 | courtesy of Hans-Peter Deifel's hledger-iadd project (see 36 | Data.Text.Zipper.Generic.Words) 37 | - Added currentChar, nextChar, and previousChar (thanks @kRITZCREEK) 38 | 39 | 0.9 40 | --- 41 | 42 | - insertChar and insertMany now only insert printable characters and 43 | newlines (subject to text zipper line limits) 44 | - The GenericTextZipper class now requires a new method, 45 | toList :: a -> [Char] 46 | 47 | 0.8.3 48 | ----- 49 | 50 | - Fixed insertMany accidental addition of trailing newline 51 | 52 | 0.8.2 53 | ----- 54 | 55 | - Fixed insertMany for zippers with no line limit 56 | 57 | 0.8.1 58 | ----- 59 | 60 | - Added Github links and CHANGELOG to package 61 | 62 | 0.8 63 | --- 64 | 65 | - Added 'transposeChars' function 66 | 67 | 0.7.1 68 | ----- 69 | 70 | - Generic: import everything from Monoid for older GHCs 71 | 72 | 0.7 73 | --- 74 | 75 | - API changes: Add Generic module to abstract over text container types 76 | 77 | 0.6.1 78 | ----- 79 | 80 | - Make insertMany respect the zipper's line limit 81 | 82 | 0.6 83 | --- 84 | 85 | - Add insertMany for faster bulk insertion 86 | 87 | 0.5 88 | --- 89 | 90 | - Added killToBOL function (thanks Hans-Peter Deifel) 91 | - Enabled -Wall 92 | - Added dependency on deepseq 93 | - Added NFData instance for TextZipper 94 | 95 | 0.4 96 | --- 97 | 98 | - Added clearZipper 99 | - Added isFirstLine (thanks Kwang Yul Seo) 100 | - Renamed lastLine to isLastLine (thanks Kwang Yul Seo) 101 | 102 | 0.3.1 103 | ----- 104 | 105 | - Fixed export of vectorZipper 106 | 107 | 0.3 108 | --- 109 | 110 | - Added vectorZipper for zipping over vectors of characters 111 | 112 | 0.2.1 113 | ----- 114 | 115 | - Exported getLineLimit to permit obtaining a zipper's line limit 116 | 117 | 0.2 118 | --- 119 | 120 | - Added support for limiting the number of lines in the zipper 121 | - insertChar "\n" is now equivalent to breakLine 122 | - Improved Show instance for TextZipper 123 | 124 | 0.1.1 125 | ----- 126 | 127 | - Updated package metadata 128 | 129 | 0.1 130 | --- 131 | 132 | Initial release (originally split off from vty-ui) 133 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Jonathan Daugherty 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jonathan Daugherty nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | (cd $HOME && cabal install hspec-discover) 6 | cabal new-build --enable-tests 7 | ./dist-newstyle/build/text-zipper-*/build/text-zipper-tests/text-zipper-tests 8 | -------------------------------------------------------------------------------- /src/Data/Text/Zipper.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides a two-dimensional text zipper data structure. 2 | -- This structure represents a body of text and an editing cursor 3 | -- which can be moved throughout the text, along with a set of editing 4 | -- transformations. 5 | -- 6 | -- Text zippers are generalized over the set of data types that might be 7 | -- used to store lists of characters (e.g., 'String', 'T.Text', etc.). 8 | -- As a result, the most general way to create a text zipper is to use 9 | -- 'mkZipper' and provide all of the functions required to manipulate 10 | -- the underlying text data. 11 | -- 12 | -- Implementations using 'T.Text' and 'String' are provided. 13 | module Data.Text.Zipper 14 | ( TextZipper 15 | 16 | -- * Construction and extraction 17 | , mkZipper 18 | , textZipper 19 | , stringZipper 20 | , clearZipper 21 | , vectorZipper 22 | , getText 23 | , currentLine 24 | , cursorPosition 25 | , lineLengths 26 | , getLineLimit 27 | 28 | -- * Navigation functions 29 | , moveCursor 30 | , moveCursorClosest 31 | , moveRight 32 | , moveLeft 33 | , moveUp 34 | , moveDown 35 | , gotoEOL 36 | , gotoBOL 37 | , gotoEOF 38 | , gotoBOF 39 | 40 | -- * Inspection functions 41 | , currentChar 42 | , nextChar 43 | , previousChar 44 | 45 | -- * Editing functions 46 | , insertChar 47 | , insertMany 48 | , deletePrevChar 49 | , deleteChar 50 | , breakLine 51 | , killToEOL 52 | , killToBOL 53 | , killToEOF 54 | , killToBOF 55 | , transposeChars 56 | ) 57 | where 58 | 59 | import Control.Applicative ((<$>)) 60 | import Control.DeepSeq 61 | import Data.Char (isPrint) 62 | import Data.List (foldl') 63 | import Data.Monoid 64 | import qualified Data.Text as T 65 | import qualified Data.Vector as V 66 | import qualified Data.Text.Zipper.Vector as V 67 | 68 | data TextZipper a = 69 | TZ { toLeft :: a 70 | , toRight :: a 71 | , above :: [a] 72 | , below :: [a] 73 | , fromChar :: Char -> a 74 | , drop_ :: Int -> a -> a 75 | , take_ :: Int -> a -> a 76 | , length_ :: a -> Int 77 | , last_ :: a -> Char 78 | , init_ :: a -> a 79 | , null_ :: a -> Bool 80 | , lines_ :: a -> [a] 81 | , toList_ :: a -> [Char] 82 | , lineLimit :: Maybe Int 83 | } 84 | 85 | instance (NFData a) => NFData (TextZipper a) where 86 | rnf z = (toLeft z) `deepseq` 87 | (toRight z) `deepseq` 88 | (above z) `deepseq` 89 | (below z) `deepseq` 90 | () 91 | 92 | -- | Get the line limit, if any, for a zipper. 93 | getLineLimit :: TextZipper a -> Maybe Int 94 | getLineLimit = lineLimit 95 | 96 | instance (Eq a) => Eq (TextZipper a) where 97 | a == b = and [ toLeft a == toLeft b 98 | , toRight a == toRight b 99 | , above a == above b 100 | , below a == below b 101 | ] 102 | 103 | instance (Show a) => Show (TextZipper a) where 104 | show tz = concat [ "TextZipper { " 105 | , "above = " 106 | , show $ above tz 107 | , ", below = " 108 | , show $ below tz 109 | , ", toLeft = " 110 | , show $ toLeft tz 111 | , ", toRight = " 112 | , show $ toRight tz 113 | , " }" 114 | ] 115 | 116 | -- | Create a zipper using a custom text storage type. Takes the initial 117 | -- text as well as all of the functions necessary to manipulate the 118 | -- underlying text values. 119 | mkZipper :: (Monoid a) => 120 | (Char -> a) 121 | -- ^A singleton constructor. 122 | -> (Int -> a -> a) 123 | -- ^'drop'. 124 | -> (Int -> a -> a) 125 | -- ^'take'. 126 | -> (a -> Int) 127 | -- ^'length'. 128 | -> (a -> Char) 129 | -- ^'last'. 130 | -> (a -> a) 131 | -- ^'init'. 132 | -> (a -> Bool) 133 | -- ^'null'. 134 | -> (a -> [a]) 135 | -- ^'lines'. 136 | -> (a -> [Char]) 137 | -- ^'toList'. 138 | -> [a] 139 | -- ^The initial lines of text. 140 | -> Maybe Int 141 | -- ^Limit to this many lines of text ('Nothing' means no limit). 142 | -> TextZipper a 143 | mkZipper fromCh drp tk lngth lst int nl linesFunc toListF ls lmt = 144 | let limitedLs = case lmt of 145 | Nothing -> ls 146 | Just n -> take n ls 147 | (first, rest) = if null limitedLs 148 | then (mempty, mempty) 149 | else (head limitedLs, tail limitedLs) 150 | numLines = length ls 151 | insertLine z (i, l) = (if i < numLines - 1 then breakLine else id) $ insertMany l z 152 | loadInitial z = foldl' insertLine z $ zip [0..] (first:rest) 153 | in loadInitial $ TZ mempty mempty mempty mempty fromCh drp tk lngth lst int nl linesFunc toListF lmt 154 | 155 | -- | Get the text contents of the zipper. 156 | getText :: (Monoid a) => TextZipper a -> [a] 157 | getText tz = concat [ above tz 158 | , [currentLine tz] 159 | , below tz 160 | ] 161 | 162 | -- | Return the lengths of the lines in the zipper. 163 | lineLengths :: (Monoid a) => TextZipper a -> [Int] 164 | lineLengths tz = (length_ tz) <$> concat [ above tz 165 | , [currentLine tz] 166 | , below tz 167 | ] 168 | 169 | -- | Get the cursor position of the zipper; returns @(row, col)@. 170 | -- @row@ ranges from @[0..num_rows-1]@ inclusive; @col@ ranges from 171 | -- @[0..length of current line]@ inclusive. Column values equal to line 172 | -- width indicate a cursor that is just past the end of a line of text. 173 | cursorPosition :: TextZipper a -> (Int, Int) 174 | cursorPosition tz = (length $ above tz, length_ tz $ toLeft tz) 175 | 176 | -- | Move the cursor to the specified row and column. Invalid cursor 177 | -- positions will be ignored. Valid cursor positions range as described 178 | -- for 'cursorPosition'. 179 | moveCursor :: (Monoid a) => (Int, Int) -> TextZipper a -> TextZipper a 180 | moveCursor (row, col) tz = 181 | let t = getText tz 182 | in if row < 0 183 | || row >= length t 184 | || col < 0 185 | || col > length_ tz (t !! row) 186 | then tz 187 | else tz { above = take row t 188 | , below = drop (row + 1) t 189 | , toLeft = take_ tz col (t !! row) 190 | , toRight = drop_ tz col (t !! row) 191 | } 192 | 193 | -- | Move the cursor to the specified row and column. Invalid cursor 194 | -- positions will be reinterpreted as the closest valid position. Valid 195 | -- cursor positions range as described for 'cursorPosition'. 196 | moveCursorClosest :: (Monoid a) => (Int, Int) -> TextZipper a -> TextZipper a 197 | moveCursorClosest (row, col) tz = 198 | let t = getText tz 199 | bestRow = min (max 0 $ length t - 1) $ max 0 row 200 | bestCol = if bestRow < length t 201 | then min (length_ tz (t !! bestRow)) $ max 0 col 202 | else 0 203 | in tz { above = take bestRow t 204 | , below = drop (bestRow + 1) t 205 | , toLeft = take_ tz bestCol (t !! bestRow) 206 | , toRight = drop_ tz bestCol (t !! bestRow) 207 | } 208 | 209 | isFirstLine :: TextZipper a -> Bool 210 | isFirstLine = null . above 211 | 212 | isLastLine :: TextZipper a -> Bool 213 | isLastLine = (== 0) . length . below 214 | 215 | nextLine :: TextZipper a -> a 216 | nextLine = head . below 217 | 218 | -- | The line of text on which the zipper's cursor currently resides. 219 | currentLine :: (Monoid a) => TextZipper a -> a 220 | currentLine tz = (toLeft tz) `mappend` (toRight tz) 221 | 222 | -- | Insert a character at the current cursor position. 223 | -- 224 | -- If the character is a newline, break the current line. 225 | -- 226 | -- If the character is non-printable, ignore it. 227 | -- 228 | -- Otherwise insert the character and move the cursor one position to 229 | -- the right. 230 | insertChar :: (Monoid a) => Char -> TextZipper a -> TextZipper a 231 | insertChar ch tz 232 | | ch == '\n' = breakLine tz 233 | | isPrint ch = tz { toLeft = toLeft tz `mappend` (fromChar tz ch) } 234 | | otherwise = tz 235 | 236 | -- | Insert many characters at the current cursor position. Move the 237 | -- cursor to the end of the inserted text. 238 | insertMany :: (Monoid a) => a -> TextZipper a -> TextZipper a 239 | insertMany str tz = foldl' (flip insertChar) tz $ toList_ tz str 240 | 241 | -- | Insert a line break at the current cursor position. 242 | breakLine :: (Monoid a) => TextZipper a -> TextZipper a 243 | breakLine tz = 244 | -- Plus two because we count the current line and the line we are 245 | -- about to create; if that number of lines exceeds the limit, 246 | -- ignore this operation. 247 | let modified = tz { above = above tz ++ [toLeft tz] 248 | , toLeft = mempty 249 | } 250 | in case lineLimit tz of 251 | Just lim -> if length (above tz) + length (below tz) + 2 > lim 252 | then tz 253 | else modified 254 | Nothing -> modified 255 | 256 | -- | Move the cursor to the end of the current line. 257 | gotoEOL :: (Monoid a) => TextZipper a -> TextZipper a 258 | gotoEOL tz = tz { toLeft = currentLine tz 259 | , toRight = mempty 260 | } 261 | 262 | -- | Move the cursor to the end of a text zipper. 263 | gotoEOF :: (Monoid a) => TextZipper a -> TextZipper a 264 | gotoEOF tz = 265 | tz { toLeft = end 266 | , toRight = mempty 267 | , above = top 268 | , below = mempty 269 | } 270 | where 271 | tx = getText tz 272 | (top, end) = if null tx 273 | then (mempty, mempty) 274 | else (init tx, last tx) 275 | 276 | -- | Remove all text from the cursor position to the end of the current 277 | -- line. If the cursor is at the beginning of a line and the line is 278 | -- empty, the entire line will be removed. 279 | killToEOL :: (Monoid a) => TextZipper a -> TextZipper a 280 | killToEOL tz 281 | | (null_ tz $ toLeft tz) && (null_ tz $ toRight tz) && 282 | (not $ null $ below tz) = 283 | tz { toRight = head $ below tz 284 | , below = tail $ below tz 285 | } 286 | | otherwise = tz { toRight = mempty 287 | } 288 | 289 | -- | Remove all text from the cursor position to the beginning of the 290 | -- current line. 291 | killToBOL :: Monoid a => TextZipper a -> TextZipper a 292 | killToBOL tz = tz { toLeft = mempty 293 | } 294 | 295 | -- | Remove all text from the cursor position to the end of the text 296 | -- zipper. If the cursor is at the beginning of a line and the line is 297 | -- empty, the entire line will be removed. 298 | killToEOF :: (Monoid a) => TextZipper a -> TextZipper a 299 | killToEOF tz = 300 | tz { toRight = mempty 301 | , below = mempty 302 | } 303 | 304 | -- | Remove all text from the cursor position to the beginning of the 305 | -- text zipper. 306 | killToBOF :: Monoid a => TextZipper a -> TextZipper a 307 | killToBOF tz = 308 | tz { toLeft = mempty 309 | , above = mempty 310 | } 311 | 312 | -- | Delete the character preceding the cursor position, and move the 313 | -- cursor backwards by one character. 314 | deletePrevChar :: (Eq a, Monoid a) => TextZipper a -> TextZipper a 315 | deletePrevChar tz 316 | | moveLeft tz == tz = tz 317 | | otherwise = deleteChar $ moveLeft tz 318 | 319 | -- | Delete the character at the cursor position. Leaves the cursor 320 | -- position unchanged. If the cursor is at the end of a line of text, 321 | -- this combines the line with the line below. 322 | deleteChar :: (Monoid a) => TextZipper a -> TextZipper a 323 | deleteChar tz 324 | -- Can we just remove a char from the current line? 325 | | (not $ null_ tz (toRight tz)) = 326 | tz { toRight = drop_ tz 1 $ toRight tz 327 | } 328 | -- Do we need to collapse the previous line onto the current one? 329 | | null_ tz (toRight tz) && (not $ null $ below tz) = 330 | tz { toRight = head $ below tz 331 | , below = tail $ below tz 332 | } 333 | | otherwise = tz 334 | 335 | -- | Get the Char on which the cursor currently resides. If the cursor 336 | -- is at the end of the text or the text is empty return @Nothing@. 337 | currentChar :: TextZipper a -> Maybe Char 338 | currentChar tz 339 | | not (null_ tz (toRight tz)) = 340 | Just (last_ tz (take_ tz 1 (toRight tz))) 341 | | otherwise = Nothing 342 | 343 | -- | Get the Char after the cursor position. If the cursor is at the end 344 | -- of a line return the first character of the next line, or if that one 345 | -- is empty as well, return @Nothing@. 346 | nextChar :: (Monoid a) => TextZipper a -> Maybe Char 347 | nextChar tz = currentChar (moveRight tz) 348 | 349 | -- | Get the Char before the cursor position. If the cursor is at the 350 | -- beginning of the text, return @Nothing@ 351 | previousChar :: (Monoid a) => TextZipper a -> Maybe Char 352 | previousChar tz 353 | -- Only return Nothing if we are at the beginning of a line and only empty 354 | -- lines are above 355 | | snd (cursorPosition tz) == 0 && all (null_ tz) (above tz) = 356 | Nothing 357 | | otherwise = 358 | currentChar (moveLeft tz) 359 | 360 | -- | Move the cursor to the beginning of the current line. 361 | gotoBOL :: (Monoid a) => TextZipper a -> TextZipper a 362 | gotoBOL tz = tz { toLeft = mempty 363 | , toRight = currentLine tz 364 | } 365 | 366 | -- | Move the cursor to the beginning of a text zipper. 367 | gotoBOF :: (Monoid a) => TextZipper a -> TextZipper a 368 | gotoBOF tz = 369 | tz { toLeft = mempty 370 | , toRight = first 371 | , above = mempty 372 | , below = rest 373 | } 374 | where 375 | tx = getText tz 376 | (first, rest) = if null tx 377 | then (mempty, mempty) 378 | else (head tx, tail tx) 379 | 380 | -- | Move the cursor right by one position. If the cursor is at the end 381 | -- of a line, the cursor is moved to the first position of the following 382 | -- line (if any). 383 | moveRight :: (Monoid a) => TextZipper a -> TextZipper a 384 | moveRight tz 385 | -- Are we able to keep moving right on the current line? 386 | | not (null_ tz (toRight tz)) = 387 | tz { toLeft = toLeft tz 388 | `mappend` (take_ tz 1 $ toRight tz) 389 | , toRight = drop_ tz 1 (toRight tz) 390 | } 391 | -- If we are going to go beyond the end of the current line, can 392 | -- we move to the next one? 393 | | not $ null (below tz) = 394 | tz { above = above tz ++ [toLeft tz] 395 | , below = tail $ below tz 396 | , toLeft = mempty 397 | , toRight = nextLine tz 398 | } 399 | | otherwise = tz 400 | 401 | -- | Move the cursor left by one position. If the cursor is at the 402 | -- beginning of a line, the cursor is moved to the last position of the 403 | -- preceding line (if any). 404 | moveLeft :: (Monoid a) => TextZipper a -> TextZipper a 405 | moveLeft tz 406 | -- Are we able to keep moving left on the current line? 407 | | not $ null_ tz (toLeft tz) = 408 | tz { toLeft = init_ tz $ toLeft tz 409 | , toRight = fromChar tz (last_ tz (toLeft tz)) 410 | `mappend` toRight tz 411 | } 412 | -- If we are going to go beyond the beginning of the current line, 413 | -- can we move to the end of the previous one? 414 | | not $ null (above tz) = 415 | tz { above = init $ above tz 416 | , below = currentLine tz : below tz 417 | , toLeft = last $ above tz 418 | , toRight = mempty 419 | } 420 | | otherwise = tz 421 | 422 | -- | Move the cursor up by one row. If there no are rows above the 423 | -- current one, move to the first position of the current row. If the 424 | -- row above is shorter, move to the end of that row. 425 | moveUp :: (Monoid a) => TextZipper a -> TextZipper a 426 | moveUp tz 427 | -- Is there a line above at least as long as the current one? 428 | | (not $ isFirstLine tz) && 429 | (length_ tz $ last $ above tz) >= length_ tz (toLeft tz) = 430 | tz { below = currentLine tz : below tz 431 | , above = init $ above tz 432 | , toLeft = take_ tz (length_ tz $ toLeft tz) (last $ above tz) 433 | , toRight = drop_ tz (length_ tz $ toLeft tz) (last $ above tz) 434 | } 435 | -- Or if there is a line above, just go to the end of it 436 | | (not $ isFirstLine tz) = 437 | tz { above = init $ above tz 438 | , below = currentLine tz : below tz 439 | , toLeft = last $ above tz 440 | , toRight = mempty 441 | } 442 | -- If nothing else, go to the beginning of the current line 443 | | otherwise = gotoBOL tz 444 | 445 | -- | Move the cursor down by one row. If there are no rows below the 446 | -- current one, move to the last position of the current row. If the row 447 | -- below is shorter, move to the end of that row. 448 | moveDown :: (Monoid a) => TextZipper a -> TextZipper a 449 | moveDown tz 450 | -- Is there a line below at least as long as the current one? 451 | | (not $ isLastLine tz) && 452 | (length_ tz $ nextLine tz) >= length_ tz (toLeft tz) = 453 | tz { below = tail $ below tz 454 | , above = above tz ++ [currentLine tz] 455 | , toLeft = take_ tz (length_ tz $ toLeft tz) (nextLine tz) 456 | , toRight = drop_ tz (length_ tz $ toLeft tz) (nextLine tz) 457 | } 458 | -- Or if there is a line below, just go to the end of it 459 | | (not $ isLastLine tz) = 460 | tz { above = above tz ++ [currentLine tz] 461 | , below = tail $ below tz 462 | , toLeft = nextLine tz 463 | , toRight = mempty 464 | } 465 | -- If nothing else, go to the end of the current line 466 | | otherwise = gotoEOL tz 467 | 468 | -- | Transpose the character before the cursor with the one at the 469 | -- cursor position and move the cursor one position to the right. If 470 | -- the cursor is at the end of the current line, transpose the current 471 | -- line's last two characters. 472 | transposeChars :: (Monoid a) => TextZipper a -> TextZipper a 473 | transposeChars tz 474 | | null_ tz (toLeft tz) = tz 475 | | null_ tz (toRight tz) = 476 | if length_ tz (toLeft tz) < 2 477 | then tz 478 | else let prefixLen = length_ tz (toLeft tz) - 2 479 | prefix = take_ tz prefixLen (toLeft tz) 480 | lastTwo = drop_ tz prefixLen (toLeft tz) 481 | a = take_ tz 1 lastTwo 482 | b = drop_ tz 1 lastTwo 483 | in tz { toLeft = prefix <> b <> a 484 | } 485 | | otherwise = tz { toLeft = (init_ tz $ toLeft tz) <> 486 | (take_ tz 1 $ toRight tz) <> 487 | (fromChar tz $ last_ tz $ toLeft tz) 488 | , toRight = (drop_ tz 1 $ toRight tz) 489 | } 490 | 491 | -- | Construct a zipper from list values. 492 | stringZipper :: [String] -> Maybe Int -> TextZipper String 493 | stringZipper = 494 | mkZipper (:[]) drop take length last init null lines id 495 | 496 | -- | Construct a zipper from vectors of characters. 497 | vectorZipper :: [V.Vector Char] -> Maybe Int -> TextZipper (V.Vector Char) 498 | vectorZipper = 499 | mkZipper V.singleton V.drop V.take V.length V.last V.init V.null V.vecLines V.toList 500 | 501 | -- | Empty a zipper. 502 | clearZipper :: (Monoid a) => TextZipper a -> TextZipper a 503 | clearZipper tz = 504 | tz { toLeft = mempty 505 | , toRight = mempty 506 | , above = [] 507 | , below = [] 508 | } 509 | 510 | -- | Construct a zipper from 'T.Text' values. 511 | textZipper :: [T.Text] -> Maybe Int -> TextZipper T.Text 512 | textZipper = 513 | mkZipper T.singleton T.drop T.take T.length T.last T.init T.null T.lines T.unpack 514 | -------------------------------------------------------------------------------- /src/Data/Text/Zipper/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | module Data.Text.Zipper.Generic 3 | ( GenericTextZipper(..) 4 | , Data.Text.Zipper.Generic.textZipper 5 | ) 6 | where 7 | 8 | import qualified Prelude 9 | import Prelude hiding (drop, take, length, last, init, null, lines) 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Zipper.Vector as V 12 | import qualified Data.Vector as V 13 | 14 | import Data.Monoid 15 | 16 | import Data.Text.Zipper 17 | 18 | class Monoid a => GenericTextZipper a where 19 | singleton :: Char -> a 20 | drop :: Int -> a -> a 21 | take :: Int -> a -> a 22 | length :: a -> Int 23 | last :: a -> Char 24 | init :: a -> a 25 | null :: a -> Bool 26 | lines :: a -> [a] 27 | toList :: a -> [Char] 28 | 29 | instance GenericTextZipper [Char] where 30 | singleton = (:[]) 31 | drop = Prelude.drop 32 | take = Prelude.take 33 | length = Prelude.length 34 | last = Prelude.last 35 | init = Prelude.init 36 | null = Prelude.null 37 | lines = Prelude.lines 38 | toList = id 39 | 40 | instance GenericTextZipper T.Text where 41 | singleton = T.singleton 42 | drop = T.drop 43 | take = T.take 44 | length = T.length 45 | last = T.last 46 | init = T.init 47 | null = T.null 48 | lines = T.lines 49 | toList = T.unpack 50 | 51 | instance GenericTextZipper (V.Vector Char) where 52 | singleton = V.singleton 53 | drop = V.drop 54 | take = V.take 55 | length = V.length 56 | last = V.last 57 | init = V.init 58 | null = V.null 59 | lines = V.vecLines 60 | toList = V.toList 61 | 62 | textZipper :: GenericTextZipper a => 63 | [a] -> Maybe Int -> TextZipper a 64 | textZipper = 65 | mkZipper singleton drop take length last init null lines toList 66 | -------------------------------------------------------------------------------- /src/Data/Text/Zipper/Generic/Words.hs: -------------------------------------------------------------------------------- 1 | -- | Implements word movements. 2 | -- 3 | -- Copyright (c) Hans-Peter Deifel 4 | module Data.Text.Zipper.Generic.Words 5 | ( moveWordLeft 6 | , moveWordRight 7 | , deletePrevWord 8 | , deleteWord 9 | ) 10 | where 11 | 12 | import Data.Char 13 | 14 | import Data.Text.Zipper 15 | import qualified Data.Text.Zipper.Generic as TZ 16 | 17 | -- | Move one word to the left. 18 | -- 19 | -- A word is defined as a consecutive string not satisfying isSpace. 20 | -- This function always leaves the cursor at the beginning of a word 21 | -- (except at the very start of the text). 22 | moveWordLeft :: TZ.GenericTextZipper a => TextZipper a -> TextZipper a 23 | moveWordLeft = doWordLeft False moveLeft 24 | 25 | -- | Delete the previous word. 26 | -- 27 | -- Does the same as 'moveWordLeft' but deletes characters instead of 28 | -- simply moving past them. 29 | deletePrevWord :: (Eq a, TZ.GenericTextZipper a) => TextZipper a -> TextZipper a 30 | deletePrevWord = doWordLeft False deletePrevChar 31 | 32 | doWordLeft :: TZ.GenericTextZipper a 33 | => Bool 34 | -> (TextZipper a -> TextZipper a) 35 | -> TextZipper a 36 | -> TextZipper a 37 | doWordLeft inWord transform zipper = case charToTheLeft zipper of 38 | Nothing -> zipper -- start of text 39 | Just c 40 | | isSpace c && not inWord -> 41 | doWordLeft False transform (transform zipper) 42 | | not (isSpace c) && not inWord -> 43 | doWordLeft True transform zipper -- switch to skipping letters 44 | | not (isSpace c) && inWord -> 45 | doWordLeft True transform (transform zipper) 46 | | otherwise -> 47 | zipper -- Done 48 | 49 | -- | Move one word to the right. 50 | -- 51 | -- A word is defined as a consecutive string not satisfying isSpace. 52 | -- This function always leaves the cursor at the end of a word (except 53 | -- at the very end of the text). 54 | moveWordRight :: TZ.GenericTextZipper a => TextZipper a -> TextZipper a 55 | moveWordRight = doWordRight False moveRight 56 | 57 | -- | Delete the next word. 58 | -- 59 | -- Does the same as 'moveWordRight' but deletes characters instead of 60 | -- simply moving past them. 61 | deleteWord :: TZ.GenericTextZipper a => TextZipper a -> TextZipper a 62 | deleteWord = doWordRight False deleteChar 63 | 64 | doWordRight :: TZ.GenericTextZipper a 65 | => Bool 66 | -> (TextZipper a -> TextZipper a) 67 | -> TextZipper a 68 | -> TextZipper a 69 | doWordRight inWord transform zipper = case charToTheRight zipper of 70 | Nothing -> zipper -- end of text 71 | Just c 72 | | isSpace c && not inWord -> 73 | doWordRight False transform (transform zipper) 74 | | not (isSpace c) && not inWord -> 75 | doWordRight True transform zipper -- switch to skipping letters 76 | | not (isSpace c) && inWord -> 77 | doWordRight True transform (transform zipper) 78 | | otherwise -> 79 | zipper -- Done 80 | 81 | -- Helpers 82 | 83 | charToTheLeft :: TZ.GenericTextZipper a => TextZipper a -> Maybe Char 84 | charToTheLeft zipper = case cursorPosition zipper of 85 | (0, 0) -> Nothing -- Very start of text, no char left 86 | (_, 0) -> Just '\n' -- Start of line, simulate newline 87 | (_, x) -> Just (TZ.toList (currentLine zipper) !! (x-1)) 88 | 89 | charToTheRight :: TZ.GenericTextZipper a => TextZipper a -> Maybe Char 90 | charToTheRight zipper 91 | | null (getText zipper) = Nothing 92 | | otherwise = 93 | let 94 | (row, col) = cursorPosition zipper 95 | content = getText zipper 96 | curLine = content !! row 97 | numLines = length content 98 | in 99 | if row == numLines - 1 && col == (TZ.length curLine) then 100 | Nothing -- very end 101 | else if col == (TZ.length curLine) then 102 | Just '\n' -- simulate newline 103 | else 104 | Just (TZ.toList curLine !! col) 105 | -------------------------------------------------------------------------------- /src/Data/Text/Zipper/Vector.hs: -------------------------------------------------------------------------------- 1 | module Data.Text.Zipper.Vector 2 | ( vecLines 3 | ) 4 | where 5 | 6 | import qualified Data.Vector as V 7 | 8 | vecLines :: V.Vector Char -> [V.Vector Char] 9 | vecLines v | V.null v = [] 10 | | otherwise = case V.elemIndex '\n' v of 11 | Nothing -> [v] 12 | Just i -> let (h, t) = V.splitAt i v 13 | in h : vecLines t 14 | 15 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /tests/WordsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module WordsSpec (spec) where 5 | 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | 9 | import Data.Char 10 | 11 | import Data.Text.Zipper 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Data.Text.Zipper.Generic.Words 15 | 16 | spec :: Spec 17 | spec = do 18 | constructorSpec 19 | insertCharSpec 20 | insertManySpec 21 | moveWordLeftSpec 22 | moveWordRightSpec 23 | deletePrevWordSpec 24 | deleteWordSpec 25 | 26 | constructorSpec :: Spec 27 | constructorSpec = describe "constructor" $ do 28 | it "inserts only printable characters at construction time" $ 29 | (stringZipper ["abc\x1b def"] Nothing) `shouldBe` (stringZipper ["abc def"] Nothing) 30 | 31 | insertCharSpec :: Spec 32 | insertCharSpec = describe "insertChar" $ do 33 | it "ignores an insert of a non-printable character" $ 34 | let z = stringZipper [] Nothing 35 | in (insertChar '\x1b' z) `shouldBe` z 36 | 37 | insertManySpec :: Spec 38 | insertManySpec = describe "insertMany" $ do 39 | it "ignores an insert of a non-printable character" $ 40 | let z = stringZipper ["abc"] Nothing 41 | in (insertMany "ghi\x1bjkl" z) `shouldBe` (insertMany "ghijkl" z) 42 | 43 | moveWordLeftSpec :: Spec 44 | moveWordLeftSpec = describe "moveWordLeft" $ do 45 | it "does nothing at the start of the text" $ 46 | moveWordLeft (zipLoc ["foo bar"] (0, 0)) `isAt` (0, 0) 47 | 48 | it "moves from middle of the word to the start" $ 49 | moveWordLeft (zipLoc ["foo barfoo"] (0, 7)) `isAt` (0, 4) 50 | 51 | it "moves from end to beginning" $ 52 | moveWordLeft (zipLoc ["barfoo"] (0, 6)) `isAt` (0, 0) 53 | 54 | it "stops at beginning of line if word boundary" $ 55 | moveWordLeft (zipLoc ["foo", "bar"] (1, 2)) `isAt` (1, 0) 56 | 57 | it "moves across lines from beginning of line" $ 58 | moveWordLeft (zipLoc ["foo", "bar"] (1, 0)) `isAt` (0, 0) 59 | 60 | it "skips multiple space characters" $ 61 | moveWordLeft (zipLoc ["foo bar"] (0, 6)) `isAt` (0, 0) 62 | 63 | it "skips multiple space characters across lines" $ 64 | moveWordLeft (zipLoc ["foo ", " bar"] (1, 1)) `isAt` (0, 0) 65 | 66 | it "always lands on the start of a word" $ property $ \(textlist :: [Text]) cursor -> 67 | isAtWordStart (moveWordLeft (zipLoc textlist cursor)) 68 | 69 | moveWordRightSpec :: Spec 70 | moveWordRightSpec = describe "moveWordRight" $ do 71 | it "does nothing at the end of the text" $ 72 | moveWordRight (zipLoc ["foo bar"] (0, 7)) `isAt` (0, 7) 73 | 74 | it "moves from middle of the word to its end" $ 75 | moveWordRight (zipLoc ["barfoo foo"] (0, 2)) `isAt`(0, 6) 76 | 77 | it "moves from beginning to end" $ 78 | moveWordRight (zipLoc ["barfoo"] (0, 0)) `isAt` (0, 6) 79 | 80 | it "stops at end of line if word boundary" $ 81 | moveWordRight (zipLoc ["foo", "bar"] (0, 1)) `isAt` (0, 3) 82 | 83 | it "moves across lines from end of line" $ 84 | moveWordRight (zipLoc ["foo", "bar"] (0, 3)) `isAt` (1, 3) 85 | 86 | it "skips multiple space characters" $ 87 | moveWordRight (zipLoc ["foo bar"] (0, 4)) `isAt` (0, 10) 88 | 89 | it "skips multiple space characters across lines" $ 90 | moveWordRight (zipLoc ["foo ", " bar"] (0, 4)) `isAt` (1, 5) 91 | 92 | it "always lands at the end of a word" $ property $ \(textlist :: [Text]) cursor -> 93 | isAtWordEnd (moveWordRight (zipLoc textlist cursor)) 94 | 95 | deletePrevWordSpec :: Spec 96 | deletePrevWordSpec = describe "deletePrevWord" $ do 97 | it "does the same cursor movement as moveWordLeft" $ property $ \(textlist :: [Text]) cursor -> 98 | let zip = zipLoc textlist cursor 99 | in deletePrevWord zip `isAt` (cursorPosition (moveWordLeft zip)) 100 | 101 | it "has the same prefix than moveWordLeft" $ property $ \textlist cursor -> 102 | let zip = zipLoc textlist cursor 103 | in deleteToEnd (deletePrevWord zip) === deleteToEnd (moveWordLeft zip) 104 | 105 | it "has the same suffix than before" $ property $ \textlist cursor -> 106 | let zip = zipLoc textlist cursor 107 | in deleteToBeginning (deletePrevWord zip) === deleteToBeginning zip 108 | 109 | deleteWordSpec :: Spec 110 | deleteWordSpec = describe "deleteWord" $ do 111 | it "does no cursor movement" $ property $ \textlist cursor -> 112 | let zip = zipLoc textlist cursor 113 | in deleteWord zip `isAt` cursorPosition zip 114 | 115 | it "has the same prefix than before" $ property $ \textlist cursor -> 116 | let zip = zipLoc textlist cursor 117 | in deleteToEnd (deleteWord zip) === deleteToEnd zip 118 | 119 | it "has the same suffix than moveWordRight" $ property $ \textlist cursor -> 120 | let zip = zipLoc textlist cursor 121 | in deleteToBeginning (deleteWord zip) === deleteToBeginning (moveWordRight zip) 122 | 123 | -- Helpers 124 | 125 | -- | Creates a zipper with initial content and cursor location 126 | zipLoc :: [Text] -> (Int, Int) -> TextZipper Text 127 | zipLoc content location = moveCursor location $ textZipper content Nothing 128 | 129 | -- | Set the expectation that the given zipper is at the given cursor 130 | -- location 131 | isAt :: TextZipper a -> (Int, Int) -> Expectation 132 | isAt zipper loc = cursorPosition zipper `shouldBe` loc 133 | 134 | isAtWordEnd :: TextZipper Text -> Property 135 | isAtWordEnd zipper = counterexample (show zipper) $ 136 | let 137 | (row, col) = cursorPosition zipper 138 | numLines = length (getText zipper) 139 | curLine = currentLine zipper 140 | in 141 | (col == T.length curLine && row == numLines - 1) 142 | || ((col == T.length curLine || isSpace (T.index curLine col)) -- next is space 143 | && (col == 0 || not (isSpace (T.index curLine (col-1))))) -- previous is word 144 | 145 | isAtWordStart :: TextZipper Text -> Property 146 | isAtWordStart zipper = counterexample (show zipper) $ 147 | let 148 | (row, col) = cursorPosition zipper 149 | curLine = currentLine zipper 150 | in 151 | (row == 0 && col == 0) 152 | || ((col == 0 || isSpace (T.index curLine (col-1))) -- previous is space 153 | && (col == T.length curLine || not (isSpace (T.index curLine col)))) -- next is word 154 | 155 | -- | Delete to the very end of a zipper 156 | deleteToEnd :: TextZipper Text -> TextZipper Text 157 | deleteToEnd zipper = 158 | let 159 | (row, _) = cursorPosition zipper 160 | numLines = length (getText zipper) 161 | in 162 | if row == numLines-1 then 163 | killToEOL zipper 164 | else 165 | deleteToEnd (deleteChar (killToEOL zipper)) 166 | 167 | deleteToBeginning :: TextZipper Text -> TextZipper Text 168 | deleteToBeginning zipper = case cursorPosition zipper of 169 | (0, _) -> killToBOL zipper 170 | _ -> deleteToBeginning (deletePrevChar (killToBOL zipper)) 171 | 172 | instance Arbitrary Text where 173 | arbitrary = do 174 | ls <- lines <$> arbitrary 175 | return $ T.pack $ case ls of 176 | (l:_) -> l 177 | _ -> mempty 178 | -------------------------------------------------------------------------------- /text-zipper.cabal: -------------------------------------------------------------------------------- 1 | name: text-zipper 2 | version: 0.13 3 | synopsis: A text editor zipper library 4 | description: This library provides a zipper and API for editing text. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Jonathan Daugherty 8 | maintainer: cygnus@foobox.com 9 | copyright: (c) 2015 Jonathan Daugherty 10 | category: Text 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | data-files: CHANGELOG.md 14 | homepage: https://github.com/jtdaugherty/text-zipper/ 15 | bug-reports: https://github.com/jtdaugherty/text-zipper/issues 16 | 17 | Source-Repository head 18 | type: git 19 | location: git://github.com/jtdaugherty/text-zipper.git 20 | 21 | library 22 | exposed-modules: 23 | Data.Text.Zipper 24 | Data.Text.Zipper.Generic 25 | Data.Text.Zipper.Generic.Words 26 | 27 | other-modules: 28 | Data.Text.Zipper.Vector 29 | 30 | build-depends: base < 5, 31 | text, 32 | vector, 33 | deepseq 34 | ghc-options: -Wall 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | 38 | test-suite text-zipper-tests 39 | type: exitcode-stdio-1.0 40 | hs-source-dirs: tests 41 | main-is: Main.hs 42 | other-modules: WordsSpec 43 | default-language: Haskell2010 44 | build-tool-depends: hspec-discover:hspec-discover 45 | build-depends: base, 46 | text, 47 | hspec, 48 | QuickCheck, 49 | text-zipper 50 | --------------------------------------------------------------------------------