{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, Rank2Types #-}moduleGeneral.Binary(BinaryOp (..),binaryOpMap ,binarySplit ,binarySplit2 ,binarySplit3 ,unsafeBinarySplit ,Builder (..),runBuilder ,sizeBuilder ,BinaryEx (..),Storable,putExStorable ,getExStorable ,putExStorableList ,getExStorableList ,putExList ,getExList ,putExN ,getExN )whereimportDevelopment.Shake.Classes importControl.MonadimportData.BinaryimportData.List.ExtraimportData.Tuple.ExtraimportForeign.StorableimportForeign.PtrimportSystem.IO.UnsafeasUimportqualifiedData.ByteStringasBSimportqualifiedData.ByteString.InternalasBSimportqualifiedData.ByteString.UnsafeasBSimportqualifiedData.ByteString.LazyasLBSimportqualifiedData.ByteString.UTF8asUTF8importData.Semigroup(Semigroup(..))----------------------------------------------------------------------- STORE TYPE-- | An explicit and more efficient version of BinarydataBinaryOp v =BinaryOp {putOp ::v ->Builder ,getOp ::BS.ByteString->v }binaryOpMap::(Eqa ,Hashablea ,BinaryEx a )=>(a ->BinaryOp b )->BinaryOp (a ,b )binaryOpMap mp =BinaryOp {putOp=\(a ,b )->putExN (putEx a )<>putOp(mp a )b ,getOp=\bs ->let(bs1 ,bs2 )=getExN bs ;a =getEx bs1 in(a ,getOp(mp a )bs2 )}binarySplit::foralla .Storablea =>BS.ByteString->(a ,BS.ByteString)binarySplit bs |BS.lengthbs <sizeOf(undefined::a )=error"Reading from ByteString, insufficient left"|otherwise=unsafeBinarySplit bs binarySplit2::foralla b .(Storablea ,Storableb )=>BS.ByteString->(a ,b ,BS.ByteString)binarySplit2 bs |BS.lengthbs <sizeOf(undefined::a )+sizeOf(undefined::b )=error"Reading from ByteString, insufficient left"|(a ,bs )<-unsafeBinarySplit bs ,(b ,bs )<-unsafeBinarySplit bs =(a ,b ,bs )binarySplit3::foralla b c .(Storablea ,Storableb ,Storablec )=>BS.ByteString->(a ,b ,c ,BS.ByteString)binarySplit3 bs |BS.lengthbs <sizeOf(undefined::a )+sizeOf(undefined::b )+sizeOf(undefined::c )=error"Reading from ByteString, insufficient left"|(a ,bs )<-unsafeBinarySplit bs ,(b ,bs )<-unsafeBinarySplit bs ,(c ,bs )<-unsafeBinarySplit bs =(a ,b ,c ,bs )unsafeBinarySplit::Storablea =>BS.ByteString->(a ,BS.ByteString)unsafeBinarySplit bs =(v ,BS.unsafeDrop(sizeOfv )bs )wherev =unsafePerformIO$BS.unsafeUseAsCStringbs $\ptr ->peek(castPtrptr )-- forM for zipWithfor2M_ asbs f =zipWithM_f asbs ----------------------------------------------------------------------- BINARY SERIALISATION-- We can't use the Data.ByteString builder as that doesn't track the size of the chunk.dataBuilder =Builder {-# UNPACK#-}!Int(foralla .Ptra ->Int->IO())sizeBuilder::Builder ->IntsizeBuilder (Builder i _)=i runBuilder::Builder ->BS.ByteStringrunBuilder (Builder i f )=unsafePerformIO$BS.createi $\ptr ->f ptr 0instanceSemigroupBuilder where(Builder x1 x2 )<> (Builder y1 y2 )=Builder (x1 +y1 )$\p i ->dox2 p i ;y2 p $i +x1 instanceMonoidBuilder wheremempty =Builder 0$\__->return()mappend =(<>)-- | Methods for Binary serialisation that go directly between strict ByteString values.-- When the Database is read each key/value will be loaded as a separate ByteString,-- and for certain types (e.g. file rules) this may remain the preferred format for storing keys.-- Optimised for performance.classBinaryEx a whereputEx ::a ->Builder getEx ::BS.ByteString->a instanceBinaryEx BS.ByteStringwhereputEx x =Builder n $\ptr i ->BS.useAsCStringx $\bs ->BS.memcpy(ptr `plusPtr`i )(castPtrbs )(fromIntegraln )wheren =BS.lengthx getEx =idinstanceBinaryEx LBS.ByteStringwhereputEx x =Builder (fromIntegral$LBS.lengthx )$\ptr i ->doletgo _[]=return()goi (x :xs )=doletn =BS.lengthx BS.useAsCStringx $\bs ->BS.memcpy(ptr `plusPtr`i )(castPtrbs )(fromIntegraln )go (i +n )xs go i $LBS.toChunksx getEx =LBS.fromChunks.returninstanceBinaryEx [BS.ByteString]where-- Format:-- n :: Word32 - number of strings-- ns :: [Word32]{n} - length of each string-- contents of each string concatenated (sum ns bytes)putEx xs =Builder (4+(n *4)+sumns )$\p i ->dopokeByteOffp i (fromIntegraln ::Word32)for2M_ [4+i ,8+i ..]ns $\i x ->pokeByteOffp i (fromIntegralx ::Word32)p <-return$p `plusPtr`(i +4+(n *4))for2M_ (scanl(+)0ns )xs $\i x ->BS.useAsCStringLenx $\(bs ,n )->BS.memcpy(p `plusPtr`i )(castPtrbs )(fromIntegraln )wherens =mapBS.lengthxs n =lengthns getEx bs =unsafePerformIO$BS.useAsCStringbs $\p ->don <-fromIntegral<$>(peekByteOffp 0::IOWord32)ns ::[Word32]<-forM[1..fromIntegraln ]$\i ->peekByteOffp (i *4)return$snd$mapAccumL(\bs i ->swap$BS.splitAt(fromIntegrali )bs )(BS.drop(4+(n *4))bs )ns instanceBinaryEx ()whereputEx ()=memptygetEx _=()instanceBinaryEx StringwhereputEx =putEx .UTF8.fromStringgetEx =UTF8.toStringinstanceBinaryEx (MaybeString)whereputEx Nothing=memptyputEx(Justxs )=putEx $UTF8.fromString$'0円':xs getEx =fmapsnd.uncons.UTF8.toStringinstanceBinaryEx [String]whereputEx =putEx .mapUTF8.fromStringgetEx =mapUTF8.toString.getEx instanceBinaryEx (String,[String])whereputEx (a ,bs )=putEx $a :bs getEx x =leta :bs =getEx x in(a ,bs )instanceBinaryEx BoolwhereputEx False=Builder 1$\ptr i ->pokeByteOffptr i (0::Word8)putExTrue=memptygetEx =BS.nullinstanceBinaryEx Word8whereputEx =putExStorable getEx =getExStorable instanceBinaryEx Word16whereputEx =putExStorable getEx =getExStorable instanceBinaryEx Word32whereputEx =putExStorable getEx =getExStorable instanceBinaryEx IntwhereputEx =putExStorable getEx =getExStorable instanceBinaryEx FloatwhereputEx =putExStorable getEx =getExStorable putExStorable::foralla .Storablea =>a ->Builder putExStorable x =Builder (sizeOfx )$\p i ->pokeByteOffp i x getExStorable::foralla .Storablea =>BS.ByteString->a getExStorable =\bs ->unsafePerformIO$BS.useAsCStringLenbs $\(p ,size )->ifsize /=n thenerror"size mismatch"elsepeek(castPtrp )wheren =sizeOf(undefined::a )putExStorableList::foralla .Storablea =>[a ]->Builder putExStorableList xs =Builder (n *lengthxs )$\ptr i ->for2M_ [i ,i +n ..]xs $\i x ->pokeByteOffptr i x wheren =sizeOf(undefined::a )getExStorableList::foralla .Storablea =>BS.ByteString->[a ]getExStorableList =\bs ->unsafePerformIO$BS.useAsCStringLenbs $\(p ,size )->let(d ,m )=size `divMod`n inifm /=0thenerror"size mismatch"elseforM[0..d -1]$\i ->peekElemOff(castPtrp )i wheren =sizeOf(undefined::a )-- repeating:-- Word32, length of BS-- BSputExList::[Builder ]->Builder putExList xs =Builder (sum$map(\b ->sizeBuilder b +4)xs )$\p i ->doletgo _[]=return()goi (Builder n b :xs )=dopokeByteOffp i (fromIntegraln ::Word32)b p (i +4)go (i +4+n )xs go i xs getExList::BS.ByteString->[BS.ByteString]getExList bs |len ==0=[]|len >=4,(n ::Word32,bs )<-unsafeBinarySplit bs ,n <-fromIntegraln ,(len -4)>=n =BS.unsafeTaken bs :getExList (BS.unsafeDropn bs )|otherwise=error"getList, corrupted binary"wherelen =BS.lengthbs putExN::Builder ->Builder putExN (Builder n old )=Builder (n +4)$\p i ->dopokeByteOffp i (fromIntegraln ::Word32)old p $i +4getExN::BS.ByteString->(BS.ByteString,BS.ByteString)getExN bs |len >=4,(n ::Word32,bs )<-unsafeBinarySplit bs ,n <-fromIntegraln ,(len -4)>=n =(BS.unsafeTaken bs ,BS.unsafeDropn bs )|otherwise=error"getList, corrupted binary"wherelen =BS.lengthbs