├── .ghci ├── .gitignore ├── .gitmodules ├── CHANGELOG.md ├── LICENSE ├── README.md ├── cabal.project ├── src └── Data │ └── Binary │ ├── Succinct.hs │ └── Succinct │ ├── Blob.hs │ ├── Get.hs │ ├── Orphans.hs │ ├── Put.hs │ ├── Result.hs │ └── Size.hs └── succinct-binary.cabal /.ghci: -------------------------------------------------------------------------------- 1 | :m + Data.Word Data.Void 2 | :set -XTypeApplications 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .hsenv/ 4 | docs 5 | wiki 6 | TAGS 7 | tags 8 | wip 9 | .DS_Store 10 | .*.swp 11 | .*.swo 12 | *.o 13 | *.hi 14 | *~ 15 | *# 16 | cabal.project.local 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | .stack-work/ 20 | codex.tags 21 | .ghc.environment.* 22 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "nih/generics-sop"] 2 | path = nih/generics-sop 3 | url = https://github.com/Taneb/generics-sop 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0 2 | 3 | * Repository initialized 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2018 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | succinct-binary 2 | ============ 3 | 4 | 5 | 6 | Lazy (de)serialization. 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ., nih/* 2 | 3 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct.hs: -------------------------------------------------------------------------------- 1 | module Data.Binary.Succinct 2 | ( module Data.Binary.Succinct.Get 3 | , module Data.Binary.Succinct.Put 4 | , module Data.Binary.Succinct.Blob 5 | ) where 6 | 7 | import Data.Binary.Succinct.Get 8 | import Data.Binary.Succinct.Put 9 | import Data.Binary.Succinct.Blob 10 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct/Blob.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -Wno-orphans #-} 2 | 3 | module Data.Binary.Succinct.Blob 4 | ( Blob(..) 5 | , blob 6 | -- guts 7 | , inspectMeta 8 | , inspectShape 9 | , inspectContent 10 | , inspectBlob 11 | ) where 12 | 13 | import Data.Word 14 | import Data.Bits 15 | import Data.ByteString as Strict 16 | import Data.ByteString.Builder as Builder 17 | import Data.ByteString.Lazy as Lazy 18 | import Data.Semigroup 19 | import qualified Data.Vector.Storable as Storable 20 | import HaskellWorks.Data.BalancedParens.RangeMinMax as BP 21 | import HaskellWorks.Data.RankSelect.CsPoppy as CsPoppy 22 | import HaskellWorks.Data.RankSelect.Base.Rank0 23 | import Data.Vector.Storable.ByteString 24 | 25 | import Data.Binary.Succinct.Put 26 | import Data.Binary.Succinct.Orphans () 27 | 28 | data Blob = Blob 29 | { blobSize :: Word64 30 | , blobMeta :: CsPoppy 31 | , blobShape :: RangeMinMax (Storable.Vector Word64) 32 | , blobContent :: Strict.ByteString 33 | } -- deriving Show 34 | 35 | -- for debugging 36 | instance Show Blob where 37 | show = inspectBlob 38 | 39 | -- evil orphan for debugging 40 | instance Show Put where 41 | show = show . blob 42 | 43 | blob :: Put -> Blob 44 | blob ma = case runPut ma (State 0 0 0 0) of 45 | Result (State i b j b') (W m s c n) -> Blob 46 | { blobSize = n 47 | , blobMeta = makeCsPoppy $ ws $ flush8 i b m 48 | , blobShape = mkRangeMinMax $ ws $ flush8 j b' s 49 | , blobContent = bs c 50 | } 51 | where 52 | flush :: Int -> Word8 -> Builder -> Builder 53 | flush 0 _ xs = xs 54 | flush _ b xs = xs <> word8 b 55 | 56 | flush8 :: Int -> Word8 -> Builder -> Builder 57 | flush8 r k d = flush r k d <> stimes (7 :: Int) (word8 0) 58 | 59 | trim8 :: Strict.ByteString -> Strict.ByteString 60 | trim8 b = Strict.take (Strict.length b .&. complement 7) b 61 | 62 | bs :: Builder -> Strict.ByteString 63 | bs = Lazy.toStrict . Builder.toLazyByteString 64 | 65 | ws :: Builder -> Storable.Vector Word64 66 | ws = byteStringToVector . trim8 . bs 67 | 68 | access :: Rank1 v => v -> Word64 -> Word64 69 | access s 1 = rank1 s 1 70 | access s n = rank1 s n - rank1 s (n - 1) 71 | 72 | as :: Rank1 v => a -> a -> v -> Word64 -> a 73 | as l r s i = case access s i of 74 | 0 -> l 75 | _ -> r 76 | 77 | -- Print out a string of S's and D's, corresponding to Shape or Data, from the meta index 78 | inspectMeta :: Blob -> String 79 | inspectMeta (Blob n m _ _) = as 'D' 'S' m <$> [1..n] 80 | 81 | -- Print out the balanced parentheses representation of our paren index 82 | inspectShape :: Blob -> String 83 | inspectShape (Blob n m s _) = as ')' '(' s <$> [1..rank1 m n] 84 | 85 | -- Print out our raw content buffer 86 | inspectContent :: Blob -> String 87 | inspectContent (Blob _ _ _ c) = show c 88 | 89 | -- Print out a representation of the entire blob, interleaving paren and content 90 | inspectBlob :: Blob -> String 91 | inspectBlob (Blob n m s c) = do 92 | i <- [1..n] 93 | case access m i of 94 | 0 -> '{' : shows (Strict.index c $ fromIntegral $ rank0 m i - 1) "}" 95 | _ -> [as ')' '(' s $ rank1 m i] 96 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct/Get.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor #-} 2 | {-# language DefaultSignatures #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language EmptyCase #-} 5 | {-# language GADTs #-} 6 | {-# language PolyKinds #-} 7 | {-# language DataKinds #-} 8 | {-# language ScopedTypeVariables #-} 9 | {-# language TypeApplications #-} 10 | {-# language TypeOperators #-} 11 | module Data.Binary.Succinct.Get where 12 | 13 | foo :: Int 14 | foo = 1 15 | 16 | {- 17 | ( Get(..) 18 | , get8 19 | , Gettable(..) 20 | , liftGet 21 | ) where 22 | 23 | 24 | 25 | import Control.Monad (ap) 26 | import Data.Binary.Succinct.Blob 27 | import Data.ByteString as Strict 28 | import Data.Functor.Compose as F 29 | import Data.Functor.Product as F 30 | import Data.Functor.Sum as F 31 | import Data.Int 32 | import Data.Maybe 33 | import Data.Proxy 34 | import qualified Data.Serialize.Get as S 35 | import Data.Vector.Storable as Storable 36 | import Data.Word 37 | import Debug.Trace 38 | import GHC.Generics as G 39 | import qualified Generics.SOP as SOP 40 | import qualified Generics.SOP.GGP as SOP 41 | 42 | import HaskellWorks.Data.BalancedParens.RangeMinMax as BP 43 | import HaskellWorks.Data.BalancedParens.BalancedParens as BP 44 | import HaskellWorks.Data.RankSelect.Base.Rank0 45 | import HaskellWorks.Data.RankSelect.Base.Rank1 46 | import HaskellWorks.Data.RankSelect.Base.Select1 47 | 48 | newtype Get a = Get { runGet :: Blob -> Word64 -> a } 49 | deriving Functor 50 | 51 | instance Applicative Get where 52 | pure a = Get $ \_ _ -> a 53 | (<*>) = ap 54 | 55 | instance Monad Get where 56 | m >>= k = Get $ \e s -> runGet (k (runGet m e s)) e s 57 | 58 | shapely 59 | :: (RangeMinMax (Storable.Vector Word64) -> Word64 -> Maybe Word64) 60 | -> Blob 61 | -> Word64 62 | -> Word64 63 | shapely k b@(Blob meta shape _) i 64 | = select1 meta 65 | . fromMaybe (error $ "bad shape: " <> show (b,i)) 66 | . k shape 67 | . rank1 meta 68 | $ i 69 | 70 | move :: (RangeMinMax (Storable.Vector Word64) -> Word64 -> Maybe Word64) 71 | -> Get a -> Get a 72 | move f m = Get $ \d i -> runGet m d (shapely f d i) 73 | 74 | get8 :: Get Word8 75 | get8 = Get $ \(Blob meta _ content) i -> 76 | let result = Strict.index content $ fromIntegral $ rank0 meta i in 77 | traceShow ("get8",i,result) result 78 | 79 | liftGet :: S.Get a -> Get a 80 | liftGet g = Get $ \(Blob meta _ content) i -> 81 | case S.runGet g $ Strict.drop (fromIntegral $ rank0 meta i) content of 82 | Left e -> error e 83 | Right a -> a 84 | 85 | -------------------------------------------------------------------------------- 86 | -- * Gettable 87 | -------------------------------------------------------------------------------- 88 | 89 | class Gettable a where 90 | get :: Get a 91 | default get :: (G.Generic a, SOP.GTo a, SOP.All2 Gettable (SOP.GCode a)) 92 | => Get a 93 | get = gget 94 | 95 | gget :: forall a. (G.Generic a, SOP.GTo a, SOP.All2 Gettable (SOP.GCode a)) 96 | => Get a 97 | gget = case SOP.shape :: SOP.Shape (SOP.GCode a) of 98 | SOP.ShapeCons SOP.ShapeNil -> SOP.gto . SOP.SOP . SOP.Z 99 | <$> move firstChild (products SOP.shape) 100 | n -> do 101 | k <- get8 102 | traceShow ("read tag",k) $ SOP.gto . SOP.SOP <$> sums k n 103 | where 104 | sums :: SOP.All2 Gettable xss 105 | => Word8 106 | -> SOP.Shape xss 107 | -> Get (SOP.NS (SOP.NP SOP.I) xss) 108 | -- do we need to add a case for where the firstChild doesn't have any content 109 | -- when the Shape of the products is empty 110 | 111 | sums 0 (SOP.ShapeCons _) = SOP.Z <$> move firstChild (products SOP.shape) 112 | sums k (SOP.ShapeCons xs) = SOP.S <$> sums (k-1) xs 113 | sums _ SOP.ShapeNil = error "bad tag" 114 | 115 | products :: SOP.All Gettable xs => SOP.Shape xs -> Get (SOP.NP SOP.I xs) 116 | products SOP.ShapeNil = return SOP.Nil 117 | products (SOP.ShapeCons SOP.ShapeNil) = fmap (\a -> SOP.I a SOP.:* SOP.Nil) get 118 | products (SOP.ShapeCons xs) = do 119 | a <- get 120 | as <- move nextSibling (products xs) 121 | return $ SOP.I a SOP.:* as 122 | 123 | instance Gettable () 124 | instance Gettable Word8 where 125 | get = get8 126 | 127 | instance Gettable Word16 where get = liftGet S.getWord16le 128 | instance Gettable Word32 where get = liftGet S.getWord32le 129 | instance Gettable Word64 where get = liftGet S.getWord64le 130 | instance Gettable Int8 where get = liftGet S.getInt8 131 | instance Gettable Int16 where get = liftGet S.getInt16le 132 | instance Gettable Int32 where get = liftGet S.getInt32le 133 | instance Gettable Int64 where get = liftGet S.getInt64le 134 | 135 | instance Gettable (Proxy a) 136 | instance Gettable a => Gettable (Maybe a) 137 | instance Gettable a => Gettable [a] 138 | instance (Gettable a, Gettable b) => Gettable (a, b) 139 | instance (Gettable a, Gettable b) => Gettable (Either a b) 140 | instance Gettable (f (g a)) => Gettable (F.Compose f g a) 141 | instance (Gettable (f a), Gettable (g a)) => Gettable (F.Product f g a) 142 | instance (Gettable (f a), Gettable (g a)) => Gettable (F.Sum f g a) 143 | 144 | -} 145 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# language StandaloneDeriving #-} 2 | {-# options_ghc -Wno-orphans #-} 3 | module Data.Binary.Succinct.Orphans where 4 | 5 | import HaskellWorks.Data.BalancedParens.RangeMinMax 6 | 7 | deriving instance Show a => Show (RangeMinMax a) 8 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct/Put.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor #-} 2 | {-# language DefaultSignatures #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language BangPatterns #-} 5 | {-# language EmptyCase #-} 6 | {-# language GADTs #-} 7 | {-# language TypeOperators #-} 8 | {-# language RankNTypes #-} 9 | {-# language TypeApplications #-} 10 | {-# language ScopedTypeVariables #-} 11 | {-# options_ghc -funbox-strict-fields #-} 12 | module Data.Binary.Succinct.Put {- .Internal -} 13 | ( Put(..) 14 | -- guts 15 | , meta, metas, paren, parens, content 16 | , State(..) 17 | , W(..) 18 | , Result(..) 19 | , put8 20 | , Puttable(..) 21 | , putN 22 | , putN_ 23 | , gput 24 | ) where 25 | 26 | import Data.Bits 27 | import Data.ByteString.Lazy as Lazy 28 | import Data.ByteString.Builder as Builder 29 | import Data.Int 30 | import Data.Proxy 31 | import Data.Semigroup 32 | import Data.Void 33 | import Data.Word 34 | import qualified GHC.Generics as G 35 | import Data.Functor.Compose as F 36 | import Data.Functor.Product as F 37 | import Data.Functor.Sum as F 38 | import qualified Generics.SOP as SOP 39 | import qualified Generics.SOP.GGP as SOP 40 | 41 | import Data.Binary.Succinct.Size 42 | 43 | data State = State !Int !Word8 !Int !Word8 44 | data W = W !Builder !Builder !Builder !Word64 45 | 46 | instance Semigroup W where 47 | W a b c m <> W d e f n = W (a <> d) (b <> e) (c <> f) (m + n) 48 | 49 | instance Monoid W where 50 | mempty = W mempty mempty mempty 0 51 | mappend = (<>) 52 | 53 | data Result = Result {-# UNPACK #-} !State {-# UNPACK #-} !W 54 | 55 | newtype Put = Put { runPut :: State -> Result } 56 | 57 | instance Semigroup Put where 58 | f <> g = Put $ \s -> case runPut f s of 59 | Result s' m -> case runPut g s' of 60 | Result s'' n -> Result s'' (m <> n) 61 | 62 | instance Monoid Put where 63 | mempty = Put $ \s -> Result s mempty 64 | 65 | push :: Bool -> Int -> Word8 -> (Builder, Int, Word8) 66 | push v i b 67 | | i == 7 = (Builder.word8 b', 0, 0) 68 | | otherwise = (mempty, i + 1, b') 69 | where b' = if v then setBit b i else b 70 | {-# INLINE push #-} 71 | 72 | meta :: Bool -> Put 73 | meta v = Put $ \(State i b j c) -> case push v i b of 74 | (m,i',b') -> Result (State i' b' j c) (W m mempty mempty 1) 75 | 76 | paren :: Bool -> Put 77 | paren v = Put $ \(State i b j c) -> case push v j c of 78 | (s,j',c') -> case push True i b of 79 | (m, i', b') -> Result (State i' b' j' c') (W m s mempty 1) 80 | 81 | parens :: Put -> Put 82 | parens p = paren True <> p <> paren False 83 | 84 | -- push a run of 0s into the meta buffer 85 | metas :: Int -> Put 86 | metas k 87 | | k <= 0 = mempty 88 | | otherwise = Put $ \(State i b j c) -> case divMod (i + k) 8 of 89 | (0,r) -> Result (State r b j c) $ W mempty mempty mempty (fromIntegral k) 90 | (q,r) -> Result (State r 0 j c) $ 91 | W (Builder.word8 b <> stimesMonoid (q-1) (Builder.word8 0)) 92 | mempty 93 | mempty 94 | (fromIntegral k) 95 | 96 | content :: Builder -> Put 97 | content m = Put $ \s -> Result s (W mempty mempty m 0) 98 | 99 | put8 :: Word8 -> Put 100 | put8 x = meta False <> content (word8 x) 101 | 102 | putN :: Int -> Builder -> Put 103 | putN i w = metas i <> content w 104 | 105 | putN_ :: Builder -> Put 106 | putN_ w = putN (fromIntegral $ Lazy.length bs) (Builder.lazyByteString bs) where 107 | bs = Builder.toLazyByteString w 108 | 109 | -------------------------------------------------------------------------------- 110 | -- * Puttable 111 | -------------------------------------------------------------------------------- 112 | 113 | class Sized a => Puttable a where 114 | put :: a -> Put 115 | default put :: (G.Generic a, SOP.GFrom a, SOP.All2 Puttable (SOP.GCode a)) => a -> Put 116 | put = gput 117 | 118 | gput :: (G.Generic a, SOP.GFrom a, SOP.All2 Puttable (SOP.GCode a)) => a -> Put 119 | gput xs0 = case SOP.lengthSList sop of 120 | 1 -> case sop of 121 | SOP.Z xs -> products xs 122 | _ -> error "the impossible happened" 123 | _ -> sums 0 sop 124 | where 125 | SOP.SOP sop = SOP.gfrom xs0 126 | 127 | sums :: SOP.All2 Puttable xss => Word8 -> SOP.NS (SOP.NP SOP.I) xss -> Put 128 | sums !acc (SOP.Z xs) = put8 acc <> products xs 129 | sums acc (SOP.S xss) = sums (acc + 1) xss 130 | 131 | products :: SOP.All Puttable xs => SOP.NP SOP.I xs -> Put 132 | products SOP.Nil = mempty 133 | products (SOP.I x SOP.:* xs) = products1 x xs 134 | 135 | -- the last field is written without parens 136 | products1 :: (Puttable x, SOP.All Puttable xs) => x -> SOP.NP SOP.I xs -> Put 137 | products1 x SOP.Nil = put x 138 | products1 x (SOP.I y SOP.:* ys) = putWithParens x <> products1 y ys 139 | 140 | putWithParens :: forall a. Puttable a => a -> Put 141 | putWithParens = case size @a of 142 | Variable -> parens . put 143 | _ -> put 144 | 145 | instance Puttable Void where 146 | put = absurd 147 | 148 | instance Puttable Word64 where 149 | put = putN 8 . Builder.word64LE 150 | 151 | instance Puttable Word32 where 152 | put = putN 4 . Builder.word32LE 153 | 154 | instance Puttable Word16 where 155 | put = putN 2 . Builder.word16LE 156 | 157 | instance Puttable Word8 where 158 | put = putN 1 . Builder.word8 159 | 160 | instance Puttable Int64 where 161 | put = putN 8 . Builder.int64LE 162 | 163 | instance Puttable Int32 where 164 | put = putN 4 . Builder.int32LE 165 | 166 | instance Puttable Int16 where 167 | put = putN 2 . Builder.int16LE 168 | 169 | instance Puttable Int8 where 170 | put = putN 1 . Builder.int8 171 | 172 | instance Puttable Char where 173 | put = put . (fromIntegral . fromEnum :: Char -> Word32) 174 | 175 | instance Puttable () 176 | instance Puttable (Proxy a) 177 | instance Puttable a => Puttable (Maybe a) 178 | instance Puttable a => Puttable [a] 179 | instance (Puttable a, Puttable b) => Puttable (a, b) 180 | instance (Puttable a, Puttable b) => Puttable (Either a b) 181 | instance Puttable (f (g a)) => Puttable (Compose f g a) 182 | instance (Puttable (f a), Puttable (g a)) => Puttable (F.Product f g a) 183 | instance (Puttable (f a), Puttable (g a)) => Puttable (F.Sum f g a) 184 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct/Result.hs: -------------------------------------------------------------------------------- 1 | 2 | import qualified Data.Vector.Storable as Storable 3 | import HaskellWorks.Data.BalancedParens.RangeMinMax as BP 4 | import HaskellWorks.Data.RankSelect.CsPoppy as CsPoppy 5 | {- 6 | data Serialized = Serialized 7 | { shapeOrContent :: CsPoppy, 8 | , shape :: RangeMinMax (Storable.Vector Word64) 9 | , content :: Storable.Vector Word64 10 | } deriving Show 11 | -} 12 | 13 | -------------------------------------------------------------------------------- /src/Data/Binary/Succinct/Size.hs: -------------------------------------------------------------------------------- 1 | {-# Language AllowAmbiguousTypes #-} 2 | {-# Language TypeApplications #-} 3 | {-# Language ScopedTypeVariables #-} 4 | {-# Language DefaultSignatures #-} 5 | {-# Language FlexibleContexts #-} 6 | {-# Language MonoLocalBinds #-} 7 | {-# Language GADTs #-} 8 | 9 | module Data.Binary.Succinct.Size 10 | ( Sized(..) 11 | , gsize 12 | , Size(..) 13 | , (/\) 14 | , (\/) 15 | ) where 16 | 17 | import Data.Functor.Compose as F 18 | import Data.Functor.Product as F 19 | import Data.Functor.Sum as F 20 | import Data.Int 21 | import Data.Void 22 | import Data.Word 23 | import Generics.SOP 24 | import Generics.SOP.GGP 25 | import GHC.Generics as GHC 26 | 27 | data Size = Any | Variable | Exactly !Int 28 | deriving (Eq,Ord,Show,Read) 29 | 30 | class Sized a where 31 | size :: Size 32 | default size :: (GHC.Generic a, GFrom a, All2 Sized (GCode a)) => Size 33 | size = gsize @(GCode a) 34 | 35 | -- @((\/), Any)@ is a semilattice 36 | (\/) :: Size -> Size -> Size 37 | Any \/ x = x 38 | x \/ Any = x 39 | Exactly x \/ Exactly y | x == y = Exactly x 40 | _ \/ _ = Variable 41 | 42 | -- @((/\), Exactly 0)@ is a commutative monoid 43 | (/\) :: Size -> Size -> Size 44 | Any /\ _ = Any 45 | _ /\ Any = Any 46 | Exactly x /\ Exactly y = Exactly (x + y) 47 | _ /\ _ = Variable 48 | 49 | gsize :: forall xss. All2 Sized xss => Size 50 | gsize = sums $ hcollapse np where 51 | ksize :: forall x. Sized x => K Size x 52 | ksize = K (size @x) 53 | 54 | np :: NP (K Size) xss 55 | np = hcmap (Proxy @(All Sized)) (\xs -> K (products $ hcollapse xs)) npnp 56 | 57 | npnp :: NP (NP (K Size)) xss 58 | npnp = unPOP $ hcpure (Proxy @Sized) ksize 59 | 60 | sums :: [Size] -> Size 61 | sums [x] = x 62 | sums xs = Exactly 1 /\ foldr (\/) Any xs 63 | 64 | products :: [Size] -> Size 65 | products = foldr (/\) (Exactly 0) 66 | 67 | instance Sized [a] where size = Variable 68 | instance Sized Word8 where size = Exactly 1 69 | instance Sized Word16 where size = Exactly 2 70 | instance Sized Word32 where size = Exactly 4 71 | instance Sized Word64 where size = Exactly 8 72 | instance Sized Int8 where size = Exactly 1 73 | instance Sized Int16 where size = Exactly 2 74 | instance Sized Int32 where size = Exactly 4 75 | instance Sized Int64 where size = Exactly 8 76 | instance Sized Char where size = Exactly 4 77 | instance Sized a => Sized (Maybe a) 78 | instance (Sized a, Sized b) => Sized (a, b) 79 | instance (Sized a, Sized b) => Sized (Either a b) 80 | instance Sized (Proxy a) 81 | instance Sized () 82 | instance Sized Void 83 | 84 | instance Sized (f (g a)) => Sized (F.Compose f g a) 85 | instance (Sized (f a), Sized (g a)) => Sized (F.Product f g a) 86 | instance (Sized (f a), Sized (g a)) => Sized (F.Sum f g a) 87 | -------------------------------------------------------------------------------- /succinct-binary.cabal: -------------------------------------------------------------------------------- 1 | name: succinct-binary 2 | category: Data 3 | version: 0 4 | license: BSD2 5 | cabal-version: >= 1.8 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/succinct-binary/ 11 | bug-reports: http://github.com/ekmett/succinct-binary/issues 12 | copyright: Copyright (C) 2018 Edward A. Kmett 13 | synopsis: Lazy binary (de)serialization 14 | description: Lazy binary (de)serialization. 15 | build-type: Simple 16 | extra-source-files: 17 | .gitignore 18 | README.md 19 | CHANGELOG.md 20 | 21 | source-repository head 22 | type: git 23 | location: git://github.com/ekmett/succinct-binary.git 24 | 25 | library 26 | build-depends: 27 | base >= 4 && < 5, 28 | bytestring, 29 | contravariant, 30 | generics-sop, 31 | hw-rankselect >= 0.12.0.4, 32 | hw-rankselect-base, 33 | hw-balancedparens, 34 | spool, 35 | vector 36 | 37 | hs-source-dirs: src 38 | exposed-modules: 39 | Data.Binary.Succinct 40 | Data.Binary.Succinct.Blob 41 | Data.Binary.Succinct.Get 42 | Data.Binary.Succinct.Orphans 43 | Data.Binary.Succinct.Put 44 | Data.Binary.Succinct.Size 45 | 46 | ghc-options: -Wall 47 | --------------------------------------------------------------------------------