From db29f6d193988ebef66ecabdead0fd8f2ed3087d Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Tue, 26 Nov 2019 21:24:25 +0100
Subject: Use Sequence-based string in VM; 50% faster lispparser.lisp

---
 DString.hs | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 71 insertions(+)
 create mode 100644 DString.hs

(limited to 'DString.hs')

diff --git a/DString.hs b/DString.hs
new file mode 100644
index 0000000..042ed09
--- /dev/null
+++ b/DString.hs
@@ -0,0 +1,71 @@
+-- | Some kind of dynamic string, or dequeue string, if you like, that
+-- supports efficient concatenation on both sides if you don't make your
+-- chunks too weird.
+module DString (
+    DString,
+    pack, unpack, singleton, length, take, drop, null, head, concat, hPutStr
+) where
+
+import Prelude hiding (length, take, drop, null, head, concat)
+
+import Data.Foldable (toList)
+import qualified Data.Sequence as S
+import Data.Sequence (ViewL((:<)))
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.IO as T
+import System.IO (Handle)
+
+
+newtype DString = DString (S.Seq T.Text)
+  deriving (Show)
+
+instance Eq DString where
+    DString s == DString s' = T.concat (toList s) == T.concat (toList s')
+
+pack :: String -> DString
+pack s = DString (S.singleton (T.pack s))
+
+unpack :: DString -> String
+unpack (DString s) = T.unpack (T.concat (toList s))
+
+singleton :: Char -> DString
+singleton c = DString (S.singleton (T.singleton c))
+
+length :: DString -> Int
+length (DString s) = fromIntegral (sum (map T.length (toList s)))
+
+take :: Int -> DString -> DString
+take n (DString s) =
+    let n' = fromIntegral n
+        lens = S.scanl (\acc t -> acc + T.length t) 0 s
+        ndigits = S.length (S.takeWhileL (< n') lens) + 1
+        text = T.take n' (T.concat (toList (S.take ndigits s)))
+    in DString (S.singleton text)
+
+drop :: Int -> DString -> DString
+drop n (DString s)
+    | n <= 0 = DString s
+    | otherwise =
+        let n' = fromIntegral n
+            lens = S.scanl (\acc text -> acc + T.length text) 0 s
+            ndigits = S.length (S.takeWhileL (< n') lens) - 1
+            s' = S.drop ndigits s
+            remain = n' - (lens `S.index` ndigits)
+            s'' = case S.viewl s' of
+                      S.EmptyL -> S.empty
+                      text :< rest -> T.drop remain text S.<| rest
+        in DString s''
+
+null :: DString -> Bool
+null (DString s) = sum (map T.length (toList s)) == 0
+
+head :: DString -> Char
+head (DString s) = case S.viewl s of
+                       S.EmptyL -> error "Empty DString in DString.head"
+                       text :< rest -> if T.length text > 0 then T.head text else DString.head (DString rest)
+
+concat :: [DString] -> DString
+concat strs = DString (mconcat [s | DString s <- strs])
+
+hPutStr :: Handle -> DString -> IO ()
+hPutStr h (DString s) = mapM_ (T.hPutStr h) (toList s)
-- 
cgit v1.2.3-54-g00ecf