Internal.hs

{-# 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