packages feed

rope-utf16-splay (empty) → 0.1.0.0

raw patch · 10 files changed

+640/−0 lines, 10 filesdep +QuickCheckdep +basedep +rope-utf16-splaysetup-changed

Dependencies added: QuickCheck, base, rope-utf16-splay, tasty, tasty-hunit, tasty-quickcheck, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Olle Fredriksson (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,7 @@+# rope-utf16-splay [![Build Status](https://travis-ci.org/ollef/rope-utf16-splay.svg?branch=master)](https://travis-ci.org/ollef/rope-utf16-splay)++Thick strings optimised for indexing and updating using UTF-16 code points and+row/column pairs.++This implementation uses splay trees instead of the usual finger trees, which+is faster according to [the benchmarks](bench.html).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rope-utf16-splay.cabal view
@@ -0,0 +1,52 @@+name:                rope-utf16-splay+version:             0.1.0.0+synopsis:            Ropes optimised for updating using UTF-16 code points and row/column pairs.+description:         This implementation uses splay trees instead of the usual+                     finger trees. According to my benchmarks, splay trees are+                     faster in most situations.+homepage:            https://github.com/ollef/rope-utf16-splay+license:             BSD3+license-file:        LICENSE+author:              Olle Fredriksson+maintainer:          fredriksson.olle@gmail.com+copyright:           (c) 2018 Olle Fredriksson+category:            Data, Text, Language+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10+tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1++source-repository head+  type:     git+  location: https://github.com/ollef/rope-utf16-splay++library+  hs-source-dirs:      src+  exposed-modules:+                       Data.Rope.UTF16+                       Data.Rope.UTF16.Internal+                       Data.Rope.UTF16.Internal.Text+                       Data.Rope.UTF16.Position+                       Data.SplayTree+  build-depends:+                       base >= 4.9 && < 5,+                       text >= 1.0+  default-language:    Haskell2010+  ghc-options:         -Wall+                       -funbox-strict-fields++test-suite tests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             Main.hs+  default-language:    Haskell2010+  ghc-options:         -Wall+  build-depends:+                       base,+                       QuickCheck,+                       rope-utf16-splay,+                       tasty,+                       tasty-hunit,+                       tasty-quickcheck,+                       text+  other-modules:
+ src/Data/Rope/UTF16.hs view
@@ -0,0 +1,31 @@+module Data.Rope.UTF16+  ( module Position+  , Rope.Rope++  -- * Conversions to and from @Text@ and @String@+  , Rope.toText+  , Rope.toLazyText+  , Rope.fromText+  , Rope.toString++  -- * Chunking+  , Rope.toChunks+  , Rope.unconsChunk+  , Rope.unsnocChunk++  -- * UTF-16 code point indexing+  , Rope.length+  , Rope.splitAt+  , Rope.take+  , Rope.drop+  , Rope.rowColumnCodePoints++  -- * Breaking by predicate+  , Rope.span+  , Rope.break+  , Rope.takeWhile+  , Rope.dropWhile+  ) where++import Data.Rope.UTF16.Position as Position+import Data.Rope.UTF16.Internal as Rope
+ src/Data/Rope/UTF16/Internal.hs view
@@ -0,0 +1,188 @@+{-# language BangPatterns #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language MultiParamTypeClasses #-}+module Data.Rope.UTF16.Internal where++import Data.Foldable+import Data.Function+import Data.Semigroup+import Data.String+import Data.Text(Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text.Unsafe as Unsafe++import Data.Rope.UTF16.Internal.Text+import Data.Rope.UTF16.Position+import Data.SplayTree(SplayTree)+import qualified Data.SplayTree as SplayTree++data Chunk = Chunk { chunkText :: !Text, chunkMeasure :: !Position }++instance Show Chunk where+  show (Chunk t _) = show t++instance Semigroup Chunk where+  Chunk t1 m1 <> Chunk t2 m2 = Chunk (t1 <> t2) (m1 <> m2)++chunk :: Text -> Chunk+chunk t = Chunk t $ Position len $ go 0 $ RowColumn 0 0+  where+    len = Unsafe.lengthWord16 t+    go i !v+      | i >= len = v+      | otherwise = case Unsafe.iter t i of+        Unsafe.Iter '\n' delta -> go (i + delta) (v <> RowColumn 1 0)+        Unsafe.Iter _ delta -> go (i + delta) (v <> RowColumn 0 delta)++instance SplayTree.Measured Position Chunk where+  measure (Chunk _ m) = m++-- | A @SplayTree@ of @Text@ values optimised for being indexed by and+-- modified at UTF-16 code points and row/column (@RowColumn@) positions.+-- Internal invariant: No empty @Chunk@s in the @SplayTree@+newtype Rope = Rope { unrope :: SplayTree Position Chunk }+  deriving (SplayTree.Measured Position, Show)++-- | The maximum length, in code points, of a chunk+chunkLength :: Int+chunkLength = 1000++-- | Append joins adjacent chunks if that can be done while staying below+-- @chunkLength@.+instance Semigroup Rope where+  Rope r1 <> Rope r2 = case (SplayTree.unsnoc r1, SplayTree.uncons r2) of+    (Nothing, _) -> Rope r2+    (_, Nothing) -> Rope r1+    (Just (r1', a), Just (b, r2'))+      | codePoints (chunkMeasure a <> chunkMeasure b) <= chunkLength+        -> Rope $ r1' <> ((a <> b) SplayTree.<| r2')+      | otherwise+        -> Rope $ r1' <> (a SplayTree.<| b SplayTree.<| r2')++instance Monoid Rope where+  mempty = Rope mempty+  mappend = (<>)++instance Eq Rope where+  (==) = (==) `on` toText++instance Ord Rope where+  compare = compare `on` toText++instance IsString Rope where+  fromString = fromText . Text.pack++-------------------------------------------------------------------------------+-- * Conversions to and from @Text@ and @String@++toText :: Rope -> Text+toText = Text.concat . toChunks++toLazyText :: Rope -> Lazy.Text+toLazyText = Lazy.fromChunks . toChunks++fromText :: Text -> Rope+fromText t+  | Text.null t = mempty+  | otherwise = Rope $ go numChunks chunks+  where+    chunks = chunks16Of chunkLength t+    numChunks = Prelude.length chunks+    go !_ [] = mempty+    go len cs = SplayTree.fork (go mid pre) (chunk c) (go (len - mid - 1) post)+      where+        (pre, c:post) = Prelude.splitAt mid cs+        mid = len `div` 2++fromShortText :: Text -> Rope+fromShortText t+  | Text.null t = mempty+  | otherwise = Rope $ SplayTree.singleton $ chunk t++toString :: Rope -> String+toString = concatMap Text.unpack . toChunks++-------------------------------------------------------------------------------+-- * Chunking++-- | The raw @Text@ data that the @Rope@ is built from+toChunks :: Rope -> [Text]+toChunks = fmap chunkText . toList . unrope++-- | Get the first chunk and the rest of the @Rope@ if non-empty+unconsChunk :: Rope -> Maybe (Text, Rope)+unconsChunk (Rope r) = case SplayTree.uncons r of+  Nothing -> Nothing+  Just (Chunk t _, r') -> Just (t, Rope r')++-- | Get the last chunk and the rest of the @Rope@ if non-empty+unsnocChunk :: Rope -> Maybe (Rope, Text)+unsnocChunk (Rope r) = case SplayTree.unsnoc r of+  Nothing -> Nothing+  Just (r', Chunk t _) -> Just (Rope r', t)++-------------------------------------------------------------------------------+-- * UTF-16 code point indexing++-- | Length in code points (not characters)+length :: Rope -> Int+length = codePoints . SplayTree.measure++-- | Split the rope at the nth code point (not character)+splitAt :: Int -> Rope -> (Rope, Rope)+splitAt n (Rope r) = case SplayTree.split ((> n) . codePoints) r of+  SplayTree.Outside+    | n < 0 -> (mempty, Rope r)+    | otherwise -> (Rope r, mempty)+  SplayTree.Inside pre (Chunk t _) post -> (Rope pre <> fromShortText pret, fromShortText postt <> Rope post)+    where+      n' = n - codePoints (SplayTree.measure pre)+      (pret, postt) = split16At n' t++-- | Take the first n code points (not characters)+take :: Int -> Rope -> Rope+take n = fst . Data.Rope.UTF16.Internal.splitAt n++-- | Drop the first n code points (not characters)+drop :: Int -> Rope -> Rope+drop n = snd . Data.Rope.UTF16.Internal.splitAt n++-- | Get the code point index in the rope that corresponds to a @RowColumn@ position+rowColumnCodePoints :: RowColumn -> Rope -> Int+rowColumnCodePoints v (Rope r) = case SplayTree.split ((> v) . rowColumn) r of+  SplayTree.Outside+    | v <= RowColumn 0 0 -> 0+    | otherwise -> codePoints $ SplayTree.measure r+  SplayTree.Inside pre (Chunk t _) _ -> go 0 $ rowColumn prePos+    where+      prePos = SplayTree.measure pre+      len = Unsafe.lengthWord16 t+      go i !v'+        | v <= v' || i >= len = codePoints prePos + i+        | otherwise = case Unsafe.iter t i of+          Unsafe.Iter '\n' delta -> go (i + delta) (v' <> RowColumn 1 0)+          Unsafe.Iter _ 2 | v == v' <> RowColumn 0 1 -> codePoints prePos + i+          Unsafe.Iter _ delta -> go (i + delta) (v' <> RowColumn 0 delta)++-------------------------------------------------------------------------------+-- * Breaking by predicate++span :: (Char -> Bool) -> Rope -> (Rope, Rope)+span f (Rope r) = case SplayTree.uncons r of+  Nothing -> (mempty, mempty)+  Just (t, r')+    | Text.null postt -> (Rope (SplayTree.singleton t) <> pre', post')+    | otherwise -> (fromShortText pret, fromShortText postt <> Rope r')+    where+      (pret, postt) = Text.span f $ chunkText t+      (pre', post') = Data.Rope.UTF16.Internal.span f $ Rope r'++break :: (Char -> Bool) -> Rope -> (Rope, Rope)+break f = Data.Rope.UTF16.Internal.span (not . f)++takeWhile :: (Char -> Bool) -> Rope -> Rope+takeWhile f = fst . Data.Rope.UTF16.Internal.span f++dropWhile :: (Char -> Bool) -> Rope -> Rope+dropWhile f = snd . Data.Rope.UTF16.Internal.span f
+ src/Data/Rope/UTF16/Internal/Text.hs view
@@ -0,0 +1,38 @@+-- | Helpers for working with @Text@ in UTF-16 code points+module Data.Rope.UTF16.Internal.Text where++import Data.Text(Text)+import qualified Data.Text.Array as Array+import qualified Data.Text.Internal as Text+import qualified Data.Text.Unsafe as Unsafe++clamp16 :: Int -> Text -> Int+clamp16 i t@(Text.Text arr off _len)+  | i <= 0 = 0+  | i >= len = len+  | isLowSurrogate = i - 1+  | otherwise = i+  where+    cp = Array.unsafeIndex arr (off + i)+    isLowSurrogate = 0xDC00 <= cp && cp <= 0xDFFF+    len = Unsafe.lengthWord16 t++take16 :: Int -> Text -> Text+take16 n t = Unsafe.takeWord16 (clamp16 n t) t++drop16 :: Int -> Text -> Text+drop16 n t = Unsafe.dropWord16 (clamp16 n t) t++split16At :: Int -> Text -> (Text, Text)+split16At n t = (Unsafe.takeWord16 n' t, Unsafe.dropWord16 n' t)+  where+    n' = clamp16 n t++chunks16Of :: Int -> Text -> [Text]+chunks16Of n t+  | len == 0 = []+  | len <= n = [t]+  | otherwise = pre : chunks16Of n post+  where+    (pre, post) = split16At n t+    len = Unsafe.lengthWord16 t
+ src/Data/Rope/UTF16/Position.hs view
@@ -0,0 +1,34 @@+module Data.Rope.UTF16.Position where++import Data.Semigroup++data RowColumn = RowColumn+  { row :: !Int -- ^ Number of newlines before this position+  , column :: !Int -- ^ Number of code points since last newline or start of string+  } deriving (Eq, Ord, Show)++instance Semigroup RowColumn where+  RowColumn 0 c1 <> RowColumn 0 c2 = RowColumn 0 $ c1 + c2+  RowColumn 0 _ <> v2 = v2+  RowColumn r1 c1 <> RowColumn 0 c2 = RowColumn r1 $ c1 + c2+  RowColumn r1 _ <> RowColumn r2 c2 = RowColumn (r1 + r2) c2++instance Monoid RowColumn where+  mempty = RowColumn 0 0+  mappend = (<>)++data Position = Position+  { codePoints :: !Int+  , rowColumn :: !RowColumn+  } deriving (Eq, Ord, Show)++lineStart :: Position -> Position+lineStart (Position cp (RowColumn r c)) = Position (cp - c) $ RowColumn r 0++instance Semigroup Position where+  Position cp1 v1 <> Position cp2 v2+    = Position (cp1 + cp2) (v1 <> v2)++instance Monoid Position where+  mempty = Position 0 mempty+  mappend = (<>)
+ src/Data/SplayTree.hs view
@@ -0,0 +1,188 @@+{-# language DeriveFoldable #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+module Data.SplayTree where++import Data.Monoid+import qualified Data.Semigroup as Semigroup++infixr 5 <|+infixl 5 |>++class Monoid v => Measured v a | a -> v where+  measure :: a -> v++data SplayTree v a+  = Leaf+  | Fork (SplayTree v a) a (SplayTree v a) !v -- ^ Cached measure of the whole node+  deriving (Eq, Ord, Show, Foldable)++instance Measured v a => Measured v (SplayTree v a) where+  {-# INLINE measure #-}+  measure Leaf = mempty+  measure (Fork _ _ _ v) = v++instance Measured v a => Semigroup.Semigroup (SplayTree v a) where+  {-# INLINE (<>) #-}+  Leaf <> t = t+  t <> Leaf = t+  Fork l1 a1 r1 lar1 <> Fork l2 a2 r2 lar2+    = Fork l1 a1 (Fork (r1 <> l2) a2 r2 (measure r1 <> lar2)) (lar1 <> lar2)++instance Measured v a => Monoid (SplayTree v a) where+  {-# INLINE mempty #-}+  mempty = Leaf+  {-# INLINE mappend #-}+  mappend = (Semigroup.<>)++-------------------------------------------------------------------------------+-- * Construction++{-# INLINE singleton #-}+singleton :: Measured v a => a -> SplayTree v a+singleton a = Fork Leaf a Leaf $ measure a++{-# INLINE (<|) #-}+(<|) :: Measured v a => a -> SplayTree v a -> SplayTree v a+(<|) = fork Leaf++{-# INLINE (|>) #-}+(|>) :: Measured v a => SplayTree v a -> a -> SplayTree v a+(|>) t a = fork t a Leaf++{-# INLINE fork #-}+fork :: Measured v a => SplayTree v a -> a -> SplayTree v a -> SplayTree v a+fork l a r = Fork l a r $ measure l <> measure a <> measure r++-------------------------------------------------------------------------------+-- * Deconstruction++{-# INLINE uncons #-}+uncons :: Measured v a => SplayTree v a -> Maybe (a, SplayTree v a)+uncons Leaf = Nothing+uncons (Fork left el right _) = Just $ go left el right+  where+    go Leaf a r = (a, r)+    go (Fork l a m _) b r = go l a (fork m b r)++{-# INLINE unsnoc #-}+unsnoc :: Measured v a => SplayTree v a -> Maybe (SplayTree v a, a)+unsnoc Leaf = Nothing+unsnoc (Fork left el right _) = Just $ go left el right+  where+    go l a Leaf = (l, a)+    go l a (Fork m b r _) = go (fork l a m) b r++data SplitResult v a+  = Outside+  | Inside (SplayTree v a) a (SplayTree v a)+  deriving (Eq, Ord, Show)++{-# INLINE split #-}+split :: Measured v a => (v -> Bool) -> SplayTree v a -> SplitResult v a+split = go mempty+  where+    go _ _ Leaf = Outside+    go v f (Fork l a r _)+      | f vl = case go v f l of+        Outside -> Outside+        Inside l' a' m -> Inside l' a' $ fork m a r+      | f vla = Inside l a r+      | otherwise = case go vla f r of+        Outside -> Outside+        Inside m a' r' -> Inside (fork l a m) a' r'+      where+        vl = v <> measure l+        vla = vl <> measure a++-------------------------------------------------------------------------------+-- * Maps++{-# INLINE map #-}+map+  :: (Measured v a, Measured w b)+  => (a -> b)+  -> SplayTree v a+  -> SplayTree w b+map _ Leaf = Leaf+map f (Fork l a r _) = fork (Data.SplayTree.map f l) (f a) (Data.SplayTree.map f r)++{-# INLINE mapWithPos #-}+mapWithPos+  :: (Measured v a, Measured w b)+  => (v -> a -> b)+  -> SplayTree v a+  -> SplayTree w b+mapWithPos f = go mempty+  where+    go _ Leaf = Leaf+    go i (Fork l a r _) = fork (go i l) (f il a) (go ila r)+      where+        il = i <> measure l+        ila = il <> measure a++{-# INLINE mapWithContext #-}+mapWithContext+  :: (Measured v a, Measured w b)+  => (v -> a -> v -> b)+  -> SplayTree v a+  -> SplayTree w b+mapWithContext f t = go mempty t mempty+  where+    go _ Leaf _ = Leaf+    go i (Fork l a r _) j = fork (go i l arj) (f il a rj) (go ila r j)+      where+        ma = measure a+        il = i <> measure l+        ila = il <> ma+        rj = measure r <> j+        arj = ma++-------------------------------------------------------------------------------+-- * Traversals++{-# INLINE traverse #-}+traverse+  :: (Measured v a, Measured w b, Applicative f)+  => (a -> f b)+  -> SplayTree v a+  -> f (SplayTree w b)+traverse _ Leaf = pure Leaf+traverse f (Fork l a r _)+  = fork+  <$> Data.SplayTree.traverse f l+  <*> f a+  <*> Data.SplayTree.traverse f r++{-# INLINE traverseWithPos #-}+traverseWithPos+  :: (Measured v a, Measured w b, Applicative f)+  => (v -> a -> f b)+  -> SplayTree v a+  -> f (SplayTree w b)+traverseWithPos f = go mempty+  where+    go _ Leaf = pure Leaf+    go i (Fork l a r _)+      = fork <$> go i l <*> f il a <*> go ila r+      where+        il = i <> measure l+        ila = il <> measure a++{-# INLINE traverseWithContext #-}+traverseWithContext+  :: (Measured v a, Measured w b, Applicative f)+  => (v -> a -> v -> f b)+  -> SplayTree v a+  -> f (SplayTree w b)+traverseWithContext f t = go mempty t mempty+  where+    go _ Leaf _ = pure Leaf+    go i (Fork l a r _) j+      = fork <$> go i l arj <*> f il a rj <*> go ila r j+      where+        ma = measure a+        il = i <> measure l+        ila = il <> ma+        rj = measure r <> j+        arj = ma
+ tests/Main.hs view
@@ -0,0 +1,70 @@+module Main where++import Data.Semigroup+import qualified Data.Text as Text+import qualified Data.Text.Unsafe as Unsafe+import Test.QuickCheck.Function as QC+import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.Rope.UTF16 as Rope+import qualified Data.Rope.UTF16.Internal.Text as Rope++main :: IO ()+main = defaultMain $ testGroup "Tests"+  [ testProperty "toText . fromText = id" $ \s -> do+    let t = Text.pack s+    Rope.toText (Rope.fromText t) == t++  , testProperty "append matches Text" $ \s1 s2 -> do+    let t1 = Text.pack s1+        t2 = Text.pack s2+    Rope.toText (Rope.fromText t1 <> Rope.fromText t2) == t1 <> t2++  , testProperty "length is UTF-16 code points" $ \s -> do+    let t = Text.pack s+    Rope.length (Rope.fromText t) == Unsafe.lengthWord16 t++  , testProperty "splitAt matches Text" $ \s i -> do+    let t = Text.pack s+        (r1, r2) = Rope.splitAt i $ Rope.fromText t+    (Rope.toText r1, Rope.toText r2) == Rope.split16At i t++  , testProperty "take matches Text" $ \s i -> do+    let t = Text.pack s+    Rope.toText (Rope.take i $ Rope.fromText t) == Rope.take16 i t++  , testProperty "drop matches Text" $ \s i -> do+    let t = Text.pack s+    Rope.toText (Rope.drop i $ Rope.fromText t) == Rope.drop16 i t++  , testProperty "rowColumnCodePoints first line" $ \s i -> do+    let t = Text.pack $ takeWhile (/= '\n') s+    Rope.clamp16 i t == Rope.rowColumnCodePoints (Rope.RowColumn 0 i) (Rope.fromText t)++  , testProperty "rowColumnCodePoints subsequent lines" $ \s (NonNegative newlines) (NonNegative i) -> do+    let t = Text.pack $ replicate newlines '\n' ++ takeWhile (/= '\n') s+    Rope.clamp16 (newlines + i) t == Rope.rowColumnCodePoints (Rope.RowColumn newlines i) (Rope.fromText t)++  , testProperty "span matches Text" $ \s p -> do+    let t = Text.pack s+        f = QC.applyFun p+        (r1, r2) = Rope.span f $ Rope.fromText t+    (Rope.toText r1, Rope.toText r2) == Text.span f t++  , testProperty "break matches Text" $ \s p -> do+    let t = Text.pack s+        f = QC.applyFun p+        (r1, r2) = Rope.break f $ Rope.fromText t+    (Rope.toText r1, Rope.toText r2) == Text.break f t++  , testProperty "takeWhile matches Text" $ \s p -> do+    let t = Text.pack s+        f = QC.applyFun p+    Rope.toText (Rope.takeWhile f $ Rope.fromText t) == Text.takeWhile f t++  , testProperty "dropWhile matches Text" $ \s p -> do+    let t = Text.pack s+        f = QC.applyFun p+    Rope.toText (Rope.dropWhile f $ Rope.fromText t) == Text.dropWhile f t+  ]