packages feed

binary-generic-combinators (empty) → 0.4.0.0

raw patch · 8 files changed

+345/−0 lines, 8 filesdep +QuickCheckdep +basedep +binarysetup-changed

Dependencies added: QuickCheck, base, binary, binary-generic-combinators, generic-arbitrary, hspec

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for binary-generic-combinators++## v0.4.0.0++- Initial release as a separate library.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Georg Rudoy (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Georg Rudoy nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# binary-generic-combinators
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ binary-generic-combinators.cabal view
@@ -0,0 +1,60 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1a85e157782b016bc20ca8aa8487ecead92a285a1fc236a94ad0e7d6186b37be++name:           binary-generic-combinators+version:        0.4.0.0+synopsis:       Combinators and utilities to make Generic-based deriving of Binary easier and more expressive+description:    Please see the README on GitHub at <https://github.com/0xd34df00d/binary-generic-combinators#readme>+category:       Data, Parsing+homepage:       https://github.com/0xd34df00d/binary-generic-combinators#readme+bug-reports:    https://github.com/0xd34df00d/binary-generic-combinators/issues+author:         Georg Rudoy+maintainer:     0xd34df00d@gmail.com+copyright:      2021 Georg Rudoy+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/0xd34df00d/binary-generic-combinators++library+  exposed-modules:+      Data.Binary.Combinators+      Data.Binary.DerivingVia+  other-modules:+      Paths_binary_generic_combinators+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , binary+  default-language: Haskell2010++test-suite binary-generic-combinators-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_binary_generic_combinators+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , binary+    , binary-generic-combinators+    , generic-arbitrary+    , hspec+  default-language: Haskell2010
+ src/Data/Binary/Combinators.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, GADTs #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Binary.Combinators+( Many(..)+, Some(..)+, CountedBy(..)+, SkipCount(..)+, SkipByte(..)+, MatchBytes+, matchBytes+) where++import Control.Applicative+import Control.Monad+import Data.Binary+import Data.Binary.Get(lookAhead)+import Data.Functor+import Data.Kind+import Data.Proxy+import GHC.TypeLits+import Numeric+import Test.QuickCheck+++newtype Many a = Many { getMany :: [a] } deriving (Eq, Ord)++instance Show a => Show (Many a) where+  show = show . getMany++instance Binary a => Binary (Many a) where+  get = Many <$> many get+  put = mapM_ put . getMany++instance Arbitrary a => Arbitrary (Many a) where+  arbitrary = Many <$> arbitrary+  shrink (Many xs) = Many <$> shrink xs+++newtype Some a = Some { getSome :: [a] } deriving (Eq, Ord)++instance Show a => Show (Some a) where+  show = show . getSome++instance Binary a => Binary (Some a) where+  get = Some <$> some get+  put = mapM_ put . getSome++instance Arbitrary a => Arbitrary (Some a) where+  arbitrary = Some . getNonEmpty <$> arbitrary+  shrink (Some xs) = Some <$> filter (not . null) (shrink xs)+++newtype CountedBy ty a = CountedBy { getCounted :: [a] } deriving (Eq, Ord)++instance Show a => Show (CountedBy ty a) where+  show = show . getCounted++instance (Integral ty, Binary ty, Binary a) => Binary (CountedBy ty a) where+  get = do cnt :: ty <- get+           CountedBy <$> replicateM (fromIntegral cnt) get+  put (CountedBy xs) = put (fromIntegral $ length xs :: ty) >> mapM_ put xs++instance Arbitrary a => Arbitrary (CountedBy ty a) where+  arbitrary = CountedBy <$> arbitrary+  shrink (CountedBy xs) = CountedBy <$> shrink xs+++data SkipCount ty (n :: Nat) = SkipCount deriving (Eq, Ord, Show)++instance (Num ty, Binary ty, KnownNat n) => Binary (SkipCount ty n) where+  get   = replicateM_ (fromIntegral $ natVal (Proxy :: Proxy n)) (get :: Get ty) $> SkipCount+  put _ = replicateM_ (fromIntegral $ natVal (Proxy :: Proxy n)) $ put (0 :: ty)++instance Arbitrary (SkipCount ty n) where+  arbitrary = pure SkipCount+++data SkipByte (n :: Nat) = SkipByte deriving (Eq, Ord, Show)++instance (KnownNat n) => Binary (SkipByte n) where+  get   = do nextByte <- lookAhead get+             if nextByte /= expected+             then pure SkipByte+             else (get :: Get Word8) >> get+    where+      expected :: Word8+      expected = fromIntegral $ natVal (Proxy :: Proxy n)+  put _ = pure ()++instance Arbitrary (SkipByte n) where+  arbitrary = pure SkipByte+++data MatchBytes :: Symbol -> [Nat] -> Type where+  ConsumeNil  :: MatchBytes ctx '[]+  ConsumeCons :: KnownNat n => Proxy n -> MatchBytes ctx ns -> MatchBytes ctx (n ': ns)++deriving instance Eq (MatchBytes s ns)+deriving instance Ord (MatchBytes s ns)++instance Binary (MatchBytes ctx '[]) where+  get = pure ConsumeNil+  put _ = pure ()++instance (KnownSymbol ctx, KnownNat n, Binary (MatchBytes ctx ns)) => Binary (MatchBytes ctx (n : ns)) where+  get = do byte <- get+           when (byte /= expected) $ fail $ "Unexpected byte 0x" <> showHex byte ", expected 0x"+                                                                 <> showHex expected " when parsing "+                                                                 <> symbolVal (Proxy :: Proxy ctx)+           ConsumeCons Proxy <$> get+    where+      expected :: Word8+      expected = fromInteger $ natVal (Proxy :: Proxy n)++  put (ConsumeCons proxy ns) = put theByte >> put ns+    where+      theByte :: Word8+      theByte = fromInteger $ natVal proxy++instance Show (MatchBytes ctx ns) where+  show bs = "Marker [ " <> go bs <> "]"+    where+      go :: MatchBytes ctx' ns' -> String+      go ConsumeNil = ""+      go (ConsumeCons proxy ns) = "0x" <> showHex (natVal proxy) " " <> go ns++class MatchBytesSing ctx ns where+  matchBytesSing :: MatchBytes ctx ns++instance MatchBytesSing ctx '[] where+  matchBytesSing = ConsumeNil++instance (KnownNat n, MatchBytesSing ctx ns) => MatchBytesSing ctx (n ': ns) where+  matchBytesSing = ConsumeCons Proxy matchBytesSing++matchBytes :: MatchBytesSing ctx ns => MatchBytes ctx ns+matchBytes = matchBytesSing++instance MatchBytesSing ctx ns => Arbitrary (MatchBytes ctx ns) where+  arbitrary = pure matchBytes
+ src/Data/Binary/DerivingVia.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TypeOperators, FlexibleContexts, UndecidableInstances #-}++module Data.Binary.DerivingVia+( Alternatively(..)+) where++import Control.Applicative+import Data.Binary+import GHC.Generics++newtype Alternatively a = Alternatively { getAlt :: a }++class GAltBinary grecord where+  gAltGet :: Get (grecord p)+  gAltPut :: grecord p -> Put++instance Binary grecord => GAltBinary (K1 i grecord) where+  gAltGet = K1 <$> get+  gAltPut = put . unK1++instance GAltBinary grecord => GAltBinary (M1 i t grecord) where+  gAltGet = M1 <$> gAltGet+  gAltPut = gAltPut . unM1++instance (GAltBinary l, GAltBinary r) => GAltBinary (l :*: r) where+  gAltGet = (:*:) <$> gAltGet <*> gAltGet+  gAltPut (l :*: r) = gAltPut l <> gAltPut r++instance (GAltBinary l, GAltBinary r) => GAltBinary (l :+: r) where+  gAltGet = L1 <$> gAltGet+        <|> R1 <$> gAltGet+  gAltPut (L1 l) = gAltPut l+  gAltPut (R1 r) = gAltPut r++instance (Generic a, GAltBinary (Rep a)) => Binary (Alternatively a) where+  get = Alternatively . to <$> gAltGet+  put = gAltPut . from . getAlt
+ test/Spec.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DerivingVia, DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}++import Data.Binary+import GHC.Generics+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++import Data.Binary.Combinators+import Data.Binary.DerivingVia++decenc :: Binary a => a -> a+decenc = decode . encode++data SimpleSumType1+  = SST11 (MatchBytes "test context" '[ 0xd3, 0x4d, 0xf0, 0x0d ])+  | SST12 (MatchBytes "test context" '[ 0xde, 0xad, 0xbe, 0xef ])+  deriving (Show, Eq, Generic)+  deriving Binary via Alternatively SimpleSumType1++data SimpleSumType2+  = SST21 (MatchBytes "test context" '[ 0xde, 0xad, 0xbe, 0xef ])+  | SST22 (MatchBytes "test context" '[ 0xd3, 0x4d, 0xf0, 0x0d ])+  deriving (Show, Eq, Generic)+  deriving Binary via Alternatively SimpleSumType2++data ComplexType+  = CT1+    { header1 :: MatchBytes "test context" '[ 0xaa, 0xbb, 0xff ]+    , skip1 :: SkipByte 0xff+    , skipCount1 :: SkipCount Word8 123+    , counted1 :: CountedBy Word16 Word8+    , rest1 :: Some Word8+    }+  | CT2+    { header2 :: MatchBytes "test context" '[ 0xdd, 0xea, 0xae ]+    , skipCount2 :: SkipCount Word16 9+    , counted2 :: CountedBy Word32 Word16+    , rest2 :: Some Word16+    }+  | CT3+    { header3 :: MatchBytes "test context" '[ 0xda, 0xdd, 0xee ]+    , skipCount3 :: SkipCount Int 17+    , rest3 :: Some Word16+    }+  deriving (Show, Eq, Generic)+  deriving Binary via Alternatively ComplexType++instance Arbitrary ComplexType where+  arbitrary = genericArbitrary+  shrink = genericShrink++main :: IO ()+main = hspec $ do+  describe "Alternatively" $ do+    it "works for simple types" $ do+      let val = SST11 matchBytes in decenc val `shouldBe` val+      let val = SST12 matchBytes in decenc val `shouldBe` val+    it "is order-invariant" $ do+      decode (encode $ SST11 matchBytes) `shouldBe` SST22 matchBytes+  describe "decode . encode = id" $ do+    it "for Many" $ property $ \(xs :: Many Int) -> decenc xs `shouldBe` xs+    it "for Some" $ property $ \(xs :: Some Int) -> decenc xs `shouldBe` xs+    it "for CountedBy" $ property $ \(xs :: CountedBy Word16 Int) -> decenc xs `shouldBe` xs+    it "for complex types" $ property $ \(val :: ComplexType) -> decenc val `shouldBe` val