Logo Questions Linux Laravel Mysql Ubuntu Git Menu
 

creating custom instance of UArray

Suppose I have a simple data type like:

data Cell = Open | Blocked

and I'd like to use a UArray Int Cell. Is there an easy way to do this? Can I somehow reuse the definition for UArray Int Bool?

like image 873
ErikR Avatar asked Feb 20 '14 02:02

ErikR


1 Answers

This answer explains why Vectors are better than Arrays, so I'm going to give you the answer for unboxed vectors.

I did try deriving an MArray and IArray instance for Cell based on the Bool instances, but the Bool instances are quite complicated; it would be at least as ugly as manually deriving an Unbox instance for vectors. Unlike vectors, you also can't just derive Storable and use Storable arrays: you still need the Marray and IArray instances. There doesn't appear to be a nice TH solution yet, so you're better off using vectors for those reasons as well.

There are several ways to do this, some more painful than others.

  1. vector-th-unbox

    Pros: Straightforward, much shorter than manually deriving Unbox instances

    Cons: Requires -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. Write your own Unbox, M.MVector, and V.Vector instances, plus two data instances

    {-# 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
    

    Wasn't that fun?

  3. Create a Storable instance and use Data.Vector.Storable instead.

    Pros: No TH, and relatively simple instance

    Cons: The instance is less obvious than the TH definition. Also, whenever you ask a SO question about Storable vectors, someone will inevitably ask why you aren't using Unboxed vectors, though no one seems to know why Unboxed vectors are better.

    For a data:

    {-# 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
    

    Or for a newtype:

    {-# 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. Unbox instances for newtype

    This doesn't directly apply to your question since you don't have a newtype, but I'll include it for completeness.

    Pros: No TH, no code to write, still using Unboxed vectors for the haters

    Cons: None?

    {-# 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)
    

    EDIT

    Note that this solution currently isn't possible in GHC 7.8.

like image 143
crockeea Avatar answered Nov 06 '22 06:11

crockeea