module Data.Repa.Convert.Format.Sep
( Sep (..)
, SepFormat (..)
, SepMeta (..))
where
import Data.Repa.Convert.Internal.Format
import Data.Repa.Convert.Internal.Packable
import Data.Repa.Convert.Internal.Packer
import Data.Repa.Convert.Format.Binary
import Data.Repa.Scalar.Product
import Data.Monoid
import Data.Word
import Data.Char
import GHC.Exts
import Prelude hiding (fail)
#include "repa-convert.h"
data Sep f where
SepNil :: Sep ()
SepCons :: {-# UNPACK #-} !SepMeta
-> !f
-> Sep fs
-> Sep (f :*: fs)
data SepMeta
= SepMeta
{
SepMeta -> Int
smFieldCount :: !Int
, SepMeta -> Int
smMinSize :: !Int
, SepMeta -> Maybe Int
smFixedSize :: !(Maybe Int)
, SepMeta -> Char
smSepChar :: !Char }
class SepFormat f where
mkSep :: Char -> f -> Sep f
takeSepChar :: Sep f -> Maybe Char
instance SepFormat () where
mkSep :: Char -> () -> Sep ()
mkSep Char
_ () = Sep ()
SepNil
{-# INLINE mkSep #-}
takeSepChar :: Sep () -> Maybe Char
takeSepChar Sep ()
_ = Maybe Char
forall a. Maybe a
Nothing
{-# INLINE takeSepChar #-}
instance (Format f1, SepFormat fs)
=> SepFormat (f1 :*: fs) where
mkSep :: Char -> (f1 :*: fs) -> Sep (f1 :*: fs)
mkSep Char
c (f1
f1 :*: fs
fs)
= case Char -> fs -> Sep fs
forall f. SepFormat f => Char -> f -> Sep f
mkSep Char
c fs
fs of
Sep fs
SepNil
-> SepMeta -> f1 -> Sep fs -> Sep (f1 :*: fs)
forall f fs. SepMeta -> f -> Sep fs -> Sep (f :*: fs)
SepCons
(SepMeta { smFieldCount :: Int
smFieldCount = Int
1
, smMinSize :: Int
smMinSize = f1 -> Int
forall f. Format f => f -> Int
minSize f1
f1
, smFixedSize :: Maybe Int
smFixedSize = f1 -> Maybe Int
forall f. Format f => f -> Maybe Int
fixedSize f1
f1
, smSepChar :: Char
smSepChar = Char
c })
f1
f1 Sep fs
Sep ()
SepNil
sep :: Sep fs
sep@(SepCons SepMeta
sm f
_ Sep fs
_)
-> SepMeta -> f1 -> Sep fs -> Sep (f1 :*: fs)
forall f fs. SepMeta -> f -> Sep fs -> Sep (f :*: fs)
SepCons
(SepMeta { smFieldCount :: Int
smFieldCount = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SepMeta -> Int
smFieldCount SepMeta
sm
, smMinSize :: Int
smMinSize = f1 -> Int
forall f. Format f => f -> Int
minSize f1
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SepMeta -> Int
smMinSize SepMeta
sm
, smFixedSize :: Maybe Int
smFixedSize
= do Int
s1 <- f1 -> Maybe Int
forall f. Format f => f -> Maybe Int
fixedSize f1
f1
Int
ss <- SepMeta -> Maybe Int
smFixedSize SepMeta
sm
Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ss
, smSepChar :: Char
smSepChar = Char
c })
f1
f1 Sep fs
sep
{-# INLINE mkSep #-}
takeSepChar :: Sep (f1 :*: fs) -> Maybe Char
takeSepChar (SepCons SepMeta
sm f
_ Sep fs
_)
= Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char) -> Char -> Maybe Char
forall a b. (a -> b) -> a -> b
$ SepMeta -> Char
smSepChar SepMeta
sm
{-# INLINE takeSepChar #-}
instance Format (Sep ()) where
type Value (Sep ()) = ()
fieldCount :: Sep () -> Int
fieldCount Sep ()
SepNil = Int
0
minSize :: Sep () -> Int
minSize Sep ()
SepNil = Int
0
fixedSize :: Sep () -> Maybe Int
fixedSize Sep ()
SepNil = Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
packedSize :: Sep () -> Value (Sep ()) -> Maybe Int
packedSize Sep ()
SepNil Value (Sep ())
_ = Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
{-# INLINE minSize #-}
{-# INLINE fieldCount #-}
{-# INLINE fixedSize #-}
{-# INLINE packedSize #-}
instance Packable (Sep ()) where
packer :: Sep ()
-> Value (Sep ()) -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
packer Sep ()
_fmt Value (Sep ())
_val Addr#
dst IO ()
_fails Addr# -> IO ()
k
= Addr# -> IO ()
k Addr#
dst
{-# INLINE packer #-}
instance Unpackable (Sep ()) where
unpacker :: Sep ()
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value (Sep ()) -> IO ())
-> IO ()
unpacker Sep ()
_fmt Addr#
start Addr#
_end Word8 -> Bool
_stop IO ()
_fail Addr# -> Value (Sep ()) -> IO ()
eat
= Addr# -> Value (Sep ()) -> IO ()
eat Addr#
start ()
{-# INLINE unpacker #-}
instance ( Format f1, Format (Sep fs)
, Value (Sep fs) ~ Value fs)
=> Format (Sep (f1 :*: fs)) where
type Value (Sep (f1 :*: fs))
= Value f1 :*: Value fs
fieldCount :: Sep (f1 :*: fs) -> Int
fieldCount (SepCons SepMeta
sm f
_f1 Sep fs
_sfs)
= SepMeta -> Int
smFieldCount SepMeta
sm
{-# INLINE fieldCount #-}
minSize :: Sep (f1 :*: fs) -> Int
minSize (SepCons SepMeta
sm f
_f1 Sep fs
_sfs)
= SepMeta -> Int
smMinSize SepMeta
sm
{-# INLINE minSize #-}
fixedSize :: Sep (f1 :*: fs) -> Maybe Int
fixedSize (SepCons SepMeta
sm f
_f1 Sep fs
_sfs)
= SepMeta -> Maybe Int
smFixedSize SepMeta
sm
{-# INLINE fixedSize #-}
packedSize :: Sep (f1 :*: fs) -> Value (Sep (f1 :*: fs)) -> Maybe Int
packedSize (SepCons SepMeta
_sm f
f1 Sep fs
sfs) (Value f1
x1 :*: Value fs
xs)
= do Int
s1 <- f -> Value f -> Maybe Int
forall f. Format f => f -> Value f -> Maybe Int
packedSize f
f1 Value f1
Value f
x1
Int
ss <- Sep fs -> Value (Sep fs) -> Maybe Int
forall f. Format f => f -> Value f -> Maybe Int
packedSize Sep fs
sfs Value fs
Value (Sep fs)
xs
let sSep :: Int
sSep = Int -> Int
zeroOrOne (Sep fs -> Int
forall f. Format f => f -> Int
fieldCount Sep fs
sfs)
Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sSep Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ss
{-# INLINE packedSize #-}
instance ( Packable f1
, Value (Sep ()) ~ Value ())
=> Packable (Sep (f1 :*: ())) where
packer :: Sep (f1 :*: ())
-> Value (Sep (f1 :*: ()))
-> Addr#
-> IO ()
-> (Addr# -> IO ())
-> IO ()
packer (SepCons SepMeta
_ f
f1 Sep fs
_ ) (Value f1
x1 :*: ()
_) Addr#
start IO ()
k
= f -> Value f -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
forall format.
Packable format =>
format
-> Value format -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
packer f
f1 Value f1
Value f
x1 Addr#
start IO ()
k
{-# INLINE packer #-}
instance ( Unpackable f1
, Value (Sep ()) ~ Value ())
=> Unpackable (Sep (f1 :*: ())) where
unpacker :: Sep (f1 :*: ())
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value (Sep (f1 :*: ())) -> IO ())
-> IO ()
unpacker (SepCons SepMeta
sm f
f1 Sep fs
sfs) Addr#
start Addr#
end Word8 -> Bool
stop IO ()
fail Addr# -> Value (Sep (f1 :*: ())) -> IO ()
eat
= do let stop' :: Word8 -> Bool
stop' Word8
x = Int -> Word8
forall a. Integral a => a -> Word8
w8 (Char -> Int
ord (SepMeta -> Char
smSepChar SepMeta
sm)) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
x Bool -> Bool -> Bool
|| Word8 -> Bool
stop Word8
x
{-# INLINE stop' #-}
f
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value f -> IO ())
-> IO ()
forall format.
Unpackable format =>
format
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value format -> IO ())
-> IO ()
unpacker f
f1 Addr#
start Addr#
end Word8 -> Bool
stop' IO ()
fail ((Addr# -> Value f -> IO ()) -> IO ())
-> (Addr# -> Value f -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Addr#
start_x1 Value f
x1
-> Sep fs
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value (Sep fs) -> IO ())
-> IO ()
forall format.
Unpackable format =>
format
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value format -> IO ())
-> IO ()
unpacker Sep fs
sfs Addr#
start_x1 Addr#
end Word8 -> Bool
stop IO ()
fail ((Addr# -> Value (Sep fs) -> IO ()) -> IO ())
-> (Addr# -> Value (Sep fs) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Addr#
start_xs Value (Sep fs)
xs
-> Addr# -> Value (Sep (f1 :*: ())) -> IO ()
eat Addr#
start_xs (Value f1
Value f
x1 Value f1 -> () -> Value f1 :*: ()
forall a b. a -> b -> a :*: b
:*: ()
Value (Sep fs)
xs)
{-# INLINE unpacker #-}
instance ( Packable f1
, Packable (Sep (f2 :*: fs))
, Value (Sep (f2 :*: fs)) ~ Value (f2 :*: fs)
, Value (Sep fs) ~ Value fs)
=> Packable (Sep (f1 :*: f2 :*: fs)) where
pack :: Sep (f1 :*: (f2 :*: fs))
-> Value (Sep (f1 :*: (f2 :*: fs))) -> Packer
pack (SepCons SepMeta
sm f
f1 Sep fs
sfs) (Value f1
x1 :*: Value f2 :*: Value fs
xs)
= f -> Value f -> Packer
forall format. Packable format => format -> Value format -> Packer
pack f
f1 Value f1
Value f
x1
Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<> Word8be -> Value Word8be -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Word8be
Word8be (Int -> Word8
forall a. Integral a => a -> Word8
w8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord (Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ SepMeta -> Char
smSepChar SepMeta
sm)
Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<> Sep fs -> Value (Sep fs) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Sep fs
sfs Value f2 :*: Value fs
Value (Sep fs)
xs
{-# INLINE pack #-}
packer :: Sep (f1 :*: (f2 :*: fs))
-> Value (Sep (f1 :*: (f2 :*: fs)))
-> Addr#
-> IO ()
-> (Addr# -> IO ())
-> IO ()
packer Sep (f1 :*: (f2 :*: fs))
f Value (Sep (f1 :*: (f2 :*: fs)))
v
= Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
fromPacker (Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ())
-> Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sep (f1 :*: (f2 :*: fs))
-> Value (Sep (f1 :*: (f2 :*: fs))) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Sep (f1 :*: (f2 :*: fs))
f Value (Sep (f1 :*: (f2 :*: fs)))
v
{-# INLINE packer #-}
instance ( Unpackable f1
, Unpackable (Sep (f2 :*: fs))
, Value (Sep (f2 :*: fs)) ~ Value (f2 :*: fs)
, Value (Sep fs) ~ Value fs)
=> Unpackable (Sep (f1 :*: f2 :*: fs)) where
unpacker :: Sep (f1 :*: (f2 :*: fs))
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value (Sep (f1 :*: (f2 :*: fs))) -> IO ())
-> IO ()
unpacker (SepCons SepMeta
sm f
f1 Sep fs
sfs) Addr#
start Addr#
end Word8 -> Bool
stop IO ()
fail Addr# -> Value (Sep (f1 :*: (f2 :*: fs))) -> IO ()
eat
= do
let len :: Int
len = Int# -> Int
I# (Addr# -> Addr# -> Int#
minusAddr# Addr#
end Addr#
start)
let stop' :: Word8 -> Bool
stop' Word8
x = Int -> Word8
forall a. Integral a => a -> Word8
w8 (Char -> Int
ord (SepMeta -> Char
smSepChar SepMeta
sm)) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
x Bool -> Bool -> Bool
|| Word8 -> Bool
stop Word8
x
{-# INLINE stop' #-}
if Bool -> Bool
not (SepMeta -> Int
smMinSize SepMeta
sm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len)
then IO ()
fail
else do
f
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value f -> IO ())
-> IO ()
forall format.
Unpackable format =>
format
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value format -> IO ())
-> IO ()
unpacker f
f1 Addr#
start Addr#
end Word8 -> Bool
stop' IO ()
fail ((Addr# -> Value f -> IO ()) -> IO ())
-> (Addr# -> Value f -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Addr#
start_x1 Value f
x1
-> Sep fs
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value (Sep fs) -> IO ())
-> IO ()
forall format.
Unpackable format =>
format
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value format -> IO ())
-> IO ()
unpacker Sep fs
sfs (Addr# -> Int# -> Addr#
plusAddr# Addr#
start_x1 Int#
1#) Addr#
end Word8 -> Bool
stop IO ()
fail ((Addr# -> Value (Sep fs) -> IO ()) -> IO ())
-> (Addr# -> Value (Sep fs) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Addr#
start_xs Value (Sep fs)
xs
-> Addr# -> Value (Sep (f1 :*: (f2 :*: fs))) -> IO ()
eat Addr#
start_xs (Value f1
Value f
x1 Value f1
-> (Value f2 :*: Value fs) -> Value f1 :*: (Value f2 :*: Value fs)
forall a b. a -> b -> a :*: b
:*: Value f2 :*: Value fs
Value (Sep fs)
xs)
{-# INLINE unpacker #-}
w8 :: Integral a => a -> Word8
w8 :: forall a. Integral a => a -> Word8
w8 = a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE w8 #-}
zeroOrOne :: Int -> Int
zeroOrOne :: Int -> Int
zeroOrOne (I# Int#
i) = Int# -> Int
I# (Int#
1# Int# -> Int# -> Int#
-# (Int#
0# Int# -> Int# -> Int#
==# Int#
i))
{-# INLINE zeroOrOne #-}