module Data.Vector.HFixed.HVec (
HVec
, MutableHVec
, newMutableHVec
, unsafeFreezeHVec
, readMutableHVec
, writeMutableHVec
, modifyMutableHVec
, modifyMutableHVec'
) where
import Control.Monad.ST (ST,runST)
import Control.Monad.Primitive (PrimMonad(..))
import Control.DeepSeq (NFData(..))
import Data.Monoid (Monoid(..))
import Data.List (intercalate)
import Data.Primitive.Array (Array,MutableArray,newArray,writeArray,readArray,
indexArray, unsafeFreezeArray)
import GHC.Prim (Any)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Vector.Fixed.Cont as F (Arity(..))
import qualified Data.Vector.HFixed as H
import Data.Vector.HFixed.Class
newtype HVec (xs :: [*]) = HVec (Array Any)
instance (ArityC Show xs) => Show (HVec xs) where
show v
= "[" ++ intercalate ", " (H.foldr (Proxy :: Proxy Show) (\x xs -> show x : xs) [] v) ++ "]"
instance (ArityC Eq xs) => Eq (HVec xs) where
(==) = H.eq
instance (ArityC Ord xs, Eq (HVec xs)) => Ord (HVec xs) where
compare = H.compare
instance (ArityC Monoid xs) => Monoid (HVec xs) where
mempty = H.replicate (Proxy :: Proxy Monoid) mempty
mappend = H.zipMono (Proxy :: Proxy Monoid) mappend
instance (ArityC NFData xs) => NFData (HVec xs) where
rnf = H.rnf
instance Arity xs => HVector (HVec xs) where
type Elems (HVec xs) = xs
inspect (HVec arr) = inspectFF arr
construct = constructFF
inspectFF :: forall xs r. Arity xs => Array Any -> Fun xs r -> r
inspectFF arr
= runContVec
$ apply (\(T_insp i a) -> ( unsafeCoerce $ indexArray a i
, T_insp (i+1) a))
(T_insp 0 arr :: T_insp xs)
constructFF :: forall xs. Arity xs => Fun xs (HVec xs)
constructFF
= Fun $ accum (\(T_con i box) a -> T_con (i+1) (writeToBox (unsafeCoerce a) i box))
(\(T_con _ box) -> HVec $ runBox len box :: HVec xs)
(T_con 0 (Box $ \_ -> return ()) :: T_con xs)
where
len = arity (Proxy :: Proxy xs)
data T_insp (xs :: [*]) = T_insp Int (Array Any)
data T_con (xs :: [*]) = T_con Int (Box Any)
newtype Box a = Box (forall s. MutableArray s a -> ST s ())
writeToBox :: a -> Int -> Box a -> Box a
writeToBox a i (Box f) = Box $ \arr -> f arr >> (writeArray arr i $! a)
runBox :: Int -> Box a -> Array a
runBox size (Box f) = runST $ do arr <- newArray size uninitialised
f arr
unsafeFreezeArray arr
uninitialised :: a
uninitialised = error "Data.Vector.HFixed: uninitialised element"
newtype MutableHVec s (xs :: [*]) = MutableHVec (MutableArray s Any)
newMutableHVec :: forall m xs. (PrimMonad m, Arity xs)
=> m (MutableHVec (PrimState m) xs)
newMutableHVec = do
arr <- newArray n uninitialised
return $ MutableHVec arr
where
n = arity (Proxy :: Proxy xs)
unsafeFreezeHVec :: (PrimMonad m) => MutableHVec (PrimState m) xs -> m (HVec xs)
unsafeFreezeHVec (MutableHVec marr) = do
arr <- unsafeFreezeArray marr
return $ HVec arr
readMutableHVec :: (PrimMonad m, Index n xs, Arity xs)
=> MutableHVec (PrimState m) xs
-> n
-> m (ValueAt n xs)
readMutableHVec (MutableHVec arr) n = do
a <- readArray arr $ F.arity n
return $ unsafeCoerce a
writeMutableHVec :: (PrimMonad m, Index n xs, Arity xs)
=> MutableHVec (PrimState m) xs
-> n
-> ValueAt n xs
-> m ()
writeMutableHVec (MutableHVec arr) n a = do
writeArray arr (F.arity n) (unsafeCoerce a)
modifyMutableHVec :: (PrimMonad m, Index n xs, Arity xs)
=> MutableHVec (PrimState m) xs
-> n
-> (ValueAt n xs -> ValueAt n xs)
-> m ()
modifyMutableHVec hvec n f = do
a <- readMutableHVec hvec n
writeMutableHVec hvec n (f a)
modifyMutableHVec' :: (PrimMonad m, Index n xs, Arity xs)
=> MutableHVec (PrimState m) xs
-> n
-> (ValueAt n xs -> ValueAt n xs)
-> m ()
modifyMutableHVec' hvec n f = do
a <- readMutableHVec hvec n
writeMutableHVec hvec n $! f a