Add iso-deriving for Unboxed instances

vector/src/Data/Vector/Unboxed.hs

@@ -56,7 +56,7 @@
 -- >>> instance Unbox Foo
 module Data.Vector.Unboxed (
   -- * Unboxed vectors
-  Vector, MVector(..), Unbox,
+  Vector(V_UnboxAs), MVector(..), Unbox,
 
   -- * Accessors
 
@@ -192,7 +192,9 @@ module Data.Vector.Unboxed (
   freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy,
 
   -- ** Deriving via
-  UnboxViaPrim(..)
+  UnboxViaPrim(..),
+  As(..),
+  IsoUnbox(..)
 ) where
 
 import Data.Vector.Unboxed.Base

vector/src/Data/Vector/Unboxed/Base.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE BangPatterns, CPP, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
 {-# LANGUAGE PolyKinds #-}
@@ -16,7 +18,8 @@
 --
 
 module Data.Vector.Unboxed.Base (
-  MVector(..), IOVector, STVector, Vector(..), Unbox, UnboxViaPrim(..)
+  MVector(..), IOVector, STVector, Vector(..), Unbox,
+  UnboxViaPrim(..), As(..), IsoUnbox(..)
 ) where
 
 import qualified Data.Vector.Generic         as G
@@ -52,6 +55,8 @@ import Data.Semigroup (Min(..),Max(..),First(..),Last(..),WrappedMonoid(..),Arg(
 import Data.Typeable ( Typeable )
 import Data.Data     ( Data(..) )
 import GHC.Exts      ( Down(..) )
+import GHC.Generics
+import Data.Coerce
 
 -- Data.Vector.Internal.Check is unused
 #define NOT_VECTOR_MODULE
@@ -253,6 +258,130 @@ instance P.Prim a => G.Vector Vector (UnboxViaPrim a) where
   basicUnsafeCopy (MV_UnboxViaPrim mv) (V_UnboxViaPrim v) = G.basicUnsafeCopy mv v
   elemseq _ = seq
 
+-- | Isomorphism between type @a@ and its representation in unboxed
+-- vector @b@. Default instance coerces between generic
+-- representations of @a@ and @b@ which means they have same shape and
+-- corresponding fields could be coerced to each other. Note that this
+-- means it's possible to have fields that have different types:
+--
+-- >>> :set -XMultiParamTypeClasses -XDeriveGeneric -XFlexibleInstances
+-- >>> import GHC.Generics (Generic)
+-- >>> import Data.Monoid
+-- >>> import qualified Data.Vector.Unboxed as VU
+-- >>> :{
+-- data Foo a = Foo Int a
+--   deriving (Show,Generic)
+-- instance VU.IsoUnbox (Foo a) (Int, a)
+-- instance VU.IsoUnbox (Foo a) (Sum Int, Product a)
+-- :}
+--
+class IsoUnbox a b where
+  -- | Convert value into it representation in unboxed vector.
+  toURepr   :: a -> b
+  default toURepr :: (Generic a, Generic b, Coercible (Rep a ()) (Rep b ())) => a -> b
+  toURepr = to . idU . coerce . idU . from
+  -- | Convert value representation in unboxed vector back to value.
+  fromURepr :: b -> a
+  default fromURepr :: (Generic a, Generic b, Coercible (Rep b ()) (Rep a ())) => b -> a
+  fromURepr = to . idU . coerce . idU . from
+
+idU :: f () -> f ()
+idU = id
+
+
+-- | Newtype which allows to derive unbox instances for type @a@ which
+-- uses @b@ as underlying representation (usually tuple). Type @a@ and
+-- its representation @b@ are connected by type class
+-- 'IsoUnbox'. Here's example which uses explicit 'IsoUnbox' instance:
+--
+--
+-- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia
+-- >>> :set -XMultiParamTypeClasses -XTypeOperators -XFlexibleInstances
+-- >>> import qualified Data.Vector.Unboxed         as VU
+-- >>> import qualified Data.Vector.Generic         as VG
+-- >>> import qualified Data.Vector.Generic.Mutable as VGM
+-- >>> :{
+-- data Foo a = Foo Int a
+--   deriving Show
+-- instance VU.IsoUnbox (Foo a) (Int,a) where
+--   toURepr (Foo i a) = (i,a)
+--   fromURepr (i,a) = Foo i a
+--   {-# INLINE toURepr #-}
+--   {-# INLINE fromURepr #-}
+-- newtype instance VU.MVector s (Foo a) = MV_Foo (VU.MVector s (Int, a))
+-- newtype instance VU.Vector    (Foo a) = V_Foo  (VU.Vector    (Int, a))
+-- deriving via (Foo a `VU.As` (Int, a)) instance VU.Unbox a => VGM.MVector MVector (Foo a)
+-- deriving via (Foo a `VU.As` (Int, a)) instance VU.Unbox a => VG.Vector  Vector  (Foo a)
+-- instance VU.Unbox a => VU.Unbox (Foo a)
+-- :}
+--
+--
+-- It's also possible to use generic-based instance for 'IsoUnbox'
+-- which should work for all product types.
+--
+-- >>> :set -XTypeFamilies -XStandaloneDeriving -XDerivingVia -XDeriveGeneric
+-- >>> :set -XMultiParamTypeClasses -XTypeOperators -XFlexibleInstances
+-- >>> import qualified Data.Vector.Unboxed         as VU
+-- >>> import qualified Data.Vector.Generic         as VG
+-- >>> import qualified Data.Vector.Generic.Mutable as VGM
+-- >>> :{
+-- data Bar a = Bar Int a
+--   deriving (Show,Generic)
+-- instance VU.IsoUnbox (Bar a) (Int,a) where
+-- newtype instance VU.MVector s (Bar a) = MV_Bar (VU.MVector s (Int, a))
+-- newtype instance VU.Vector    (Bar a) = V_Bar  (VU.Vector    (Int, a))
+-- deriving via (Bar a `VU.As` (Int, a)) instance VU.Unbox a => VGM.MVector VU.MVector (Bar a)
+-- deriving via (Bar a `VU.As` (Int, a)) instance VU.Unbox a => VG.Vector  VU.Vector  (Bar a)
+-- instance VU.Unbox a => VU.Unbox (Bar a)
+-- :}
+--
+newtype As a b = As a
+
+newtype instance MVector s (As a b) = MV_UnboxAs (MVector s b)
+newtype instance Vector    (As a b) = V_UnboxAs  (Vector b)
+
+instance (IsoUnbox a b, Unbox b) => M.MVector MVector (As a b) 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 (MV_UnboxAs v) = M.basicLength v
+  basicUnsafeSlice i n (MV_UnboxAs v) = MV_UnboxAs $ M.basicUnsafeSlice i n v
+  basicOverlaps (MV_UnboxAs v1) (MV_UnboxAs v2) = M.basicOverlaps v1 v2
+  basicUnsafeNew n = MV_UnboxAs `liftM` M.basicUnsafeNew n
+  basicInitialize (MV_UnboxAs v) = M.basicInitialize v
+  basicUnsafeReplicate n (As x) = MV_UnboxAs `liftM` M.basicUnsafeReplicate n (toURepr x)
+  basicUnsafeRead (MV_UnboxAs v) i = (As . fromURepr) `liftM` M.basicUnsafeRead v i
+  basicUnsafeWrite (MV_UnboxAs v) i (As x) = M.basicUnsafeWrite v i (toURepr x)
+  basicClear (MV_UnboxAs v) = M.basicClear v
+  basicSet (MV_UnboxAs v) (As x) = M.basicSet v (toURepr x)
+  basicUnsafeCopy (MV_UnboxAs v1) (MV_UnboxAs v2) = M.basicUnsafeCopy v1 v2
+  basicUnsafeMove (MV_UnboxAs v1) (MV_UnboxAs v2) = M.basicUnsafeMove v1 v2
+  basicUnsafeGrow (MV_UnboxAs v) n = MV_UnboxAs `liftM` M.basicUnsafeGrow v n
+
+instance (IsoUnbox a b, Unbox b) => G.Vector Vector (As a b) where
+  {-# INLINE basicUnsafeFreeze #-}
+  {-# INLINE basicUnsafeThaw #-}
+  {-# INLINE basicLength #-}
+  {-# INLINE basicUnsafeSlice #-}
+  {-# INLINE basicUnsafeIndexM #-}
+  {-# INLINE elemseq #-}
+  basicUnsafeFreeze (MV_UnboxAs v) = V_UnboxAs `liftM` G.basicUnsafeFreeze v
+  basicUnsafeThaw (V_UnboxAs v) = MV_UnboxAs `liftM` G.basicUnsafeThaw v
+  basicLength (V_UnboxAs v) = G.basicLength v
+  basicUnsafeSlice i n (V_UnboxAs v) = V_UnboxAs $ G.basicUnsafeSlice i n v
+  basicUnsafeIndexM (V_UnboxAs v) i = As . fromURepr <$> G.basicUnsafeIndexM v i
+  basicUnsafeCopy (MV_UnboxAs mv) (V_UnboxAs v) = G.basicUnsafeCopy mv v
+  elemseq _ = seq
+
 
 #define primMVector(ty,con)                                             \
 instance M.MVector MVector ty where {                                   \

vector/tests-inspect/Inspect/DerivingVia.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DerivingVia           #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# OPTIONS_GHC -fplugin=Test.Tasty.Inspection.Plugin #-}
+{-# OPTIONS_GHC -dsuppress-all                        #-}
+{-# OPTIONS_GHC -dno-suppress-type-signatures         #-}
+-- | Most basic inspection tests
+module Inspect.DerivingVia where
+
+import Test.Tasty
+import Test.Tasty.Inspection
+import qualified Data.Vector.Generic         as VG
+import qualified Data.Vector.Generic.Mutable as VGM
+import qualified Data.Vector.Unboxed         as VU
+import GHC.Generics (Generic)
+
+import Inspect.DerivingVia.OtherFoo
+
+
+-- | Simple product data type for which we derive Unbox instances
+-- using generics and iso-deriving. This one is used in same module
+-- where it's defined. It's used to check that there's no difference
+-- between data type defined in same and different module (see
+-- 'OtherFoo').
+data Foo a = Foo Int a
+  deriving (Show,Generic)
+
+instance VU.IsoUnbox (Foo a) (Int,a) where
+
+newtype instance VU.MVector s (Foo a) = MV_Int (VU.MVector s (Int, a))
+newtype instance VU.Vector    (Foo a) = V_Int  (VU.Vector    (Int, a))
+
+instance VU.Unbox a => VU.Unbox (Foo a)
+deriving via (Foo a `VU.As` (Int, a)) instance VU.Unbox a => VGM.MVector VU.MVector (Foo a)
+deriving via (Foo a `VU.As` (Int, a)) instance VU.Unbox a => VG.Vector   VU.Vector  (Foo a)
+
+map_Foo :: VU.Vector (Foo Double) -> VU.Vector (Foo Double)
+map_Foo = VU.map (\(Foo a b) -> Foo (a*10) (b*100))
+
+pipeline_Foo :: Int -> Double
+pipeline_Foo n
+  = VU.foldl' (\acc (Foo a b) -> acc + b^^a) 0
+  $ VU.filter (\(Foo a _) -> a < 4)
+  $ VU.map (\(Foo a b) -> Foo (a + 2) (log b))
+  $ VU.generate n (\i -> Foo i (log (fromIntegral i)))
+
+map_OtherFoo :: VU.Vector (OtherFoo Double) -> VU.Vector (OtherFoo Double)
+map_OtherFoo = VU.map (\(OtherFoo a b) -> OtherFoo (a*10) (b*100))
+
+pipeline_OtherFoo :: Int -> Double
+pipeline_OtherFoo n
+  = VU.foldl' (\acc (OtherFoo a b) -> acc + b^^a) 0
+  $ VU.filter (\(OtherFoo a _) -> a < 4)
+  $ VU.map (\(OtherFoo a b) -> OtherFoo (a + 2) (log b))
+  $ VU.generate n (\i -> OtherFoo i (log (fromIntegral i)))
+
+
+-- | Here we test that optimizer successfully eliminated all generics
+-- and even mentions of Foo data type.
+tests :: TestTree
+tests = testGroup "iso-deriving"
+  [ $(inspectObligations [(`doesNotUse` 'Foo), hasNoGenerics, hasNoTypeClasses]
+       'map_Foo)
+  , $(inspectObligations [(`doesNotUse` 'OtherFoo), hasNoGenerics, hasNoTypeClasses]
+       'pipeline_Foo)
+  , $(inspectObligations [(`doesNotUse` 'OtherFoo), hasNoGenerics, hasNoTypeClasses]
+       'map_OtherFoo)
+  , $(inspectObligations [(`doesNotUse` 'OtherFoo), hasNoGenerics, hasNoTypeClasses]
+       'pipeline_OtherFoo)
+  ]

vector/tests-inspect/Inspect/DerivingVia/OtherFoo.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DerivingVia           #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+module Inspect.DerivingVia.OtherFoo where
+
+import qualified Data.Vector.Generic         as VG
+import qualified Data.Vector.Generic.Mutable as VGM
+import qualified Data.Vector.Unboxed         as VU
+import GHC.Generics (Generic)
+
+
+-- | Simple product data type for which we derive Unbox instances
+-- using generics and iso-deriving. It's defined in separate module in
+-- order to test that it doesn't impede optimizer
+data OtherFoo a = OtherFoo Int a
+  deriving (Show,Generic)
+
+instance VU.IsoUnbox (OtherFoo a) (Int,a) where
+
+newtype instance VU.MVector s (OtherFoo a) = MV_Int (VU.MVector s (Int, a))
+newtype instance VU.Vector    (OtherFoo a) = V_Int  (VU.Vector    (Int, a))
+
+instance VU.Unbox a => VU.Unbox (OtherFoo a)
+deriving via (OtherFoo a `VU.As` (Int, a)) instance VU.Unbox a => VGM.MVector VU.MVector (OtherFoo a)
+deriving via (OtherFoo a `VU.As` (Int, a)) instance VU.Unbox a => VG.Vector   VU.Vector  (OtherFoo a)

vector/tests-inspect/main.hs

@@ -1,10 +1,16 @@
+{-# LANGUAGE CPP #-}
 module Main (main) where
 
 import qualified Inspect
-
+#if MIN_VERSION_base(4,12,0)
+import qualified Inspect.DerivingVia
+#endif
 import Test.Tasty (defaultMain,testGroup)
 
 main :: IO ()
 main = defaultMain $ testGroup "tests"
   [ Inspect.tests
+#if MIN_VERSION_base(4,12,0)
+  , Inspect.DerivingVia.tests
+#endif
   ]

vector/vector.cabal

@@ -281,8 +281,11 @@ test-suite vector-inspection
   -- -as well
   Ghc-Options:      -Wall
   main-is:          main.hs
-  Other-modules:    Inspect
   default-language: Haskell2010
+  Other-modules:    Inspect
+  if impl(ghc >= 8.6)
+    Other-modules:  Inspect.DerivingVia
+                    Inspect.DerivingVia.OtherFoo
   -- GHC<8.0 doesn't support plugins
   if impl(ghc < 8.0)
     buildable: False