module Data.Rope.Internal
( Rope(..)
, cons8
, empty
, fromChunks
, fromByteString
, fromLazyByteString
, fromString
, fromWords
, fromChar
, fromWord8
, length
, null
, body
, toChunks
, toLazyByteString
, Annotation(..)
, elide
, splitAt
, take
, drop
, uncons8
, unsnoc8
, w2c
, Packable(..)
, break8
, findIndexOrEnd
) where
import Prelude hiding (length, foldl, null, length, splitAt, take, drop, fst, snd)
import Control.Applicative hiding (empty)
import Control.Monad.Writer.Class (MonadWriter, tell, pass, listen)
import Data.Data (Data(..), DataType, Constr, Fixity(..), mkConstr, mkDataType, constrIndex, gcast1)
import Data.Typeable (TyCon, Typeable1(..), mkTyCon, mkTyConApp)
import Data.FingerTree (ViewL(..),ViewR(..),viewl,viewr,(<|),(|>), Measured(..), (><))
import qualified Data.FingerTree as F (empty, split, null, singleton)
import Data.Foldable (Foldable, foldl)
import qualified Data.Foldable as F
import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Data.Monoid
import Data.Rope.Body
import Data.Rope.Util.Comonad
import Data.Rope.Util.Reducer (Reducer, cons, snoc, unit)
import Data.Rope.Util.Product
import Data.Word (Word8)
import GHC.Base (unsafeChr)
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable (peek)
import qualified Data.ByteString as S (null, splitAt, take, drop, length, singleton)
import Data.ByteString.Internal (ByteString(..), inlinePerformIO)
import qualified Data.ByteString.Unsafe as S (unsafeTail, unsafeHead)
import qualified Data.ByteString.UTF8 as U
import qualified Data.ByteString.Lazy as L (ByteString, pack, fromChunks, drop, take, splitAt, toChunks)
import qualified Data.ByteString.Lazy.UTF8 as LU
data Rope a = Rope !Body a
deriving (Show)
body :: Rope a -> Body
body (Rope b _) = b
instance Monoid a => Monoid (Rope a) where
mempty = empty
Rope t m `mappend` Rope t' m' = Rope (t >< t') (m `mappend` m')
instance Eq a => Eq (Rope a) where
a == b = measure (body a) == measure (body b)
&& toLazyByteString a == toLazyByteString b
&& extract a == extract b
instance Measured Count (Rope a) where
measure (Rope m _) = measure m
instance Functor Rope where
fmap f (Rope b a) = Rope b (f a)
instance Applicative Rope where
pure = Rope mempty
Rope m f <*> Rope m' a = Rope (m `mappend` m') (f a)
instance Monad Rope where
return = Rope mempty
Rope m a >>= f = let Rope m' b = f a in Rope (m `mappend` m') b
instance MonadWriter (Rope ()) Rope where
tell (Rope m _) = Rope m ()
listen (Rope m a) = Rope m (a, Rope m ())
pass (Rope m (a,f)) = Rope (body (f (Rope m ()))) a
instance Comonad Rope where
extract (Rope _ a) = a
duplicate (Rope b a) = Rope b (Rope b a)
extend f r = Rope (body r) (f r)
instance Foldable Rope where
foldr f z (Rope _ a) = f a z
foldr1 _ (Rope _ a) = a
foldl f z (Rope _ a) = f z a
foldl1 _ (Rope _ a) = a
foldMap f (Rope _ a) = f a
instance Traversable Rope where
traverse f (Rope b a) = Rope b <$> f a
empty :: Monoid m => Rope m
empty = Rope F.empty mempty
fromChunks :: (ByteString `Reducer` m) => [ByteString] -> Rope m
fromChunks = foldr (\l (Rope t m) -> Rope (l `cons'` t) (l `cons` m)) mempty
toChunks :: Rope m -> [ByteString]
toChunks r = unchunk <$> F.toList (body r)
toLazyByteString :: Rope m -> L.ByteString
toLazyByteString = L.fromChunks . toChunks
length :: Rope m -> Int
length = measureBody . body
null :: Rope m -> Bool
null = F.null . body
fromByteString :: (ByteString `Reducer` m) => ByteString -> Rope m
fromByteString b | S.null b = mempty
| otherwise = Rope (F.singleton (Chunk b)) (unit b)
fromLazyByteString :: (ByteString `Reducer` m) => L.ByteString -> Rope m
fromLazyByteString = foldr (\l (Rope t m) -> Rope (Chunk l <| t) (l `cons` m)) mempty . L.toChunks
fromString :: (ByteString `Reducer` m) => String -> Rope m
fromString = fromLazyByteString . LU.fromString
fromWords :: (ByteString `Reducer` m) => [Word8] -> Rope m
fromWords = fromLazyByteString . L.pack
fromChar :: (ByteString `Reducer` m) => Char -> Rope m
fromChar c = Rope (F.singleton (Chunk b)) (unit b)
where b = U.fromString [c]
fromWord8 :: (ByteString `Reducer` m) => Word8 -> Rope m
fromWord8 b = Rope (F.singleton (Chunk s)) (unit s)
where s = S.singleton b
cons8 :: (ByteString `Reducer` m) => Word8 -> Rope m -> Rope m
cons8 a (Rope t m) = case viewl t of
Chunk c :< cs | S.length c < 16 -> Rope (Chunk (mappend b c) <| cs) (cons b m)
_ -> Rope (Chunk b <| t) (cons b m)
where b = S.singleton a
instance (Annotation a, Data a) => Data (Rope a) where
gfoldl f z r = case uncons8 r of
Nothing -> z empty
Just (x,xs) -> z cons8 `f` x `f` xs
gunfold k z c = case constrIndex c of
1 -> z empty
2 -> k (k (z cons8))
_ -> error "gunfoldl"
toConstr xs
| null xs = emptyConstr
| otherwise = consConstr
dataTypeOf _ = ropeDataType
dataCast1 f = gcast1 f
emptyConstr, consConstr :: Constr
emptyConstr = mkConstr ropeDataType "empty" [] Prefix
consConstr = mkConstr ropeDataType "`cons`" [] Infix
ropeDataType :: DataType
ropeDataType = mkDataType "Data.Rope.Internal.Rope" [emptyConstr, consConstr]
ropeTc :: TyCon
ropeTc = mkTyCon "Rope"
instance Typeable1 Rope where
typeOf1 _ = mkTyConApp ropeTc []
class (ByteString `Reducer` a) => Annotation a where
elide' :: Int -> Int -> Rope a -> a
splitAt' :: Int -> Rope a -> (a, a)
take' :: Int -> Rope a -> a
take' n = fst . splitAt' n
drop' :: Int -> Rope a -> a
drop' n = snd . splitAt' n
elide :: Annotation a => Int -> Int -> Rope a -> Rope a
elide f l = elide' f l . duplicate
splitAt :: Annotation a => Int -> Rope a -> (Rope a, Rope a)
splitAt n = splitAt' n . duplicate
take :: Annotation a => Int -> Rope a -> Rope a
take n = take' n . duplicate
drop :: Annotation a => Int -> Rope a -> Rope a
drop n = drop' n . duplicate
instance Annotation () where
elide' _ _ _ = ()
splitAt' _ _ = ((),())
take' _ _ = ()
drop' _ _ = ()
instance (Annotation a, Annotation b) => Annotation (a, b) where
elide' x y = bothC (elide' x y) (elide' x y)
splitAt' x (Rope t (a,b)) = ((a',b'),(a'',b'')) where
(a',a'') = splitAt' x (Rope t a)
(b',b'') = splitAt' x (Rope t b)
take' x = bothC (take' x) (take' x)
drop' x = bothC (drop' x) (drop' x)
instance (Annotation a, Annotation b) => Annotation (a :*: b) where
elide' x y = bothC (elide' x y) (elide' x y)
splitAt' x (Rope t (a :*: b)) = ((a' :*: b'),(a'' :*: b'')) where
(a',a'') = splitAt' x (Rope t a)
(b',b'') = splitAt' x (Rope t b)
take' x = bothC (take' x) (take' x)
drop' x = bothC (drop' x) (drop' x)
instance Annotation ByteString where
elide' = undefined
splitAt' n rb = S.splitAt n (extract rb)
take' n rb = S.take n (extract rb)
drop' n rb = S.drop n (extract rb)
instance Annotation L.ByteString where
elide' = undefined
splitAt' n rb = L.splitAt (fromIntegral n) (extract rb)
take' n rb = L.take (fromIntegral n) (extract rb)
drop' n rb = L.drop (fromIntegral n) (extract rb)
instance Annotation Body where
elide' = undefined
splitAt' 0 rf = (mempty, extract rf)
splitAt' n rf
| n >= measureBody f = (f, mempty)
| otherwise = (x `snoc'` y', y'' `cons'` z)
where
f = extract rf
(x,yz) = F.split (> Count n) (extract rf)
Chunk y :< z = viewl yz
(y', y'') = S.splitAt (n measureBody x) y
instance Annotation a => Annotation (Rope a) where
elide' = undefined
splitAt' n rra = (Rope t a, Rope t' a') where
(t,t') = splitAt' n (body <$> rra)
(a,a') = splitAt' n (extract rra)
break8 :: Annotation m => (Word8 -> Bool) -> Rope m -> (Rope m, Rope m)
break8 f r = (Rope t' a', Rope t'' a'')
where
(t',t'') = break' (body r)
(a',a'') = splitAt' (measureBody t') r
break' ccs = case viewl ccs of
EmptyL -> (F.empty, F.empty)
Chunk c :< cs -> case findIndexOrEnd f c of
0 -> (F.empty, ccs)
n | n < S.length c -> (F.singleton (Chunk (S.take n c)), Chunk (S.drop n c) <| cs)
| otherwise -> let (cs', cs'') = break' cs
in (Chunk c <| cs', cs'')
findIndexOrEnd :: (Word8 -> Bool) -> ByteString -> Int
findIndexOrEnd k (PS x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
where
go ptr n | ptr `seq` n `seq` False = undefined
| n >= l = return l
| otherwise = do w <- peek ptr
if k w
then return n
else go (ptr `plusPtr` 1) (n+1)
uncons8 :: Annotation m => Rope m -> Maybe (Word8, Rope m)
uncons8 r = case viewl (body r) of
Chunk c :< cs -> Just (S.unsafeHead c, Rope (S.unsafeTail c `cons'` cs) (drop' 1 r))
_ -> Nothing
unsnoc8 :: Annotation m => Rope m -> Maybe (Rope m, Word8)
unsnoc8 r = case viewr (body r) of
cs :> Chunk c -> Just (Rope (cs `snoc'` S.unsafeTail c) (take' (length r 1) r), S.unsafeHead c)
_ -> Nothing
w2c :: Word8 -> Char
w2c = unsafeChr . fromIntegral
class Packable a where
pack :: Annotation m => a -> Rope m
packl :: Annotation m => a -> Rope m -> Rope m
packr :: Annotation m => Rope m -> a -> Rope m
packl a r = pack a `mappend` r
packr r a = r `mappend` pack a
instance Packable Char where
pack = fromChar
packl a (Rope t m) = case viewl t of
Chunk c :< cs | S.length c < 16 -> Rope (Chunk (mappend b c) <| cs) (cons b m)
_ -> Rope (Chunk b <| t) (cons b m)
where b = U.fromString [a]
packr (Rope t m) a = case viewr t of
cs :> Chunk c | S.length c < 16 -> Rope (cs |> Chunk (mappend c b)) (snoc m b)
_ -> Rope (t |> Chunk b) (snoc m b)
where b = U.fromString [a]
instance Packable Word8 where
pack = fromWord8
packl = cons8
packr (Rope t m) a = case viewr t of
cs :> Chunk c | S.length c < 16 -> Rope (cs |> Chunk (mappend c b)) (snoc m b)
_ -> Rope (t |> Chunk b) (snoc m b)
where b = S.singleton a
instance Annotation n => Packable (Rope n) where
pack (Rope t _) = Rope t (foldl (\a b -> a `snoc` unchunk b) mempty t)
instance Packable String where
pack = fromString
instance Packable [Word8] where
pack = fromWords
instance Packable ByteString where
pack = fromByteString
instance Packable L.ByteString where
pack = fromLazyByteString
instance Packable Chunk where
pack = fromByteString . unchunk
instance (Packable a, Annotation m) => Reducer a (Rope m) where
unit = pack
cons = packl
snoc = packr