{-# LANGUAGE BangPatterns #-}
module Network.HPACK.Huffman.Tree (
HTree(..)
, eosInfo
, toHTree
, showTree
, printTree
, flatten
) where
import Control.Arrow (second)
import Imports
import Network.HPACK.Huffman.Bit
import Network.HPACK.Huffman.Params
type EOSInfo = Maybe Int
data HTree = Tip
!EOSInfo
{-# UNPACK #-} !Int
| Bin
!EOSInfo
{-# UNPACK #-} !Int
!HTree
!HTree
deriving Int -> HTree -> ShowS
[HTree] -> ShowS
HTree -> String
(Int -> HTree -> ShowS)
-> (HTree -> String) -> ([HTree] -> ShowS) -> Show HTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HTree] -> ShowS
$cshowList :: [HTree] -> ShowS
show :: HTree -> String
$cshow :: HTree -> String
showsPrec :: Int -> HTree -> ShowS
$cshowsPrec :: Int -> HTree -> ShowS
Show
eosInfo :: HTree -> EOSInfo
eosInfo :: HTree -> EOSInfo
eosInfo (Tip mx :: EOSInfo
mx _) = EOSInfo
mx
eosInfo (Bin mx :: EOSInfo
mx _ _ _) = EOSInfo
mx
showTree :: HTree -> String
showTree :: HTree -> String
showTree = String -> HTree -> String
showTree' ""
showTree' :: String -> HTree -> String
showTree' :: String -> HTree -> String
showTree' _ (Tip _ i :: Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
showTree' pref :: String
pref (Bin _ n :: Int
n l :: HTree
l r :: HTree
r) = "No " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pref String -> ShowS
forall a. [a] -> [a] -> [a]
++ "+ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> HTree -> String
showTree' String
pref' HTree
l
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pref String -> ShowS
forall a. [a] -> [a] -> [a]
++ "+ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> HTree -> String
showTree' String
pref' HTree
r
where
pref' :: String
pref' = " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pref
printTree :: HTree -> IO ()
printTree :: HTree -> IO ()
printTree = String -> IO ()
putStr (String -> IO ()) -> (HTree -> String) -> HTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HTree -> String
showTree
toHTree :: [Bits] -> HTree
toHTree :: [Bits] -> HTree
toHTree bs :: [Bits]
bs = Int -> Bits -> HTree -> HTree
mark 1 Bits
eos (HTree -> HTree) -> HTree -> HTree
forall a b. (a -> b) -> a -> b
$ (Int, HTree) -> HTree
forall a b. (a, b) -> b
snd ((Int, HTree) -> HTree) -> (Int, HTree) -> HTree
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, Bits)] -> (Int, HTree)
build 0 ([(Int, Bits)] -> (Int, HTree)) -> [(Int, Bits)] -> (Int, HTree)
forall a b. (a -> b) -> a -> b
$ [Int] -> [Bits] -> [(Int, Bits)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..Int
idxEos] [Bits]
bs
where
eos :: Bits
eos = [Bits]
bs [Bits] -> Int -> Bits
forall a. [a] -> Int -> a
!! Int
idxEos
build :: Int -> [(Int,Bits)] -> (Int, HTree)
build :: Int -> [(Int, Bits)] -> (Int, HTree)
build !Int
cnt0 [(v :: Int
v,[])] = (Int
cnt0,EOSInfo -> Int -> HTree
Tip EOSInfo
forall a. Maybe a
Nothing Int
v)
build !Int
cnt0 xs :: [(Int, Bits)]
xs = let (cnt1 :: Int
cnt1,l :: HTree
l) = Int -> [(Int, Bits)] -> (Int, HTree)
build (Int
cnt0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [(Int, Bits)]
fs
(cnt2 :: Int
cnt2,r :: HTree
r) = Int -> [(Int, Bits)] -> (Int, HTree)
build Int
cnt1 [(Int, Bits)]
ts
in (Int
cnt2, EOSInfo -> Int -> HTree -> HTree -> HTree
Bin EOSInfo
forall a. Maybe a
Nothing Int
cnt0 HTree
l HTree
r)
where
(fs' :: [(Int, Bits)]
fs',ts' :: [(Int, Bits)]
ts') = ((Int, Bits) -> Bool)
-> [(Int, Bits)] -> ([(Int, Bits)], [(Int, Bits)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (B -> B -> Bool
forall a. Eq a => a -> a -> Bool
(==) B
F (B -> Bool) -> ((Int, Bits) -> B) -> (Int, Bits) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bits -> B
forall a. [a] -> a
head (Bits -> B) -> ((Int, Bits) -> Bits) -> (Int, Bits) -> B
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Bits) -> Bits
forall a b. (a, b) -> b
snd) [(Int, Bits)]
xs
fs :: [(Int, Bits)]
fs = ((Int, Bits) -> (Int, Bits)) -> [(Int, Bits)] -> [(Int, Bits)]
forall a b. (a -> b) -> [a] -> [b]
map ((Bits -> Bits) -> (Int, Bits) -> (Int, Bits)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Bits -> Bits
forall a. [a] -> [a]
tail) [(Int, Bits)]
fs'
ts :: [(Int, Bits)]
ts = ((Int, Bits) -> (Int, Bits)) -> [(Int, Bits)] -> [(Int, Bits)]
forall a b. (a -> b) -> [a] -> [b]
map ((Bits -> Bits) -> (Int, Bits) -> (Int, Bits)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Bits -> Bits
forall a. [a] -> [a]
tail) [(Int, Bits)]
ts'
mark :: Int -> Bits -> HTree -> HTree
mark :: Int -> Bits -> HTree -> HTree
mark i :: Int
i [] (Tip Nothing v :: Int
v) = EOSInfo -> Int -> HTree
Tip (Int -> EOSInfo
forall a. a -> Maybe a
Just Int
i) Int
v
mark i :: Int
i (F:bs :: Bits
bs) (Bin Nothing n :: Int
n l :: HTree
l r :: HTree
r) = EOSInfo -> Int -> HTree -> HTree -> HTree
Bin (Int -> EOSInfo
forall a. a -> Maybe a
Just Int
i) Int
n (Int -> Bits -> HTree -> HTree
mark (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Bits
bs HTree
l) HTree
r
mark i :: Int
i (T:bs :: Bits
bs) (Bin Nothing n :: Int
n l :: HTree
l r :: HTree
r) = EOSInfo -> Int -> HTree -> HTree -> HTree
Bin (Int -> EOSInfo
forall a. a -> Maybe a
Just Int
i) Int
n HTree
l (Int -> Bits -> HTree -> HTree
mark (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Bits
bs HTree
r)
mark _ _ _ = String -> HTree
forall a. HasCallStack => String -> a
error "mark"
flatten :: HTree -> [HTree]
flatten :: HTree -> [HTree]
flatten (Tip _ _) = []
flatten t :: HTree
t@(Bin _ _ l :: HTree
l r :: HTree
r) = HTree
t HTree -> [HTree] -> [HTree]
forall a. a -> [a] -> [a]
: (HTree -> [HTree]
flatten HTree
l [HTree] -> [HTree] -> [HTree]
forall a. [a] -> [a] -> [a]
++ HTree -> [HTree]
flatten HTree
r)