{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits
  ( XmlInterestBits(..)
  , getXmlInterestBits
  , blankedXmlToInterestBits
  , blankedXmlBssToInterestBitsBs
  ) where

import Control.Applicative
import Data.ByteString.Internal
import Data.Word
import HaskellWorks.Data.Bits.BitShown
import HaskellWorks.Data.Conduit.List
import HaskellWorks.Data.FromByteString
import HaskellWorks.Data.RankSelect.Poppy512
import HaskellWorks.Data.Xml.Conduit
import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml

import qualified Data.ByteString      as BS
import qualified Data.Vector.Storable as DVS

newtype XmlInterestBits a = XmlInterestBits a

getXmlInterestBits :: XmlInterestBits a -> a
getXmlInterestBits (XmlInterestBits a) = a

blankedXmlBssToInterestBitsBs :: [ByteString] -> ByteString
blankedXmlBssToInterestBitsBs bss = BS.concat $ runListConduit blankedXmlToInterestBits bss

genInterest :: ByteString -> Maybe (Word8, ByteString)
genInterest = BS.uncons

genInterestForever :: ByteString -> Maybe (Word8, ByteString)
genInterestForever bs = BS.uncons bs <|> Just (0, bs)

instance FromBlankedXml (XmlInterestBits (BitShown [Bool])) where
  fromBlankedXml = XmlInterestBits . fromByteString . BS.concat . runListConduit blankedXmlToInterestBits . getBlankedXml

instance FromBlankedXml (XmlInterestBits (BitShown BS.ByteString)) where
  fromBlankedXml = XmlInterestBits . BitShown . BS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml

instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word8))) where
  fromBlankedXml = XmlInterestBits . BitShown . DVS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml

instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word16))) where
  fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)))
    where interestBS    = blankedXmlBssToInterestBitsBs (getBlankedXml bj)
          newLen        = (BS.length interestBS + 1) `div` 2 * 2

instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word32))) where
  fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)))
    where interestBS    = blankedXmlBssToInterestBitsBs (getBlankedXml bj)
          newLen        = (BS.length interestBS + 3) `div` 4 * 4

instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word64))) where
  fromBlankedXml bj    = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)))
    where interestBS    = blankedXmlBssToInterestBitsBs (getBlankedXml bj)
          newLen        = (BS.length interestBS + 7) `div` 8 * 8

instance FromBlankedXml (XmlInterestBits Poppy512) where
  fromBlankedXml = XmlInterestBits . makePoppy512 . bitShown . getXmlInterestBits . fromBlankedXml