diff --git a/binrep.cabal b/binrep.cabal index b826315..88ea957 100644 --- a/binrep.cabal +++ b/binrep.cabal @@ -90,7 +90,7 @@ library , bytezap , deepseq >=1.4.6.1 && <1.6 , flatparse >=0.5.0.2 && <0.6 - , generic-data-functions >=0.2.0 && <0.3 + , generic-data-functions >=0.3.0 && <0.4 , megaparsec >=9.2.0 && <9.7 , parser-combinators >=1.3.0 && <1.4 , primitive >=0.8.0.0 && <0.10.0.0 @@ -138,7 +138,7 @@ test-suite spec , bytezap , deepseq >=1.4.6.1 && <1.6 , flatparse >=0.5.0.2 && <0.6 - , generic-data-functions >=0.2.0 && <0.3 + , generic-data-functions >=0.3.0 && <0.4 , generic-random >=1.5.0.1 && <1.6 , hspec >=2.7 && <2.12 , megaparsec >=9.2.0 && <9.7 @@ -184,7 +184,7 @@ benchmark bench , deepseq >=1.4.6.1 && <1.6 , flatparse >=0.5.0.2 && <0.6 , gauge - , generic-data-functions >=0.2.0 && <0.3 + , generic-data-functions >=0.3.0 && <0.4 , megaparsec >=9.2.0 && <9.7 , parser-combinators >=1.3.0 && <1.4 , primitive >=0.8.0.0 && <0.10.0.0 diff --git a/flake.lock b/flake.lock index a11a470..0fc081c 100644 --- a/flake.lock +++ b/flake.lock @@ -50,6 +50,22 @@ "type": "github" } }, + "generic-data-functions": { + "flake": false, + "locked": { + "lastModified": 1712109010, + "narHash": "sha256-mZwQjaW8Z6DUbTk4ClW+kRmJvecRaL2FRKjUVANHRWg=", + "owner": "raehik", + "repo": "generic-data-functions", + "rev": "9b38614df05c1b1d138f314256f1076bce7a23e8", + "type": "github" + }, + "original": { + "owner": "raehik", + "repo": "generic-data-functions", + "type": "github" + } + }, "haskell-flake": { "locked": { "lastModified": 1711729580, @@ -104,6 +120,7 @@ "bytezap": "bytezap", "flake-parts": "flake-parts", "flatparse": "flatparse", + "generic-data-functions": "generic-data-functions", "haskell-flake": "haskell-flake", "nixpkgs": "nixpkgs", "strongweak": "strongweak" diff --git a/flake.nix b/flake.nix index 138eb9c..9c080ea 100644 --- a/flake.nix +++ b/flake.nix @@ -3,12 +3,14 @@ nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; flake-parts.url = "github:hercules-ci/flake-parts"; haskell-flake.url = "github:srid/haskell-flake"; - bytezap.url = "github:raehik/bytezap"; + bytezap.url = "github:raehik/bytezap"; bytezap.flake = false; - flatparse.url = "github:AndrasKovacs/flatparse"; + flatparse.url = "github:AndrasKovacs/flatparse"; flatparse.flake = false; - strongweak.url = "github:raehik/strongweak"; + strongweak.url = "github:raehik/strongweak"; strongweak.flake = false; + generic-data-functions.url = "github:raehik/generic-data-functions"; + generic-data-functions.flake = false; }; outputs = inputs: let @@ -34,6 +36,7 @@ packages.bytezap.source = inputs.bytezap; packages.flatparse.source = inputs.flatparse; packages.strongweak.source = inputs.strongweak; + packages.generic-data-functions.source = inputs.generic-data-functions; devShell = nondevDevShell "ghc98"; }; haskellProjects.ghc96 = { @@ -41,6 +44,7 @@ packages.bytezap.source = inputs.bytezap; packages.flatparse.source = inputs.flatparse; packages.strongweak.source = inputs.strongweak; + packages.generic-data-functions.source = inputs.generic-data-functions; devShell.mkShellArgs.name = "ghc96-binrep"; devShell.tools = _: { haskell-language-server = null; # 2024-03-06: broken @@ -51,6 +55,7 @@ packages.bytezap.source = inputs.bytezap; packages.flatparse.source = inputs.flatparse; packages.strongweak.source = inputs.strongweak; + packages.generic-data-functions.source = inputs.generic-data-functions; devShell = nondevDevShell "ghc94"; }; haskellProjects.ghc92 = { @@ -58,6 +63,7 @@ packages.bytezap.source = inputs.bytezap; packages.flatparse.source = inputs.flatparse; packages.strongweak.source = inputs.strongweak; + packages.generic-data-functions.source = inputs.generic-data-functions; devShell = nondevDevShell "ghc92"; }; }; diff --git a/package.yaml b/package.yaml index 3bf1d6a..50f3967 100644 --- a/package.yaml +++ b/package.yaml @@ -56,7 +56,7 @@ dependencies: - bytezap - primitive >= 0.8.0.0 && < 0.10.0.0 - flatparse >= 0.5.0.2 && < 0.6 -- generic-data-functions ^>= 0.2.0 +- generic-data-functions ^>= 0.3.0 - parser-combinators ^>= 1.3.0 - bytestring >= 0.11 && < 0.13 - strongweak ^>= 0.6.0 diff --git a/src/Binrep/BLen.hs b/src/Binrep/BLen.hs index db63caf..6567a34 100644 --- a/src/Binrep/BLen.hs +++ b/src/Binrep/BLen.hs @@ -36,7 +36,7 @@ import Data.Word import Data.Int import Binrep.Util.ByteOrder -import Data.Monoid ( Sum(..) ) +import Data.Monoid qualified as Monoid import GHC.Generics import Generic.Data.Function.FoldMap import Generic.Data.Rep.Assert @@ -51,22 +51,19 @@ class BLen a where -- | Calculate the serialized byte length of the given value. blen :: a -> Int --- newtype sum monoid for generic foldMap -newtype BLen' a = BLen' { getBLen' :: a } - deriving (Semigroup, Monoid) via Sum a - -instance GenericFoldMap (BLen' Int) where - type GenericFoldMapC (BLen' Int) a = BLen a - genericFoldMapF = BLen' . blen +instance GenericFoldMap BLen where + type GenericFoldMapM BLen = Monoid.Sum Int + type GenericFoldMapC BLen a = BLen a + genericFoldMapF = Monoid.Sum . blen -- | Measure the byte length of a term of the non-sum type @a@ via its 'Generic' -- instance. blenGenericNonSum - :: forall {cd} {f} {asserts} a - . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum (BLen' Int) f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + :: forall {cd} {gf} {asserts} a + . ( Generic a, Rep a ~ D1 cd gf, GFoldMapNonSum BLen gf + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts gf) => a -> Int -blenGenericNonSum = getBLen' . genericFoldMapNonSum @asserts +blenGenericNonSum = Monoid.getSum . genericFoldMapNonSum @asserts @BLen -- | Measure the byte length of a term of the sum type @a@ via its 'Generic' -- instance. @@ -75,11 +72,12 @@ blenGenericNonSum = getBLen' . genericFoldMapNonSum @asserts -- inspecting the reified constructor names. This is regrettably inefficient. -- Alas. Do write your own instance if you want better performance! blenGenericSum - :: forall {cd} {f} {asserts} a - . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly (BLen' Int) f - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + :: forall {cd} {gf} {asserts} a + . (Generic a, Rep a ~ D1 cd gf, GFoldMapSum 'SumOnly BLen gf + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts gf) => (String -> Int) -> a -> Int -blenGenericSum f = getBLen' . genericFoldMapSum @'SumOnly @asserts (BLen' <$> f) +blenGenericSum f = + Monoid.getSum . genericFoldMapSum @'SumOnly @asserts @BLen (Monoid.Sum <$> f) instance TypeError ENoEmpty => BLen Void where blen = undefined instance TypeError ENoSum => BLen (Either a b) where blen = undefined diff --git a/src/Binrep/Get.hs b/src/Binrep/Get.hs index d78a337..6461144 100644 --- a/src/Binrep/Get.hs +++ b/src/Binrep/Get.hs @@ -165,12 +165,13 @@ runGetter g bs = case FP.runParser g bs of FP.Fail -> Left EFail FP.Err e -> Left e -instance GenericTraverse (FP.Parser E) where - type GenericTraverseC (FP.Parser E) a = Get a +instance GenericTraverse Get where + type GenericTraverseF Get = FP.Parser E + type GenericTraverseC Get a = Get a genericTraverseAction cd cc mcs si = getWrapGeneric cd $ EGenericField cc mcs si -instance GenericTraverseSum (FP.Parser E) where +instance GenericTraverseSum Get where genericTraverseSumPfxTagAction cd = getWrapGeneric cd $ EGenericSum . EGenericSumTag -- TODO proper offset info @@ -178,19 +179,19 @@ instance GenericTraverseSum (FP.Parser E) where FP.err $ E 0 $ EGeneric cd $ EGenericSum $ EGenericSumTagNoMatch cstrs ptText getGenericNonSum - :: forall {cd} {f} {asserts} a - . (Generic a, Rep a ~ D1 cd f, GTraverseNonSum cd (FP.Parser E) f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + :: forall {cd} {gf} {asserts} a + . (Generic a, Rep a ~ D1 cd gf, GTraverseNonSum cd Get gf + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts gf) => Getter a -getGenericNonSum = genericTraverseNonSum @asserts +getGenericNonSum = genericTraverseNonSum @asserts @Get getGenericSum - :: forall {cd} {f} {asserts} pt a - . ( Generic a, Rep a ~ D1 cd f, GTraverseSum 'SumOnly cd (FP.Parser E) f + :: forall {cd} {gf} {asserts} pt a + . ( Generic a, Rep a ~ D1 cd gf, GTraverseSum 'SumOnly cd Get gf , Get pt - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts gf) => PfxTagCfg pt -> Getter a -getGenericSum = genericTraverseSum @'SumOnly @asserts +getGenericSum = genericTraverseSum @'SumOnly @asserts @Get instance TypeError ENoEmpty => Get Void where get = undefined instance TypeError ENoSum => Get (Either a b) where get = undefined diff --git a/src/Binrep/Put.hs b/src/Binrep/Put.hs index 2a1c17a..15f3218 100644 --- a/src/Binrep/Put.hs +++ b/src/Binrep/Put.hs @@ -44,20 +44,18 @@ class PutC a where putC :: a -> PutterC runPut :: (BLen a, Put a) => a -> B.ByteString runPut a = unsafeRunPokeBS (blen a) (put a) --- TODO UGH I need to make my own internal idx here. Can't use 'Putter' since --- that's just bytezap, which others may want to use differently with g-f-d. --- Ah, but that means I need to redesign g-f-d! -instance GenericFoldMap Putter where - type GenericFoldMapC Putter a = Put a +instance GenericFoldMap Put where + type GenericFoldMapM Put = Putter + type GenericFoldMapC Put a = Put a genericFoldMapF = put -- | Serialize a term of the non-sum type @a@ via its 'Generic' instance. putGenericNonSum - :: forall {cd} {f} {asserts} a - . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Putter f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + :: forall {cd} {gf} {asserts} a + . ( Generic a, Rep a ~ D1 cd gf, GFoldMapNonSum Put gf + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts gf) => a -> Putter -putGenericNonSum = genericFoldMapNonSum @asserts +putGenericNonSum = genericFoldMapNonSum @asserts @Put -- | Serialize a term of the sum type @a@ via its 'Generic' instance. -- @@ -65,11 +63,11 @@ putGenericNonSum = genericFoldMapNonSum @asserts -- inefficient due to having to use 'String's. Alas. Do write your own instance -- if you want better performance! putGenericSum - :: forall {cd} {f} {asserts} a - . ( Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Putter f - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + :: forall {cd} {gf} {asserts} a + . ( Generic a, Rep a ~ D1 cd gf, GFoldMapSum 'SumOnly Put gf + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts gf) => (String -> Putter) -> a -> Putter -putGenericSum = genericFoldMapSum @'SumOnly @asserts +putGenericSum = genericFoldMapSum @'SumOnly @asserts @Put instance Struct.GPokeBase BinrepG where type GPokeBaseSt BinrepG = RealWorld