创建 UArray 的自定义实例

Question

假设我有一个简单的数据类型，例如：

data Cell = Open | Blocked

我想使用UArray Int Cell。是否有捷径可寻？我可以以某种方式重用UArray Int Bool 的定义吗？

Answer 1

This answer 解释了为什么 Vectors 比 Arrays 更好，所以我将为您提供未装箱向量的答案。

我确实尝试根据Bool 实例为Cell 派生MArray 和IArray 实例，但是Bool 实例相当复杂；它至少与手动为向量派生 Unbox 实例一样难看。与向量不同，您也不能只派生Storable 并使用Storable 数组：您仍然需要Marray 和IArray 实例。似乎还没有一个很好的 TH 解决方案，因此出于这些原因，您最好还是使用向量。

有几种方法可以做到这一点，有些方法比其他方法更痛苦。

1. vector-th-unbox

   优点：简单明了，比手动派生 Unbox 实例要短得多

   缺点：需要-XTemplateHaskell

   {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies #-}
   
   import Data.Vector.Unboxed
   import Data.Vector.Unboxed.Deriving
   import qualified Data.Vector.Generic
   import qualified Data.Vector.Generic.Mutable
   
   data Cell = Open | Blocked deriving (Show)
   
   derivingUnbox "Cell"
       [t| Cell -> Bool |]
       [| \ x -> case x of
           Open -> True
           Blocked -> False |]
       [| \ x -> case x of
           True -> Open
           False -> Blocked |]
   
   main = print $ show $ singleton Open
   

2. 编写您自己的 Unbox、M.MVector 和 V.Vector 实例，外加两个数据实例

   {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}
   
   import qualified Data.Vector.Generic            as V
   import qualified Data.Vector.Generic.Mutable    as M
   import qualified Data.Vector.Unboxed            as U
   import Control.Monad
   
   data Cell = Open | Blocked deriving (Show)
   
   data instance U.MVector s Cell = MV_Cell (U.MVector s Cell)
   data instance U.Vector Cell = V_Cell (U.Vector Cell)
   
   instance U.Unbox Cell
   
   {- purloined and tweaked from code in `vector` 
      package that defines types as unboxed -}
   instance M.MVector U.MVector Cell where
     {-# INLINE basicLength #-}
     {-# INLINE basicUnsafeSlice #-}
     {-# INLINE basicOverlaps #-}
     {-# INLINE basicUnsafeNew #-}
     {-# INLINE basicUnsafeReplicate #-}
     {-# INLINE basicUnsafeRead #-}
     {-# INLINE basicUnsafeWrite #-}
     {-# INLINE basicClear #-}
     {-# INLINE basicSet #-}
     {-# INLINE basicUnsafeCopy #-}
     {-# INLINE basicUnsafeGrow #-}
   
     basicLength (MV_Cell v) = M.basicLength v
     basicUnsafeSlice i n (MV_Cell v) = MV_Cell $ M.basicUnsafeSlice i n v
     basicOverlaps (MV_Cell v1) (MV_Cell v2) = M.basicOverlaps v1 v2
     basicUnsafeNew n = MV_Cell `liftM` M.basicUnsafeNew n
     basicUnsafeReplicate n x = MV_Cell `liftM` M.basicUnsafeReplicate n x
     basicUnsafeRead (MV_Cell v) i = M.basicUnsafeRead v i
     basicUnsafeWrite (MV_Cell v) i x = M.basicUnsafeWrite v i x
     basicClear (MV_Cell v) = M.basicClear v
     basicSet (MV_Cell v) x = M.basicSet v x
     basicUnsafeCopy (MV_Cell v1) (MV_Cell v2) = M.basicUnsafeCopy v1 v2
     basicUnsafeMove (MV_Cell v1) (MV_Cell v2) = M.basicUnsafeMove v1 v2
     basicUnsafeGrow (MV_Cell v) n = MV_Cell `liftM` M.basicUnsafeGrow v n
   
   instance V.Vector U.Vector Cell where
     {-# INLINE basicUnsafeFreeze #-}
     {-# INLINE basicUnsafeThaw #-}
     {-# INLINE basicLength #-}
     {-# INLINE basicUnsafeSlice #-}
     {-# INLINE basicUnsafeIndexM #-}
     {-# INLINE elemseq #-}
   
     basicUnsafeFreeze (MV_Cell v) = V_Cell `liftM` V.basicUnsafeFreeze v
     basicUnsafeThaw (V_Cell v) = MV_Cell `liftM` V.basicUnsafeThaw v
     basicLength (V_Cell v) = V.basicLength v
     basicUnsafeSlice i n (V_Cell v) = V_Cell $ V.basicUnsafeSlice i n v
     basicUnsafeIndexM (V_Cell v) i = V.basicUnsafeIndexM v i
     basicUnsafeCopy (MV_Cell mv) (V_Cell v) = V.basicUnsafeCopy mv v
     elemseq _ = seq
   
   main = print $ show $ U.singleton Open
   

   那不是很有趣吗？

3. 创建一个Storable 实例并改用Data.Vector.Storable。

   优点：没有 TH，实例相对简单

   缺点：实例不如 TH 定义明显。此外，每当你问一个关于 Storable 向量的 SO 问题时，总会有人问你为什么不使用 Unboxed 向量，尽管似乎没有人知道为什么 Unboxed 向量更好。

   对于数据：

   {-# LANGUAGE ScopedTypeVariables #-}
   
   import Control.Monad
   import Data.Vector.Storable
   import Foreign.Storable
   
   import GHC.Ptr
   import GHC.Int
   
   -- defined in HsBaseConfig.h as 
   -- #define HTYPE_INT Int32
   type HTYPE_INT = Int32
   
   data Cell = Open | Blocked deriving (Show)
   
   instance Storable Cell where
    sizeOf _          = sizeOf (undefined::HTYPE_INT)
    alignment _       = alignment (undefined::HTYPE_INT)
    peekElemOff p i   = liftM (\x -> case x of 
                           (0::HTYPE_INT) -> Blocked
                           otherwise -> Open) $ peekElemOff (castPtr p) i
    pokeElemOff p i x = pokeElemOff (castPtr p) i $ case x of
       Blocked -> 0
       Open -> (1 :: HTYPE_INT)
   
   main = print $ show $ singleton Open
   

   或者对于新类型：

   {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   
   import Data.Vector.Storable as S
   import Foreign.Storable
   
   newtype Cell = IsOpen Bool deriving (Show)
   
   main = print $ show $ S.singleton (Foo True)
   

4. 为newtype拆箱实例

   这并不直接适用于您的问题，因为您没有 newtype，但为了完整起见，我将其包括在内。

   优点：没有 TH，无需编写代码，仍然使用 Unboxed 向量作为仇恨者

   缺点：没有？

   {-# LANGUAGE GeneralizedNewtypeDeriving, 
                StandaloneDeriving, 
                MultiParamTypeClasses #-}
   
   import Data.Vector.Generic as V
   import Data.Vector.Generic.Mutable as M
   import Data.Vector.Unboxed as U
   
   newtype Cell = IsOpen Bool deriving (Unbox, Show)
   deriving instance V.Vector U.Vector Cell
   deriving instance M.MVector U.MVector Cell
   
   main = print $ show $ U.singleton (IsOpen True)
   

   编辑

   请注意，此解决方案目前为isn't possible in GHC 7.8。