Unpackable.hs

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