Reproducing a bug in 'packHuffmanTree'

packHuffmanTree.hs

import qualified Data.ByteString as B
import Control.Monad.ST( runST )
import Codec.Picture.Jpg.DefaultTable
import Codec.Picture.BitWriter
import Data.Word(Word8)
import Control.Monad(forM_)

goodTree :: HuffmanTree
goodTree = Branch (Leaf 1) (Branch (Leaf 2) (Leaf 3))

-- that tree will be handled incorrectly by
-- 'packHuffmanTree', but it will never arise
-- in production, because
--      > buildHuffmanTree [[1],[2,3]]
-- returns 'goodTree'
badTree :: HuffmanTree
badTree = Branch (Branch (Leaf 1) (Leaf 2)) (Leaf 3)

boolState :: Word8 -> BoolState
boolState i = initBoolStateJpg $ B.pack [i]

goodTest :: IO ()
goodTest =
    let states = [0   -- false, false, ... => 1
                 ,250 -- true,  true,  ... => 3
                 ,170 -- true,  false, ... => 2
                 ] in
         forM_ states $ \i ->
             print . fst $ runST $ runBoolReaderWith
                 (boolState i)
                 (huffmanPackedDecode packed)
             where packed = packHuffmanTree goodTree

badTest :: IO ()
badTest =
    let states = [0   -- false, false, ... => 1
                 ,250 -- true,  true,  ... => 3
                 ,127 -- false, true,  ... => 2
                 ] in
         forM_ states $ \i ->
             print . fst $ runST $ runBoolReaderWith
                 (boolState i)
                 (huffmanPackedDecode packed)
             where packed = packHuffmanTree badTree

main :: IO ()
main = do
        putStrLn "GOOD TREE:" >> goodTest
        putStrLn "BAD TREE:"  >> badTest