text-compression-0.1.0.8: src/Data/RLE/Internal.hs
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module : Data.RLE.Internal
-- Copyright : (c) Matthew Mosior 2022
-- License : BSD-style
-- Maintainer : mattm.github@gmail.com
-- Portability : portable
--
-- = WARNING
--
-- This module is considered __internal__.
--
-- The Package Versioning Policy __does not apply__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this library are expected to track development
-- closely.
--
-- All credit goes to the author(s)/maintainer(s) of the
-- [containers](https://hackage.haskell.org/package/containers) library
-- for the above warning text.
--
-- = Description
--
-- Various data structures and custom data types to describe the Run-length encoding (RLE)
-- and the Inverse RLE implementations, namely 'vecToRLEB', 'vecToRLET', 'vecFromRLEB', and 'vecFromRLET'.
--
-- The RLE implementations rely heavily upon 'DVB.Vector' provided by the [vector](https://hackage.haskell.org/package/vector) library,
-- 'STRef' and associated functions in the [stref](https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-STRef.html) library,
-- and 'runST' in the [Control.Monad.ST](https://hackage.haskell.org/package/base-4.17.0.0/docs/Control-Monad-ST.html) library.
module Data.RLE.Internal where
import Control.Monad as CM
import Control.Monad.ST as CMST
import Control.Monad.State.Strict()
import Data.ByteString as BS
import Data.ByteString.Char8 as BSC8 (pack,unpack)
import Data.ByteString.Internal()
import Data.List()
import Data.Maybe as DMaybe (fromJust,isJust,isNothing)
import Data.STRef as DSTR
import Data.Text as DText
import Data.Vector as DVB
import Data.Vector.Unboxed()
import GHC.Generics (Generic)
import Prelude as P
{-Base level types.-}
-- | Basic RLE ('ByteString') data type.
newtype RLEB = RLEB (DVB.Vector (Maybe ByteString))
deriving (Eq,Ord,Show,Read,Generic)
-- | Basic RLE ('Text') data type.
newtype RLET = RLET (DVB.Vector (Maybe Text))
deriving (Eq,Ord,Show,Read,Generic)
{-------------------}
{-toRLE (ByteString) functions.-}
-- | Abstract 'RLEVecB' type utilizing a sequence.
type RLEVecB = DVB.Vector (Maybe ByteString)
-- | Abstract data type representing a 'RLEVecB' in the (strict) ST monad.
type STRLEVecB s a = STRef s RLEVecB
-- | State function to push 'RLEVecB' data into stack.
pushSTRLEVecB :: STRLEVecB s (Maybe ByteString) -> Maybe ByteString -> ST s ()
pushSTRLEVecB s Nothing = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 Nothing)
pushSTRLEVecB s (Just e) = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 (Just e))
-- | State function to create empty 'STRLEVecB' type.
emptySTRLEVecB :: ST s (STRLEVecB s a)
emptySTRLEVecB = newSTRef DVB.empty
-- | Abstract 'STRLETempB' and associated state type.
type STRLETempB s a = STRef s (Maybe ByteString)
-- | State function to update 'STRLETempB'.
updateSTRLETempB :: STRLETempB s (Maybe ByteString) -> Maybe ByteString -> ST s ()
updateSTRLETempB s Nothing = writeSTRef s Nothing
updateSTRLETempB s (Just e) = writeSTRef s (Just e)
-- | State function to create empty 'STRLETempB' type.
emptySTRLETempB :: ST s (STRLETempB s a)
emptySTRLETempB = newSTRef (Just BS.empty)
-- | Abstract 'STRLECounterB' state type.
type STRLECounterB s a = STRef s Int
-- | State function to update 'STRLECounterB'.
updateSTRLECounterB :: STRLECounterB s Int -> Int -> ST s ()
updateSTRLECounterB s e = writeSTRef s e
-- | State function to create empty 'STRLECounterB' type.
emptySTRLECounterB :: ST s (STRLECounterB s Int)
emptySTRLECounterB = newSTRef (-1)
-- | Strict state monad function.
vecToRLEB :: RLEVecB
-> ST s RLEVecB
vecToRLEB (DVB.uncons -> Nothing) = do
brlevecstackempty <- emptySTRLEVecB
brlevecstackemptyr <- readSTRef brlevecstackempty
return brlevecstackemptyr
vecToRLEB (DVB.uncons -> Just (v,vs)) = do
brlevecstack <- emptySTRLEVecB
brlecounterstack <- emptySTRLECounterB
brletempstack <- emptySTRLETempB
updateSTRLECounterB brlecounterstack
1
updateSTRLETempB brletempstack
v
iRLEB vs
brlevecstack
brlecounterstack
brletempstack
brlevecstackr <- readSTRef brlevecstack
return brlevecstackr
where
iRLEB (DVB.uncons -> Nothing) brless brlecs brlets = do
cbrlecs <- readSTRef brlecs
cbrlets <- readSTRef brlets
pushSTRLEVecB brless
(Just $
BSC8.pack $
show cbrlecs)
pushSTRLEVecB brless
cbrlets
pure ()
iRLEB (DVB.uncons -> Just (y,ys)) brless brlecs brlets = do
cbrlecs <- readSTRef brlecs
cbrlets <- readSTRef brlets
if | isNothing y
-> do pushSTRLEVecB brless
(Just $
BSC8.pack $
show cbrlecs)
pushSTRLEVecB brless
cbrlets
pushSTRLEVecB brless
(Just $
BSC8.pack $
show (1 :: Int))
pushSTRLEVecB brless
Nothing
updateSTRLETempB brlets
Nothing
iRLEB ys
brless
brlecs
brlets
| isNothing cbrlets
-> do updateSTRLECounterB brlecs
1
updateSTRLETempB brlets
y
iRLEB ys
brless
brlecs
brlets
| fromJust cbrlets == fromJust y
-> do updateSTRLECounterB brlecs
(cbrlecs + 1)
iRLEB ys
brless
brlecs
brlets
| otherwise
-> do pushSTRLEVecB brless
(Just $
BSC8.pack $
show cbrlecs)
pushSTRLEVecB brless
cbrlets
updateSTRLECounterB brlecs
1
updateSTRLETempB brlets
y
iRLEB ys
brless
brlecs
brlets
{-------------------------------}
{-toRLE (Text) functions.-}
-- | Abstract 'RLEVecT' type utilizing a sequence.
type RLEVecT = DVB.Vector (Maybe Text)
-- | Abstract data type representing a 'RLEVecT' in the (strict) ST monad.
type STRLEVecT s a = STRef s RLEVecT
-- | State function to push 'RLEVecT' data into stack.
pushSTRLEVecT :: STRLEVecT s (Maybe Text) -> (Maybe Text) -> ST s ()
pushSTRLEVecT s Nothing = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 Nothing)
pushSTRLEVecT s (Just e) = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 (Just e))
-- | State function to create empty 'STRLEVecT' type.
emptySTRLEVecT :: ST s (STRLEVecT s a)
emptySTRLEVecT = newSTRef DVB.empty
-- | Abstract 'STRLETempT' state type.
type STRLETempT s a = STRef s (Maybe Text)
-- | State function to update 'STRLETempT'.
updateSTRLETempT :: STRLETempT s (Maybe Text) -> (Maybe Text) -> ST s ()
updateSTRLETempT s Nothing = writeSTRef s Nothing
updateSTRLETempT s (Just e) = writeSTRef s (Just e)
-- | State function to create empty 'STRLETempT' type.
emptySTRLETempT :: ST s (STRLETempT s a)
emptySTRLETempT = newSTRef (Just DText.empty)
-- | Abstract 'STRLECounterT' and associated state type.
type STRLECounterT s a = STRef s Int
-- | State function to update 'STRLECounterT'.
updateSTRLECounterT :: STRLECounterT s Int -> Int -> ST s ()
updateSTRLECounterT s e = writeSTRef s e
-- | State function to create empty 'STRLECounterT' type.
emptySTRLECounterT :: ST s (STRLECounterT s Int)
emptySTRLECounterT = newSTRef (-1)
-- | Strict state monad function.
vecToRLET :: RLEVecT ->
ST s RLEVecT
vecToRLET (DVB.uncons -> Nothing) = do
trlevecstackempty <- emptySTRLEVecT
trlevecstackemptyr <- readSTRef trlevecstackempty
return trlevecstackemptyr
vecToRLET (DVB.uncons -> Just (v,vs)) = do
trlevecstack <- emptySTRLEVecT
trlecounterstack <- emptySTRLECounterT
trletempstack <- emptySTRLETempT
updateSTRLECounterT trlecounterstack
1
updateSTRLETempT trletempstack
v
iRLET vs
trlevecstack
trlecounterstack
trletempstack
trlevecstackr <- readSTRef trlevecstack
return trlevecstackr
where
iRLET (DVB.uncons -> Nothing) trless trlecs trlets = do
ctrlecs <- readSTRef trlecs
ctrlets <- readSTRef trlets
pushSTRLEVecT trless
(Just $
DText.pack $
show ctrlecs)
pushSTRLEVecT trless
ctrlets
pure ()
iRLET (DVB.uncons -> Just (y,ys)) trless trlecs trlets = do
ctrlecs <- readSTRef trlecs
ctrlets <- readSTRef trlets
if | isNothing y
-> do pushSTRLEVecT trless
(Just $
DText.pack $
show ctrlecs)
pushSTRLEVecT trless
ctrlets
pushSTRLEVecT trless
(Just $
DText.pack $
show (1 :: Int))
pushSTRLEVecT trless
Nothing
updateSTRLETempT trlets
Nothing
iRLET ys
trless
trlecs
trlets
| isNothing ctrlets
-> do updateSTRLECounterT trlecs
1
updateSTRLETempT trlets
y
iRLET ys
trless
trlecs
trlets
| fromJust ctrlets == fromJust y
-> do updateSTRLECounterT trlecs
(ctrlecs + 1)
iRLET ys
trless
trlecs
trlets
| otherwise
-> do pushSTRLEVecT trless
(Just $
DText.pack $
show ctrlecs)
pushSTRLEVecT trless
ctrlets
updateSTRLECounterT trlecs
1
updateSTRLETempT trlets
y
iRLET ys
trless
trlecs
trlets
{-------------------------}
{-fromRLE (ByteString) functions.-}
-- | 'DVB.Vector' auxilary function
-- to pattern match on first two elements
-- of a vector.
unconsb2 :: DVB.Vector a -> Maybe (a,DVB.Vector a,Maybe (DVB.Vector a))
unconsb2 v = if | DVB.length v < 3
-> Just (DVB.unsafeHead v,DVB.drop 1 v,Nothing)
| otherwise
-> Just (DVB.unsafeHead v,DVB.drop 1 v,Just $ DVB.drop 2 v)
-- | Abstract 'FRLEVecB' type utilizing a sequence.
type FRLEVecB = DVB.Vector (Maybe ByteString)
-- | Abstract data type representing a 'FRLEVecB' in the (strict) ST monad.
type FSTRLEVecB s a = STRef s FRLEVecB
-- | State function to push 'FRLEVecB' data into stack.
pushFSTRLEVecB :: FSTRLEVecB s (Maybe ByteString) -> (Maybe ByteString) -> ST s ()
pushFSTRLEVecB s Nothing = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 Nothing)
pushFSTRLEVecB s (Just e) = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 (Just e))
-- | State function to create empty 'FSTRLEVecB' type.
emptyFSTRLEVecB :: ST s (FSTRLEVecB s a)
emptyFSTRLEVecB = newSTRef DVB.empty
-- | Strict state monad function.
vecFromRLEB :: RLEB
-> ST s FRLEVecB
vecFromRLEB (RLEB (DVB.uncons -> Nothing)) = do
fbrlevecstackempty <- emptyFSTRLEVecB
fbrlevecstackemptyr <- readSTRef fbrlevecstackempty
return fbrlevecstackemptyr
vecFromRLEB vs = do
fbrlevecstack <- emptySTRLEVecB
let rlebvec = (\(RLEB b) -> b) vs
iFRLEB rlebvec
fbrlevecstack
fbrlevecstackr <- readSTRef fbrlevecstack
return fbrlevecstackr
where
iFRLEB (unconsb2 -> Just (y1,y2,Nothing)) fbrless =
if | isJust y1 &&
isNothing (DVB.head y2)
-> do pushFSTRLEVecB fbrless
Nothing
pure ()
| otherwise
-> do let y1' = read $
BSC8.unpack $
fromJust y1 :: Int
let y2' = fromJust $
DVB.head y2
CM.replicateM_ y1'
(pushFSTRLEVecB fbrless
(Just y2'))
pure ()
iFRLEB (unconsb2 -> Just (y1,y2,Just ys)) fbrless =
if | isJust y1 &&
isNothing (DVB.head y2)
-> do pushFSTRLEVecB fbrless
Nothing
iFRLEB ys
fbrless
| otherwise
-> do let y1' = read $
BSC8.unpack $
fromJust y1 :: Int
let y2' = fromJust $
DVB.head y2
CM.replicateM_ y1'
(pushFSTRLEVecB fbrless
(Just y2'))
iFRLEB ys
fbrless
{---------------------------------}
{-fromRLE (Text) functions.-}
-- | 'DVB.Vector' auxilary function
-- to pattern match on first two elements
-- of a vector.
unconst2 :: DVB.Vector a -> Maybe (a,DVB.Vector a, Maybe (DVB.Vector a))
unconst2 v = if | DVB.length v < 3
-> Just (DVB.unsafeHead v,DVB.drop 1 v,Nothing)
| otherwise
-> Just (DVB.unsafeHead v, DVB.drop 1 v,Just $ DVB.drop 2 v)
-- | Abstract 'FRLEVecT' type utilizing a sequence.
type FRLEVecT = DVB.Vector (Maybe Text)
-- | Abstract data type representing a 'FRLEVecT' in the (strict) ST monad.
type FSTRLEVecT s a = STRef s FRLEVecT
-- | State function to push 'FSTRLEVecT' data into stack.
pushFSTRLEVecT :: FSTRLEVecT s (Maybe Text) -> (Maybe Text) -> ST s ()
pushFSTRLEVecT s Nothing = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 Nothing)
pushFSTRLEVecT s (Just e) = do
s2 <- readSTRef s
writeSTRef s (DVB.snoc s2 (Just e))
-- | State function to create empty 'FSTRLEVecT' type.
emptyFSTRLEVecT :: ST s (FSTRLEVecT s a)
emptyFSTRLEVecT = newSTRef DVB.empty
-- | Strict state monad function.
vecFromRLET :: RLET ->
ST s FRLEVecT
vecFromRLET (RLET (DVB.uncons -> Nothing)) = do
ftrlevecstackempty <- emptyFSTRLEVecT
ftrlevecstackemptyr <- readSTRef ftrlevecstackempty
return ftrlevecstackemptyr
vecFromRLET vs = do
ftrlevecstack <- emptySTRLEVecT
let rletvec = (\(RLET t) -> t) vs
iFRLET rletvec
ftrlevecstack
ftrlevecstackr <- readSTRef ftrlevecstack
return ftrlevecstackr
where
iFRLET (unconst2 -> Just (y1,y2,Nothing)) ftrless =
if | isJust y1 &&
isNothing (DVB.head y2)
-> do pushFSTRLEVecT ftrless
Nothing
pure ()
| otherwise
-> do let y1' = read $
DText.unpack $
fromJust y1 :: Int
let y2' = fromJust $
DVB.head y2
CM.replicateM_ y1'
(pushFSTRLEVecT ftrless
(Just y2'))
pure ()
iFRLET (unconst2 -> Just (y1,y2,Just ys)) ftrless =
if | isJust y1 &&
isNothing (DVB.head y2)
-> do pushFSTRLEVecT ftrless
Nothing
iFRLET ys
ftrless
| otherwise
-> do let y1' = read $
DText.unpack $
fromJust y1 :: Int
let y2' = fromJust $
DVB.head y2
CM.replicateM_ y1'
(pushFSTRLEVecT ftrless
(Just y2'))
iFRLET ys
ftrless
{---------------------------}