{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoStrict #-}

module Data.IP.Builder (
    -- * 'P.BoundedPrim' 'B.Builder's for general, IPv4 and IPv6 addresses.
    ipBuilder,
    ipv4Builder,
    ipv6Builder,
) where

import qualified Data.ByteString.Builder as B
import Data.ByteString.Builder.Prim ((>$<), (>*<))
import qualified Data.ByteString.Builder.Prim as P
import GHC.Exts
import GHC.Word (Word16 (..), Word32 (..), Word8 (..))

import Data.IP.Addr

------------ IP builders

{-# INLINE ipBuilder #-}

-- | 'P.BoundedPrim' bytestring 'B.Builder' for general 'IP' addresses.
ipBuilder :: IP -> B.Builder
ipBuilder :: IP -> Builder
ipBuilder (IPv4 IPv4
addr) = IPv4 -> Builder
ipv4Builder IPv4
addr
ipBuilder (IPv6 IPv6
addr) = IPv6 -> Builder
ipv6Builder IPv6
addr

{-# INLINE ipv4Builder #-}

-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv4' addresses.
ipv4Builder :: IPv4 -> B.Builder
ipv4Builder :: IPv4 -> Builder
ipv4Builder IPv4
addr = BoundedPrim Word32 -> Word32 -> Builder
forall a. BoundedPrim a -> a -> Builder
P.primBounded BoundedPrim Word32
ipv4Bounded (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$! IPv4 -> Word32
fromIPv4w IPv4
addr

{-# INLINE ipv6Builder #-}

-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv6' addresses.
ipv6Builder :: IPv6 -> B.Builder
ipv6Builder :: IPv6 -> Builder
ipv6Builder IPv6
addr = BoundedPrim (Word32, Word32, Word32, Word32)
-> (Word32, Word32, Word32, Word32) -> Builder
forall a. BoundedPrim a -> a -> Builder
P.primBounded BoundedPrim (Word32, Word32, Word32, Word32)
ipv6Bounded ((Word32, Word32, Word32, Word32) -> Builder)
-> (Word32, Word32, Word32, Word32) -> Builder
forall a b. (a -> b) -> a -> b
$! IPv6 -> (Word32, Word32, Word32, Word32)
fromIPv6w IPv6
addr

------------ Builder utilities

-- Convert fixed to bounded for fusion
toB :: P.FixedPrim a -> P.BoundedPrim a
toB :: forall a. FixedPrim a -> BoundedPrim a
toB = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded
{-# INLINE toB #-}

ipv4Bounded :: P.BoundedPrim Word32
ipv4Bounded :: BoundedPrim Word32
ipv4Bounded =
    Word32 -> (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
quads
        (Word32 -> (((Word8, ()), (Word8, ())), ((Word8, ()), Word8)))
-> BoundedPrim (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
-> BoundedPrim Word32
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< ((BoundedPrim Word8
P.word8Dec BoundedPrim Word8 -> BoundedPrim () -> BoundedPrim (Word8, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
dotsep) BoundedPrim (Word8, ())
-> BoundedPrim (Word8, ())
-> BoundedPrim ((Word8, ()), (Word8, ()))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim Word8
P.word8Dec BoundedPrim Word8 -> BoundedPrim () -> BoundedPrim (Word8, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
dotsep))
            BoundedPrim ((Word8, ()), (Word8, ()))
-> BoundedPrim ((Word8, ()), Word8)
-> BoundedPrim (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< ((BoundedPrim Word8
P.word8Dec BoundedPrim Word8 -> BoundedPrim () -> BoundedPrim (Word8, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
dotsep) BoundedPrim (Word8, ())
-> BoundedPrim Word8 -> BoundedPrim ((Word8, ()), Word8)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word8
P.word8Dec)
  where
    quads :: Word32 -> (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
quads Word32
a = ((Int# -> Word32 -> (Word8, ())
qdot Int#
0o30# Word32
a, Int# -> Word32 -> (Word8, ())
qdot Int#
0o20# Word32
a), (Int# -> Word32 -> (Word8, ())
qdot Int#
0o10# Word32
a, Word32 -> Word8
qfin Word32
a))
    {-# INLINE quads #-}
    qdot :: Int# -> Word32 -> (Word8, ())
qdot Int#
s (W32# Word32#
a) =
        ( Word8# -> Word8
W8#
            (Word# -> Word8#
wordToWord8Compat# ((Word32# -> Word#
word32ToWordCompat# Word32#
a Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
s) Word# -> Word# -> Word#
`and#` Word#
0xff##))
        , ()
        )
    {-# INLINE qdot #-}
    qfin :: Word32 -> Word8
qfin (W32# Word32#
a) = Word8# -> Word8
W8# (Word# -> Word8#
wordToWord8Compat# (Word32# -> Word#
word32ToWordCompat# Word32#
a Word# -> Word# -> Word#
`and#` Word#
0xff##))
    {-# INLINE qfin #-}
    dotsep :: BoundedPrim b
dotsep = Word8 -> b -> Word8
forall a b. a -> b -> a
const Word8
0x2e (b -> Word8) -> BoundedPrim Word8 -> BoundedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
toB FixedPrim Word8
P.word8

-- | For each 32-bit chunk of an IPv6 address, encode its display format in the
-- presentation form of the address, based on its location relative to the
-- "best gap", i.e. the left-most longest run of zeros. The "hi" (H) and/or
-- "lo" (L) 16 bits may be accompanied by colons (C) on the left and/or right.
data FF
    = -- | :<h>:<l>
      CHL Word32
    | -- |  <h>:<l>
      HL Word32
    | -- |  nop
      NOP
    | -- | :
      COL
    | -- | :   :
      CC
    | -- |     :<l>
      CLO Word32
    | -- | :<h>:
      CHC Word32
    | -- |  <h>:
      HC Word32

-- Build an IPv6 address in conformance with
-- [RFC5952](http://tools.ietf.org/html/rfc5952 RFC 5952).
--
ipv6Bounded :: P.BoundedPrim (Word32, Word32, Word32, Word32)
ipv6Bounded :: BoundedPrim (Word32, Word32, Word32, Word32)
ipv6Bounded =
    ((Word32, Word32, Word32, Word32) -> Bool)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB
        (Word32, Word32, Word32, Word32) -> Bool
generalCase
        ((Word32, Word32, Word32, Word32) -> ((FF, FF), (FF, FF))
genFields ((Word32, Word32, Word32, Word32) -> ((FF, FF), (FF, FF)))
-> BoundedPrim ((FF, FF), (FF, FF))
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ((FF, FF), (FF, FF))
output128)
        ( ((Word32, Word32, Word32, Word32) -> Bool)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB
            (Word32, Word32, Word32, Word32) -> Bool
v4mapped
            ( (Word32, Word32, Word32, Word32)
-> ((Word32, Word32), (Word32, Word32))
forall {a} {b} {a} {b}. (a, b, a, b) -> ((a, b), (a, b))
pairPair
                ((Word32, Word32, Word32, Word32)
 -> ((Word32, Word32), (Word32, Word32)))
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Word32
forall {b}. BoundedPrim b
colsep BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
forall {b}. BoundedPrim b
colsep)
                    BoundedPrim (Word32, Word32)
-> BoundedPrim (Word32, Word32)
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim Word32
forall {b}. BoundedPrim b
ffff BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (Word32 -> ((), Word32)
forall a. a -> ((), a)
fstUnit (Word32 -> ((), Word32))
-> BoundedPrim ((), Word32) -> BoundedPrim Word32
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word32 -> BoundedPrim ((), Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
ipv4Bounded))
            )
            ((Word32, Word32, Word32, Word32)
-> ((Word32, Word32), (Word32, Word32))
forall {a} {b} {a} {b}. (a, b, a, b) -> ((a, b), (a, b))
pairPair ((Word32, Word32, Word32, Word32)
 -> ((Word32, Word32), (Word32, Word32)))
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Word32
forall {b}. BoundedPrim b
P.emptyB BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
forall {b}. BoundedPrim b
colsep) BoundedPrim (Word32, Word32)
-> BoundedPrim (Word32, Word32)
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim Word32
forall {b}. BoundedPrim b
colsep BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
ipv4Bounded))
        )
  where
    -- The boundedPrim switches and predicates need to be inlined for best
    -- performance, gaining a factor of ~2 in throughput in tests.
    --
    {-# INLINE output128 #-}
    {-# INLINE output64 #-}
    {-# INLINE generalCase #-}
    {-# INLINE v4mapped #-}
    {-# INLINE output32 #-}

    generalCase :: (Word32, Word32, Word32, Word32) -> Bool
    generalCase :: (Word32, Word32, Word32, Word32) -> Bool
generalCase (Word32
w0, Word32
w1, Word32
w2, Word32
w3) =
        Word32
w0 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
|| Word32
w1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
|| (Word32
w2 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0xffff Bool -> Bool -> Bool
&& (Word32
w2 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
|| Word32
w3 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
0xffff))
    --
    v4mapped :: (Word32, Word32, Word32, Word32) -> Bool
    v4mapped :: (Word32, Word32, Word32, Word32) -> Bool
v4mapped (Word32
w0, Word32
w1, Word32
w2, Word32
_) =
        Word32
w0 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Word32
w1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Word32
w2 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xffff

    -- BoundedPrim for the full 128-bit IPv6 address given as
    -- a pair of pairs of FF values, which encode the
    -- output format of each of the 32-bit chunks.
    --
    output128 :: P.BoundedPrim ((FF, FF), (FF, FF))
    output128 :: BoundedPrim ((FF, FF), (FF, FF))
output128 = BoundedPrim (FF, FF)
output64 BoundedPrim (FF, FF)
-> BoundedPrim (FF, FF) -> BoundedPrim ((FF, FF), (FF, FF))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim (FF, FF)
output64
    output64 :: BoundedPrim (FF, FF)
output64 = (BoundedPrim FF
output32 BoundedPrim FF -> BoundedPrim FF -> BoundedPrim (FF, FF)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim FF
output32)
    --
    -- And finally the per-word case-work.
    --
    output32 :: P.BoundedPrim FF
    output32 :: BoundedPrim FF
output32 =
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case CHL Word32
_ -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
build_CHL (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :hi:lo
            (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case HL Word32
_ -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
build_HL (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ --  hi:lo
                (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case FF
NOP -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
forall {b}. BoundedPrim b
build_NOP (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ --
                    (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case FF
COL -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
forall {b}. BoundedPrim b
build_COL (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :
                        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case FF
CC -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
forall {b}. BoundedPrim b
build_CC (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :  :
                            (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case CLO Word32
_ -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
build_CLO (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ --    :lo
                                (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case CHC Word32
_ -> Bool
True; FF
_ -> Bool
False) BoundedPrim FF
build_CHC (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :hi:
                                    BoundedPrim FF
build_HC --  hi:

    -- encoders for the eight field format (FF) cases.
    --
    build_CHL :: BoundedPrim FF
build_CHL =
        ( \case
            CHL Word32
w -> (Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
hi16 Word32
w), Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
lo16 Word32
w))
            FF
_ -> (((), Word16), ((), Word16))
forall a. HasCallStack => a
undefined
        )
            (FF -> (((), Word16), ((), Word16)))
-> BoundedPrim (((), Word16), ((), Word16)) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex)
                BoundedPrim ((), Word16)
-> BoundedPrim ((), Word16)
-> BoundedPrim (((), Word16), ((), Word16))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex)
    --
    build_HL :: BoundedPrim FF
build_HL =
        ( \case
            HL Word32
w -> (Word32 -> Word16
hi16 Word32
w, Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
lo16 Word32
w))
            FF
_ -> (Word16, ((), Word16))
forall a. HasCallStack => a
undefined
        )
            (FF -> (Word16, ((), Word16)))
-> BoundedPrim (Word16, ((), Word16)) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Word16
P.word16Hex BoundedPrim Word16
-> BoundedPrim ((), Word16) -> BoundedPrim (Word16, ((), Word16))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex
    --
    build_NOP :: BoundedPrim a
build_NOP = BoundedPrim a
forall {b}. BoundedPrim b
P.emptyB
    --
    build_COL :: BoundedPrim b
build_COL = () -> b -> ()
forall a b. a -> b -> a
const () (b -> ()) -> BoundedPrim () -> BoundedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall {b}. BoundedPrim b
colsep
    --
    build_CC :: BoundedPrim b
build_CC = ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()) (b -> ((), ())) -> BoundedPrim ((), ()) -> BoundedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim () -> BoundedPrim ((), ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
colsep
    --
    build_CLO :: BoundedPrim FF
build_CLO =
        ( \case
            CLO Word32
w -> Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
lo16 Word32
w)
            FF
_ -> ((), Word16)
forall a. HasCallStack => a
undefined
        )
            (FF -> ((), Word16)) -> BoundedPrim ((), Word16) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex
    --
    build_CHC :: BoundedPrim FF
build_CHC =
        ( \case
            CHC Word32
w -> (Word16, ()) -> ((), (Word16, ()))
forall a. a -> ((), a)
fstUnit (Word16 -> (Word16, ())
forall a. a -> (a, ())
sndUnit (Word32 -> Word16
hi16 Word32
w))
            FF
_ -> ((), (Word16, ()))
forall a. HasCallStack => a
undefined
        )
            (FF -> ((), (Word16, ())))
-> BoundedPrim ((), (Word16, ())) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall {b}. BoundedPrim b
colsep BoundedPrim ()
-> BoundedPrim (Word16, ()) -> BoundedPrim ((), (Word16, ()))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex BoundedPrim Word16 -> BoundedPrim () -> BoundedPrim (Word16, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
colsep
    --
    build_HC :: BoundedPrim FF
build_HC =
        ( \case
            HC Word32
w -> Word16 -> (Word16, ())
forall a. a -> (a, ())
sndUnit (Word32 -> Word16
hi16 Word32
w)
            FF
_ -> (Word16, ())
forall a. HasCallStack => a
undefined
        )
            (FF -> (Word16, ())) -> BoundedPrim (Word16, ()) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Word16
P.word16Hex BoundedPrim Word16 -> BoundedPrim () -> BoundedPrim (Word16, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall {b}. BoundedPrim b
colsep

    -- static encoders
    --
    colsep :: P.BoundedPrim a
    colsep :: forall {b}. BoundedPrim b
colsep = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
toB (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ Word8 -> a -> Word8
forall a b. a -> b -> a
const Word8
0x3a (a -> Word8) -> FixedPrim Word8 -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Word8
P.word8
    --
    ffff :: P.BoundedPrim a
    ffff :: forall {b}. BoundedPrim b
ffff = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
toB (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ Word16 -> a -> Word16
forall a b. a -> b -> a
const Word16
0xffff (a -> Word16) -> FixedPrim Word16 -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Word16
P.word16HexFixed

    -- \| Helpers
    hi16, lo16 :: Word32 -> Word16
    hi16 :: Word32 -> Word16
hi16 !(W32# Word32#
w) = Word16# -> Word16
W16# (Word# -> Word16#
wordToWord16Compat# (Word32# -> Word#
word32ToWordCompat# Word32#
w Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
16#))
    lo16 :: Word32 -> Word16
lo16 !(W32# Word32#
w) = Word16# -> Word16
W16# (Word# -> Word16#
wordToWord16Compat# (Word32# -> Word#
word32ToWordCompat# Word32#
w Word# -> Word# -> Word#
`and#` Word#
0xffff##))
    --
    fstUnit :: a -> ((), a)
    fstUnit :: forall a. a -> ((), a)
fstUnit = ((),)
    --
    sndUnit :: a -> (a, ())
    sndUnit :: forall a. a -> (a, ())
sndUnit = (,())
    --
    pairPair :: (a, b, a, b) -> ((a, b), (a, b))
pairPair (a
a, b
b, a
c, b
d) = ((a
a, b
b), (a
c, b
d))

    -- Construct fields decorated with output format details
    genFields :: (Word32, Word32, Word32, Word32) -> ((FF, FF), (FF, FF))
genFields (Word32
w0, Word32
w1, Word32
w2, Word32
w3) =
        let !(!Int
gapStart, !Int
gapEnd) = Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)
bestgap Word32
w0 Word32
w1 Word32
w2 Word32
w3
            !f0 :: FF
f0 = Int -> Int -> Word32 -> FF
makeF0 Int
gapStart Int
gapEnd Word32
w0
            !f1 :: FF
f1 = Int -> Int -> Int# -> Int# -> Word32 -> FF
makeF12 Int
gapStart Int
gapEnd Int#
2# Int#
3# Word32
w1
            !f2 :: FF
f2 = Int -> Int -> Int# -> Int# -> Word32 -> FF
makeF12 Int
gapStart Int
gapEnd Int#
4# Int#
5# Word32
w2
            !f3 :: FF
f3 = Int -> Int -> Word32 -> FF
makeF3 Int
gapStart Int
gapEnd Word32
w3
         in ((FF
f0, FF
f1), (FF
f2, FF
f3))

    makeF0 :: Int -> Int -> Word32 -> FF
makeF0 (I# Int#
gapStart) (I# Int#
gapEnd) !Word32
w =
        case (Int#
gapEnd Int# -> Int# -> Int#
==# Int#
0#) Int# -> Int# -> Int#
`orI#` (Int#
gapStart Int# -> Int# -> Int#
># Int#
1#) of
            Int#
1# -> Word32 -> FF
HL Word32
w
            Int#
_ -> case Int#
gapStart Int# -> Int# -> Int#
==# Int#
0# of
                Int#
1# -> FF
COL
                Int#
_ -> Word32 -> FF
HC Word32
w
    {-# INLINE makeF0 #-}

    makeF12 :: Int -> Int -> Int# -> Int# -> Word32 -> FF
makeF12 (I# Int#
gapStart) (I# Int#
gapEnd) Int#
il Int#
ir !Word32
w =
        case (Int#
gapEnd Int# -> Int# -> Int#
<=# Int#
il) Int# -> Int# -> Int#
`orI#` (Int#
gapStart Int# -> Int# -> Int#
># Int#
ir) of
            Int#
1# -> Word32 -> FF
CHL Word32
w
            Int#
_ -> case Int#
gapStart Int# -> Int# -> Int#
>=# Int#
il of
                Int#
1# -> case Int#
gapStart Int# -> Int# -> Int#
==# Int#
il of
                    Int#
1# -> FF
COL
                    Int#
_ -> Word32 -> FF
CHC Word32
w
                Int#
_ -> case Int#
gapEnd Int# -> Int# -> Int#
==# Int#
ir of
                    Int#
0# -> FF
NOP
                    Int#
_ -> Word32 -> FF
CLO Word32
w
    {-# INLINE makeF12 #-}

    makeF3 :: Int -> Int -> Word32 -> FF
makeF3 (I# Int#
gapStart) (I# Int#
gapEnd) !Word32
w =
        case Int#
gapEnd Int# -> Int# -> Int#
<=# Int#
6# of
            Int#
1# -> Word32 -> FF
CHL Word32
w
            Int#
_ -> case Int#
gapStart Int# -> Int# -> Int#
==# Int#
6# of
                Int#
0# -> case Int#
gapEnd Int# -> Int# -> Int#
==# Int#
8# of
                    Int#
1# -> FF
COL
                    Int#
_ -> Word32 -> FF
CLO Word32
w
                Int#
_ -> FF
CC
    {-# INLINE makeF3 #-}

-- | Unrolled and inlined calculation of the first longest
-- run (gap) of 16-bit aligned zeros in the input address.
bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)
bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)
bestgap !(W32# Word32#
a0) !(W32# Word32#
a1) !(W32# Word32#
a2) !(W32# Word32#
a3) =
    Int# -> (Int, Int)
finalGap
        ( Word# -> Int# -> Int#
updateGap
            (Word#
0xffff## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a3))
            ( Word# -> Int# -> Int#
updateGap
                (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a3))
                ( Word# -> Int# -> Int#
updateGap
                    (Word#
0xffff## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a2))
                    ( Word# -> Int# -> Int#
updateGap
                        (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a2))
                        ( Word# -> Int# -> Int#
updateGap
                            (Word#
0xffff## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a1))
                            ( Word# -> Int# -> Int#
updateGap
                                (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a1))
                                ( Word# -> Int# -> Int#
updateGap
                                    (Word#
0xffff## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a0))
                                    (Word# -> Int#
initGap (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` (Word32# -> Word#
word32ToWordCompat# Word32#
a0)))
                                )
                            )
                        )
                    )
                )
            )
        )
  where
    -- The state after the first input word is always i' = 7,
    -- but if the input word is zero, then also g=z=1 and e'=7.
    initGap :: Word# -> Int#
    initGap :: Word# -> Int#
initGap Word#
w = case Word#
w of Word#
0## -> Int#
0x1717#; Word#
_ -> Int#
0x0707#

    -- Update the nibbles of g|e'|z|i' based on the next input
    -- word.  We always decrement i', reset z on non-zero input,
    -- otherwise increment z and check for a new best gap, if so
    -- we replace g|e' with z|i'.
    updateGap :: Word# -> Int# -> Int#
    updateGap :: Word# -> Int# -> Int#
updateGap Word#
w Int#
g = case Word#
w Word# -> Word# -> Int#
`neWord#` Word#
0## of
        Int#
1# -> (Int#
g Int# -> Int# -> Int#
+# Int#
0xffff#) Int# -> Int# -> Int#
`andI#` Int#
0xff0f# -- g, e, 0, --i
        Int#
_ ->
            let old :: Int#
old = Int#
g Int# -> Int# -> Int#
+# Int#
0xf# -- ++z, --i
                zi :: Int#
zi = Int#
old Int# -> Int# -> Int#
`andI#` Int#
0xff#
                new :: Int#
new = (Int#
zi Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
8#) Int# -> Int# -> Int#
`orI#` Int#
zi
             in case Int#
new Int# -> Int# -> Int#
># Int#
old of
                    Int#
1# -> Int#
new -- z, i, z, i
                    Int#
_ -> Int#
old -- g, e, z, i

    -- Extract gap start and end from the nibbles of g|e'|z|i'
    -- where g is the gap width and e' is 8 minus its end.
    finalGap :: Int# -> (Int, Int)
    finalGap :: Int# -> (Int, Int)
finalGap Int#
i =
        let g :: Int#
g = Int#
i Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
12#
         in case Int#
g Int# -> Int# -> Int#
<# Int#
2# of
                Int#
1# -> (Int
0, Int
0)
                Int#
_ ->
                    let e :: Int#
e = Int#
8# Int# -> Int# -> Int#
-# ((Int#
i Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
8#) Int# -> Int# -> Int#
`andI#` Int#
0xf#)
                        s :: Int#
s = Int#
e Int# -> Int# -> Int#
-# Int#
g
                     in (Int# -> Int
I# Int#
s, Int# -> Int
I# Int#
e)
{-# INLINE bestgap #-}

#if MIN_VERSION_base(4,16,0)
word32ToWordCompat# :: Word32# -> Word#
word32ToWordCompat# :: Word32# -> Word#
word32ToWordCompat# = Word32# -> Word#
word32ToWord#

wordToWord8Compat# :: Word# -> Word8#
wordToWord8Compat# :: Word# -> Word8#
wordToWord8Compat# = Word# -> Word8#
wordToWord8#

wordToWord16Compat# :: Word# -> Word16#
wordToWord16Compat# :: Word# -> Word16#
wordToWord16Compat# = Word# -> Word16#
wordToWord16#
#else
word32ToWordCompat# :: Word# -> Word#
word32ToWordCompat# x = x

wordToWord8Compat# :: Word# -> Word#
wordToWord8Compat# x = x

wordToWord16Compat# :: Word# -> Word#
wordToWord16Compat# x = x
#endif