#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#include "MachDeps.h"
#endif
module Data.Tickle.Get(
Get
, lazyByteString
, lazyByteStringNul
, remainingLazyByteString
, ptr
, word8
, word16be
, word16le
, word32be
, word32le
, word64be
, word64le
, wordhost
, word16host
, word32host
, word64host
, failGet
, constant
, bytesRead
, demandInput
, skip
, isNotEmpty
, isEmpty
, getByteString
, modify
, readN
, ensureN
, toFloat
, toFloat16
, float16be
, float16le
, float32be
, float32le
, float64be
, float64le
, int8
, int16be
, int16le
, int32be
, int32le
, int64be
, int64le
, IntegerError
, integerError
, _IntegerTagUnexpectedEof
, _Integer0TagUnexpectedEof
, _Integer1TagUnexpectedEof
, _IntegerListError
, integer
, ListError
, listError
, listErrorIso
, list
, many
, runAndKeepTrack
, pushBack
, pushFront
, xrunGetIncremental
, noMeansNo
, prompt
, isolate
, lookAhead
, lookAheadM
, lookAheadE
, readNWith
, calculateOffset
, pushChunk
, pushChunks
, pushEndOfInput
, (!+)
, addLabel
, (!-)
, setLabel
, (!!-)
, modifyLabel
, Decoder
, decoder
, _Fail
, _Partial
, _Done
, runGet
, (.>>)
, (<<.)
, runGetIncremental
, XDecoder
, xdecoder
, _XFail
, _XPartial
, _XDone
, _XBytesRead
, CompletedXDecoder
, completedXDecoder
, _CompletedFail
, _CompletedDone
, completedIso
, completedByteString
, completedValue
, uncomplete
, uncompletedByteString
, uncompletedValue
) where
import Control.Applicative(Applicative((<*>), pure), (<$>))
import Control.Category(Category((.), id))
import Control.Lens.Iso(Iso', iso)
import Control.Lens.Lens(lens)
import Control.Lens.Prism(Prism', prism')
import Control.Lens.Review((#))
import Control.Lens.Type(Iso, Lens', Traversal')
import Control.Monad(Monad((>>=), (>>), return), ap)
import Data.Bifoldable(Bifoldable(bifoldMap))
import Data.Bifunctor(Bifunctor(bimap))
import Data.Bitraversable(Bitraversable(bitraverse))
import Data.Bits((.|.), (.&.), shiftL, shiftR)
import Data.Bool(Bool(False, True), (&&), not, otherwise)
import qualified Data.ByteString as B(ByteString, concat, append, length, splitAt, empty, null, break, drop)
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy as L(ByteString, toChunks, fromChunks)
import qualified Data.ByteString.Lazy.Internal as LI(ByteString(Chunk, Empty))
import qualified Data.ByteString.Unsafe as BU(unsafeDrop, unsafeTake, unsafeHead, unsafeIndex, unsafeUseAsCString)
import Data.Either(Either(Left, Right), either)
import Data.Eq(Eq((==)))
import Data.Foldable(Foldable(foldMap))
import Data.Function(const)
import Data.Functor(Functor(fmap))
import Data.Functor.Apply(Apply((<.>)))
import Data.Functor.Alt(Alt((<!>)))
import qualified Data.Functor.Alt as Al(Alt(some, many))
import Data.Functor.Bind(Bind((>>-)))
import Data.Int(Int, Int8, Int16, Int32, Int64)
import Data.List(reverse, foldr)
import Data.Maybe(Maybe(Nothing, Just), maybe, isJust)
import Data.Monoid(Monoid(mempty))
import Data.Ord(Ord((>), (>=), (<), (>=)))
import Data.Semigroup(Semigroup((<>)))
import Data.Tickle.IsolateError(IsolateError, _NegativeSize, _IsolateXFail, _UnexpectedConsumed)
import Data.Tickle.RunGetResult(RunGetResult, _RunGet, _RunGetFail)
import Data.Traversable(Traversable(traverse))
import Data.Tuple(uncurry)
import Foreign(Ptr, castPtr, Storable(peek), sizeOf, alloca, poke)
import System.IO.Unsafe(unsafePerformIO)
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Word(Word, Word8, Word16(W16#), Word32(W32#), Word64(W64#))
import GHC.Base(uncheckedShiftL#, Int(I#))
#endif
import Prelude(Num((), (+)), Float, Double, Integer, ($!), Show, fromIntegral, undefined, seq)
import System.IO(IO)
newtype Get e a =
Get (forall r.
B.ByteString ->
(B.ByteString -> a -> XDecoder e r) ->
XDecoder e r)
bimapG ::
(e -> f)
-> (a -> b)
-> Get e a
-> Get f b
bimapG f g (Get z) =
Get (\b q ->
let r = z b XDone
go (XDone i a) = q i (g a)
go (XPartial k) = XPartial (go . k)
go (XFail i s) = XFail i (f s)
go (XBytesRead u k) = XBytesRead u (go . k)
in go r)
instance Bifunctor Get where
bimap =
bimapG
fmapG ::
(a -> b)
-> Get e a
-> Get e b
fmapG =
bimapG id
instance Functor (Get e) where
fmap =
fmapG
instance Apply (Get e) where
(<.>) =
ap
apG ::
Get e (a -> b)
-> Get e a
-> Get e b
apG d e =
do b <- d
a <- e
return (b a)
instance Applicative (Get e) where
pure =
return
(<*>) =
apG
instance Bind (Get e) where
(>>-) =
(>>=)
returnG ::
a
-> Get e a
returnG a =
Get (\b q -> q b a)
bindG ::
Get e a
-> (a -> Get e b)
-> Get e b
Get k `bindG` f =
Get (\b q -> k b (\c a ->
let Get l = f a
in l c q))
instance Monad (Get e) where
return =
returnG
(>>=) =
bindG
instance Alt (Get e) where
f <!> g =
do (d, bs) <- runAndKeepTrack f
case d of
CompletedDone b a -> Get (\_ q -> q b a)
CompletedFail _ _ -> pushBack bs >> g
some p =
(:) <$> p <*> Al.many p
many p =
(p >>= \x ->
fmap (x:) (Al.many p)) <!> pure []
instance Semigroup (Get e a) where
(<>) =
(<!>)
failGet ::
e
-> Get e a
failGet e =
Get (\i _ -> XFail i e)
constant ::
(forall r. XDecoder e r)
-> Get e a
constant d =
Get (\_ _ -> d)
runAndKeepTrack ::
Get e a
-> Get x (CompletedXDecoder e a, [B.ByteString])
runAndKeepTrack (Get k) =
Get (\b q ->
let go !acc w = case w of
XDone c a -> q b (CompletedDone c a, reverse acc)
XPartial l -> XPartial (\c -> go (maybe acc (:acc) c) (l c))
XFail c e -> q b (CompletedFail c e, reverse acc)
XBytesRead i l -> XBytesRead i (go acc . l)
in go [] (k b XDone))
pushBack ::
[B.ByteString]
-> Get e ()
pushBack z =
let y [] = id
y _ = B.concat . (:z)
in Get (\b q -> q (y z b) ())
pushFront ::
B.ByteString
-> Get e ()
pushFront b =
Get (\c q -> q (B.append b c) ())
xrunGetIncremental ::
Get e a
-> XDecoder e a
xrunGetIncremental (Get k) =
noMeansNo (k B.empty XDone)
noMeansNo ::
XDecoder e a
-> XDecoder e a
noMeansNo =
let neverAgain (XPartial k) =
neverAgain (k Nothing)
neverAgain (XBytesRead i k) =
XBytesRead i (neverAgain . k)
neverAgain r@(XDone _ _) =
r
neverAgain r@(XFail _ _) =
r
go (XPartial k) =
XPartial (\b ->
(if isJust b then go else neverAgain) (k b))
go (XBytesRead i k) =
XBytesRead i (go . k)
go r@(XDone _ _) =
r
go r@(XFail _ _) =
r
in go
prompt ::
B.ByteString
-> XDecoder e a
-> (B.ByteString -> XDecoder e a)
-> XDecoder e a
prompt b d f =
let loop = XPartial (maybe d (\s -> if B.null s then loop else f (b `B.append` s)))
in loop
bytesRead ::
Get e Int64
bytesRead =
Get (\b q -> XBytesRead (fromIntegral (B.length b)) (q b))
isolate ::
Int
-> Get e a
-> Get (IsolateError e) a
isolate m (Get k) =
let go !n (XDone l x) =
if n == 0 && B.null l
then
return x
else
do pushFront l
failGet (_UnexpectedConsumed # (m n B.length l, m))
go 0 (XPartial r) =
go 0 (r Nothing)
go n (XPartial r) =
do i <- Get (\b q -> let takeLimited t =
let (j, o) = B.splitAt n t
in q o (Just j)
in if B.null b
then
prompt b (q B.empty Nothing) takeLimited
else
takeLimited b)
case i of
Nothing ->
go n (r Nothing)
Just u ->
go (n B.length u) (r (Just u))
go _ (XFail b e) =
pushFront b >> failGet (_IsolateXFail # e)
go n (XBytesRead i r) =
go n (r $! fromIntegral m fromIntegral n i)
in if m < 0
then
failGet (_NegativeSize # ())
else
go m (k B.empty XDone)
demandInput ::
Get () ()
demandInput =
Get (\b q ->
prompt b (XFail b ()) (`q` ()))
skip ::
Int
-> Get () ()
skip n =
readN n (return ())
isNotEmpty ::
Get e Bool
isNotEmpty =
fmap not isEmpty
isEmpty ::
Get e Bool
isEmpty =
Get (\b q ->
if B.null b
then
prompt b (q b True) (`q` False)
else
q b False)
lookAhead ::
Get e a
-> Get e a
lookAhead g =
do (d, bs) <- runAndKeepTrack g
case d of
CompletedDone _ a ->
pushBack bs >> return a
CompletedFail inp s ->
constant (XFail inp s)
lookAheadM ::
Get e (Maybe a)
-> Get e (Maybe a)
lookAheadM g =
let g' = fmap (maybe (Left ()) Right) g
in fmap (either (return Nothing) Just) (lookAheadE g')
lookAheadE ::
Get e (Either a b)
-> Get e (Either a b)
lookAheadE g =
do (d, b) <- runAndKeepTrack g
case d of
CompletedDone _ (Left x) ->
pushBack b >> return (Left x)
CompletedDone i (Right x) ->
Get (\_ q -> q i (Right x))
CompletedFail i s ->
constant (XFail i s)
(!+) ::
Semigroup e =>
e
-> Get e a
-> Get e a
(!+) =
addLabel
infixl 3 !+
addLabel ::
Semigroup e =>
e
-> Get e a
-> Get e a
addLabel m =
modifyLabel (<> m)
(!-) ::
e
-> Get d a
-> Get e a
(!-) =
setLabel
infixl 3 !-
setLabel ::
e
-> Get d a
-> Get e a
setLabel =
modifyLabel . return
(!!-) ::
(d -> e)
-> Get d a
-> Get e a
(!!-) =
modifyLabel
infixl 3 !!-
modifyLabel ::
(d -> e)
-> Get d a
-> Get e a
modifyLabel m =
bimap m id
getByteString ::
Int
-> Get () B.ByteString
getByteString n =
if n > 0
then
readN n (BU.unsafeTake n)
else
return B.empty
modify ::
(B.ByteString -> B.ByteString)
-> Get e ()
modify f =
Get (\b q -> q (f b) ())
get ::
Get e B.ByteString
get =
Get (\b q -> q b b)
put ::
B.ByteString -> Get e ()
put s =
Get (\_ q -> q s ())
readN ::
Int
-> (B.ByteString -> a)
-> Get () a
readN !n f =
ensureN n >> unsafeReadN n f
ensureN ::
Int
-> Get () ()
ensureN !m =
Get (\i k ->
let go n =
Get (\b q -> if B.length b >= n
then
q b ()
else
let Get g = demandInput >> go n
in g b q)
in if B.length i >= m
then
k i ()
else
let Get g = go m
in g i k)
toFloat ::
(Storable w, Storable f) =>
w
-> f
toFloat w =
unsafePerformIO (alloca (\buf ->
do poke (castPtr buf) w
peek buf))
toFloat16 ::
Word16
-> Float
toFloat16 word16 =
let sign16 =
word16 .&. 0x8000
exp16 =
word16 .&. 0x7C00
frac16 =
word16 .&. 0x3FF
sign32 =
if sign16 > 0
then
0x80000000
else
0
word32
:: Word32
word32 | word16 .&. 0x7FFF == 0 =
0
| exp16 == 0x7C00 =
special
| otherwise =
shiftL exp32 23 .|. shiftL frac32 13
special =
if frac16 == 0
then 0x7F800000
else 0x7FC00000 .|. fromIntegral frac16
(exp32, frac32) =
if exp16 > 0
then normalised
else denormalised
normalised =
let exp = (fromIntegral exp16 `shiftR` 10) 15 + 127
frac = fromIntegral frac16
in (exp, frac)
denormalised =
let exp = (fromIntegral exp16 `shiftR` 10) 15 + 127 e
(e, frac ) =
let step acc x = if x .&. 0x400 == 0
then step (acc + 1) (shiftL x 1)
else (acc, fromIntegral x .&. 0x3FF)
in step 0 (shiftL frac16 1)
in (exp, frac)
in toFloat (sign32 .|. word32)
float16be ::
Get () Float
float16be =
fmap toFloat16 word16be
float16le ::
Get () Float
float16le =
fmap toFloat16 word16le
float32be ::
Get () Float
float32be =
fmap toFloat word32be
float32le ::
Get () Float
float32le =
fmap toFloat word32le
float64be ::
Get () Double
float64be =
fmap toFloat word64be
float64le ::
Get () Double
float64le =
fmap toFloat word64le
int8 ::
Get () Int8
int8 =
fmap fromIntegral word8
int16be ::
Get () Int16
int16be =
fmap fromIntegral word16be
int16le ::
Get () Int16
int16le =
fmap fromIntegral word16le
int32be ::
Get () Int32
int32be =
fmap fromIntegral word32be
int32le ::
Get () Int32
int32le =
fmap fromIntegral word32le
int64be ::
Get () Int64
int64be =
fmap fromIntegral word64be
int64le ::
Get () Int64
int64le =
fmap fromIntegral word64le
data IntegerError =
IntegerTagUnexpectedEof
| Integer0TagUnexpectedEof Word8
| Integer1TagUnexpectedEof
| IntegerListError ListError
deriving (Eq, Ord, Show)
integerError ::
a
-> (Word8 -> a)
-> a
-> (ListError -> a)
-> IntegerError
-> a
integerError u _ _ _ IntegerTagUnexpectedEof =
u
integerError _ u _ _ (Integer0TagUnexpectedEof w) =
u w
integerError _ _ u _ Integer1TagUnexpectedEof =
u
integerError _ _ _ u (IntegerListError e) =
u e
_IntegerTagUnexpectedEof ::
Prism' IntegerError ()
_IntegerTagUnexpectedEof =
prism'
(\() -> IntegerTagUnexpectedEof)
(\x -> case x of
IntegerTagUnexpectedEof ->
Just ()
_ ->
Nothing)
_Integer0TagUnexpectedEof ::
Prism' IntegerError Word8
_Integer0TagUnexpectedEof =
prism'
Integer0TagUnexpectedEof
(\x -> case x of
Integer0TagUnexpectedEof w ->
Just w
_ ->
Nothing)
_Integer1TagUnexpectedEof ::
Prism' IntegerError ()
_Integer1TagUnexpectedEof =
prism'
(\() -> Integer1TagUnexpectedEof)
(\x -> case x of
Integer1TagUnexpectedEof ->
Just ()
_ ->
Nothing)
_IntegerListError ::
Prism' IntegerError ListError
_IntegerListError =
prism'
IntegerListError
(\x -> case x of
IntegerListError e ->
Just e
_ ->
Nothing)
integer ::
Get IntegerError Integer
integer =
do t <- IntegerTagUnexpectedEof !- word8
case t of
0 ->
Integer0TagUnexpectedEof t !- fmap fromIntegral int32be
_ ->
do s <- Integer1TagUnexpectedEof !- word8
y <- IntegerListError !!- list word8
let v = foldr (\b a -> a `shiftL` 8 .|. fromIntegral b) 0 y
return $! if s == (1 :: Word8) then v else v
data ListError =
ListUnexpectedEof
| ListTagError
deriving (Eq, Ord, Show)
listError ::
a
-> a
-> ListError
-> a
listError u _ ListUnexpectedEof =
u
listError _ e ListTagError =
e
listErrorIso ::
Iso' Bool ListError
listErrorIso =
iso
(\p -> if p then ListUnexpectedEof else ListTagError)
(== ListUnexpectedEof)
list ::
Get e a
-> Get ListError [a]
list q =
do n <- ListTagError !- int64be
ListUnexpectedEof !- many q n
many ::
Get e a
-> Int64
-> Get e [a]
many g n =
let go x 0 =
return $! reverse x
go x i =
do a <- g
x `seq` go (a:x) (i 1)
in go [] n
unsafeReadN ::
Int
-> (B.ByteString -> a)
-> Get e a
unsafeReadN !n f =
Get (\b ks -> ks (BU.unsafeDrop n b) $! f b)
readNWith ::
Int
-> (Ptr a -> IO a)
-> Get () a
readNWith n f =
readN n (\s -> BI.inlinePerformIO (BU.unsafeUseAsCString s (f . castPtr)))
data Decoder e a =
Fail !B.ByteString !Int64 e
| Partial (Maybe B.ByteString -> Decoder e a)
| Done !B.ByteString !Int64 a
decoder ::
(B.ByteString -> Int64 -> e -> x)
-> ((Maybe B.ByteString -> Decoder e a) -> x)
-> (B.ByteString -> Int64 -> a -> x)
-> Decoder e a
-> x
decoder f _ _ (Fail b i e) =
f b i e
decoder _ p _ (Partial k) =
p k
decoder _ _ d (Done b i a) =
d b i a
_Fail ::
Prism' (Decoder e a) (B.ByteString, Int64, e)
_Fail =
prism'
(\(b, i, e) -> Fail b i e)
(\x -> case x of
Fail b i e -> Just (b, i, e)
_ -> Nothing)
_Partial ::
Prism' (Decoder e a) (Maybe B.ByteString -> Decoder e a)
_Partial =
prism'
Partial
(\x -> case x of
Partial k -> Just k
_ -> Nothing)
_Done ::
Prism' (Decoder e a) (B.ByteString, Int64, a)
_Done =
prism'
(\(b, i, a) -> Done b i a)
(\x -> case x of
Done b i a -> Just (b, i, a)
_ -> Nothing)
bimapD ::
(e -> f)
-> (a -> b)
-> Decoder e a
-> Decoder f b
bimapD f _ (Fail b i e) =
Fail b i (f e)
bimapD f g (Partial k) =
Partial (bimapD f g . k)
bimapD _ g (Done b i a) =
Done b i (g a)
instance Bifunctor Decoder where
bimap =
bimapD
fmapD ::
(a -> b)
-> Decoder e a
-> Decoder e b
fmapD =
bimapD id
instance Functor (Decoder e) where
fmap =
fmapD
calculateOffset ::
XDecoder e a
-> Decoder e a
calculateOffset s =
let go r !acc =
case r of
XDone i a ->
Done i (acc fromIntegral (B.length i)) a
XFail i e ->
Fail i (acc fromIntegral (B.length i)) e
XPartial k ->
Partial (\b ->
case b of
Nothing -> go (k Nothing) acc
Just j -> go (k b) (acc + fromIntegral (B.length j)))
XBytesRead i k ->
go (k $! (acc i)) acc
in go s 0
runGetIncremental ::
Get e a
-> Decoder e a
runGetIncremental =
calculateOffset . xrunGetIncremental
takeHeadChunk ::
L.ByteString
-> Maybe B.ByteString
takeHeadChunk lbs =
case lbs of
(LI.Chunk bs _) ->
Just bs
_ ->
Nothing
dropHeadChunk ::
L.ByteString
-> L.ByteString
dropHeadChunk lbs =
case lbs of
(LI.Chunk _ lbs') ->
lbs'
_ ->
LI.Empty
(.>>) ::
Get e a
-> L.ByteString
-> RunGetResult e a
(.>>) =
runGet
infixl 2 .>>
(<<.) ::
L.ByteString
-> Get e a
-> RunGetResult e a
(<<.) b =
(`runGet` b)
infixl 2 <<.
runGet ::
Get e a
-> L.ByteString
-> RunGetResult e a
runGet g b =
let feedAll (Done _ _ x) _ =
_RunGet # x
feedAll (Partial k) c =
feedAll (k (takeHeadChunk c)) (dropHeadChunk c)
feedAll (Fail _ p e) _ =
_RunGetFail # (p, e)
in feedAll (runGetIncremental g) b
pushChunk ::
Decoder e a
-> B.ByteString
-> Decoder e a
pushChunk r i =
case r of
Done j p a ->
Done (j `B.append` i) p a
Partial k ->
k (Just i)
Fail j p s ->
Fail (j `B.append` i) p s
pushChunks ::
Decoder e a
-> L.ByteString
-> Decoder e a
pushChunks r0 =
let go r [] =
r
go (Done i p a) xs =
Done (B.concat (i:xs)) p a
go (Fail i p s) xs =
Fail (B.concat (i:xs)) p s
go (Partial k) (x:xs) =
go (k (Just x)) xs
in go r0 . L.toChunks
pushEndOfInput ::
Decoder e a
-> Decoder e a
pushEndOfInput r =
case r of
Done {} -> r
Partial k -> k Nothing
Fail {} -> r
lazyByteString ::
Int64
-> Get () L.ByteString
lazyByteString =
let consume n s =
if fromIntegral (B.length s) >= n
then
Right (B.splitAt (fromIntegral n) s)
else
Left (fromIntegral (B.length s))
go n =
do s <- get
case consume n s of
Left u ->
do put B.empty
demandInput
fmap (s:) (go (n u))
Right (w, r) ->
do put r
return [w]
in fmap L.fromChunks . go
lazyByteStringNul ::
Get () L.ByteString
lazyByteStringNul =
let findNull s =
case B.break (==0) s of
(w, r) ->
if B.null r
then
Nothing
else
Just (w, B.drop 1 r)
go =
do s <- get
case findNull s of
Nothing ->
do put B.empty
demandInput
fmap (s:) go
Just (w, r) ->
do put r
return [w]
in fmap L.fromChunks go
remainingLazyByteString ::
Get e L.ByteString
remainingLazyByteString =
let go =
do s <- get
put B.empty
d <- isEmpty
if d
then
return [s]
else
fmap (s:) go
in fmap L.fromChunks go
ptr ::
Storable a =>
Int
-> Get () a
ptr n =
readNWith n peek
word8 ::
Get () Word8
word8 =
readN 1 BU.unsafeHead
word16be' ::
B.ByteString
-> Word16
word16be' s =
(fromIntegral (s `BU.unsafeIndex` 0) `shiftlW16` 8) .|.
fromIntegral (s `BU.unsafeIndex` 1)
word16be ::
Get () Word16
word16be =
readN 2 word16be'
word16le' ::
B.ByteString
-> Word16
word16le' s =
(fromIntegral (s `BU.unsafeIndex` 1) `shiftlW16` 8) .|.
fromIntegral (s `BU.unsafeIndex` 0)
word16le ::
Get () Word16
word16le =
readN 2 word16le'
word32be' ::
B.ByteString
-> Word32
word32be' s =
(fromIntegral (s `BU.unsafeIndex` 0) `shiftlW32` 24) .|.
(fromIntegral (s `BU.unsafeIndex` 1) `shiftlW32` 16) .|.
(fromIntegral (s `BU.unsafeIndex` 2) `shiftlW32` 8) .|.
fromIntegral (s `BU.unsafeIndex` 3)
word32be ::
Get () Word32
word32be =
readN 4 word32be'
word32le' ::
B.ByteString
-> Word32
word32le' s =
(fromIntegral (s `BU.unsafeIndex` 3) `shiftlW32` 24) .|.
(fromIntegral (s `BU.unsafeIndex` 2) `shiftlW32` 16) .|.
(fromIntegral (s `BU.unsafeIndex` 1) `shiftlW32` 8) .|.
fromIntegral (s `BU.unsafeIndex` 0)
word32le ::
Get () Word32
word32le =
readN 4 word32le'
word64be' ::
B.ByteString
-> Word64
word64be' s =
(fromIntegral (s `BU.unsafeIndex` 0) `shiftlW64` 56) .|.
(fromIntegral (s `BU.unsafeIndex` 1) `shiftlW64` 48) .|.
(fromIntegral (s `BU.unsafeIndex` 2) `shiftlW64` 40) .|.
(fromIntegral (s `BU.unsafeIndex` 3) `shiftlW64` 32) .|.
(fromIntegral (s `BU.unsafeIndex` 4) `shiftlW64` 24) .|.
(fromIntegral (s `BU.unsafeIndex` 5) `shiftlW64` 16) .|.
(fromIntegral (s `BU.unsafeIndex` 6) `shiftlW64` 8) .|.
fromIntegral (s `BU.unsafeIndex` 7)
word64be ::
Get () Word64
word64be =
readN 8 word64be'
word64le' ::
B.ByteString
-> Word64
word64le' s =
(fromIntegral (s `BU.unsafeIndex` 7) `shiftlW64` 56) .|.
(fromIntegral (s `BU.unsafeIndex` 6) `shiftlW64` 48) .|.
(fromIntegral (s `BU.unsafeIndex` 5) `shiftlW64` 40) .|.
(fromIntegral (s `BU.unsafeIndex` 4) `shiftlW64` 32) .|.
(fromIntegral (s `BU.unsafeIndex` 3) `shiftlW64` 24) .|.
(fromIntegral (s `BU.unsafeIndex` 2) `shiftlW64` 16) .|.
(fromIntegral (s `BU.unsafeIndex` 1) `shiftlW64` 8) .|.
fromIntegral (s `BU.unsafeIndex` 0)
word64le ::
Get () Word64
word64le =
readN 8 word64le'
wordhost ::
Get () Word
wordhost =
ptr (sizeOf (undefined :: Word))
word16host ::
Get () Word16
word16host =
ptr (sizeOf (undefined :: Word16))
word32host ::
Get () Word32
word32host =
ptr (sizeOf (undefined :: Word32))
word64host ::
Get () Word64
word64host =
ptr (sizeOf (undefined :: Word64))
shiftlW16 ::
Word16
-> Int
-> Word16
shiftlW32 ::
Word32
-> Int
-> Word32
shiftlW64 ::
Word64
-> Int
-> Word64
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
shiftlW16 (W16# w) (I# i) =
W16# (w `uncheckedShiftL#` i)
shiftlW32 (W32# w) (I# i) =
W32# (w `uncheckedShiftL#` i)
#if WORD_SIZE_IN_BITS < 64
shiftlW64 (W64# w) (I# i) =
W64# (w `uncheckedShiftL64#` i)
#if __GLASGOW_HASKELL__ <= 606
foreign import ccall unsafe "stg_uncheckedShiftL64"
uncheckedShiftL64# ::
Word64#
-> Int#
-> Word64#
#endif
#else
shiftlW64 (W64# w) (I# i) =
W64# (w `uncheckedShiftL#` i)
#endif
#else
shiftlW16 =
shiftL
shiftlW32 =
shiftL
shiftlW64 =
shiftL
#endif
data XDecoder e a =
XFail !B.ByteString e
| XPartial (Maybe B.ByteString -> XDecoder e a)
| XDone !B.ByteString a
| XBytesRead !Int64 (Int64 -> XDecoder e a)
xdecoder ::
(B.ByteString -> e -> x)
-> ((Maybe B.ByteString -> XDecoder e a) -> x)
-> (B.ByteString -> a -> x)
-> (Int64 -> (Int64 -> XDecoder e a) -> x)
-> XDecoder e a
-> x
xdecoder f _ _ _ (XFail b e) =
f b e
xdecoder _ p _ _ (XPartial k) =
p k
xdecoder _ _ d _ (XDone b a) =
d b a
xdecoder _ _ _ r (XBytesRead i k) =
r i k
_XFail ::
Prism' (XDecoder e a) (B.ByteString, e)
_XFail =
prism'
(uncurry XFail)
(\x -> case x of
XFail b e -> Just (b, e)
_ -> Nothing)
_XPartial ::
Prism' (XDecoder e a) (Maybe B.ByteString -> XDecoder e a)
_XPartial =
prism'
XPartial
(\x -> case x of
XPartial k -> Just k
_ -> Nothing)
_XDone ::
Prism' (XDecoder e a) (B.ByteString, a)
_XDone =
prism'
(uncurry XDone)
(\x -> case x of
XDone b a -> Just (b, a)
_ -> Nothing)
_XBytesRead ::
Prism' (XDecoder e a) (Int64, Int64 -> XDecoder e a)
_XBytesRead =
prism'
(uncurry XBytesRead)
(\x -> case x of
XBytesRead i k -> Just (i, k)
_ -> Nothing)
instance Functor (XDecoder e) where
fmap =
bimap id
instance Bifunctor XDecoder where
bimap f _ (XFail b e) =
XFail b (f e)
bimap f g (XPartial k) =
XPartial (bimap f g . k)
bimap _ g (XDone b a) =
XDone b (g a)
bimap f g (XBytesRead i k) =
XBytesRead i (bimap f g . k)
instance Bifoldable XDecoder where
bifoldMap f _ (XFail _ e) =
f e
bifoldMap _ _ (XPartial _) =
mempty
bifoldMap _ g (XDone _ a) =
g a
bifoldMap _ _ (XBytesRead _ _) =
mempty
instance Foldable (XDecoder e) where
foldMap _ (XFail _ _) =
mempty
foldMap _ (XPartial _) =
mempty
foldMap f (XDone _ a) =
f a
foldMap _ (XBytesRead _ _) =
mempty
data CompletedXDecoder e a =
CompletedFail !B.ByteString e
| CompletedDone !B.ByteString a
deriving (Eq, Ord, Show)
completedXDecoder ::
(B.ByteString -> e -> x)
-> (B.ByteString -> a -> x)
-> CompletedXDecoder e a
-> x
completedXDecoder f _ (CompletedFail b e) =
f b e
completedXDecoder _ d (CompletedDone b a) =
d b a
_CompletedFail ::
Prism' (CompletedXDecoder e a) (B.ByteString, e)
_CompletedFail =
prism'
(uncurry CompletedFail)
(\x -> case x of
CompletedFail b e -> Just (b, e)
_ -> Nothing)
_CompletedDone ::
Prism' (CompletedXDecoder e a) (B.ByteString, a)
_CompletedDone =
prism'
(uncurry CompletedDone)
(\x -> case x of
CompletedDone b a -> Just (b, a)
_ -> Nothing)
completedIso ::
Iso (CompletedXDecoder e a) (CompletedXDecoder f b) (Either e a, B.ByteString) (Either f b, B.ByteString)
completedIso =
iso
(\d -> case d of
CompletedFail b e -> (Left e, b)
CompletedDone b a -> (Right a, b))
(\z -> case z of
(Left e, b) -> CompletedFail b e
(Right a, b) -> CompletedDone b a)
completedByteString ::
Lens' (CompletedXDecoder e a) B.ByteString
completedByteString =
lens
(\d -> case d of
CompletedFail b _ -> b
CompletedDone b _ -> b)
(\d b -> case d of
CompletedFail _ e -> CompletedFail b e
CompletedDone _ a -> CompletedDone b a)
completedValue ::
Lens' (CompletedXDecoder e a) (Either e a)
completedValue =
lens
(\d -> case d of
CompletedFail _ e -> Left e
CompletedDone _ a -> Right a)
(\d z -> case d of
CompletedFail b e -> CompletedFail b (either id (pure e) z)
CompletedDone b a -> CompletedDone b (either (pure a) id z))
instance Functor (CompletedXDecoder e) where
fmap =
bimap id
instance Bifunctor CompletedXDecoder where
bimap f _ (CompletedFail b e) =
CompletedFail b (f e)
bimap _ g (CompletedDone b a) =
CompletedDone b (g a)
instance Foldable (CompletedXDecoder e) where
foldMap _ (CompletedFail _ _) =
mempty
foldMap f (CompletedDone _ a) =
f a
instance Traversable (CompletedXDecoder e) where
traverse =
bitraverse pure
instance Bifoldable CompletedXDecoder where
bifoldMap f _ (CompletedFail _ e) =
f e
bifoldMap _ g (CompletedDone _ a) =
g a
instance Bitraversable CompletedXDecoder where
bitraverse f _ (CompletedFail b e) =
fmap (CompletedFail b) (f e)
bitraverse _ g (CompletedDone b a) =
fmap (CompletedDone b) (g a)
uncomplete ::
Prism' (XDecoder e a) (CompletedXDecoder e a)
uncomplete =
prism'
(\d -> case d of
CompletedFail b e -> XFail b e
CompletedDone b a -> XDone b a)
(\d -> case d of
XFail b e -> Just (CompletedFail b e)
XPartial _ -> Nothing
XDone b a -> Just (CompletedDone b a)
XBytesRead _ _ -> Nothing)
uncompletedByteString ::
Traversal' (XDecoder e a) B.ByteString
uncompletedByteString =
uncomplete . completedByteString
uncompletedValue ::
Traversal' (XDecoder e a) (Either e a)
uncompletedValue =
uncomplete . completedValue