{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Winery.Internal
-- Copyright   :  (c) Fumiaki Kinoshita 2019
-- License     :  BSD3
-- Stability   :  Experimental
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Internal functions and datatypes
--
-----------------------------------------------------------------------------
module Codec.Winery.Internal
  ( unsignedVarInt
  , varInt
  , Decoder(..)
  , DecoderResult(..)
  , evalDecoder
  , State(..)
  , evalState
  , decodeVarInt
  , decodeVarIntFinite
  , getWord8
  , getWord16
  , getWord32
  , getWord64
  , getBytes
  , DecodeException(..)
  , indexDefault
  , unsafeIndexV
  , lookupWithIndexV
  , Strategy(..)
  , throwStrategy
  , TransFusion(..)
  )where

import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Fix
import qualified Data.ByteString as B
import qualified Data.ByteString.FastBuilder as BB
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Builder.Prim.Internal as BPI
import Data.Bits
import Data.Monoid ((<>))
import Data.String
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector as V
import Data.Word
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.Ptr
import System.Endian

unsignedVarInt :: (Bits a, Integral a) => a -> BB.Builder
unsignedVarInt :: a -> Builder
unsignedVarInt a
n
  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x80 = Word8 -> Builder
BB.word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)
  | Bool
otherwise = Word8 -> Builder
BB.word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. (Bits a, Integral a) => a -> Builder
uvarInt (a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftR a
n Int
7)
{-# INLINE unsignedVarInt #-}

varInt :: (Bits a, Integral a) => a -> BB.Builder
varInt :: a -> Builder
varInt a
n
  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = case a -> a
forall a. Num a => a -> a
negate a
n of
    a
n'
      | a
n' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x40 -> Word8 -> Builder
BB.word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n' Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
6)
      | Bool
otherwise -> Word8 -> Builder
BB.word8 (Word8
0xc0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n') Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. (Bits a, Integral a) => a -> Builder
uvarInt (a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftR a
n' Int
6)
  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x40 = Word8 -> Builder
BB.word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)
  | Bool
otherwise = Word8 -> Builder
BB.word8 (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
7 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
6) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. (Bits a, Integral a) => a -> Builder
uvarInt (a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftR a
n Int
6)
{-# RULES "varInt/Int" varInt = varIntFinite #-}
{-# INLINEABLE[1] varInt #-}

varIntFinite :: Int -> BB.Builder
varIntFinite :: Int -> Builder
varIntFinite = BoundedPrim Int -> Int -> Builder
forall a. BoundedPrim a -> a -> Builder
BB.primBounded (Int -> (Int -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim Int
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BPI.boudedPrim Int
10 Int -> Ptr Word8 -> IO (Ptr Word8)
writeIntFinite)

writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 Word8
w Ptr Word8
p = do
  Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p Word8
w
  Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p Int
1

writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8)
writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8)
writeIntFinite !Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = case Int -> Int
forall a. Num a => a -> a
negate Int
n of
    Int
n'
      | Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x40 -> Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n' Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
6)
      | Bool
otherwise ->
          Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 (Word8
0xc0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n') (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
            (Ptr Word8 -> IO (Ptr Word8)) -> Int -> Ptr Word8 -> IO (Ptr Word8)
forall r. (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r
writeUnsignedFinite Ptr Word8 -> IO (Ptr Word8)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n' Int
6)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x40 = Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  | Bool
otherwise = Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
7 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`clearBit` Int
6) (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
      (Ptr Word8 -> IO (Ptr Word8)) -> Int -> Ptr Word8 -> IO (Ptr Word8)
forall r. (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r
writeUnsignedFinite Ptr Word8 -> IO (Ptr Word8)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
n Int
6)
{-# INLINE writeIntFinite #-}

writeUnsignedFinite :: (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r
writeUnsignedFinite :: (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r
writeUnsignedFinite Ptr Word8 -> IO r
k = Int -> Ptr Word8 -> IO r
go
  where
    go :: Int -> Ptr Word8 -> IO r
go Int
m
      | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80 = Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m) (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO r) -> Ptr Word8 -> IO r
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Ptr Word8 -> IO r
k
      | Bool
otherwise = Word8 -> Ptr Word8 -> IO (Ptr Word8)
writeWord8 (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
setBit (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m) Int
7) (Ptr Word8 -> IO (Ptr Word8))
-> (Ptr Word8 -> IO r) -> Ptr Word8 -> IO r
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Int -> Ptr Word8 -> IO r
go (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftR Int
m Int
7)
{-# INLINE writeUnsignedFinite #-}

uvarInt :: (Bits a, Integral a) => a -> BB.Builder
uvarInt :: a -> Builder
uvarInt = a -> Builder
forall t. (Integral t, Bits t) => t -> Builder
go where
  go :: t -> Builder
go t
m
    | t
m t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0x80 = Word8 -> Builder
BB.word8 (t -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
m)
    | Bool
otherwise = Word8 -> Builder
BB.word8 (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
setBit (t -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
m) Int
7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> t -> Builder
go (t -> Int -> t
forall a. Bits a => a -> Int -> a
unsafeShiftR t
m Int
7)
{-# INLINE uvarInt #-}

-- | A state monad. The reason being not @State@ from transformers is to
-- allow coercion for newtype deriving and DerivingVia.
newtype State s a = State { State s a -> s -> (a, s)
runState :: s -> (a, s) }
  deriving a -> State s b -> State s a
(a -> b) -> State s a -> State s b
(forall a b. (a -> b) -> State s a -> State s b)
-> (forall a b. a -> State s b -> State s a) -> Functor (State s)
forall a b. a -> State s b -> State s a
forall a b. (a -> b) -> State s a -> State s b
forall s a b. a -> State s b -> State s a
forall s a b. (a -> b) -> State s a -> State s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> State s b -> State s a
$c<$ :: forall s a b. a -> State s b -> State s a
fmap :: (a -> b) -> State s a -> State s b
$cfmap :: forall s a b. (a -> b) -> State s a -> State s b
Functor

evalState :: State s a -> s -> a
evalState :: State s a -> s -> a
evalState State s a
m = (a, s) -> a
forall a b. (a, b) -> a
fst ((a, s) -> a) -> (s -> (a, s)) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State s a -> s -> (a, s)
forall s a. State s a -> s -> (a, s)
runState State s a
m
{-# INLINE evalState #-}

instance Applicative (State s) where
  pure :: a -> State s a
pure a
a = (s -> (a, s)) -> State s a
forall s a. (s -> (a, s)) -> State s a
State ((s -> (a, s)) -> State s a) -> (s -> (a, s)) -> State s a
forall a b. (a -> b) -> a -> b
$ \s
s -> (a
a, s
s)
  State s (a -> b)
m <*> :: State s (a -> b) -> State s a -> State s b
<*> State s a
k = (s -> (b, s)) -> State s b
forall s a. (s -> (a, s)) -> State s a
State ((s -> (b, s)) -> State s b) -> (s -> (b, s)) -> State s b
forall a b. (a -> b) -> a -> b
$ \s
s -> case State s (a -> b) -> s -> (a -> b, s)
forall s a. State s a -> s -> (a, s)
runState State s (a -> b)
m s
s of
    (a -> b
f, s
s') -> case State s a -> s -> (a, s)
forall s a. State s a -> s -> (a, s)
runState State s a
k s
s' of
      (a
a, s
s'') -> (a -> b
f a
a, s
s'')

instance Monad (State s) where
  State s a
m >>= :: State s a -> (a -> State s b) -> State s b
>>= a -> State s b
k = (s -> (b, s)) -> State s b
forall s a. (s -> (a, s)) -> State s a
State ((s -> (b, s)) -> State s b) -> (s -> (b, s)) -> State s b
forall a b. (a -> b) -> a -> b
$ \s
s -> case State s a -> s -> (a, s)
forall s a. State s a -> s -> (a, s)
runState State s a
m s
s of
    (a
a, s
s') -> State s b -> s -> (b, s)
forall s a. State s a -> s -> (a, s)
runState (a -> State s b
k a
a) s
s'

instance MonadFix (State s) where
  mfix :: (a -> State s a) -> State s a
mfix a -> State s a
f = (s -> (a, s)) -> State s a
forall s a. (s -> (a, s)) -> State s a
State ((s -> (a, s)) -> State s a) -> (s -> (a, s)) -> State s a
forall a b. (a -> b) -> a -> b
$ \s
s -> ((a, s) -> (a, s)) -> (a, s)
forall a. (a -> a) -> a
fix (((a, s) -> (a, s)) -> (a, s)) -> ((a, s) -> (a, s)) -> (a, s)
forall a b. (a -> b) -> a -> b
$ \ ~(a
a, s
_) -> State s a -> s -> (a, s)
forall s a. State s a -> s -> (a, s)
runState (a -> State s a
f a
a) s
s

data DecoderResult a = DecoderResult {-# UNPACK #-} !Int a deriving a -> DecoderResult b -> DecoderResult a
(a -> b) -> DecoderResult a -> DecoderResult b
(forall a b. (a -> b) -> DecoderResult a -> DecoderResult b)
-> (forall a b. a -> DecoderResult b -> DecoderResult a)
-> Functor DecoderResult
forall a b. a -> DecoderResult b -> DecoderResult a
forall a b. (a -> b) -> DecoderResult a -> DecoderResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DecoderResult b -> DecoderResult a
$c<$ :: forall a b. a -> DecoderResult b -> DecoderResult a
fmap :: (a -> b) -> DecoderResult a -> DecoderResult b
$cfmap :: forall a b. (a -> b) -> DecoderResult a -> DecoderResult b
Functor

-- | The Decoder monad
newtype Decoder a = Decoder { Decoder a -> ByteString -> Int -> DecoderResult a
unDecoder :: B.ByteString -> Int -> DecoderResult a }
  deriving a -> Decoder b -> Decoder a
(a -> b) -> Decoder a -> Decoder b
(forall a b. (a -> b) -> Decoder a -> Decoder b)
-> (forall a b. a -> Decoder b -> Decoder a) -> Functor Decoder
forall a b. a -> Decoder b -> Decoder a
forall a b. (a -> b) -> Decoder a -> Decoder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Decoder b -> Decoder a
$c<$ :: forall a b. a -> Decoder b -> Decoder a
fmap :: (a -> b) -> Decoder a -> Decoder b
$cfmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
Functor

instance Applicative Decoder where
  pure :: a -> Decoder a
pure a
a = (ByteString -> Int -> DecoderResult a) -> Decoder a
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult a) -> Decoder a)
-> (ByteString -> Int -> DecoderResult a) -> Decoder a
forall a b. (a -> b) -> a -> b
$ \ByteString
_ Int
i -> Int -> a -> DecoderResult a
forall a. Int -> a -> DecoderResult a
DecoderResult Int
i a
a
  {-# INLINE pure #-}
  Decoder ByteString -> Int -> DecoderResult (a -> b)
m <*> :: Decoder (a -> b) -> Decoder a -> Decoder b
<*> Decoder ByteString -> Int -> DecoderResult a
n = (ByteString -> Int -> DecoderResult b) -> Decoder b
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult b) -> Decoder b)
-> (ByteString -> Int -> DecoderResult b) -> Decoder b
forall a b. (a -> b) -> a -> b
$ \ByteString
bs Int
i -> case ByteString -> Int -> DecoderResult (a -> b)
m ByteString
bs Int
i of
    DecoderResult Int
j a -> b
f -> a -> b
f (a -> b) -> DecoderResult a -> DecoderResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Int -> DecoderResult a
n ByteString
bs Int
j
  {-# INLINE (<*>) #-}
instance Monad Decoder where
  Decoder ByteString -> Int -> DecoderResult a
m >>= :: Decoder a -> (a -> Decoder b) -> Decoder b
>>= a -> Decoder b
k = (ByteString -> Int -> DecoderResult b) -> Decoder b
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult b) -> Decoder b)
-> (ByteString -> Int -> DecoderResult b) -> Decoder b
forall a b. (a -> b) -> a -> b
$ \ByteString
bs Int
i -> case ByteString -> Int -> DecoderResult a
m ByteString
bs Int
i of
    DecoderResult Int
j a
a -> Decoder b -> ByteString -> Int -> DecoderResult b
forall a. Decoder a -> ByteString -> Int -> DecoderResult a
unDecoder (a -> Decoder b
k a
a) ByteString
bs Int
j
  {-# INLINE (>>=) #-}

-- | Run a 'Decoder'
evalDecoder :: Decoder a -> B.ByteString -> a
evalDecoder :: Decoder a -> ByteString -> a
evalDecoder Decoder a
m ByteString
bs = case Decoder a -> ByteString -> Int -> DecoderResult a
forall a. Decoder a -> ByteString -> Int -> DecoderResult a
unDecoder Decoder a
m ByteString
bs Int
0 of
  DecoderResult Int
_ a
a -> a
a
{-# INLINE evalDecoder #-}

getWord8 :: Decoder Word8
getWord8 :: Decoder Word8
getWord8 = (ByteString -> Int -> DecoderResult Word8) -> Decoder Word8
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult Word8) -> Decoder Word8)
-> (ByteString -> Int -> DecoderResult Word8) -> Decoder Word8
forall a b. (a -> b) -> a -> b
$ \(B.PS ForeignPtr Word8
fp Int
ofs Int
len) Int
i -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len
  then DecodeException -> DecoderResult Word8
forall a e. Exception e => e -> a
throw DecodeException
InsufficientInput
  else Int -> Word8 -> DecoderResult Word8
forall a. Int -> a -> DecoderResult a
DecoderResult (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    (Word8 -> DecoderResult Word8) -> Word8 -> DecoderResult Word8
forall a b. (a -> b) -> a -> b
$! IO Word8 -> Word8
forall a. IO a -> a
B.accursedUnutterablePerformIO (IO Word8 -> Word8) -> IO Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> (Ptr Word8 -> IO Word8) -> IO Word8
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Word8) -> IO Word8)
-> (Ptr Word8 -> IO Word8) -> IO Word8
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p (Int
ofs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
{-# INLINE getWord8 #-}

-- | Exceptions thrown by a 'Decoder'
data DecodeException = InsufficientInput
  | IntegerOverflow
  | InvalidTag deriving (DecodeException -> DecodeException -> Bool
(DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> Bool)
-> Eq DecodeException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeException -> DecodeException -> Bool
$c/= :: DecodeException -> DecodeException -> Bool
== :: DecodeException -> DecodeException -> Bool
$c== :: DecodeException -> DecodeException -> Bool
Eq, Int -> DecodeException -> ShowS
[DecodeException] -> ShowS
DecodeException -> String
(Int -> DecodeException -> ShowS)
-> (DecodeException -> String)
-> ([DecodeException] -> ShowS)
-> Show DecodeException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodeException] -> ShowS
$cshowList :: [DecodeException] -> ShowS
show :: DecodeException -> String
$cshow :: DecodeException -> String
showsPrec :: Int -> DecodeException -> ShowS
$cshowsPrec :: Int -> DecodeException -> ShowS
Show, ReadPrec [DecodeException]
ReadPrec DecodeException
Int -> ReadS DecodeException
ReadS [DecodeException]
(Int -> ReadS DecodeException)
-> ReadS [DecodeException]
-> ReadPrec DecodeException
-> ReadPrec [DecodeException]
-> Read DecodeException
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DecodeException]
$creadListPrec :: ReadPrec [DecodeException]
readPrec :: ReadPrec DecodeException
$creadPrec :: ReadPrec DecodeException
readList :: ReadS [DecodeException]
$creadList :: ReadS [DecodeException]
readsPrec :: Int -> ReadS DecodeException
$creadsPrec :: Int -> ReadS DecodeException
Read)
instance Exception DecodeException

decodeVarIntBase :: (Num a, Bits a) => Decoder a -> Decoder a
decodeVarIntBase :: Decoder a -> Decoder a
decodeVarIntBase Decoder a
body = Decoder Word8
getWord8 Decoder Word8 -> (Word8 -> Decoder a) -> Decoder a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Word8
n | Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
7 -> do
      a
m <- Decoder a
body
      if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
6
        then a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Decoder a) -> a -> Decoder a
forall a b. (a -> b) -> a -> b
$! a -> a
forall a. Num a => a -> a
negate (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL a
m Int
6 a -> a -> a
forall a. Bits a => a -> a -> a
.|. Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
        else a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Decoder a) -> a -> Decoder a
forall a b. (a -> b) -> a -> b
$! a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL a
m Int
6 a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> Int -> a
forall a. Bits a => a -> Int -> a
clearBit (Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Int
7
    | Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
6 -> a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Decoder a) -> a -> Decoder a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Num a => a -> a
negate (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> a) -> Word8 -> a
forall a b. (a -> b) -> a -> b
$ Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
clearBit Word8
n Int
6
    | Bool
otherwise -> a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Decoder a) -> a -> Decoder a
forall a b. (a -> b) -> a -> b
$ Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n
{-# INLINE decodeVarIntBase #-}

decodeVarInt :: (Num a, Bits a) => Decoder a
decodeVarInt :: Decoder a
decodeVarInt = Decoder a -> Decoder a
forall a. (Num a, Bits a) => Decoder a -> Decoder a
decodeVarIntBase (Decoder a -> Decoder a) -> Decoder a -> Decoder a
forall a b. (a -> b) -> a -> b
$ Decoder Word8
getWord8 Decoder Word8 -> (Word8 -> Decoder a) -> Decoder a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Decoder a
forall b. (Bits b, Num b) => Word8 -> Decoder b
go
  where
    go :: Word8 -> Decoder b
go Word8
n
      | Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
7 = do
        b
m <- Decoder Word8
getWord8 Decoder Word8 -> (Word8 -> Decoder b) -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Decoder b
go
        b -> Decoder b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Decoder b) -> b -> Decoder b
forall a b. (a -> b) -> a -> b
$! b -> Int -> b
forall a. Bits a => a -> Int -> a
unsafeShiftL b
m Int
7 b -> b -> b
forall a. Bits a => a -> a -> a
.|. b -> Int -> b
forall a. Bits a => a -> Int -> a
clearBit (Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Int
7
      | Bool
otherwise = b -> Decoder b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Decoder b) -> b -> Decoder b
forall a b. (a -> b) -> a -> b
$ Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n
{-# INLINE decodeVarInt #-}

decodeVarIntFinite :: forall a. (Num a, FiniteBits a) => Decoder a
decodeVarIntFinite :: Decoder a
decodeVarIntFinite = Decoder a -> Decoder a
forall a. (Num a, Bits a) => Decoder a -> Decoder a
decodeVarIntBase (Decoder a -> Decoder a) -> Decoder a -> Decoder a
forall a b. (a -> b) -> a -> b
$ Decoder Word8
getWord8 Decoder Word8 -> (Word8 -> Decoder a) -> Decoder a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> Decoder a
go Int
7
  where
    go :: Int -> Word8 -> Decoder a
go Int
w Word8
n
      | Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
7 = do
        a
m <- Decoder Word8
getWord8 Decoder Word8 -> (Word8 -> Decoder a) -> Decoder a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> Decoder a
go (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7)
        a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Decoder a) -> a -> Decoder a
forall a b. (a -> b) -> a -> b
$! a -> Int -> a
forall a. Bits a => a -> Int -> a
unsafeShiftL a
m Int
7 a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> Int -> a
forall a. Bits a => a -> Int -> a
clearBit (Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Int
7
      | Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word8 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word8
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (a
0 :: a) = a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Decoder a) -> a -> Decoder a
forall a b. (a -> b) -> a -> b
$ Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n
      | Bool
otherwise = DecodeException -> Decoder a
forall a e. Exception e => e -> a
throw DecodeException
IntegerOverflow
{-# INLINABLE[1] decodeVarIntFinite #-}
{-# SPECIALISE decodeVarIntFinite :: Decoder Int #-}

getWord16 :: Decoder Word16
getWord16 :: Decoder Word16
getWord16 = (ByteString -> Int -> DecoderResult Word16) -> Decoder Word16
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult Word16) -> Decoder Word16)
-> (ByteString -> Int -> DecoderResult Word16) -> Decoder Word16
forall a b. (a -> b) -> a -> b
$ \(B.PS ForeignPtr Word8
fp Int
ofs Int
len) Int
i -> if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len
  then Int -> Word16 -> DecoderResult Word16
forall a. Int -> a -> DecoderResult a
DecoderResult (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
    (Word16 -> DecoderResult Word16) -> Word16 -> DecoderResult Word16
forall a b. (a -> b) -> a -> b
$ IO Word16 -> Word16
forall a. IO a -> a
B.accursedUnutterablePerformIO (IO Word16 -> Word16) -> IO Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> (Ptr Word8 -> IO Word16) -> IO Word16
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp
    ((Ptr Word8 -> IO Word16) -> IO Word16)
-> (Ptr Word8 -> IO Word16) -> IO Word16
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Word16 -> Word16
fromLE16 (Word16 -> Word16) -> IO Word16 -> IO Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word16
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
ptr (Int
ofs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
  else DecodeException -> DecoderResult Word16
forall a e. Exception e => e -> a
throw DecodeException
InsufficientInput
{-# INLINE getWord16 #-}

getWord32 :: Decoder Word32
getWord32 :: Decoder Word32
getWord32 = (ByteString -> Int -> DecoderResult Word32) -> Decoder Word32
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult Word32) -> Decoder Word32)
-> (ByteString -> Int -> DecoderResult Word32) -> Decoder Word32
forall a b. (a -> b) -> a -> b
$ \(B.PS ForeignPtr Word8
fp Int
ofs Int
len) Int
i -> if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len
  then Int -> Word32 -> DecoderResult Word32
forall a. Int -> a -> DecoderResult a
DecoderResult (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
    (Word32 -> DecoderResult Word32) -> Word32 -> DecoderResult Word32
forall a b. (a -> b) -> a -> b
$ IO Word32 -> Word32
forall a. IO a -> a
B.accursedUnutterablePerformIO (IO Word32 -> Word32) -> IO Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp
    ((Ptr Word8 -> IO Word32) -> IO Word32)
-> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Word32 -> Word32
fromLE32 (Word32 -> Word32) -> IO Word32 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
ptr (Int
ofs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
  else DecodeException -> DecoderResult Word32
forall a e. Exception e => e -> a
throw DecodeException
InsufficientInput
{-# INLINE getWord32 #-}

getWord64 :: Decoder Word64
getWord64 :: Decoder Word64
getWord64 = (ByteString -> Int -> DecoderResult Word64) -> Decoder Word64
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult Word64) -> Decoder Word64)
-> (ByteString -> Int -> DecoderResult Word64) -> Decoder Word64
forall a b. (a -> b) -> a -> b
$ \(B.PS ForeignPtr Word8
fp Int
ofs Int
len) Int
i -> if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len
  then Int -> Word64 -> DecoderResult Word64
forall a. Int -> a -> DecoderResult a
DecoderResult (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8)
    (Word64 -> DecoderResult Word64) -> Word64 -> DecoderResult Word64
forall a b. (a -> b) -> a -> b
$ IO Word64 -> Word64
forall a. IO a -> a
B.accursedUnutterablePerformIO (IO Word64 -> Word64) -> IO Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> (Ptr Word8 -> IO Word64) -> IO Word64
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp
    ((Ptr Word8 -> IO Word64) -> IO Word64)
-> (Ptr Word8 -> IO Word64) -> IO Word64
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Word64 -> Word64
fromLE64 (Word64 -> Word64) -> IO Word64 -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> Int -> IO Word64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
ptr (Int
ofs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
  else DecodeException -> DecoderResult Word64
forall a e. Exception e => e -> a
throw DecodeException
InsufficientInput
{-# INLINE getWord64 #-}

getBytes :: Int -> Decoder B.ByteString
getBytes :: Int -> Decoder ByteString
getBytes Int
len = (ByteString -> Int -> DecoderResult ByteString)
-> Decoder ByteString
forall a. (ByteString -> Int -> DecoderResult a) -> Decoder a
Decoder ((ByteString -> Int -> DecoderResult ByteString)
 -> Decoder ByteString)
-> (ByteString -> Int -> DecoderResult ByteString)
-> Decoder ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
bs Int
i -> Int -> ByteString -> DecoderResult ByteString
forall a. Int -> a -> DecoderResult a
DecoderResult (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)
  (ByteString -> DecoderResult ByteString)
-> ByteString -> DecoderResult ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs
{-# INLINE getBytes #-}

unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a
unsafeIndexV :: String -> Vector a -> Int -> a
unsafeIndexV String
err Vector a
xs Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Vector a -> Int
forall a. Unbox a => Vector a -> Int
U.length Vector a
xs Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> a
forall a. HasCallStack => String -> a
error String
err
  | Bool
otherwise = Vector a -> Int -> a
forall a. Unbox a => Vector a -> Int -> a
U.unsafeIndex Vector a
xs Int
i
{-# INLINE unsafeIndexV #-}

lookupWithIndexV :: Eq k => k -> V.Vector (k, v) -> Maybe (Int, v)
lookupWithIndexV :: k -> Vector (k, v) -> Maybe (Int, v)
lookupWithIndexV k
k Vector (k, v)
v = (\Int
i -> (Int
i, (k, v) -> v
forall a b. (a, b) -> b
snd ((k, v) -> v) -> (k, v) -> v
forall a b. (a -> b) -> a -> b
$ Vector (k, v) -> Int -> (k, v)
forall a. Vector a -> Int -> a
V.unsafeIndex Vector (k, v)
v Int
i))
  (Int -> (Int, v)) -> Maybe Int -> Maybe (Int, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((k, v) -> Bool) -> Vector (k, v) -> Maybe Int
forall a. (a -> Bool) -> Vector a -> Maybe Int
V.findIndex ((k
kk -> k -> Bool
forall a. Eq a => a -> a -> Bool
==) (k -> Bool) -> ((k, v) -> k) -> (k, v) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, v) -> k
forall a b. (a, b) -> a
fst) Vector (k, v)
v
{-# INLINE lookupWithIndexV #-}

indexDefault :: a -> [a] -> Int -> a
indexDefault :: a -> [a] -> Int -> a
indexDefault a
err [a]
xs Int
i = case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
xs of
  a
x : [a]
_ -> a
x
  [a]
_ -> a
err

-- | A monad with @Reader [r]@ and @Either WineryException@ combined, used internally
-- to build an extractor.
-- @r@ is used to share environment such as extractors for fixpoints.
newtype Strategy e r a = Strategy { Strategy e r a -> r -> Either e a
unStrategy :: r -> Either e a }
  deriving a -> Strategy e r b -> Strategy e r a
(a -> b) -> Strategy e r a -> Strategy e r b
(forall a b. (a -> b) -> Strategy e r a -> Strategy e r b)
-> (forall a b. a -> Strategy e r b -> Strategy e r a)
-> Functor (Strategy e r)
forall a b. a -> Strategy e r b -> Strategy e r a
forall a b. (a -> b) -> Strategy e r a -> Strategy e r b
forall e r a b. a -> Strategy e r b -> Strategy e r a
forall e r a b. (a -> b) -> Strategy e r a -> Strategy e r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Strategy e r b -> Strategy e r a
$c<$ :: forall e r a b. a -> Strategy e r b -> Strategy e r a
fmap :: (a -> b) -> Strategy e r a -> Strategy e r b
$cfmap :: forall e r a b. (a -> b) -> Strategy e r a -> Strategy e r b
Functor

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

instance Monad (Strategy e r) where
  return :: a -> Strategy e r a
return = (r -> Either e a) -> Strategy e r a
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((r -> Either e a) -> Strategy e r a)
-> (a -> r -> Either e a) -> a -> Strategy e r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> r -> Either e a
forall a b. a -> b -> a
const (Either e a -> r -> Either e a)
-> (a -> Either e a) -> a -> r -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right
  Strategy e r a
m >>= :: Strategy e r a -> (a -> Strategy e r b) -> Strategy e r b
>>= a -> Strategy e r b
k = (r -> Either e b) -> Strategy e r b
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((r -> Either e b) -> Strategy e r b)
-> (r -> Either e b) -> Strategy e r b
forall a b. (a -> b) -> a -> b
$ \r
decs -> case Strategy e r a -> r -> Either e a
forall e r a. Strategy e r a -> r -> Either e a
unStrategy Strategy e r a
m r
decs of
    Right a
a -> Strategy e r b -> r -> Either e b
forall e r a. Strategy e r a -> r -> Either e a
unStrategy (a -> Strategy e r b
k a
a) r
decs
    Left e
e -> e -> Either e b
forall a b. a -> Either a b
Left e
e

instance IsString e => Alternative (Strategy e r) where
  empty :: Strategy e r a
empty = (r -> Either e a) -> Strategy e r a
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((r -> Either e a) -> Strategy e r a)
-> (r -> Either e a) -> Strategy e r a
forall a b. (a -> b) -> a -> b
$ Either e a -> r -> Either e a
forall a b. a -> b -> a
const (Either e a -> r -> Either e a) -> Either e a -> r -> Either e a
forall a b. (a -> b) -> a -> b
$ e -> Either e a
forall a b. a -> Either a b
Left e
"empty"
  Strategy r -> Either e a
a <|> :: Strategy e r a -> Strategy e r a -> Strategy e r a
<|> Strategy r -> Either e a
b = (r -> Either e a) -> Strategy e r a
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((r -> Either e a) -> Strategy e r a)
-> (r -> Either e a) -> Strategy e r a
forall a b. (a -> b) -> a -> b
$ \r
decs -> case r -> Either e a
a r
decs of
    Left e
_ -> r -> Either e a
b r
decs
    Right a
x -> a -> Either e a
forall a b. b -> Either a b
Right a
x

instance MonadFix (Strategy e r) where
  mfix :: (a -> Strategy e r a) -> Strategy e r a
mfix a -> Strategy e r a
f = (r -> Either e a) -> Strategy e r a
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((r -> Either e a) -> Strategy e r a)
-> (r -> Either e a) -> Strategy e r a
forall a b. (a -> b) -> a -> b
$ \r
r -> (a -> Either e a) -> Either e a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> Either e a) -> Either e a)
-> (a -> Either e a) -> Either e a
forall a b. (a -> b) -> a -> b
$ \a
a -> Strategy e r a -> r -> Either e a
forall e r a. Strategy e r a -> r -> Either e a
unStrategy (a -> Strategy e r a
f a
a) r
r
  {-# INLINE mfix #-}

throwStrategy :: e -> Strategy e r a
throwStrategy :: e -> Strategy e r a
throwStrategy = (r -> Either e a) -> Strategy e r a
forall e r a. (r -> Either e a) -> Strategy e r a
Strategy ((r -> Either e a) -> Strategy e r a)
-> (e -> r -> Either e a) -> e -> Strategy e r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> r -> Either e a
forall a b. a -> b -> a
const (Either e a -> r -> Either e a)
-> (e -> Either e a) -> e -> r -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left

-- | A Bazaar (chain of indexed store comonad)-like structure which instead
-- works for natural transformations.
newtype TransFusion f g a = TransFusion { TransFusion f g a
-> forall (h :: * -> *).
   Applicative h =>
   (forall x. f x -> h (g x)) -> h a
unTransFusion :: forall h. Applicative h => (forall x. f x -> h (g x)) -> h a }

instance Functor (TransFusion f g) where
  fmap :: (a -> b) -> TransFusion f g a -> TransFusion f g b
fmap a -> b
f (TransFusion forall (h :: * -> *).
Applicative h =>
(forall x. f x -> h (g x)) -> h a
m) = (forall (h :: * -> *).
 Applicative h =>
 (forall x. f x -> h (g x)) -> h b)
-> TransFusion f g b
forall (f :: * -> *) (g :: * -> *) a.
(forall (h :: * -> *).
 Applicative h =>
 (forall x. f x -> h (g x)) -> h a)
-> TransFusion f g a
TransFusion ((forall (h :: * -> *).
  Applicative h =>
  (forall x. f x -> h (g x)) -> h b)
 -> TransFusion f g b)
-> (forall (h :: * -> *).
    Applicative h =>
    (forall x. f x -> h (g x)) -> h b)
-> TransFusion f g b
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> h (g x)
k -> (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ((forall x. f x -> h (g x)) -> h a
forall (h :: * -> *).
Applicative h =>
(forall x. f x -> h (g x)) -> h a
m forall x. f x -> h (g x)
k)
  {-# INLINE fmap #-}

instance Applicative (TransFusion f g) where
  pure :: a -> TransFusion f g a
pure a
a = (forall (h :: * -> *).
 Applicative h =>
 (forall x. f x -> h (g x)) -> h a)
-> TransFusion f g a
forall (f :: * -> *) (g :: * -> *) a.
(forall (h :: * -> *).
 Applicative h =>
 (forall x. f x -> h (g x)) -> h a)
-> TransFusion f g a
TransFusion ((forall (h :: * -> *).
  Applicative h =>
  (forall x. f x -> h (g x)) -> h a)
 -> TransFusion f g a)
-> (forall (h :: * -> *).
    Applicative h =>
    (forall x. f x -> h (g x)) -> h a)
-> TransFusion f g a
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> h (g x)
_ -> a -> h a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  TransFusion forall (h :: * -> *).
Applicative h =>
(forall x. f x -> h (g x)) -> h (a -> b)
a <*> :: TransFusion f g (a -> b) -> TransFusion f g a -> TransFusion f g b
<*> TransFusion forall (h :: * -> *).
Applicative h =>
(forall x. f x -> h (g x)) -> h a
b = (forall (h :: * -> *).
 Applicative h =>
 (forall x. f x -> h (g x)) -> h b)
-> TransFusion f g b
forall (f :: * -> *) (g :: * -> *) a.
(forall (h :: * -> *).
 Applicative h =>
 (forall x. f x -> h (g x)) -> h a)
-> TransFusion f g a
TransFusion ((forall (h :: * -> *).
  Applicative h =>
  (forall x. f x -> h (g x)) -> h b)
 -> TransFusion f g b)
-> (forall (h :: * -> *).
    Applicative h =>
    (forall x. f x -> h (g x)) -> h b)
-> TransFusion f g b
forall a b. (a -> b) -> a -> b
$ \forall x. f x -> h (g x)
k -> (forall x. f x -> h (g x)) -> h (a -> b)
forall (h :: * -> *).
Applicative h =>
(forall x. f x -> h (g x)) -> h (a -> b)
a forall x. f x -> h (g x)
k h (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall x. f x -> h (g x)) -> h a
forall (h :: * -> *).
Applicative h =>
(forall x. f x -> h (g x)) -> h a
b forall x. f x -> h (g x)
k
  {-# INLINE (<*>) #-}