Huffman coding in Haskell for learning

Huffman.hs

import Data.Bits (setBit)
import Data.Word (Word8)
import Data.Tuple (swap)
import Data.Maybe (fromJust)
import qualified Data.Map as M
import qualified Data.Heap as H
import qualified Data.ByteString as B
import Control.Arrow (second, (&&&))

type OccurrenceTable a = M.Map a Int
type HuffmanHeap a = H.MinPrioHeap Int a
data HuffmanTree a = Leaf a | Node (HuffmanTree a) (HuffmanTree a) deriving Show
type HuffmanCode = [Bool]
type HuffmanTable a = M.Map a HuffmanCode

occurrenceTable :: Ord a => [a] -> OccurrenceTable a
occurrenceTable = M.fromListWith (+) . map (id &&& const 1)

occurrenceHeap :: Ord a => OccurrenceTable a -> HuffmanHeap a
occurrenceHeap = H.fromList . map swap . M.toList

-- fmap doesn't work on Data.Heap.MaxPiroHeap :(
hmap :: (a -> b) -> (HuffmanHeap a -> HuffmanHeap b)
hmap f = H.fromList . map (second f) . H.toList

huffmanTree :: HuffmanHeap a -> HuffmanTree a
huffmanTree = fromJust . work . hmap Leaf
  where
    work h = do
      ((p, x), h) <- H.view h
      if H.isEmpty h
        then return x
        else do
          ((q, y), h) <- H.view h
          work $ H.insert (p+q, Node x y) h

huffmanTable :: Ord a => HuffmanTree a -> HuffmanTable a
huffmanTable = work []
  where
    work c (Leaf a)   = M.singleton a c
    work c (Node x y) = M.union (work (False:c) x) (work (True:c) y)

huffmanCoding :: Ord a => [a] -> HuffmanTable a
huffmanCoding = huffmanTable . huffmanTree . occurrenceHeap . occurrenceTable

pack :: [Bool] -> [Word8]
pack [] = []
pack (a:b:c:d:e:f:g:h:bits) = word8 : pack bits
  where
    word8 = bit a 7.bit b 6.bit c 5.bit d 4.bit e 3.bit f 2.bit g 1.bit h 0 $ 0
    bit t i a = if t then setBit a i else a
pack bits = pack $ bits ++ pad
  where pad = replicate (8 - length bits) False

compress :: Ord a => [a] -> B.ByteString
compress input = B.pack . pack . concatMap (fromJust . flip M.lookup table) $ input
  where table = huffmanCoding input

compress' :: B.ByteString -> B.ByteString
compress' = compress . B.unpack

main :: IO ()
main = do
  input <- B.getContents
  B.putStr $ compress' input