Commit 52564d3f authored by Steffen Michels's avatar Steffen Michels

add Data.Encoding.GenBinary

parent d1f16cca
Pipeline #29851 passed with stage
in 3 minutes and 9 seconds
......@@ -8,7 +8,7 @@ from Control.Monad import class Monad
mapArrSt :: !(.a -> .(*st -> *(.a, *st))) !*(arr .a) !*st -> *(!*(arr .a), !*st) | Array arr a
foldrArr :: !(a .b -> .b) !.b !.(arr a) -> .b | Array arr a
foldrArr :: !(a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
foldrArrWithKey :: !(Int a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
......@@ -18,7 +18,7 @@ foldrUArr :: !(a -> .(.b -> .(*(arr a) -> *(.b, *(arr a))))) .b !*(arr a)
foldrUArrWithKey :: !(Int a -> .(.b -> .(*(arr a) -> *(.b, *(arr a))))) .b !*(arr a)
-> *(.b, *(arr a)) | Array arr a
foldlArr :: !(.b a -> .b) !.b !.(arr a) -> .b | Array arr a
foldlArr :: !(.b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
foldlArrWithKey :: !(Int .b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
......
......@@ -17,7 +17,7 @@ mapArrSt f arr st
#! arr = {arr & [idx] = e}
= mapArrSt` sz (idx + 1) f arr st
foldrArr :: !(a .b -> .b) !.b !.(arr a) -> .b | Array arr a
foldrArr :: !(a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
foldrArr f b arr = foldrArrWithKey (\_ -> f) b arr
foldrArrWithKey :: !(Int a -> .(.b -> .b)) !.b !.(arr a) -> .b | Array arr a
......@@ -49,7 +49,7 @@ foldrUArrWithKey f b arr
#! (res, arr) = foldUArr` sz (idx + 1) b arr
= f idx elem res arr
foldlArr :: !(.b a -> .b) !.b !.(arr a) -> .b | Array arr a
foldlArr :: !(.b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
foldlArr f b arr = foldlArrWithKey (\_ -> f) b arr
foldlArrWithKey :: !(Int .b -> .(a -> .b)) !.b !.(arr a) -> .b | Array arr a
......
definition module Data.Encoding.GenBinary
/**
* This module provides a compact binary encoding for arbitrary values.
* The encoding is provided as character array.
* Choices of ADTs are represented by a single bit.
* Values of basic types (except `Bool`), arrays and lists are stored byte-aligned, which wastes only little space,
* but significantly improves encoding and decoding time.
*
* @property-bootstrap
* import StdEnv, Data.Maybe.Gast, Data.Maybe.GenPrint, Data.Maybe.GenBinary
*
* :: ADT = A String | B ADT | C ADT ADT | D ADT ADT ADT
*
* derive gEq ADT
* derive class GenBinary ADT
* derive class Gast ADT
*
* instance == ADT where
* == x y = x === y
*
* :: Record = {a :: ADT, b :: ADT , c :: ADT}
*
* derive gEq Record
* derive class GenBinary Record
* derive class Gast Record
*
* instance == Record where
* == x y = x === y
*
* @property-test-with a = Maybe Bool
* @property-test-with a = Int
* @property-test-with a = String
* @property-test-with a = Char
* @property-test-with a = Real
* @property-test-with a = (Int, Int)
* @property-test-with a = (String, String)
* @property-test-with a = (String, Int)
* @property-test-with a = (Int, String)
* @property-test-with a = [Bool]
* @property-test-with a = [Int]
* @property-test-with a = [String]
* @property-test-with a = [Char]
* @property-test-with a = [Real]
* @property-test-with a = ADT
* @property-test-with a = Record
*/
from StdGeneric import :: UNIT (..), :: PAIR (..), :: EITHER (..), :: CONS (..), :: OBJECT (..), :: RECORD (..),
:: FIELD (..)
from StdInt import class + (+), instance + Int
from Data.Maybe import :: Maybe (..), instance Functor Maybe
from Data.Func import $
from Data.Functor import class Functor (fmap)
from Data.Tuple import appFst
/**
* Encodes a values as character array.
*
* @param The value.
* @result The encoded value.
*/
encode :: !a -> {#Char} | gBinaryEncodingSize{|*|}, gBinaryEncode{|*|} a
/**
* Decodes a value.
*
* @param The value encoded as character array.
* @result The corresponding value, if the provided array is a valid representation of a value.
*
* @property correctness: A.a :: a:
* // The `a == a` check is required as NaN Real values do not equal themselves.
* a == a ==> decode (encode a) =.= Just a
*/
decode :: !{#Char} -> Maybe a | gBinaryDecode{|*|} a
class GenBinary a | gBinaryEncode{|*|}, gBinaryEncodingSize{|*|}, gBinaryDecode{|*|} a
:: *EncodingSt
generic gBinaryEncode a :: !a !*EncodingSt -> *EncodingSt
gBinaryEncode{|UNIT|} _ st = st
gBinaryEncode{|PAIR|} cx cy (PAIR x y) st = cy y $ cx x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x $ encodeBool False st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x $ encodeBool True st
gBinaryEncode{|CONS|} c (CONS x) st = c x st
gBinaryEncode{|FIELD|} c (FIELD x) st = c x st
gBinaryEncode{|OBJECT|} c (OBJECT x) st = c x st
gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
derive gBinaryEncode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
generic gBinaryEncodingSize a :: !a !Int -> Int
gBinaryEncodingSize{|UNIT|} _ s = s
gBinaryEncodingSize{|PAIR|} cx cy (PAIR x y) s = cy y $ cx x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x $ s + 1
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x $ s + 1
gBinaryEncodingSize{|CONS|} c (CONS x) s = c x s
gBinaryEncodingSize{|FIELD|} c (FIELD x) s = c x s
gBinaryEncodingSize{|OBJECT|} c (OBJECT x) s = c x s
gBinaryEncodingSize{|RECORD|} c (RECORD x) s = c x s
derive gBinaryEncodingSize Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
generic gBinaryDecode a :: !*EncodingSt -> (!Maybe a, !*EncodingSt)
gBinaryDecode{|UNIT|} st = (Just UNIT, st)
gBinaryDecode{|PAIR|} fx fy st
# (mbX, st) = fx st
# (mbY, st) = fy st
= case (mbX, mbY) of
(Just x, Just y) = (Just $ PAIR x y, st)
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st
# (mbIsRight, st) = decodeBool st
= case mbIsRight of
Just isRight | isRight = appFst (fmap RIGHT) $ fr st
| otherwise = appFst (fmap LEFT) $ fl st
_ = (Nothing, st)
gBinaryDecode{|CONS|} f st = appFst (fmap CONS) $ f st
gBinaryDecode{|FIELD|} f st = appFst (fmap \x -> FIELD x) $ f st
gBinaryDecode{|OBJECT|} f st = appFst (fmap \x -> OBJECT x) $ f st
gBinaryDecode{|RECORD|} f st = appFst (fmap RECORD) $ f st
derive gBinaryDecode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
// This is only exported because it is used in exposed generic definitions.
decodeBool :: !*EncodingSt -> (!Maybe Bool, !*EncodingSt)
encodeBool :: !Bool !*EncodingSt -> *EncodingSt
implementation module Data.Encoding.GenBinary
import StdGeneric, StdEnv
import Data._Array, Data.Func, Data.Maybe, Data.Functor, Data.Tuple, Data.Array
import System._Unsafe
decode :: !{#Char} -> Maybe a | gBinaryDecode{|*|} a
decode binary = fst $ gBinaryDecode{|*|} $ mkEncodingSt {x \\ x <-: binary}
encode :: !a -> {#Char} | gBinaryEncodingSize{|*|}, gBinaryEncode{|*|} a
encode x
#! encoded_size = gBinaryEncodingSize{|*|} x 0
#! arr_size = (encoded_size+7) >> 3
#! bits = createArray arr_size '\0'
= (gBinaryEncode{|*|} x (mkEncodingSt bits)).cs_bits
mkEncodingSt :: !*{#Char} -> *EncodingSt
mkEncodingSt arr = { cs_pos = 0, cs_bits = arr}
generic gBinaryEncode a :: !a !*EncodingSt -> *EncodingSt
gBinaryEncode{|Int|} x st = encodeInt x st
gBinaryEncode{|Real|} x st = encodeReal x st
gBinaryEncode{|Char|} x st = encodeChar x st
gBinaryEncode{|Bool|} x st = encodeBool x st
gBinaryEncode{|String|} xs st = encodeArray encodeChar xs st
gBinaryEncode{|UNIT|} _ st = st
gBinaryEncode{|PAIR|} cx cy (PAIR x y) st = cy y $ cx x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x $ encodeBool False st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x $ encodeBool True st
gBinaryEncode{|CONS|} c (CONS x) st = c x st
gBinaryEncode{|FIELD|} c (FIELD x) st = c x st
gBinaryEncode{|OBJECT|} c (OBJECT x) st = c x st
gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
gBinaryEncode{|{}|} c xs st = encodeArray c xs st
gBinaryEncode{|{!}|} c xs st = encodeArray c xs st
gBinaryEncode{|[]|} c xs st = encodeList c xs st
encodeInt :: !Int !*EncodingSt -> *EncodingSt
encodeInt int st = encodeIntUsingNBytes (IF_INT_64_OR_32 8 4) int st
encodeChar :: !Char !*EncodingSt -> *EncodingSt
encodeChar c st = encodeIntUsingNBytes 1 (toInt c) st
encodeBool :: !Bool !*EncodingSt -> *EncodingSt
encodeBool False st = {st & cs_pos = st.cs_pos + 1}
encodeBool True {cs_pos = pos, cs_bits = bits}
#! byte_pos = pos >> 3
#! bit_pos = pos bitand 7
#! int = toInt bits.[byte_pos]
#! bit_mask = 1 << bit_pos
= {cs_pos = inc pos, cs_bits = {bits & [byte_pos] = toChar $ int bitor bit_mask}}
encodeReal :: !Real !*EncodingSt -> *EncodingSt
encodeReal real st = IF_INT_64_OR_32
(encodeInt (unsafeCoerce real) st)
(let (i1, i2) = unsafeCoerce real in encodeInt i2 $ encodeInt i1 st)
encodeArray :: !(a *EncodingSt -> *EncodingSt) !(b a) !*EncodingSt -> *EncodingSt | Array b a
encodeArray f xs st
#! st = encodeInt (size xs) st
= foldlArr (flip f) st xs
encodeList :: !(a *EncodingSt -> *EncodingSt) ![a] !*EncodingSt -> *EncodingSt
encodeList f xs st
#! st = encodeInt (length xs) st
= foldl (flip f) st xs
encodeIntUsingNBytes :: !Int !Int !*EncodingSt -> *EncodingSt
encodeIntUsingNBytes numBytes int st = encode numBytes $ withByteAlignedPosition st
where
encode :: !Int !*EncodingSt -> *EncodingSt
encode 0 st = st
encode remainingBytes st
#! byte_pos = st.cs_pos >> 3
#! st =
{ st
& cs_bits = {st.cs_bits & [byte_pos] = toChar $ int >> ((numBytes - remainingBytes) * 8)}
, cs_pos = st.cs_pos + 8
}
= encode (dec remainingBytes) st
generic gBinaryEncodingSize a :: !a !Int -> Int
gBinaryEncodingSize{|Int|} _ s = (IF_INT_64_OR_32 64 32) + byteAlignedPosition s
gBinaryEncodingSize{|Real|} _ s = 64 + byteAlignedPosition s
gBinaryEncodingSize{|Char|} _ s = 8 + byteAlignedPosition s
gBinaryEncodingSize{|Bool|} _ s = 1 + s
gBinaryEncodingSize{|String|} xs s = IF_INT_64_OR_32 64 32 + size xs * 8 + byteAlignedPosition s
gBinaryEncodingSize{|UNIT|} _ s = s
gBinaryEncodingSize{|PAIR|} cx cy (PAIR x y) s = cy y $ cx x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x $ s + 1
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x $ s + 1
gBinaryEncodingSize{|CONS|} c (CONS x) s = c x s
gBinaryEncodingSize{|FIELD|} c (FIELD x) s = c x s
gBinaryEncodingSize{|OBJECT|} c (OBJECT x) s = c x s
gBinaryEncodingSize{|RECORD|} c (RECORD x) s = c x s
gBinaryEncodingSize{|[]|} c xs s = foldl (flip c) (IF_INT_64_OR_32 64 32 + byteAlignedPosition s) xs
gBinaryEncodingSize{|{}|} c xs s = foldlArr (flip c) (IF_INT_64_OR_32 64 32 + byteAlignedPosition s) xs
gBinaryEncodingSize{|{!}|} c xs s = foldlArr (flip c) (IF_INT_64_OR_32 64 32 + byteAlignedPosition s) xs
generic gBinaryDecode a :: !*EncodingSt -> (!Maybe a, !*EncodingSt)
gBinaryDecode{|Int|} st = decodeInt st
gBinaryDecode{|Real|} st = decodeReal st
gBinaryDecode{|Char|} st = decodeChar st
gBinaryDecode{|Bool|} st = decodeBool st
gBinaryDecode{|String|} st = decodeArray decodeChar st
gBinaryDecode{|UNIT|} st = (Just UNIT, st)
gBinaryDecode{|PAIR|} fx fy st
# (mbX, st) = fx st
# (mbY, st) = fy st
= case (mbX, mbY) of
(Just x, Just y) = (Just $ PAIR x y, st)
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st
# (mbIsRight, st) = decodeBool st
= case mbIsRight of
Just isRight
| isRight = appFst (fmap RIGHT) $ fr st
| otherwise = appFst (fmap LEFT) $ fl st
_ = (Nothing, st)
gBinaryDecode{|CONS|} f st = appFst (fmap CONS) $ f st
gBinaryDecode{|FIELD|} f st = appFst (fmap \x -> FIELD x) $ f st
gBinaryDecode{|OBJECT|} f st = appFst (fmap \x -> OBJECT x) $ f st
gBinaryDecode{|RECORD|} f st = appFst (fmap RECORD) $ f st
gBinaryDecode{|[]|} f st = decodeList f st
gBinaryDecode{|{}|} f st = decodeArray f st
gBinaryDecode{|{!}|} f st = decodeArray f st
decodeInt :: !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decodeInt st = decodeIntWithNBytes (IF_INT_64_OR_32 8 4) st
decodeChar :: !*EncodingSt -> (!Maybe Char, !*EncodingSt)
decodeChar st
# (mbInt, st) = decodeIntWithNBytes 1 st
= (toChar <$> mbInt, st)
decodeBool :: !*EncodingSt -> (!Maybe Bool, !*EncodingSt)
decodeBool cs=:{cs_pos = pos, cs_bits = bits}
#! s = size bits
#! byte_pos = pos >> 3
#! bit_pos = pos bitand 7
| s == byte_pos = (Nothing, cs)
#! int = toInt bits.[byte_pos]
#! bit_mask = 1 << bit_pos
#! bit = (bit_mask bitand int) <> 0
= (Just bit, {cs & cs_pos = inc pos})
decodeReal :: !*EncodingSt -> (!Maybe Real, !*EncodingSt)
decodeReal st = IF_INT_64_OR_32 decodeReal64 decodeReal32 $ st
where
decodeReal64 st
# (mbInt, st) = decodeInt st
= (unsafeCoerce <$> mbInt, st)
decodeReal32 st
# (mbInt1, st) = decodeInt st
# (mbInt2, st) = decodeInt st
= case (mbInt1, mbInt2) of
(Just int1, Just int2) = (Just $ unsafeCoerce (int1, int2), st)
_ = (Nothing, st)
decodeArray :: !(*EncodingSt -> (Maybe a, *EncodingSt)) !*EncodingSt -> (!Maybe (b a), !*EncodingSt) | Array b a
decodeArray f st
# (mbLength, st) = decodeInt st
= case mbLength of
Just l = decodeArray 0 l (unsafeCreateArray l) st
_ = (Nothing, st)
where
decodeArray i s arr st
| i == s = (Just arr, st)
| otherwise
# (mbX, st) = f st
= case mbX of
Just x = decodeArray (inc i) s {arr & [i] = x} st
_ = (Nothing, st)
decodeList :: !(*EncodingSt -> (Maybe a, *EncodingSt)) !*EncodingSt -> (!Maybe [a], !*EncodingSt)
decodeList xs st
# (mbArr, st) = decodeArray xs st
= (arrToList <$> mbArr, st)
where
arrToList :: !{b} -> [b]
arrToList xs = [x \\ x <-: xs]
decodeIntWithNBytes :: !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decodeIntWithNBytes numBytes st=:{cs_pos} = decode numBytes 0 $ withByteAlignedPosition st
where
// we can decode an entire byte at once, as the start position is byte-aligned
decode :: !Int !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decode 0 int st = (Just int, st)
decode remainingBytes int st=:{cs_bits}
#! byte_pos = st.cs_pos >> 3
| byte_pos == size cs_bits = (Nothing, st)
#! byte = toInt cs_bits.[byte_pos]
= decode (dec remainingBytes) (byte << ((numBytes - remainingBytes) * 8) + int) {st & cs_pos = st.cs_pos + 8}
withByteAlignedPosition :: !*EncodingSt -> *EncodingSt
withByteAlignedPosition st=:{cs_pos} = {st & cs_pos = byteAlignedPosition cs_pos}
byteAlignedPosition :: !Int -> Int
byteAlignedPosition pos = (pos + 7) bitand -8
:: *EncodingSt = {cs_pos :: !Int, cs_bits :: !*{#Char}}
derive gBinaryEncode (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
derive gBinaryEncodingSize (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
derive gBinaryDecode (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
definition module Data.Maybe.GenBinary
from Data.Maybe import :: Maybe
from Data.Encoding.GenBinary import class GenBinary, generic gBinaryEncode, generic gBinaryEncodingSize,
generic gBinaryDecode, :: EncodingSt
derive class GenBinary Maybe
implementation module Data.Maybe.GenBinary
import Data.Maybe, Data.Encoding.GenBinary
derive class GenBinary Maybe
......@@ -127,6 +127,7 @@ import qualified Data.Maybe
import qualified Data.Maybe.Ord
import qualified Data.Maybe.Gast
import qualified Data.Maybe.GenPrint
import qualified Data.Maybe.GenBinary
import qualified Data.Monoid
import qualified Data.NGramIndex
import qualified Data.OrdList
......@@ -139,6 +140,7 @@ import qualified Data.Tree
import qualified Data.Tuple
import qualified Data.Word8
import qualified Data._Array
import qualified Data.Encoding.GenBinary
import qualified Database.Native
import qualified Database.Native.JSON
import qualified Database.SQL
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment