packages feed

rope (empty) → 0.1

raw patch · 12 files changed

+1111/−0 lines, 12 filesdep +basedep +bytestringdep +fingertreesetup-changed

Dependencies added: base, bytestring, fingertree, mtl, utf8-string

Files

+ Data/Rope.hs view
@@ -0,0 +1,60 @@+module Data.Rope +    ( +    -- * Size+      Rope+    , length    -- :: Rope m -> Int+    , null      -- :: Rope m -> Bool+    -- * Splicing+    , Reducer(..)+    -- * Slicing+    , Annotation(..)+    , elide     -- :: Annotation m => Int -> Int -> Rope m -> Rope m+    , splitAt   -- :: Annotation m => Int -> Rope m -> (Rope m, Rope m)+    , take      -- :: Annotation m => Int -> Rope m -> Rope m+    , drop      -- :: Annotation m => Int -> Rope m -> Rope m+    -- * Walking+    , Unpackable(..)+    -- * Packing 'Rope'+    -- ** Polymorphic construction+    , Packable(..)+    -- ** Explicit construction+    , empty              -- :: Monoid m => Rope m+    , fromByteString     -- :: Annotation m => ByteString -> Rope m+    , fromChunks         -- :: Annotation m => [ByteString] -> Rope m+    , fromLazyByteString -- :: Annotation m => L.ByteString -> Rope m+    , fromWords          -- :: Annotation m => [Word8] -> Rope m+    , fromChar           -- :: Annotation m => Char -> Rope m+    , fromWord8          -- :: Annotation m => Word8 -> Rope m+    , fromString         -- :: Annotation m => String -> Rope m+    -- * Deconstructing 'Rope's+    , toChunks           -- :: Rope m -> [ByteString]+    , toLazyByteString   -- :: Rope m -> L.ByteString+    , toString           -- :: Rope m -> String+    ) where++import Prelude hiding (null,head,length,drop,take,splitAt, last)+import Data.Rope.Internal +    ( Rope+    , empty+    , length+    , null+    , fromChunks+    , fromByteString+    , fromLazyByteString+    , fromWords+    , fromChar+    , fromWord8+    , fromString+    , toLazyByteString+    , Packable(..)+    , Annotation(..)+    , elide, splitAt, take, drop)+import Data.Rope.Unpackable (Unpackable(..))+import Data.Rope.Util.Reducer (Reducer(..))+import Data.ByteString (ByteString)++toString :: Rope m -> String+toString = unpack++toChunks :: Rope m -> [ByteString]+toChunks = unpack
+ Data/Rope/Body.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances #-}+module Data.Rope.Body+    ( Body+    , Count(..)+    , Chunk(..)+    , measureBody+    , cons'+    , snoc'+    ) where++import Prelude hiding (null, length)+import Data.FingerTree (FingerTree,(<|),(|>),Measured,measure,empty, singleton)+import Data.Data+import Data.Typeable+import Data.Monoid+import Data.Rope.Util.Reducer+import Data.ByteString (ByteString, null, length)++newtype Count = Count { getCount :: Int } deriving (Eq,Ord,Num,Show,Read,Enum,Data,Typeable)++instance Monoid Count where+    mempty = 0+    mappend = (+)++newtype Chunk = Chunk { unchunk :: ByteString } deriving (Eq,Ord,Show,Read,Data,Typeable)++instance Measured Count Chunk where+    measure = Count . length . unchunk++type Body = FingerTree Count Chunk ++measureBody :: Measured Count a => FingerTree Count a -> Int+measureBody = getCount . measure++cons' :: ByteString -> Body -> Body+b `cons'` t | null b = t+            | otherwise = Chunk b <| t++snoc' :: Body -> ByteString -> Body+t `snoc'` b | null b = t+            | otherwise = t |> Chunk b++instance Reducer ByteString Body where+    unit b | null b = empty+           | otherwise = singleton (Chunk b)+    cons = cons'+    snoc = snoc'
+ Data/Rope/Internal.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, UndecidableInstances, TypeOperators #-}+module Data.Rope.Internal+    ( Rope(..)+    -- * Construction+    , cons8                 -- :: (ByteString `Reducer` m) => Word8 -> Rope m -> Rope m+    , empty                 -- :: Monoid m => Rope m +    , fromChunks            -- :: (ByteString `Reducer` m) => [ByteString] -> Rope m+    , fromByteString        -- :: (ByteString `Reducer` m) => ByteString -> Rope m +    , fromLazyByteString    -- :: (ByteString `Reducer` m) => L.ByteString -> Rope m +    , fromString            -- :: (ByteString `Reducer` m) => String -> Rope m+    , fromWords             -- :: (ByteString `Reducer` m) => [Word8] -> Rope m+    , fromChar              -- :: (ByteString `Reducer` m) => Char -> Rope m+    , fromWord8             -- :: (ByteString `Reducer` m) => Word8 -> Rope m+    -- * Analysis+    , length                -- :: Rope m -> Int+    , null                  -- :: Rope m -> Bool+    , body                  -- :: Rope a -> Body+    -- * Deconstruction+    , toChunks              -- :: Rope m -> [S.ByteString]+    , toLazyByteString      -- :: Rope m -> L.ByteString+    -- * Cutting +    , Annotation(..)+    , elide+    , splitAt+    , take+    , drop+    , uncons8+    , unsnoc8+    , w2c+    -- * Pasting+    , 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.Bifunctor+import Data.Rope.Util.Comonad+import Data.Rope.Util.Reducer (Reducer, cons, snoc, unit)+import Data.Rope.Util.Product+-- import Data.Rope.Util.Coproduct++import Data.Word (Word8)++-- import Codec.Binary.UTF8.Generic (UTF8Bytes)+-- import qualified Codec.Binary.UTF8.Generic as UTF8Bytes++import GHC.Base (unsafeChr)+-- import GHC.IOBase+-- import GHC.Ptr (Ptr(..))++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.Char8 as SC (pack)+import qualified Data.ByteString.Lazy as L (ByteString, pack, fromChunks, drop, take, splitAt, toChunks)+import qualified Data.ByteString.Lazy.UTF8 as LU++-- a Buffer is a fingertree of non-empty chunks+data Rope a = Rope !Body a+    deriving (Show)++body :: Rope a -> Body+body (Rope b _) = b+{-# INLINE body #-}++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)++-- monadic and applicative rope actions build up a fingertree as a result, and can be used like a fast string writer+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++-- on the other hand, the context-comonadic actions on ropes can be used to provide slicing of annotated ropes+-- however, these two structures are largely unrelated, so make sure you know the purpose of your rope!++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+{-# INLINE fromChunks #-}++toChunks :: Rope m -> [ByteString]+toChunks r = unchunk <$> F.toList (body r)+{-# INLINE toChunks #-}++toLazyByteString :: Rope m -> L.ByteString+toLazyByteString = L.fromChunks . toChunks+{-# INLINE toLazyByteString #-}++length :: Rope m -> Int+length = measureBody . body+{-# INLINE length #-}++null :: Rope m -> Bool+null = F.null . body+{-# INLINE null #-}++fromByteString :: (ByteString `Reducer` m) => ByteString -> Rope m +fromByteString b | S.null b = mempty +                 | otherwise = Rope (F.singleton (Chunk b)) (unit b)+{-# INLINE fromByteString #-}++-- NB this requires a strict bytestring reducer, but a lazy bytestring+fromLazyByteString :: (ByteString `Reducer` m) => L.ByteString -> Rope m +fromLazyByteString = foldr (\l (Rope t m) -> Rope (Chunk l <| t) (l `cons` m)) mempty . L.toChunks+{-# INLINE fromLazyByteString #-}++-- utf8 encode chunks of the string+fromString :: (ByteString `Reducer` m) => String -> Rope m+fromString = fromLazyByteString . LU.fromString+{-# INLINE fromString #-}++fromWords :: (ByteString `Reducer` m) => [Word8] -> Rope m+fromWords = fromLazyByteString . L.pack+{-# INLINE fromWords #-}++fromChar :: (ByteString `Reducer` m) => Char -> Rope m+fromChar c = Rope (F.singleton (Chunk b)) (unit b)+    where b = U.fromString [c]+{-# INLINE fromChar #-}++fromWord8 :: (ByteString `Reducer` m) => Word8 -> Rope m+fromWord8 b = Rope (F.singleton (Chunk s)) (unit s)+    where s = S.singleton b+{-# INLINE fromWord8 #-}++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+{-# INLINE cons8 #-}++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 []++-- HTTP+-- import Network.BufferType+-- import Network.TCP++class (ByteString `Reducer` a) => Annotation a where+    elide' :: Int -> Int -> Rope a -> a+-- TODO+--    elide' f l ra = fst (extract rlmr) `mappend` drop l (snd <$> rlmr) where+--        rlmr = splitAt f (duplicate ra)++    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' _ _ = ()++-- Int -> Int -> Rope (a,b) -> (a,b))+-- Int -> Int -> Rope (a,b) -> ((a,a),(b,b))+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)+{-+-- relies on the fact that ropes are cozippable having only one 'hole'+eitherC :: Coproduct s => (Rope a -> b) -> (Rope c -> d) -> Rope (s a c) -> s b d+eitherC f g (Rope t sab) = bimap (f . Rope t) (g . Rope t) sab++-- TODO+++instance (Annotation a, Annotation b) => Annotation (Either a b) where+    elide' x y = eitherC (elide' x y) (elide' x y)+    splitAt' x = eitherC (splitAt' x) (splitAt' x)+    take' x = eitherC (take' x) (take' x)+    drop' x = eitherC (drop' x) (drop' x)++instance (Annotation a, Annotation b) => Annotation (a :+ b) where+    elide' x y = eitherC (elide' x y) (elide' x y)+    splitAt' x = eitherC (splitAt' x) (splitAt' x)+    take' x = eitherC (take' x) (take' x)+    drop' x = eitherC (drop' x) (drop' x)++instance (Annotation a, Annotation b) => Annotation (a :+: b) where+    elide' x y = eitherC (elide' x y) (elide' x y)+    splitAt' x = eitherC (splitAt' x) (splitAt' x)+    take' x = eitherC (take' x) (take' x)+    drop' x = eitherC (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)++{-+-- DO NOT USE! For testing purposes only. You'll have terrible O(n^2) asymptotics!+instance Ord k => Annotation (Map Int v) where+    splitAt k a = (l, M.mapKeysMonotonic (subtract k) $ maybe id (M.insert k) r) where (l,m,r) = M.splitLookup k (extract a)++-- DO NOT USE! For testing purposes only. You'll have terrible O(n^2) asymptotics!+instance Ord k => Annotation (Set Int) where+    splitAt k s = (l, S.mapKeysMonotonic (subtract k) $ maybe id S.insert r) where+        (l,m,r) = S.splitLookup k (extract a)+-}++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)+{-# INLINE findIndexOrEnd #-}++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+++{-+instance Annotation m => UTF8Bytes (Rope m) Int where+    bsplit n = splitAt n+    bdrop n = drop n +    buncons = uncons8+    elemIndex = undefined+    null = undefined+    pack = undefined+    tail r = case viewl (body r) of+        Chunk a :< as -> Rope (S.unsafeTail a `cons'` as) (drop' 1 r)+        EmptyL -> error "Codec.Binary.UTF8.Generic.UTF8Bytes.tail (Kata.Rope m): error empty list"+-}++w2c :: Word8 -> Char+w2c = unsafeChr . fromIntegral++{-+-- towards interoperating directly with Network.HTTP+-- unfortunately the machinery needed to implement HStream isn't exported, so this doesn't get us anywhere+instance Annotation m => BufferType (Rope m) where+    bufferOps = BufferOp+        { buf_hGet = \h i -> singleton <$> buf_hGet lazyBufferOp h i+        , buf_hGetContents = \h -> singleton <$> buf_hGetContents lazyBufferOp h+        , buf_hPut = \h b -> buf_hPut lazyBufferOp h (toLazy b)+        , buf_hGetLine = \h -> singleton <$> buf_hGetLine lazyBufferOp h+        , buf_empty = mempty+        , buf_append = mappend+        , buf_concat = mconcat+        , buf_fromStr = fromLazyByteString . buf_fromStr lazyBufferOp+        , buf_toStr = buf_toStr lazyBufferOp . toLazy+        , buf_snoc = snoc+        , buf_splitAt = splitAt+        , buf_span = \f -> break8 (not . f . w2c)+        , buf_isLineTerm = (unit (SC.pack "\r\n") ==)+        , buf_isEmpty = null+        }+-}++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++-- note this isn't a no-op, you can change annotations!+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+
+ Data/Rope/Unpackable.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Data.Rope.Unpackable+    ( Unpackable(..)+    ) where++import Prelude hiding (head, last, drop)+import qualified Prelude++import Data.Word (Word8)+import Data.Monoid (Monoid, mempty, mappend)+import qualified Data.Foldable as F++import qualified Data.FingerTree as F (empty, null, split)+import Data.FingerTree (FingerTree, ViewL(..),ViewR(..),viewl,viewr,(<|),(><))++import qualified Data.ByteString as S+import qualified Data.ByteString.Unsafe as S (unsafeTail, unsafeHead)+import qualified Data.ByteString.UTF8 as U+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.UTF8 as LU++import Data.Rope.Body (Count(..), Chunk(..), cons', snoc', measureBody) -- Chunk+import Data.Rope.Internal (Annotation(..), drop, Rope(..), body, toLazyByteString, uncons8, unsnoc8) -- Rope, etc.+import Codec.Binary.UTF8.Generic (UTF8Bytes)+import qualified Codec.Binary.UTF8.Generic as UTF8Bytes++class Unpackable a where+    unpack :: Rope m -> [a]++    head :: Rope m -> a+    head = Prelude.head . unpack++    last :: Rope m -> a++    uncons :: Annotation m => Rope m -> Maybe (a, Rope m)+    unsnoc :: Annotation m => Rope m -> Maybe (Rope m, a)++newtype F = F { runF :: FingerTree Count Chunk } ++instance Monoid F where+    mempty = F F.empty+    F a `mappend` F b = F (a >< b)++instance UTF8Bytes F Int where+    bsplit 0 (F f) = (mempty, F f)+    bsplit n (F f)+        | n >= measureBody f = (F f, mempty)+        | otherwise = (F (x `snoc'` y'), F (y'' `cons'` z))+        where+            (x, yz) = F.split (> Count n) f+            Chunk y :< z = viewl yz+            (y', y'') = S.splitAt (n - measureBody x) y+    bdrop n = snd . UTF8Bytes.bsplit n+    buncons f = case viewl (runF f) of+        Chunk c :< cs -> Just (S.unsafeHead c, F (S.unsafeTail c `cons' ` cs))+        EmptyL -> Nothing+    tail (F f) = case viewl f of+        Chunk c :< cs -> F (S.unsafeTail c `cons'`cs)+        EmptyL -> errorEmptyList "tail"+    elemIndex b = fmap fromIntegral . L.elemIndex b . L.fromChunks . map unchunk . F.toList . runF+    pack = F . foldr (\l r -> Chunk l <| r) F.empty . L.toChunks . L.pack+    empty = F F.empty+    null = F.null . runF++-- w2c :: Word8 -> Char+-- w2c = unsafeChr . fromIntegral+++instance Unpackable Word8 where+    unpack = concatMap (S.unpack . unchunk) . F.toList . body+    head (Rope t _) = case viewl t of+        Chunk a :< _ -> S.head a+        EmptyL -> errorEmptyList "head"+    last (Rope t _) = case viewr t of+        _ :> Chunk a -> S.last a+        EmptyR -> errorEmptyList "last"+    uncons = uncons8+    unsnoc = unsnoc8++instance Unpackable Char where+    unpack = LU.toString . toLazyByteString+    head = Prelude.head . unpack+    last = undefined -- TODO+    uncons r@(Rope t _) = case UTF8Bytes.decode (F t) of +        Nothing -> Nothing+        Just (a,n) -> Just (a, drop n r)+    unsnoc = undefined -- TODO++instance Unpackable S.ByteString where+    unpack = map unchunk . F.toList . body+    head r = case viewl (body r) of+        Chunk a :< _ -> a+        _ -> errorEmptyList "head"+    last r = case viewr (body r) of+        _ :> Chunk a -> a+        _ -> errorEmptyList "last" +    uncons r = case viewl (body r) of+        Chunk a :< as -> Just (a, Rope as (drop' (S.length a) r))+        EmptyL -> Nothing+    unsnoc r = case viewr (body r) of+        as :> Chunk a -> Just (Rope as (take' (measureBody as) r), a)+        EmptyR -> Nothing++instance Unpackable Chunk where+    unpack = F.toList . body+    head r = case viewl (body r) of+        a :< _ -> a+        _ -> errorEmptyList "head"+    last r = case viewr (body r) of+        _ :> a -> a+        _ -> errorEmptyList "last"+    uncons r = case viewl (body r) of+        Chunk a :< as -> Just (Chunk a, Rope as (drop' (S.length a) r))+        EmptyL -> Nothing+    unsnoc r = case viewr (body r) of+        as :> Chunk a -> Just (Rope as (take' (measureBody as) r), Chunk a)+        EmptyR -> Nothing++errorEmptyList :: String -> a+errorEmptyList t = error $ "Kata.Rope.Unpackable." ++ t ++ ": empty list"
+ Data/Rope/Util/Bifunctor.hs view
@@ -0,0 +1,22 @@+module Data.Rope.Util.Bifunctor (Bifunctor(..)) where++class Bifunctor f where+    bimap :: (a -> b) -> (c -> d) -> f a c -> f b d+    first :: (a -> b) -> f a c -> f b c+    second :: (b -> c) -> f a b -> f a c+    first f = bimap f id+    second = bimap id+    bimap f g = second g . first f++instance Bifunctor (,) where+    bimap f g ~(a,b) = (f a, g b)+    first f ~(a,b) = (f a, b)+    second g ~(a,b) = (a, g b)+    +instance Bifunctor Either where+    bimap f _ (Left a) = Left (f a)+    bimap _ g (Right b) = Right (g b)+    first f (Left a) = Left (f a)+    first _ (Right b) = Right b+    second _ (Left a) = Left a+    second g (Right b) = Right (g b)
+ Data/Rope/Util/Comonad.hs view
@@ -0,0 +1,11 @@+module Data.Rope.Util.Comonad +    ( Comonad(..)+    ) where++class Functor w => Comonad w where+    extract :: w a -> a+    duplicate :: w a -> w (w a)+    extend :: (w a -> b) -> w a -> w b++    duplicate = extend id+    extend f = fmap f . duplicate
+ Data/Rope/Util/Coproduct.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TypeOperators #-}+module Data.Rope.Util.Coproduct+    ( (:+:)(..)+    , (:+)(..)+    , Coproduct(..)+    , counzip+    ) where++import Control.Applicative+import Data.Rope.Util.Bifunctor++counzip :: (Coproduct s, Coproduct s', Functor f) => s (f a) (f b) -> f (s' a b)+counzip = fmap left ||| fmap right++-- a coproduct that is strict in its left argument only+data a :+ b = Inl !a+            | Inr b++instance Bifunctor (:+) where+    first f (Inl a) = Inl (f a)+    first _ (Inr b) = Inr b+    second _ (Inl a) = Inl a+    second g (Inr b) = Inr (g b)+    bimap f _ (Inl a) = Inl (f a)+    bimap _ g (Inr b) = Inr (g b)++instance Functor ((:+) a) where+    fmap _ (Inl a) = Inl a+    fmap g (Inr b) = Inr (g b)++instance Applicative ((:+)  a) where+    pure = Inr+    Inl a <*> _ = Inl a+    Inr _ <*> Inl a = Inl a+    Inr f <*> Inr a = Inr (f a)+    +instance Monad ((:+) a) where+    return = Inr+    Inl a >>= _ = Inl a+    Inr a >>= f = f a++class Bifunctor s => Coproduct s where+    left :: a -> s a b+    right :: b -> s a b+    (|||) :: (a -> c) -> (b -> c) -> s a b -> c+    codiag :: s a a -> a++instance Coproduct Either where+    left = Left+    right = Right+    (|||) = either+    codiag (Left a) = a+    codiag (Right a) = a++instance Coproduct (:+) where+    left = Inl+    right = Inr+    (|||) f _ (Inl a) = f a+    (|||) _ g (Inr b) = g b+    codiag (Inl a) = a +    codiag (Inr a) = a++data a :+: b = Left' !a +             | Right' !b++instance Bifunctor (:+:) where+    first f (Left' a) = Left' (f a)+    first _ (Right' b) = Right' b+    second _ (Left' a) = Left' a+    second g (Right' b) = Right' (g b)+    bimap f _ (Left' a) = Left' (f a)+    bimap _ g (Right' b) = Right' (g b)++instance Functor ((:+:) a) where+    fmap _ (Left' a) = Left' a+    fmap g (Right' b) = Right' (g b)++instance Coproduct (:+:) where+    left = Left'+    right = Right'+    (|||) f _ (Left' a) = f a+    (|||) _ g (Right' b) = g b+    codiag (Left' a) = a+    codiag (Right' a) = a
+ Data/Rope/Util/Product.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses #-}+module Data.Rope.Util.Product+    ( (:*:)(..)+    , Product(..), bothC+    , unzip+    ) where++import Data.Monoid hiding (Product(..))+import Data.Rope.Util.Comonad+import Data.Rope.Util.Bifunctor+import Data.Rope.Util.Reducer+import Prelude hiding (fst, snd, curry, uncurry, either, unzip)+import qualified Prelude as P++-- a product that is strict in both arguments+data a :*: b = !a :*: !b++instance Bifunctor (:*:) where+    first f (a :*: b) = f a :*: b+    second f (a :*: b) = a :*: f b+    bimap f g (a :*: b) = f a :*: g b++instance Functor ((:*:) a) where+    fmap f (a :*: b) = a :*: f b++instance Comonad ((:*:) a) where+    extract (_ :*: b) = b+    extend f ab@(a :*: _) = a :*: f ab+    duplicate ab@(a :*: _) = a :*: ab++instance (Monoid a, Monoid b) => Monoid (a :*: b) where+    mempty = mempty :*: mempty+    (a :*: b) `mappend` (c :*: d) = mappend a c :*: mappend b d++instance (Reducer c a, Reducer c b) => Reducer c (a :*: b) where+    unit c = unit c :*: unit c+    cons c (a :*: b) = cons c a :*: cons c b+    snoc (a :*: b) c = snoc a c :*: snoc b c ++class Bifunctor p => Product p where+    fst :: p a b -> a+    snd :: p a b -> b+    pair :: a -> b -> p a b+    curry :: (p a b -> c) -> a -> b -> c+    uncurry :: (a -> b -> c) -> p a b -> c+    both :: (a -> b) -> (a -> c) -> a -> p b c+    diag :: a -> p a a++    diag = both id id+    both f g = bimap f g . diag++instance Product (:*:) where+    fst (a :*: _) = a+    snd (_ :*: b) = b+    pair = (:*:)+    curry f a b = f (a :*: b)+    uncurry f (a :*: b) = f a b+    both f g a = f a :*: g a+    diag a = a :*: a++instance Product (,) where+    fst = P.fst+    snd = P.snd+    pair = (,)+    curry = P.curry+    uncurry = P.uncurry+    both f g a = (f a, g a)+    diag a = (a, a)++unzip :: (Product p, Functor f) => f (p a b) -> p (f a) (f b)+unzip = both (fmap fst) (fmap snd)+{-# INLINE unzip #-}++-- CoKleisli (&&&)+bothC :: (Product p, Functor f) => (f a -> b) -> (f c -> d) -> f (p a c) -> p b d+bothC f g = both (f . fmap fst) (g . fmap snd)+{-# INLINE bothC #-}
+ Data/Rope/Util/Reducer.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module Data.Rope.Util.Reducer +    ( Reducer(..)+    -- * Folding with 'Reducer's+    , foldMapReduce -- :: (Foldable f, e `Reducer` m) => (a -> e) -> f a -> m+    , foldReduce    -- :: (Foldable f, e `Reducer` m) => f e -> m +    -- * 'Applicative' reduction+    , pureUnit      -- :: (Applicative f, c `Reducer` n) => c -> m n+    , returnUnit    -- :: (Monad m, c `Reducer` n) c -> m n+    ) where++import Control.Applicative+import Control.Monad +import qualified Data.FingerTree as FingerTree+import Data.FingerTree (FingerTree, Measured, (><))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as Lazy++import Data.Monoid++import Data.Foldable++{-+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)++import qualified Data.Set as Set+import Data.Set (Set)++import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)++import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)++import qualified Data.Map as Map+import Data.Map (Map)+-}++-- | This type may be best read infix. A @c `Reducer` m@ is a 'Monoid' @m@ that maps+-- values of type @c@ through @unit@ to values of type @m@. A @c@-'Reducer' may also+-- supply operations which tack-on another @c@ to an existing 'Monoid' @m@ on the left+-- or right. These specialized reductions may be more efficient in some scenarios+-- and are used when appropriate by a 'Generator'. The names 'cons' and 'snoc' work+-- by analogy to the synonymous operations in the list monoid.+--+-- This class deliberately avoids functional-dependencies, so that () can be a @c@-Reducer+-- for all @c@, and so many common reducers can work over multiple types, for instance,+-- First and Last may reduce both @a@ and 'Maybe' @a@. Since a 'Generator' has a fixed element+-- type, the input to the reducer is generally known and extracting from the monoid usually+-- is sufficient to fix the result type. Combinators are available for most scenarios where+-- this is not the case, and the few remaining cases can be handled by using an explicit +-- type annotation.+--+-- Minimal definition: 'unit' or 'snoc'+class Monoid m => Reducer c m where+    -- | Convert a value into a 'Monoid'+    unit :: c -> m +    -- | Append a value to a 'Monoid' for use in left-to-right reduction+    snoc :: m -> c -> m+    -- | Prepend a value onto a 'Monoid' for use during right-to-left reduction+    cons :: c -> m -> m ++    unit = snoc mempty +    snoc m = mappend m . unit+    cons = mappend . unit++-- | Apply a 'Reducer' to a 'Foldable' container, after mapping the contents into a suitable form for reduction.+foldMapReduce :: (Foldable f, e `Reducer` m) => (a -> e) -> f a -> m+foldMapReduce f = foldMap (unit . f)++-- | Apply a 'Reducer' to a 'Foldable' mapping each element through 'unit'+foldReduce :: (Foldable f, e `Reducer` m) => f e -> m+foldReduce = foldMap unit++returnUnit :: (Monad m, c `Reducer` n) => c -> m n +returnUnit = return . unit++pureUnit :: (Applicative f, c `Reducer` n) => c -> f n+pureUnit = pure . unit++instance (Reducer c m, Reducer c n) => Reducer c (m,n) where+    unit x = (unit x,unit x)+    (m,n) `snoc` x = (m `snoc` x, n `snoc` x)+    x `cons` (m,n) = (x `cons` m, x `cons` n)++instance (Reducer c m, Reducer c n, Reducer c o) => Reducer c (m,n,o) where+    unit x = (unit x,unit x, unit x)+    (m,n,o) `snoc` x = (m `snoc` x, n `snoc` x, o `snoc` x)+    x `cons` (m,n,o) = (x `cons` m, x `cons` n, x `cons` o)++instance (Reducer c m, Reducer c n, Reducer c o, Reducer c p) => Reducer c (m,n,o,p) where+    unit x = (unit x,unit x, unit x, unit x)+    (m,n,o,p) `snoc` x = (m `snoc` x, n `snoc` x, o `snoc` x, p `snoc` x)+    x `cons` (m,n,o,p) = (x `cons` m, x `cons` n, x `cons` o, x `cons` p)++instance Reducer ByteString ByteString where+    unit = id+    snoc = mappend+    cons = mappend++instance Reducer ByteString Lazy.ByteString where+    unit = Lazy.fromChunks . return++instance Reducer c [c] where+    unit = return+    cons = (:)+    xs `snoc` x = xs ++ [x]++instance Reducer c () where+    unit _ = ()+    _ `snoc` _ = ()+    _ `cons` _ = ()++instance Reducer Bool Any where+    unit = Any++instance Reducer Bool All where+    unit = All++instance Reducer (a -> a) (Endo a) where+    unit = Endo++instance Monoid a => Reducer a (Dual a) where+    unit = Dual+    +instance Num a => Reducer a (Sum a) where+    unit = Sum++instance Num a => Reducer a (Product a) where+    unit = Product++instance Reducer (Maybe a) (First a) where+    unit = First++instance Reducer a (First a) where+    unit = First . Just++instance Reducer (Maybe a) (Last a) where+    unit = Last++instance Reducer a (Last a) where+    unit = Last . Just++-- instance Measured v a => Monoid (FingerTree v a) where+--    mempty = FingerTree.empty+--    mappend = (><)++instance Measured v a => Reducer a (FingerTree v a) where+    unit = FingerTree.singleton++{-+instance Reducer a (Seq a) where+    unit = Seq.singleton+    cons = (Seq.<|)+    snoc = (Seq.|>)++instance Reducer Int IntSet where+    unit = IntSet.singleton+    cons = IntSet.insert+    snoc = flip IntSet.insert -- left bias irrelevant++instance Ord a => Reducer a (Set a) where+    unit = Set.singleton+    cons = Set.insert+    -- pedantic about order in case 'Eq' doesn't implement structural equality+    snoc s m | Set.member m s = s +             | otherwise = Set.insert m s++instance Reducer (Int,v) (IntMap v) where+    unit = uncurry IntMap.singleton+    cons = uncurry IntMap.insert+    snoc = flip . uncurry . IntMap.insertWith $ const id++instance Ord k => Reducer (k,v) (Map k v) where+    unit = uncurry Map.singleton+    cons = uncurry Map.insert+    snoc = flip . uncurry . Map.insertWith $ const id+-}
+ LICENSE view
@@ -0,0 +1,1 @@+All Rights Reserved
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rope.cabal view
@@ -0,0 +1,35 @@+name:           rope+version:        0.1+license:        BSD3+license-file:   LICENSE+author:         Edward A. Kmett+maintainer:     Edward A. Kmett <ekmett@gmail.com>+stability:      experimental+homepage:       http://comonad.com/reader+category:       Language+synopsis:       Tools for manipulating annotated ropes of bytestrings+description:    Tools for manipulating annotated ropes of bytestrings+copyright:      (c) 2010 Edward A. Kmett+build-type:     Simple+cabal-version:  >=1.2+Tested-With:    GHC==6.10.4++library+  build-depends:    +    base >= 4 && < 6, +    bytestring >= 0.9.1.4 && < 0.10,+    fingertree >= 0.0.1 && < 0.1,+    mtl >= 1.1 && < 1.2,+    utf8-string >= 0.3.5 && < 0.4+  exposed-modules:+    Data.Rope+    Data.Rope.Body+    Data.Rope.Internal+    Data.Rope.Unpackable+    Data.Rope.Util.Bifunctor+    Data.Rope.Util.Comonad+    Data.Rope.Util.Coproduct+    Data.Rope.Util.Product+    Data.Rope.Util.Reducer+    +  ghc-options: -Wall