derive-prim 0.1.0.0 → 0.1.0.1
raw patch · 5 files changed
+102/−7 lines, 5 files
Files
- CHANGELOG.md +4/−0
- README.md +9/−0
- derive-prim.cabal +3/−3
- src/Data/Primitive/Generic.hs +76/−3
- test/Main.hs +10/−1
CHANGELOG.md view
@@ -3,3 +3,7 @@ ## 0.1.0.0 -- 2024-05-10 * Implemented generic derivation of Prim and PrinUnaligned.++## 0.1.0.1 -- 2024-05-12++* Implemented offsetof
README.md view
@@ -13,6 +13,10 @@ , membFloat :: Float } derive (Generic) derive (Prim, PrimUnaligned) via (GenericPrim Struct)++data OtherStruct = OtherStruct Int Word Float Double Char+ derive (Generic) + derive (Prim, PrimUnaligned) via (GenericPrim OtherStruct) ``` All members must implement both an instance of Prim and an instance of PrimUnaligned. Nested structs are also allowed as long as they implement the nessisary instances. ```@@ -34,6 +38,11 @@ ... , someOtherField :: Packed SomeOtherType {- This field will have an alignment of 1 bytes #-} }+```+The specific offset of a field can be queried by `offsetOf @STRUCT_TYPE @RECORD_NAME`.+```+memberOffset :: Int+memberOffset = offsetOf @Struct @"someField" ``` ## Details Members are layout in memory according to their order. Members placed higher will have a lower memory address.
derive-prim.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: derive-prim-version: 0.1.0.0+version: 0.1.0.1 synopsis: Derive Prim and PrimUnaligned description: This package provides the newtype `GenericPrim` which allows user to derive instances for Prim and PrimUnaligned through the DerivingVia extension.@@ -23,7 +23,7 @@ -- import: warnings exposed-modules: Data.Primitive.Generic- build-depends: base ^>=4.18.2.0,+ build-depends: base >=4.17.2.0 && < 4.20, primitive >= 0.9.0 && < 0.10, primitive-unaligned >= 0.1.1 && < 0.2, hs-source-dirs: src@@ -36,7 +36,7 @@ hs-source-dirs: test main-is: Main.hs build-depends:- base ^>=4.18.2.0,+ base >=4.17.2.0 && < 4.20, primitive >= 0.9.0 && < 0.10, primitive-unaligned >= 0.1.1 && < 0.2, derive-prim
src/Data/Primitive/Generic.hs view
@@ -10,6 +10,7 @@ module Data.Primitive.Generic ( Align(..), Packed , GenericPrim(..)+ , offsetOf ) where import Data.Semigroup import Data.Functor.Identity@@ -40,6 +41,9 @@ ValidAlign 0 = TypeError (Text "Alignment must be strictly possitive (> 0)") ValidAlign _ = () +-- |Derive Prim and PrimUnaligned instances+newtype GenericPrim a = GenericPrim a+ instance (ValidAlign a, KnownNat a, Prim t) => Prim (Align a t) where alignmentOfType# _ = align# where !(I# align#) = fromIntegral (natVal @a Proxy)@@ -56,9 +60,6 @@ in (# state'#, Align value #) writeOffAddr# addr# idx# (Align value) = writeOffAddr# addr# idx# value --- |Derive Prim and PrimUnaligned instances-newtype GenericPrim a = GenericPrim a- -- TODO: Implement a plugin to make the performance not terrible instance (Generic a, DerivePrim (Rep a)) => PrimUnaligned (GenericPrim a) where indexUnalignedByteArray# ba# offs# = GenericPrim (to (implIndexUnalignedByteArray# (membOffsets @(Rep a)) ba# offs#))@@ -67,6 +68,36 @@ in (# state'#, GenericPrim (to value) #) writeUnalignedByteArray# ba# offs# (GenericPrim (from -> value)) = implWriteUnalignedByteArray# (membOffsets @(Rep a)) ba# offs# value +type family Or (a :: Bool) (b :: Bool) :: Bool where+ Or False False = False+ Or _ _ = True++type family HasOffsetOf t (s :: Symbol) :: Bool where+ HasOffsetOf (f :*: g) s = Or (HasOffsetOf f s) (HasOffsetOf g s)+ HasOffsetOf (M1 _ (MetaSel (Just s) _ _ _) _) s = True+ HasOffsetOf (M1 _ _ f) s = HasOffsetOf f s+ HasOffsetOf _ _ = False++type family Assert (s :: Symbol) (c :: Bool) :: Constraint where+ Assert _ True = ()+ Assert s False = TypeError (Text s)++type family Equal a b :: Bool where+ Equal a a = True+ Equal _ _ = False+++class KnownBool (b :: Bool) where+ boolVal :: Proxy b -> Bool+ ifBool :: a -> a -> Proxy b -> a+instance KnownBool True where+ boolVal _ = True+ ifBool _ a _ = a+ +instance KnownBool False where+ boolVal _ = False+ ifBool a _ _ = a+ instance (Generic a, DerivePrim (Rep a)) => Prim (GenericPrim a) where sizeOfType# _ = structSize# @(Rep a) Proxy alignmentOfType# _ = structAlign# @(Rep a) Proxy@@ -104,6 +135,48 @@ implIndexUnalignedOffAddr# :: DeriveTree q p -> Addr# -> q p implReadUnalignedOffAddr# :: DeriveTree q p -> Addr# -> State# s -> (# State# s, q p #) implWriteUnalignedOffAddr# :: DeriveTree q p -> Addr# -> q p -> State# s -> State# s++class OffsetOf t (s :: Symbol) where+ -- | return -1 if does not contain field+ offsetOf# :: t p -> Int#+ getInt# :: t p -> Int#++instance OffsetOf V1 s where+ offsetOf# _ = -1#+ getInt# _ = -1#+instance OffsetOf U1 s where+ offsetOf# _ = -1#+ getInt# _ = -1#++instance (OffsetOf f s, OffsetOf g s, KnownBool (HasOffsetOf f s), KnownBool (HasOffsetOf g s)) => OffsetOf (f :*: g) s where+ offsetOf# (f :*: g)+ | boolVal @(HasOffsetOf f s) Proxy = offsetOf# @_ @s f+ | boolVal @(HasOffsetOf g s) Proxy = offsetOf# @_ @s g+ | otherwise = -1#++ getInt# _ = -1#+instance OffsetOf (K1 i Int) s where+ offsetOf# _ = -1#+ getInt# (K1 (I# offs#)) = offs#++instance OffsetOf c s => OffsetOf (M1 i (MetaSel (Just s') a b d) c) s where+ offsetOf# (M1 c) = getInt# @_ @s c+ getInt# (M1 c) = getInt# @_ @s c++instance OffsetOf c s => OffsetOf (M1 i (MetaSel Nothing a b d) c) s where+ offsetOf# (M1 c) = offsetOf# @_ @s c+ getInt# (M1 c) = getInt# @_ @s c++instance OffsetOf c s => OffsetOf (M1 i (MetaData a b d e) c) s where+ offsetOf# (M1 c) = offsetOf# @_ @s c+ getInt# (M1 c) = getInt# @_ @s c++instance OffsetOf c s => OffsetOf (M1 i (MetaCons a b e) c) s where+ offsetOf# (M1 c) = offsetOf# @_ @s c+ getInt# (M1 c) = getInt# @_ @s c++offsetOf :: forall t s. (Generic t, DerivePrim (Rep t), OffsetOf (DeriveTree (Rep t)) s, Assert "Field does not exist" (HasOffsetOf (DeriveTree (Rep t)) s)) => Int+offsetOf = I# (offsetOf# @_ @s (membOffsets @(Rep t))) membOffsets :: forall q p. DerivePrim q => DeriveTree q p membOffsets = tree
test/Main.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LexicalNegation #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-} module Main (main) where import Control.Monad import Control.Monad.ST@@ -27,6 +28,14 @@ deriving (Generic, Eq) deriving (Prim, PrimUnaligned) via (GenericPrim Struct3) +data Struct4 = Struct4+ { membA :: Int+ , membB :: Float+ , membC :: Int+ , membD :: Int8+ } deriving (Generic, Eq) + deriving (Prim, PrimUnaligned) via (GenericPrim Struct4)+ testPrim :: (Eq a, Prim a) => [a] -> Bool testPrim list = ba where listLen = length list@@ -52,4 +61,4 @@ , Struct3 1 $ Align $ Struct2 02 $ Struct1 '5' -32 99.0 33 , Struct3 6 $ Align $ Struct2 03 $ Struct1 '2' 902 3.02 0 ]) exitFailure-+ print (offsetOf @Struct4 @"membD")