From 21e2a20d6a2fdde183a5e8298e3bc6d26d52e7e7 Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Thu, 19 Dec 2024 10:50:15 +0100 Subject: [PATCH 1/5] Add implementation of unboxing newtypes for Storable data - Fix typos in documentation for UnboxViaStorable - Add implementation of unboxing newtypes for Storable data --- vector/src/Data/Vector/Unboxed.hs | 1 + vector/src/Data/Vector/Unboxed/Base.hs | 100 ++++++++++++++++++++++++- 2 files changed, 100 insertions(+), 1 deletion(-) diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index a9c007a1..74bb8262 100644 --- a/vector/src/Data/Vector/Unboxed.hs +++ b/vector/src/Data/Vector/Unboxed.hs @@ -210,6 +210,7 @@ module Data.Vector.Unboxed ( UnboxViaPrim(..), As(..), IsoUnbox(..), + UnboxViaStorable(..), -- *** /Lazy/ boxing DoNotUnboxLazy(..), diff --git a/vector/src/Data/Vector/Unboxed/Base.hs b/vector/src/Data/Vector/Unboxed/Base.hs index f083eda3..e8c0ce30 100644 --- a/vector/src/Data/Vector/Unboxed/Base.hs +++ b/vector/src/Data/Vector/Unboxed/Base.hs @@ -26,7 +26,7 @@ module Data.Vector.Unboxed.Base ( MVector(..), IOVector, STVector, Vector(..), Unbox, - UnboxViaPrim(..), As(..), IsoUnbox(..), + UnboxViaPrim(..), UnboxViaStorable(..), As(..), IsoUnbox(..), DoNotUnboxLazy(..), DoNotUnboxNormalForm(..), DoNotUnboxStrict(..) ) where @@ -34,6 +34,7 @@ import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector as B import qualified Data.Vector.Strict as S +import qualified Data.Vector.Storable as St import qualified Data.Vector.Primitive as P @@ -760,6 +761,103 @@ instance (Unbox a, Unbox b) => G.Vector Vector (Arg a b) where elemseq _ (Arg x y) z = G.elemseq (undefined :: Vector a) x $ G.elemseq (undefined :: Vector b) y z +-- ------- +-- Unboxing the Storable values +-- ------- + +-- | Newtype wrapper which allows to derive unboxed vector in term of +-- storable vectors using @DerivingVia@ mechanism. This is mostly +-- used as illustration of use of @DerivingVia@ for vector, see examples below. +-- +-- First is rather straightforward: we define newtype and use GND to +-- derive 'St.Storable' instance. Newtype instances should be defined +-- manually. Then we use deriving via to define necessary instances. +-- +-- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -XMultiParamTypeClasses +-- >>> -- Needed to derive Prim +-- >>> :set -XGeneralizedNewtypeDeriving -XDataKinds -XUnboxedTuples -XPolyKinds +-- >>> +-- >>> import qualified Data.Vector.Generic as VG +-- >>> import qualified Data.Vector.Generic.Mutable as VGM +-- >>> import qualified Data.Vector.Storable as VS +-- >>> import qualified Data.Vector.Unboxed as VU +-- >>> +-- >>> newtype Foo = Foo Int deriving VS.Storable +-- >>> +-- >>> newtype instance VU.MVector s Foo = MV_Foo (VS.MVector s Foo) +-- >>> newtype instance VU.Vector Foo = V_Foo (VS.Vector Foo) +-- >>> deriving via (VU.UnboxViaStorable Foo) instance VGM.MVector VU.MVector Foo +-- >>> deriving via (VU.UnboxViaStorable Foo) instance VG.Vector VU.Vector Foo +-- >>> instance VU.Unbox Foo +-- +-- Second example is essentially same but with a twist. Instead of +-- using 'St.Storable' instance of data type, we use underlying instance of 'Int': +-- +-- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -XMultiParamTypeClasses +-- >>> +-- >>> import qualified Data.Vector.Generic as VG +-- >>> import qualified Data.Vector.Generic.Mutable as VGM +-- >>> import qualified Data.Vector.Storable as VS +-- >>> import qualified Data.Vector.Unboxed as VU +-- >>> +-- >>> newtype Foo = Foo Int +-- >>> +-- >>> newtype instance VU.MVector s Foo = MV_Foo (VS.MVector s Int) +-- >>> newtype instance VU.Vector Foo = V_Foo (VS.Vector Int) +-- >>> deriving via (VU.UnboxViaStorable Int) instance VGM.MVector VU.MVector Foo +-- >>> deriving via (VU.UnboxViaStorable Int) instance VG.Vector VU.Vector Foo +-- >>> instance VU.Unbox Foo +-- +-- @since 0.13.0.0 +newtype UnboxViaStorable a = UnboxViaStorable a + +newtype instance MVector s (UnboxViaStorable a) = MV_UnboxViaStorable (St.MVector s a) +newtype instance Vector (UnboxViaStorable a) = V_UnboxViaStorable (St.Vector a) + +instance St.Storable a => M.MVector MVector (UnboxViaStorable a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength = coerce $ M.basicLength @St.MVector @a + basicUnsafeSlice = coerce $ M.basicUnsafeSlice @St.MVector @a + basicOverlaps = coerce $ M.basicOverlaps @St.MVector @a + basicUnsafeNew = coerce $ M.basicUnsafeNew @St.MVector @a + basicInitialize = coerce $ M.basicInitialize @St.MVector @a + basicUnsafeReplicate = coerce $ M.basicUnsafeReplicate @St.MVector @a + basicUnsafeRead = coerce $ M.basicUnsafeRead @St.MVector @a + basicUnsafeWrite = coerce $ M.basicUnsafeWrite @St.MVector @a + basicClear = coerce $ M.basicClear @St.MVector @a + basicSet = coerce $ M.basicSet @St.MVector @a + basicUnsafeCopy = coerce $ M.basicUnsafeCopy @St.MVector @a + basicUnsafeMove = coerce $ M.basicUnsafeMove @St.MVector @a + basicUnsafeGrow = coerce $ M.basicUnsafeGrow @St.MVector @a + +instance St.Storable a => G.Vector Vector (UnboxViaStorable a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze = coerce $ G.basicUnsafeFreeze @St.Vector @a + basicUnsafeThaw = coerce $ G.basicUnsafeThaw @St.Vector @a + basicLength = coerce $ G.basicLength @St.Vector @a + basicUnsafeSlice = coerce $ G.basicUnsafeSlice @St.Vector @a + basicUnsafeIndexM = coerce $ G.basicUnsafeIndexM @St.Vector @a + basicUnsafeCopy = coerce $ G.basicUnsafeCopy @St.Vector @a + elemseq _ = seq + +instance St.Storable a => Unbox (UnboxViaStorable a) + -- ------- -- Unboxing the boxed values -- ------- From abf31b973d971928cb0311640365fa5cecbb914c Mon Sep 17 00:00:00 2001 From: Ruifeng Xie Date: Thu, 19 Dec 2024 10:50:34 +0100 Subject: [PATCH 2/5] Fix the documentation for UnboxViaPrim --- vector/src/Data/Vector/Unboxed/Base.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/vector/src/Data/Vector/Unboxed/Base.hs b/vector/src/Data/Vector/Unboxed/Base.hs index e8c0ce30..d4121441 100644 --- a/vector/src/Data/Vector/Unboxed/Base.hs +++ b/vector/src/Data/Vector/Unboxed/Base.hs @@ -188,14 +188,14 @@ instance G.Vector Vector () where -- >>> -- >>> newtype Foo = Foo Int deriving VP.Prim -- >>> --- >>> newtype instance VU.MVector s Foo = MV_Int (VP.MVector s Foo) --- >>> newtype instance VU.Vector Foo = V_Int (VP.Vector Foo) +-- >>> newtype instance VU.MVector s Foo = MV_Foo (VP.MVector s Foo) +-- >>> newtype instance VU.Vector Foo = V_Foo (VP.Vector Foo) -- >>> deriving via (VU.UnboxViaPrim Foo) instance VGM.MVector VU.MVector Foo -- >>> deriving via (VU.UnboxViaPrim Foo) instance VG.Vector VU.Vector Foo -- >>> instance VU.Unbox Foo -- -- Second example is essentially same but with a twist. Instead of --- using @Prim@ instance of data type, we use underlying instance of @Int@: +-- using 'P.Prim' instance of data type, we use underlying instance of 'Int': -- -- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -XMultiParamTypeClasses -- >>> @@ -206,8 +206,8 @@ instance G.Vector Vector () where -- >>> -- >>> newtype Foo = Foo Int -- >>> --- >>> newtype instance VU.MVector s Foo = MV_Int (VP.MVector s Int) --- >>> newtype instance VU.Vector Foo = V_Int (VP.Vector Int) +-- >>> newtype instance VU.MVector s Foo = MV_Foo (VP.MVector s Int) +-- >>> newtype instance VU.Vector Foo = V_Foo (VP.Vector Int) -- >>> deriving via (VU.UnboxViaPrim Int) instance VGM.MVector VU.MVector Foo -- >>> deriving via (VU.UnboxViaPrim Int) instance VG.Vector VU.Vector Foo -- >>> instance VU.Unbox Foo From 5aade90283658132457108679789f91850a2e0e3 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 17 Jan 2025 15:04:19 +0300 Subject: [PATCH 3/5] Tweak doctests a bit --- vector/src/Data/Vector/Unboxed/Base.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/vector/src/Data/Vector/Unboxed/Base.hs b/vector/src/Data/Vector/Unboxed/Base.hs index d4121441..dbc57b1c 100644 --- a/vector/src/Data/Vector/Unboxed/Base.hs +++ b/vector/src/Data/Vector/Unboxed/Base.hs @@ -774,8 +774,7 @@ instance (Unbox a, Unbox b) => G.Vector Vector (Arg a b) where -- manually. Then we use deriving via to define necessary instances. -- -- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -XMultiParamTypeClasses --- >>> -- Needed to derive Prim --- >>> :set -XGeneralizedNewtypeDeriving -XDataKinds -XUnboxedTuples -XPolyKinds +-- >>> :set -XGeneralizedNewtypeDeriving -- >>> -- >>> import qualified Data.Vector.Generic as VG -- >>> import qualified Data.Vector.Generic.Mutable as VGM @@ -808,7 +807,7 @@ instance (Unbox a, Unbox b) => G.Vector Vector (Arg a b) where -- >>> deriving via (VU.UnboxViaStorable Int) instance VG.Vector VU.Vector Foo -- >>> instance VU.Unbox Foo -- --- @since 0.13.0.0 +-- @since 0.13.3.0 newtype UnboxViaStorable a = UnboxViaStorable a newtype instance MVector s (UnboxViaStorable a) = MV_UnboxViaStorable (St.MVector s a) @@ -875,7 +874,6 @@ instance St.Storable a => Unbox (UnboxViaStorable a) -- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -- >>> :set -XMultiParamTypeClasses -XTypeOperators -XFlexibleInstances -- >>> import qualified Data.Vector.Unboxed as VU --- >>> import qualified Data.Vector.Unboxed.Mutable as VUM -- >>> import qualified Data.Vector.Generic as VG -- >>> import qualified Data.Vector.Generic.Mutable as VGM -- >>> :{ @@ -888,7 +886,7 @@ instance St.Storable a => Unbox (UnboxViaStorable a) -- >>> {-# INLINE fromURepr #-} -- >>> newtype instance VU.MVector s (Foo a) = MV_Foo (VU.MVector s (Int, VU.DoNotUnboxLazy a)) -- >>> newtype instance VU.Vector (Foo a) = V_Foo (VU.Vector (Int, VU.DoNotUnboxLazy a)) --- >>> deriving via (Foo a `VU.As` (Int, VU.DoNotUnboxLazy a)) instance VGM.MVector VUM.MVector (Foo a) +-- >>> deriving via (Foo a `VU.As` (Int, VU.DoNotUnboxLazy a)) instance VGM.MVector VU.MVector (Foo a) -- >>> deriving via (Foo a `VU.As` (Int, VU.DoNotUnboxLazy a)) instance VG.Vector VU.Vector (Foo a) -- >>> instance VU.Unbox (Foo a) -- >>> :} @@ -960,7 +958,6 @@ instance Unbox (DoNotUnboxLazy a) -- >>> :set -XBangPatterns -XTypeFamilies -XStandaloneDeriving -XDerivingVia -- >>> :set -XMultiParamTypeClasses -XTypeOperators -XFlexibleInstances -- >>> import qualified Data.Vector.Unboxed as VU --- >>> import qualified Data.Vector.Unboxed.Mutable as VUM -- >>> import qualified Data.Vector.Generic as VG -- >>> import qualified Data.Vector.Generic.Mutable as VGM -- >>> :{ @@ -973,7 +970,7 @@ instance Unbox (DoNotUnboxLazy a) -- >>> {-# INLINE fromURepr #-} -- >>> newtype instance VU.MVector s (Bar a) = MV_Bar (VU.MVector s (Int, VU.DoNotUnboxStrict a)) -- >>> newtype instance VU.Vector (Bar a) = V_Bar (VU.Vector (Int, VU.DoNotUnboxStrict a)) --- >>> deriving via (Bar a `VU.As` (Int, VU.DoNotUnboxStrict a)) instance VGM.MVector VUM.MVector (Bar a) +-- >>> deriving via (Bar a `VU.As` (Int, VU.DoNotUnboxStrict a)) instance VGM.MVector VU.MVector (Bar a) -- >>> deriving via (Bar a `VU.As` (Int, VU.DoNotUnboxStrict a)) instance VG.Vector VU.Vector (Bar a) -- >>> instance VU.Unbox (Bar a) -- >>> :} @@ -1045,7 +1042,6 @@ instance Unbox (DoNotUnboxStrict a) -- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -- >>> :set -XMultiParamTypeClasses -XTypeOperators -XFlexibleInstances -- >>> import qualified Data.Vector.Unboxed as VU --- >>> import qualified Data.Vector.Unboxed.Mutable as VUM -- >>> import qualified Data.Vector.Generic as VG -- >>> import qualified Data.Vector.Generic.Mutable as VGM -- >>> import qualified Control.DeepSeq as NF @@ -1059,7 +1055,7 @@ instance Unbox (DoNotUnboxStrict a) -- >>> {-# INLINE fromURepr #-} -- >>> newtype instance VU.MVector s (Baz a) = MV_Baz (VU.MVector s (Int, VU.DoNotUnboxNormalForm a)) -- >>> newtype instance VU.Vector (Baz a) = V_Baz (VU.Vector (Int, VU.DoNotUnboxNormalForm a)) --- >>> deriving via (Baz a `VU.As` (Int, VU.DoNotUnboxNormalForm a)) instance NF.NFData a => VGM.MVector VUM.MVector (Baz a) +-- >>> deriving via (Baz a `VU.As` (Int, VU.DoNotUnboxNormalForm a)) instance NF.NFData a => VGM.MVector VU.MVector (Baz a) -- >>> deriving via (Baz a `VU.As` (Int, VU.DoNotUnboxNormalForm a)) instance NF.NFData a => VG.Vector VU.Vector (Baz a) -- >>> instance NF.NFData a => VU.Unbox (Baz a) -- >>> :} From ac341f46a0d2dd4c677193ee9e46e4a2ef281366 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 17 Jan 2025 15:09:33 +0300 Subject: [PATCH 4/5] Make sure deriving examples actually compile Doctests do awful job checking it. Constructor may be in scope for doctest and not in scope for client code --- vector/src/Data/Vector/Unboxed.hs | 2 +- vector/tests/Main.hs | 1 + vector/tests/Tests/Deriving.hs | 151 ++++++++++++++++++++++++++++++ vector/vector.cabal | 2 + 4 files changed, 155 insertions(+), 1 deletion(-) create mode 100644 vector/tests/Tests/Deriving.hs diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index 74bb8262..36d52dc7 100644 --- a/vector/src/Data/Vector/Unboxed.hs +++ b/vector/src/Data/Vector/Unboxed.hs @@ -68,7 +68,7 @@ -- @ module Data.Vector.Unboxed ( -- * Unboxed vectors - Vector(V_UnboxAs, V_UnboxViaPrim), MVector(..), Unbox, + Vector(V_UnboxAs, V_UnboxViaPrim, V_UnboxViaStorable), MVector(..), Unbox, -- * Accessors diff --git a/vector/tests/Main.hs b/vector/tests/Main.hs index 812147fb..e30c1501 100644 --- a/vector/tests/Main.hs +++ b/vector/tests/Main.hs @@ -8,6 +8,7 @@ import qualified Tests.Vector.Strict import qualified Tests.Vector.Unboxed import qualified Tests.Bundle import qualified Tests.Move +import qualified Tests.Deriving () import Test.Tasty (defaultMain,testGroup) diff --git a/vector/tests/Tests/Deriving.hs b/vector/tests/Tests/Deriving.hs new file mode 100644 index 00000000..38aefb9e --- /dev/null +++ b/vector/tests/Tests/Deriving.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +#if MIN_VERSION_base(4,12,0) +{-# LANGUAGE DerivingVia #-} +#endif +-- | +-- These tests make sure that derived Unbox instances actually works. +-- It's distressingly easy to forget to export some constructor and +-- make seemingly fine code noncompilable. +-- +-- We're only interested in checking whether examples compiling. +-- Doctests aren't reliable in ensuring that! +module Tests.Deriving () where + +import Control.DeepSeq +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Unboxed as VU + +#if MIN_VERSION_base(4,12,0) +---------------------------------------------------------------- +-- Primitive + +newtype FooP1 = FooP1 Int deriving VP.Prim + +newtype instance VU.MVector s FooP1 = MV_FooP1 (VP.MVector s FooP1) +newtype instance VU.Vector FooP1 = V_FooP1 (VP.Vector FooP1) +deriving via (VU.UnboxViaPrim FooP1) instance VGM.MVector VU.MVector FooP1 +deriving via (VU.UnboxViaPrim FooP1) instance VG.Vector VU.Vector FooP1 +instance VU.Unbox FooP1 + + + +newtype FooP2 = FooP2 Int + +newtype instance VU.MVector s FooP2 = MV_FooP2 (VP.MVector s Int) +newtype instance VU.Vector FooP2 = V_FooP2 (VP.Vector Int) +deriving via (VU.UnboxViaPrim Int) instance VGM.MVector VU.MVector FooP2 +deriving via (VU.UnboxViaPrim Int) instance VG.Vector VU.Vector FooP2 +instance VU.Unbox FooP2 + + +---------------------------------------------------------------- +-- Storable + +newtype FooS1 = FooS1 Int deriving VS.Storable + +newtype instance VU.MVector s FooS1 = MV_FooS1 (VS.MVector s FooS1) +newtype instance VU.Vector FooS1 = V_FooS1 (VS.Vector FooS1) +deriving via (VU.UnboxViaStorable FooS1) instance VGM.MVector VU.MVector FooS1 +deriving via (VU.UnboxViaStorable FooS1) instance VG.Vector VU.Vector FooS1 +instance VU.Unbox FooS1 + + +newtype FooS2 = FooS2 Int + +newtype instance VU.MVector s FooS2 = MV_FooS2 (VS.MVector s Int) +newtype instance VU.Vector FooS2 = V_FooS2 (VS.Vector Int) +deriving via (VU.UnboxViaStorable Int) instance VGM.MVector VU.MVector FooS2 +deriving via (VU.UnboxViaStorable Int) instance VG.Vector VU.Vector FooS2 +instance VU.Unbox FooS2 + + +---------------------------------------------------------------- +-- Boxed variants + + +data FooLazy a = FooLazy Int a + deriving (Eq, Ord, Show) + +instance VU.IsoUnbox (FooLazy a) (Int, VU.DoNotUnboxLazy a) where + toURepr (FooLazy i a) = (i, VU.DoNotUnboxLazy a) + fromURepr (i, VU.DoNotUnboxLazy a) = FooLazy i a + {-# INLINE toURepr #-} + {-# INLINE fromURepr #-} + +newtype instance VU.MVector s (FooLazy a) = MV_FooLazy (VU.MVector s (Int, VU.DoNotUnboxLazy a)) +newtype instance VU.Vector (FooLazy a) = V_FooLazy (VU.Vector (Int, VU.DoNotUnboxLazy a)) +deriving via (FooLazy a `VU.As` (Int, VU.DoNotUnboxLazy a)) instance VGM.MVector VU.MVector (FooLazy a) +deriving via (FooLazy a `VU.As` (Int, VU.DoNotUnboxLazy a)) instance VG.Vector VU.Vector (FooLazy a) +instance VU.Unbox (FooLazy a) + + + +data FooStrict a = FooStrict Int a + deriving (Eq, Ord, Show) + +instance VU.IsoUnbox (FooStrict a) (Int, VU.DoNotUnboxStrict a) where + toURepr (FooStrict i a) = (i, VU.DoNotUnboxStrict a) + fromURepr (i, VU.DoNotUnboxStrict a) = FooStrict i a + {-# INLINE toURepr #-} + {-# INLINE fromURepr #-} + +newtype instance VU.MVector s (FooStrict a) = MV_FooStrict (VU.MVector s (Int, VU.DoNotUnboxStrict a)) +newtype instance VU.Vector (FooStrict a) = V_FooStrict (VU.Vector (Int, VU.DoNotUnboxStrict a)) +deriving via (FooStrict a `VU.As` (Int, VU.DoNotUnboxStrict a)) instance VGM.MVector VU.MVector (FooStrict a) +deriving via (FooStrict a `VU.As` (Int, VU.DoNotUnboxStrict a)) instance VG.Vector VU.Vector (FooStrict a) +instance VU.Unbox (FooStrict a) + + +data FooNormalForm a = FooNormalForm Int a + deriving (Eq, Ord, Show) + +instance VU.IsoUnbox (FooNormalForm a) (Int, VU.DoNotUnboxNormalForm a) where + toURepr (FooNormalForm i a) = (i, VU.DoNotUnboxNormalForm a) + fromURepr (i, VU.DoNotUnboxNormalForm a) = FooNormalForm i a + {-# INLINE toURepr #-} + {-# INLINE fromURepr #-} + +newtype instance VU.MVector s (FooNormalForm a) = MV_FooNormalForm (VU.MVector s (Int, VU.DoNotUnboxNormalForm a)) +newtype instance VU.Vector (FooNormalForm a) = V_FooNormalForm (VU.Vector (Int, VU.DoNotUnboxNormalForm a)) +deriving via (FooNormalForm a `VU.As` (Int, VU.DoNotUnboxNormalForm a)) + instance NFData a => VGM.MVector VU.MVector (FooNormalForm a) +deriving via (FooNormalForm a `VU.As` (Int, VU.DoNotUnboxNormalForm a)) + instance NFData a => VG.Vector VU.Vector (FooNormalForm a) +instance NFData a => VU.Unbox (FooNormalForm a) + + + +---------------------------------------------------------------- +-- Unboxed + + +data FooAs a = FooAs Int a + deriving Show + +instance VU.IsoUnbox (FooAs a) (Int,a) where + toURepr (FooAs i a) = (i,a) + fromURepr (i,a) = FooAs i a + {-# INLINE toURepr #-} + {-# INLINE fromURepr #-} + +newtype instance VU.MVector s (FooAs a) = MV_FooAs (VU.MVector s (Int, a)) +newtype instance VU.Vector (FooAs a) = V_FooAs (VU.Vector (Int, a)) +deriving via (FooAs a `VU.As` (Int, a)) instance VU.Unbox a => VGM.MVector VU.MVector (FooAs a) +deriving via (FooAs a `VU.As` (Int, a)) instance VU.Unbox a => VG.Vector VU.Vector (FooAs a) +instance VU.Unbox a => VU.Unbox (FooAs a) + +#endif diff --git a/vector/vector.cabal b/vector/vector.cabal index 30c18977..f53c9798 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -188,6 +188,7 @@ common tests-common , template-haskell , base-orphans >= 0.6 , vector + , deepseq , primitive , random , QuickCheck >= 2.9 && < 2.16 @@ -206,6 +207,7 @@ common tests-common Tests.Vector.Primitive Tests.Vector.Unboxed Tests.Vector.UnitTests + Tests.Deriving Utilities default-extensions: From 982df63840170dc6e703bbd98322d27cf41aad21 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 17 Jan 2025 18:25:23 +0300 Subject: [PATCH 5/5] DoNotUnbox* suffer from same problem --- vector/src/Data/Vector/Unboxed.hs | 3 ++- vector/tests/Tests/Deriving.hs | 35 +++++++++++++++++++++++++++++++ 2 files changed, 37 insertions(+), 1 deletion(-) diff --git a/vector/src/Data/Vector/Unboxed.hs b/vector/src/Data/Vector/Unboxed.hs index 36d52dc7..673e4946 100644 --- a/vector/src/Data/Vector/Unboxed.hs +++ b/vector/src/Data/Vector/Unboxed.hs @@ -68,7 +68,8 @@ -- @ module Data.Vector.Unboxed ( -- * Unboxed vectors - Vector(V_UnboxAs, V_UnboxViaPrim, V_UnboxViaStorable), MVector(..), Unbox, + Vector(V_UnboxAs, V_UnboxViaPrim, V_UnboxViaStorable,V_DoNotUnboxLazy,V_DoNotUnboxStrict,V_DoNotUnboxNormalForm), + MVector(..), Unbox, -- * Accessors diff --git a/vector/tests/Tests/Deriving.hs b/vector/tests/Tests/Deriving.hs index 38aefb9e..fa7dc87f 100644 --- a/vector/tests/Tests/Deriving.hs +++ b/vector/tests/Tests/Deriving.hs @@ -25,6 +25,8 @@ module Tests.Deriving () where import Control.DeepSeq import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector as V +import qualified Data.Vector.Strict as VV import qualified Data.Vector.Storable as VS import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Unboxed as VU @@ -129,6 +131,39 @@ instance NFData a => VU.Unbox (FooNormalForm a) +data BoxedLazy = BoxedLazy Int + deriving (Eq, Ord, Show) + +newtype instance VU.MVector s BoxedLazy = MV_BoxedLazy (V.MVector s BoxedLazy) +newtype instance VU.Vector BoxedLazy = V_BoxedLazy (V.Vector BoxedLazy) +deriving via (VU.DoNotUnboxLazy BoxedLazy) instance VGM.MVector VU.MVector BoxedLazy +deriving via (VU.DoNotUnboxLazy BoxedLazy) instance VG.Vector VU.Vector BoxedLazy +instance VU.Unbox BoxedLazy + + +data BoxedStrict = BoxedStrict Int + deriving (Eq, Ord, Show) + +newtype instance VU.MVector s BoxedStrict = MV_BoxedStrict (VV.MVector s BoxedStrict) +newtype instance VU.Vector BoxedStrict = V_BoxedStrict (VV.Vector BoxedStrict) +deriving via (VU.DoNotUnboxStrict BoxedStrict) instance VGM.MVector VU.MVector BoxedStrict +deriving via (VU.DoNotUnboxStrict BoxedStrict) instance VG.Vector VU.Vector BoxedStrict +instance VU.Unbox BoxedStrict + + +data BoxedNormalForm = BoxedNormalForm Int + deriving (Eq, Ord, Show) + +instance NFData BoxedNormalForm where + rnf (BoxedNormalForm i) = rnf i + +newtype instance VU.MVector s BoxedNormalForm = MV_BoxedNormalForm (VV.MVector s BoxedNormalForm) +newtype instance VU.Vector BoxedNormalForm = V_BoxedNormalForm (VV.Vector BoxedNormalForm) +deriving via (VU.DoNotUnboxNormalForm BoxedNormalForm) instance VGM.MVector VU.MVector BoxedNormalForm +deriving via (VU.DoNotUnboxNormalForm BoxedNormalForm) instance VG.Vector VU.Vector BoxedNormalForm +instance VU.Unbox BoxedNormalForm + + ---------------------------------------------------------------- -- Unboxed