    {-# LANGUAGE Safe #-}
    -- arch-tag: Inflate implementation for Haskell

    {-
    Inflate implementation for Haskell

    Copyright 2004 Ian Lynagh <igloo@earth.li>
    Licence: 3 clause BSD.

    \section{Inflate}

    This module provides a Haskell implementation of the inflate function,
    as described by RFC 1951.

    -}

    {- |
       Module     : Data.Compression.Inflate
       Copyright  : Copyright (C) 2004 Ian Lynagh
       SPDX-License-Identifier: BSD-3-Clause

       Stability  : provisional
       Portability: portable

    Inflate algorithm implementation

    Copyright (C) 2004 Ian Lynagh
    -}

    module Data.Compression.Inflate (inflate_string,
                                         inflate_string_remainder,
                                         inflate, Output, Bit,
                                        bits_to_word32) where

    import           Control.Applicative
    import           Control.Monad
    import           Data.Array
    import qualified Data.Char
    import           Data.List
    import           Data.Maybe

    import           Data.Bits
    import           Data.Word

    inflate_string :: String -> String
    inflate_string :: String -> String
    inflate_string = (String, String) -> String
    forall a b. (a, b) -> a
    fst ((String, String) -> String)
    -> (String -> (String, String)) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> (String, String)
    inflate_string_remainder
    --    map (Data.Char.chr . fromIntegral) $ fst $ inflate $ map Data.Char.ord s

    -- | Returns (Data, Remainder)
    inflate_string_remainder :: String -> (String, String)
    inflate_string_remainder :: String -> (String, String)
    inflate_string_remainder s :: String
    s =
        let res :: (Output, [Bit])
    res = [Int] -> (Output, [Bit])
    inflate ([Int] -> (Output, [Bit])) -> [Int] -> (Output, [Bit])
    forall a b. (a -> b) -> a -> b
    $ (Char -> Int) -> String -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Int
    Data.Char.ord String
    s
            convw32l :: [a] -> String
    convw32l l :: [a]
    l = (a -> Char) -> [a] -> String
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Char
    Data.Char.chr (Int -> Char) -> (a -> Int) -> a -> Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral) [a]
    l
            output :: String
    output = Output -> String
    forall a. Integral a => [a] -> String
    convw32l (Output -> String) -> Output -> String
    forall a b. (a -> b) -> a -> b
    $ (Output, [Bit]) -> Output
    forall a b. (a, b) -> a
    fst (Output, [Bit])
    res
            b2w32 :: [Bit] -> Output
    b2w32 [] = []
            b2w32 b :: [Bit]
    b = let (this :: [Bit]
    this, next :: [Bit]
    next) = Int -> [Bit] -> ([Bit], [Bit])
    forall a. Int -> [a] -> ([a], [a])
    splitAt 8 [Bit]
    b
                          in
                          [Bit] -> Word32
    bits_to_word32 [Bit]
    this Word32 -> Output -> Output
    forall a. a -> [a] -> [a]
    : [Bit] -> Output
    b2w32 [Bit]
    next
            remainder :: String
    remainder = Output -> String
    forall a. Integral a => [a] -> String
    convw32l (Output -> String) -> Output -> String
    forall a b. (a -> b) -> a -> b
    $ [Bit] -> Output
    b2w32 ([Bit] -> Output) -> [Bit] -> Output
    forall a b. (a -> b) -> a -> b
    $ (Output, [Bit]) -> [Bit]
    forall a b. (a, b) -> b
    snd (Output, [Bit])
    res
            in
            (String
    output, String
    remainder)

    {-
    \section{Types}

    Type synonyms are your friend.

    -}
    type Output = [Word32] -- The final output

    type Code = Word32     -- A generic code
    type Dist = Code       -- A distance code
    type LitLen = Code     -- A literal/length code
    type Length = Word32   -- Number of bits needed to identify a code

    type Table = InfM Code -- A Huffman table
    type Tables = (Table, Table) -- lit/len and dist Huffman tables

    {-

    The \verb!Bit! datatype is used for the input. We can show values and
    convert from the input we are given and to \verb!Word32!s which we us to
    represent most values.

    -}
    newtype Bit = Bit Bool
        deriving Bit -> Bit -> Bool
    (Bit -> Bit -> Bool) -> (Bit -> Bit -> Bool) -> Eq Bit
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Bit -> Bit -> Bool
    $c/= :: Bit -> Bit -> Bool
    == :: Bit -> Bit -> Bool
    $c== :: Bit -> Bit -> Bool
    Eq
    instance Show Bit where
        show :: Bit -> String
    show = (\x :: Char
    x -> [Char
    x]) (Char -> String) -> (Bit -> Char) -> Bit -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bit -> Char
    show_b
        showList :: [Bit] -> String -> String
    showList bs :: [Bit]
    bs = String -> String -> String
    showString (String -> String -> String) -> String -> String -> String
    forall a b. (a -> b) -> a -> b
    $ "'" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Bit -> Char) -> [Bit] -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Bit -> Char
    show_b [Bit]
    bs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'"

    show_b :: Bit -> Char
    show_b :: Bit -> Char
    show_b (Bit True)  = '1'
    show_b (Bit False) = '0'

    int_to_bits :: Int -> [Bit]
    int_to_bits :: Int -> [Bit]
    int_to_bits = Word8 -> [Bit]
    word8_to_bits (Word8 -> [Bit]) -> (Int -> Word8) -> Int -> [Bit]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Word8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral

    word8_to_bits :: Word8 -> [Bit]
    word8_to_bits :: Word8 -> [Bit]
    word8_to_bits n :: Word8
    n = (Int -> Bit) -> [Int] -> [Bit]
    forall a b. (a -> b) -> [a] -> [b]
    map (\i :: Int
    i -> Bool -> Bit
    Bit (Word8 -> Int -> Bool
    forall a. Bits a => a -> Int -> Bool
    testBit Word8
    n Int
    i)) [0..7]

    bits_to_word32 :: [Bit] -> Word32
    bits_to_word32 :: [Bit] -> Word32
    bits_to_word32 = (Bit -> Word32 -> Word32) -> Word32 -> [Bit] -> Word32
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\(Bit b :: Bool
    b) i :: Word32
    i -> 2 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    * Word32
    i Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + (if Bool
    b then 1 else 0)) 0

    {-

    \section{Monad}

    offset is rarely used, so make it strict to avoid building huge closures.

    -}
    data State = State { State -> [Bit]
    bits    :: [Bit],                  -- remaining input bits
                         State -> Word32
    offset  :: !Word32,              -- num bits consumed mod 8
                         State -> Array Word32 Word32
    history :: Array Word32 Word32, -- last 32768 output words
                         State -> Word32
    loc     :: Word32                   -- where in history we are
                       }
    data InfM a = InfM (State -> (a, State))

    instance Monad InfM where
     -- (>>=)  :: InfM a -> (a -> InfM b) -> InfM b
        InfM v :: State -> (a, State)
    v >>= :: InfM a -> (a -> InfM b) -> InfM b
    >>= f :: a -> InfM b
    f = (State -> (b, State)) -> InfM b
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> (b, State)) -> InfM b)
    -> (State -> (b, State)) -> InfM b
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s -> let (x :: a
    x, s' :: State
    s') = State -> (a, State)
    v State
    s
                                        InfM y :: State -> (b, State)
    y = a -> InfM b
    f a
    x
                                    in State -> (b, State)
    y State
    s'
     -- return :: a -> InfM a
        return :: a -> InfM a
    return x :: a
    x = (State -> (a, State)) -> InfM a
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> (a, State)) -> InfM a)
    -> (State -> (a, State)) -> InfM a
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s -> (a
    x, State
    s)

    instance Applicative InfM where
        pure :: a -> InfM a
    pure = a -> InfM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
        <*> :: InfM (a -> b) -> InfM a -> InfM b
    (<*>) = InfM (a -> b) -> InfM a -> InfM b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Functor InfM where
        fmap :: (a -> b) -> InfM a -> InfM b
    fmap f :: a -> b
    f (InfM g :: State -> (a, State)
    g) = (State -> (b, State)) -> InfM b
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> (b, State)) -> InfM b)
    -> (State -> (b, State)) -> InfM b
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s ->
            case State -> (a, State)
    g State
    s of ~(a :: a
    a, s' :: State
    s') -> (a -> b
    f a
    a, State
    s')

    set_bits :: [Bit] -> InfM ()
    set_bits :: [Bit] -> InfM ()
    set_bits bs :: [Bit]
    bs = (State -> ((), State)) -> InfM ()
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> ((), State)) -> InfM ())
    -> (State -> ((), State)) -> InfM ()
    forall a b. (a -> b) -> a -> b
    $ ((), State) -> State -> ((), State)
    forall a b. a -> b -> a
    const ((), [Bit] -> Word32 -> Array Word32 Word32 -> Word32 -> State
    State [Bit]
    bs 0 ((Word32, Word32) -> [(Word32, Word32)] -> Array Word32 Word32
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (0, 32767) []) 0)

    {-
    no_bits :: InfM Bool
    no_bits = InfM $ \s -> (null (bits s), s)
    -}

    align_8_bits :: InfM ()
    align_8_bits :: InfM ()
    align_8_bits
     = (State -> ((), State)) -> InfM ()
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> ((), State)) -> InfM ())
    -> (State -> ((), State)) -> InfM ()
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s -> ((), State
    s { bits :: [Bit]
    bits = Word32 -> [Bit] -> [Bit]
    forall i a. Integral i => i -> [a] -> [a]
    genericDrop ((8 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - State -> Word32
    offset State
    s) Word32 -> Word32 -> Word32
    forall a. Integral a => a -> a -> a
    `mod` 8) (State -> [Bit]
    bits State
    s),
                             offset :: Word32
    offset = 0 })

    get_bits :: Word32 -> InfM [Bit]
    get_bits :: Word32 -> InfM [Bit]
    get_bits n :: Word32
    n = (State -> ([Bit], State)) -> InfM [Bit]
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> ([Bit], State)) -> InfM [Bit])
    -> (State -> ([Bit], State)) -> InfM [Bit]
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s -> case Word32 -> [Bit] -> ([Bit], [Bit])
    forall a a. (Eq a, Num a) => a -> [a] -> ([a], [a])
    need Word32
    n (State -> [Bit]
    bits State
    s) of
                                  (ys :: [Bit]
    ys, zs :: [Bit]
    zs) ->
                                      ([Bit]
    ys, State
    s { bits :: [Bit]
    bits = [Bit]
    zs,
                                               offset :: Word32
    offset = (Word32
    n Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + State -> Word32
    offset State
    s) Word32 -> Word32 -> Word32
    forall a. Integral a => a -> a -> a
    `mod` 8 } )
        where need :: a -> [a] -> ([a], [a])
    need 0 xs :: [a]
    xs     = ([], [a]
    xs)
              need _ []     = String -> ([a], [a])
    forall a. HasCallStack => String -> a
    error "get_bits: Don't have enough!"
              need i :: a
    i (x :: a
    x:xs :: [a]
    xs) = let (ys :: [a]
    ys, zs :: [a]
    zs) = a -> [a] -> ([a], [a])
    need (a
    ia -> a -> a
    forall a. Num a => a -> a -> a
    -1) [a]
    xs in (a
    xa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    ys, [a]
    zs)

    extract_InfM :: InfM a -> (a, [Bit])
    extract_InfM :: InfM a -> (a, [Bit])
    extract_InfM (InfM f :: State -> (a, State)
    f) = let (x :: a
    x, s :: State
    s) = State -> (a, State)
    f State
    forall a. HasCallStack => a
    undefined in (a
    x, State -> [Bit]
    bits State
    s)

    output_w32 :: Word32 -> InfM ()
    output_w32 :: Word32 -> InfM ()
    output_w32 w :: Word32
    w = (State -> ((), State)) -> InfM ()
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> ((), State)) -> InfM ())
    -> (State -> ((), State)) -> InfM ()
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s -> let l :: Word32
    l = State -> Word32
    loc State
    s
                                in ((), State
    s { history :: Array Word32 Word32
    history = State -> Array Word32 Word32
    history State
    s Array Word32 Word32 -> [(Word32, Word32)] -> Array Word32 Word32
    forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
    // [(Word32
    l, Word32
    w)],
                                            loc :: Word32
    loc = Word32
    l Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + 1 })

    repeat_w32s :: Word32 -> Word32 -> InfM [Word32]
    repeat_w32s :: Word32 -> Word32 -> InfM Output
    repeat_w32s len :: Word32
    len dist :: Word32
    dist
     = (State -> (Output, State)) -> InfM Output
    forall a. (State -> (a, State)) -> InfM a
    InfM ((State -> (Output, State)) -> InfM Output)
    -> (State -> (Output, State)) -> InfM Output
    forall a b. (a -> b) -> a -> b
    $ \s :: State
    s -> let l :: Word32
    l = State -> Word32
    loc State
    s
                        h :: Array Word32 Word32
    h = State -> Array Word32 Word32
    history State
    s
                        new :: Output
    new = (Word32 -> Word32) -> Output -> Output
    forall a b. (a -> b) -> [a] -> [b]
    map (Array Word32 Word32
    hArray Word32 Word32 -> Word32 -> Word32
    forall i e. Ix i => Array i e -> i -> e
    !) (Output -> Output) -> Output -> Output
    forall a b. (a -> b) -> a -> b
    $ Word32 -> Output -> Output
    forall i a. Integral i => i -> [a] -> [a]
    genericTake Word32
    dist ([(Word32
    l Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - Word32
    dist) Word32 -> Word32 -> Word32
    forall a. Integral a => a -> a -> a
    `mod` 32768..32767] Output -> Output -> Output
    forall a. [a] -> [a] -> [a]
    ++ [0..])
                        new_bit :: Output
    new_bit = Word32 -> Output -> Output
    forall i a. Integral i => i -> [a] -> [a]
    genericTake Word32
    len (Output -> Output
    forall a. [a] -> [a]
    cycle Output
    new)
                        h' :: Array Word32 Word32
    h' = Array Word32 Word32
    h Array Word32 Word32 -> [(Word32, Word32)] -> Array Word32 Word32
    forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
    // Output -> Output -> [(Word32, Word32)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((Word32 -> Word32) -> Output -> Output
    forall a b. (a -> b) -> [a] -> [b]
    map (Word32 -> Word32 -> Word32
    forall a. Integral a => a -> a -> a
    `mod` 32768) [Word32
    l..]) Output
    new_bit
                    in (Output
    new_bit, State
    s { history :: Array Word32 Word32
    history = Array Word32 Word32
    h', loc :: Word32
    loc = (Word32
    l Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    len) Word32 -> Word32 -> Word32
    forall a. Integral a => a -> a -> a
    `mod` 32768 })

    -----------------------------------

    get_word32s :: Word32 -> Word32 -> InfM [Word32]
    get_word32s :: Word32 -> Word32 -> InfM Output
    get_word32s _ 0 = Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    get_word32s b :: Word32
    b n :: Word32
    n = do Word32
    w <- Word32 -> InfM Word32
    get_w32 Word32
    b
                         Output
    ws <- Word32 -> Word32 -> InfM Output
    get_word32s Word32
    b (Word32
    nWord32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    -1)
                         Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word32
    wWord32 -> Output -> Output
    forall a. a -> [a] -> [a]
    :Output
    ws)

    get_w32 :: Word32 -> InfM Word32
    get_w32 :: Word32 -> InfM Word32
    get_w32 i :: Word32
    i = do [Bit]
    bs <- Word32 -> InfM [Bit]
    get_bits Word32
    i
                   Word32 -> InfM Word32
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Bit] -> Word32
    bits_to_word32 [Bit]
    bs)

    get_bit :: InfM Bit
    get_bit :: InfM Bit
    get_bit = do [Bit]
    res <- Word32 -> InfM [Bit]
    get_bits 1
                 case [Bit]
    res of
                     [x :: Bit
    x] -> Bit -> InfM Bit
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bit
    x
                     _   -> String -> InfM Bit
    forall a. HasCallStack => String -> a
    error (String -> InfM Bit) -> String -> InfM Bit
    forall a b. (a -> b) -> a -> b
    $ "get_bit: expected exactly one bit"

    {-
    \section{Inflate itself}

    The hardcore stuff!

    -}
    inflate :: [Int] -> (Output, [Bit])
    inflate :: [Int] -> (Output, [Bit])
    inflate is :: [Int]
    is = InfM Output -> (Output, [Bit])
    forall a. InfM a -> (a, [Bit])
    extract_InfM (InfM Output -> (Output, [Bit])) -> InfM Output -> (Output, [Bit])
    forall a b. (a -> b) -> a -> b
    $ do [Bit] -> InfM ()
    set_bits ([Bit] -> InfM ()) -> [Bit] -> InfM ()
    forall a b. (a -> b) -> a -> b
    $ (Int -> [Bit]) -> [Int] -> [Bit]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Int -> [Bit]
    int_to_bits [Int]
    is
                                   Output
    x <- Bool -> InfM Output
    inflate_blocks Bool
    False
                                   InfM ()
    align_8_bits
                                   Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return Output
    x

    -- Bool is true if we have seen the "last" block
    inflate_blocks :: Bool -> InfM Output
    inflate_blocks :: Bool -> InfM Output
    inflate_blocks True = Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    inflate_blocks False
         = do [Bit]
    res <- Word32 -> InfM [Bit]
    get_bits 3
              case [Bit]
    res of
                  [Bit is_last :: Bool
    is_last, Bit t1 :: Bool
    t1, Bit t2 :: Bool
    t2] ->
                      case (Bool
    t1, Bool
    t2) of
                          (False, False) ->
                              do InfM ()
    align_8_bits
                                 Word32
    len <- Word32 -> InfM Word32
    get_w32 16
                                 Word32
    nlen <- Word32 -> InfM Word32
    get_w32 16
                                 Bool -> InfM () -> InfM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Word32
    len Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    nlen Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == 2Word32 -> Int -> Word32
    forall a b. (Num a, Integral b) => a -> b -> a
    ^(32 :: Int) Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - 1)
                                    (InfM () -> InfM ()) -> InfM () -> InfM ()
    forall a b. (a -> b) -> a -> b
    $ String -> InfM ()
    forall a. HasCallStack => String -> a
    error "inflate_blocks: Mismatched lengths"
                                 Output
    ws <- Word32 -> Word32 -> InfM Output
    get_word32s 8 Word32
    len
                                 (Word32 -> InfM ()) -> Output -> InfM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Word32 -> InfM ()
    output_w32 Output
    ws
                                 Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return Output
    ws
                          (True, False) ->
                              Bool -> Tables -> InfM Output
    inflate_codes Bool
    is_last Tables
    inflate_trees_fixed
                          (False, True) ->
                              do Tables
    tables <- InfM Tables
    inflate_tables
                                 Bool -> Tables -> InfM Output
    inflate_codes Bool
    is_last Tables
    tables
                          (True, True) ->
                              String -> InfM Output
    forall a. HasCallStack => String -> a
    error ("inflate_blocks: case 11 reserved")
                  _ -> String -> InfM Output
    forall a. HasCallStack => String -> a
    error ("inflate_blocks: expected 3 bits")

    inflate_tables :: InfM Tables
    inflate_tables :: InfM Tables
    inflate_tables
     = do Word32
    hlit <- Word32 -> InfM Word32
    get_w32 5
          Word32
    hdist <- Word32 -> InfM Word32
    get_w32 5
          Word32
    hclen <- Word32 -> InfM Word32
    get_w32 4
          [Bit]
    llc_bs <- Word32 -> InfM [Bit]
    get_bits ((Word32
    hclen Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + 4) Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    * 3)
          let llc_bs' :: [(Word32, Word32)]
    llc_bs' = Output -> Output -> [(Word32, Word32)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (([Bit] -> Word32) -> [[Bit]] -> Output
    forall a b. (a -> b) -> [a] -> [b]
    map [Bit] -> Word32
    bits_to_word32 ([[Bit]] -> Output) -> [[Bit]] -> Output
    forall a b. (a -> b) -> a -> b
    $ [Bit] -> [[Bit]]
    forall a. [a] -> [[a]]
    triple [Bit]
    llc_bs)
                            [16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15]
              tab :: InfM Word32
    tab = [(Word32, Word32)] -> InfM Word32
    make_table [(Word32, Word32)]
    llc_bs'
          Output
    lit_dist_lengths <- InfM Word32 -> Word32 -> Word32 -> InfM Output
    make_lit_dist_lengths InfM Word32
    tab
                                                    (258 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    hlit Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    hdist)
                                                    (String -> Word32
    forall a. HasCallStack => String -> a
    error "inflate_tables dummy")
          let (lit_lengths :: Output
    lit_lengths, dist_lengths :: Output
    dist_lengths) = Word32 -> Output -> (Output, Output)
    forall i a. Integral i => i -> [a] -> ([a], [a])
    genericSplitAt (257 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    hlit)
                                                           Output
    lit_dist_lengths
              lit_table :: InfM Word32
    lit_table = [(Word32, Word32)] -> InfM Word32
    make_table (Output -> Output -> [(Word32, Word32)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip Output
    lit_lengths [0..])
              dist_table :: InfM Word32
    dist_table = [(Word32, Word32)] -> InfM Word32
    make_table (Output -> Output -> [(Word32, Word32)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip Output
    dist_lengths [0..])
          Tables -> InfM Tables
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InfM Word32
    lit_table, InfM Word32
    dist_table)

    triple :: [a] -> [[a]]
    triple :: [a] -> [[a]]
    triple (a :: a
    a:b :: a
    b:c :: a
    c:xs :: [a]
    xs) = [a
    a,a
    b,a
    c][a] -> [[a]] -> [[a]]
    forall a. a -> [a] -> [a]
    :[a] -> [[a]]
    forall a. [a] -> [[a]]
    triple [a]
    xs
    triple []         = []
    triple _          = String -> [[a]]
    forall a. HasCallStack => String -> a
    error "triple: can't happen"

    make_lit_dist_lengths :: Table -> Word32 -> Word32 -> InfM [Word32]
    make_lit_dist_lengths :: InfM Word32 -> Word32 -> Word32 -> InfM Output
    make_lit_dist_lengths _ i :: Word32
    i _ | Word32
    i Word32 -> Word32 -> Bool
    forall a. Ord a => a -> a -> Bool
    < 0 = String -> InfM Output
    forall a. HasCallStack => String -> a
    error "make_lit_dist_lengths i < 0"
    make_lit_dist_lengths _ 0 _ = Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    make_lit_dist_lengths tab :: InfM Word32
    tab i :: Word32
    i last_thing :: Word32
    last_thing
     = do Word32
    c <- InfM Word32
    tab
          (ls :: Output
    ls, i' :: Word32
    i', last_thing' :: Word32
    last_thing') <- Word32 -> Word32 -> Word32 -> InfM (Output, Word32, Word32)
    meta_code Word32
    i Word32
    c Word32
    last_thing
          Output
    ws <- InfM Word32 -> Word32 -> Word32 -> InfM Output
    make_lit_dist_lengths InfM Word32
    tab Word32
    i' Word32
    last_thing'
          Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Output
    ls Output -> Output -> Output
    forall a. [a] -> [a] -> [a]
    ++ Output
    ws)

    meta_code :: Word32 -> Code -> Word32 -> InfM ([Word32], Word32, Word32)
    meta_code :: Word32 -> Word32 -> Word32 -> InfM (Output, Word32, Word32)
    meta_code c :: Word32
    c i :: Word32
    i _ | Word32
    i Word32 -> Word32 -> Bool
    forall a. Ord a => a -> a -> Bool
    < 16 = (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Word32
    i], Word32
    c Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - 1, Word32
    i)
    meta_code c :: Word32
    c 16 last_thing :: Word32
    last_thing
                     = do [Bit]
    xs <- Word32 -> InfM [Bit]
    get_bits 2
                          let l :: Word32
    l = 3 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + [Bit] -> Word32
    bits_to_word32 [Bit]
    xs
                          (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word32 -> Word32 -> Output
    forall i a. Integral i => i -> a -> [a]
    genericReplicate Word32
    l Word32
    last_thing, Word32
    c Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - Word32
    l, Word32
    last_thing)
    meta_code c :: Word32
    c 17 _ = do [Bit]
    xs <- Word32 -> InfM [Bit]
    get_bits 3
                          let l :: Word32
    l = 3 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + [Bit] -> Word32
    bits_to_word32 [Bit]
    xs
                          (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word32 -> Word32 -> Output
    forall i a. Integral i => i -> a -> [a]
    genericReplicate Word32
    l 0, Word32
    c Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - Word32
    l, 0)
    meta_code c :: Word32
    c 18 _ = do [Bit]
    xs <- Word32 -> InfM [Bit]
    get_bits 7
                          let l :: Word32
    l = 11 Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + [Bit] -> Word32
    bits_to_word32 [Bit]
    xs
                          (Output, Word32, Word32) -> InfM (Output, Word32, Word32)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word32 -> Word32 -> Output
    forall i a. Integral i => i -> a -> [a]
    genericReplicate Word32
    l 0, Word32
    c Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    - Word32
    l, 0)
    meta_code _ i :: Word32
    i _ = String -> InfM (Output, Word32, Word32)
    forall a. HasCallStack => String -> a
    error (String -> InfM (Output, Word32, Word32))
    -> String -> InfM (Output, Word32, Word32)
    forall a b. (a -> b) -> a -> b
    $ "meta_code: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Word32 -> String
    forall a. Show a => a -> String
    show Word32
    i

    inflate_codes :: Bool -> Tables -> InfM Output
    inflate_codes :: Bool -> Tables -> InfM Output
    inflate_codes seen_last :: Bool
    seen_last tabs :: Tables
    tabs@(tab_litlen :: InfM Word32
    tab_litlen, tab_dist :: InfM Word32
    tab_dist)
     =
       {- do done <- no_bits
          if done
            then return [] -- XXX Is this right?
            else -}
                 do Word32
    i <- InfM Word32
    tab_litlen;
                    if Word32
    i Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == 256
                      then Bool -> InfM Output
    inflate_blocks Bool
    seen_last
                      else
                           do Output
    pref <- if Word32
    i Word32 -> Word32 -> Bool
    forall a. Ord a => a -> a -> Bool
    < 256
                                      then do Word32 -> InfM ()
    output_w32 Word32
    i
                                              Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Word32
    i]
                                      else case Word32 -> [(Word32, (Word32, Word32))] -> Maybe (Word32, Word32)
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Word32
    i [(Word32, (Word32, Word32))]
    litlens of
                                               Nothing -> String -> InfM Output
    forall a. HasCallStack => String -> a
    error "do_code_litlen"
                                               Just (base :: Word32
    base, num_bits :: Word32
    num_bits) ->
                                                   do Word32
    extra <- Word32 -> InfM Word32
    get_w32 Word32
    num_bits
                                                      let l :: Word32
    l = Word32
    base Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    extra
                                                      Word32
    dist <- InfM Word32 -> InfM Word32
    dist_code InfM Word32
    tab_dist
                                                      Word32 -> Word32 -> InfM Output
    repeat_w32s Word32
    l Word32
    dist
                              Output
    o <- Bool -> Tables -> InfM Output
    inflate_codes Bool
    seen_last Tables
    tabs
                              Output -> InfM Output
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Output
    pref Output -> Output -> Output
    forall a. [a] -> [a] -> [a]
    ++ Output
    o)

    litlens :: [(Code, (LitLen, Word32))]
    litlens :: [(Word32, (Word32, Word32))]
    litlens = Output -> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [257..285] ([(Word32, Word32)] -> [(Word32, (Word32, Word32))])
    -> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
    forall a b. (a -> b) -> a -> b
    $ Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
    mk_bases 3 [(Int, Word32)]
    litlen_counts [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
    forall a. [a] -> [a] -> [a]
    ++ [(258, 0)]
        where litlen_counts :: [(Int, Word32)]
    litlen_counts = [(8,0),(4,1),(4,2),(4,3),(4,4),(4,5)]

    dist_code :: Table -> InfM Dist
    dist_code :: InfM Word32 -> InfM Word32
    dist_code tab :: InfM Word32
    tab
     = do Word32
    code <- InfM Word32
    tab
          case Word32 -> [(Word32, (Word32, Word32))] -> Maybe (Word32, Word32)
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Word32
    code [(Word32, (Word32, Word32))]
    dists of
              Nothing -> String -> InfM Word32
    forall a. HasCallStack => String -> a
    error "dist_code"
              Just (base :: Word32
    base, num_bits :: Word32
    num_bits) -> do Word32
    extra <- Word32 -> InfM Word32
    get_w32 Word32
    num_bits
                                          Word32 -> InfM Word32
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Word32
    base Word32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    + Word32
    extra)

    dists :: [(Code, (Dist, Word32))]
    dists :: [(Word32, (Word32, Word32))]
    dists = Output -> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [0..29] ([(Word32, Word32)] -> [(Word32, (Word32, Word32))])
    -> [(Word32, Word32)] -> [(Word32, (Word32, Word32))]
    forall a b. (a -> b) -> a -> b
    $ Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
    mk_bases 1 [(Int, Word32)]
    dist_counts
        where dist_counts :: [(Int, Word32)]
    dist_counts = (4,0)(Int, Word32) -> [(Int, Word32)] -> [(Int, Word32)]
    forall a. a -> [a] -> [a]
    :(Word32 -> (Int, Word32)) -> Output -> [(Int, Word32)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((,) 2) [1..13]

    mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
    mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)]
    mk_bases base :: Word32
    base counts :: [(Int, Word32)]
    counts = (Word32, [(Word32, Word32)]) -> [(Word32, Word32)]
    forall a b. (a, b) -> b
    snd ((Word32, [(Word32, Word32)]) -> [(Word32, Word32)])
    -> (Word32, [(Word32, Word32)]) -> [(Word32, Word32)]
    forall a b. (a -> b) -> a -> b
    $ (Word32 -> Word32 -> (Word32, (Word32, Word32)))
    -> Word32 -> Output -> (Word32, [(Word32, Word32)])
    forall (t :: * -> *) a b c.
    Traversable t =>
    (a -> b -> (a, c)) -> a -> t b -> (a, t c)
    mapAccumL Word32 -> Word32 -> (Word32, (Word32, Word32))
    forall b a. (Integral b, Num a) => a -> b -> (a, (a, b))
    next_base Word32
    base Output
    incs
                where next_base :: a -> b -> (a, (a, b))
    next_base current :: a
    current bs :: b
    bs = (a
    current a -> a -> a
    forall a. Num a => a -> a -> a
    + 2a -> b -> a
    forall a b. (Num a, Integral b) => a -> b -> a
    ^b
    bs, (a
    current, b
    bs))
                      incs :: Output
    incs = [Output] -> Output
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([Output] -> Output) -> [Output] -> Output
    forall a b. (a -> b) -> a -> b
    $ ((Int, Word32) -> Output) -> [(Int, Word32)] -> [Output]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Int -> Word32 -> Output) -> (Int, Word32) -> Output
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry Int -> Word32 -> Output
    forall a. Int -> a -> [a]
    replicate) [(Int, Word32)]
    counts

    {-
    \section{Fixed tables}

    The fixed tables. Not much to say really.

    -}
    inflate_trees_fixed :: Tables
    inflate_trees_fixed :: Tables
    inflate_trees_fixed = ([(Word32, Word32)] -> InfM Word32
    make_table ([(Word32, Word32)] -> InfM Word32)
    -> [(Word32, Word32)] -> InfM Word32
    forall a b. (a -> b) -> a -> b
    $ [(8, Word32
    c) | Word32
    c <- [0..143]]
                                     [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
    forall a. [a] -> [a] -> [a]
    ++ [(9, Word32
    c) | Word32
    c <- [144..255]]
                                     [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
    forall a. [a] -> [a] -> [a]
    ++ [(7, Word32
    c) | Word32
    c <- [256..279]]
                                     [(Word32, Word32)] -> [(Word32, Word32)] -> [(Word32, Word32)]
    forall a. [a] -> [a] -> [a]
    ++ [(8, Word32
    c) | Word32
    c <- [280..287]],
                           [(Word32, Word32)] -> InfM Word32
    make_table [(5, Word32
    c) | Word32
    c <- [0..29]])

    {-
    \section{The Huffman Tree}

    As the name suggests, the obvious way to store Huffman trees is in a
    tree datastructure. Externally we want to view them as functions though,
    so we wrap the tree with \verb!get_code! which takes a list of bits and
    returns the corresponding code and the remaining bits. To make a tree
    from a list of length code pairs is a simple recursive process.

    -}
    data Tree = Branch Tree Tree | Leaf Word32 | Null

    make_table :: [(Length, Code)] -> Table
    make_table :: [(Word32, Word32)] -> InfM Word32
    make_table lcs :: [(Word32, Word32)]
    lcs = case Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
    make_tree 0 ([(Word32, Word32)] -> (Tree, [(Word32, Word32)]))
    -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
    forall a b. (a -> b) -> a -> b
    $ [(Word32, Word32)] -> [(Word32, Word32)]
    forall a. Ord a => [a] -> [a]
    sort ([(Word32, Word32)] -> [(Word32, Word32)])
    -> [(Word32, Word32)] -> [(Word32, Word32)]
    forall a b. (a -> b) -> a -> b
    $ ((Word32, Word32) -> Bool)
    -> [(Word32, Word32)] -> [(Word32, Word32)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    /= 0) (Word32 -> Bool)
    -> ((Word32, Word32) -> Word32) -> (Word32, Word32) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Word32, Word32) -> Word32
    forall a b. (a, b) -> a
    fst) [(Word32, Word32)]
    lcs of
                         (tree :: Tree
    tree, []) -> Tree -> InfM Word32
    get_code Tree
    tree
                         _          -> String -> InfM Word32
    forall a. HasCallStack => String -> a
    error (String -> InfM Word32) -> String -> InfM Word32
    forall a b. (a -> b) -> a -> b
    $ "make_table: Left-over lcs from"

    get_code :: Tree -> InfM Code
    get_code :: Tree -> InfM Word32
    get_code (Branch zero_tree :: Tree
    zero_tree one_tree :: Tree
    one_tree)
     = do Bit b :: Bool
    b <- InfM Bit
    get_bit
          if Bool
    b then Tree -> InfM Word32
    get_code Tree
    one_tree else Tree -> InfM Word32
    get_code Tree
    zero_tree
    get_code (Leaf w :: Word32
    w) = Word32 -> InfM Word32
    forall (m :: * -> *) a. Monad m => a -> m a
    return Word32
    w
    get_code Null = String -> InfM Word32
    forall a. HasCallStack => String -> a
    error "get_code Null"

    make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)])
    make_tree :: Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
    make_tree _ [] = (Tree
    Null, [])
    make_tree i :: Word32
    i lcs :: [(Word32, Word32)]
    lcs@((l :: Word32
    l, c :: Word32
    c):lcs' :: [(Word32, Word32)]
    lcs')
     | Word32
    i Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word32
    l = (Word32 -> Tree
    Leaf Word32
    c, [(Word32, Word32)]
    lcs')
     | Word32
    i Word32 -> Word32 -> Bool
    forall a. Ord a => a -> a -> Bool
    < Word32
    l = let (zero_tree :: Tree
    zero_tree, lcs_z :: [(Word32, Word32)]
    lcs_z) = Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
    make_tree (Word32
    iWord32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    +1) [(Word32, Word32)]
    lcs
                   (one_tree :: Tree
    one_tree, lcs_o :: [(Word32, Word32)]
    lcs_o) = Word32 -> [(Word32, Word32)] -> (Tree, [(Word32, Word32)])
    make_tree (Word32
    iWord32 -> Word32 -> Word32
    forall a. Num a => a -> a -> a
    +1) [(Word32, Word32)]
    lcs_z
               in (Tree -> Tree -> Tree
    Branch Tree
    zero_tree Tree
    one_tree, [(Word32, Word32)]
    lcs_o)
     | Bool
    otherwise = String -> (Tree, [(Word32, Word32)])
    forall a. HasCallStack => String -> a
    error "make_tree: can't happen"