module Data.Vector.HFixed.HVec (
HVec
, HVecF
) where
import Control.Monad.ST (ST,runST)
import Data.Functor.Identity (Identity(..))
import Data.Functor.Classes
import Control.DeepSeq (NFData(..))
import Data.Monoid (Monoid(..),All(..))
import Data.List (intersperse,intercalate)
import Data.Primitive.SmallArray ( SmallArray, SmallMutableArray, newSmallArray
, writeSmallArray, indexSmallArray
, unsafeFreezeSmallArray)
import Text.Show (showChar)
import GHC.Exts (Any)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Vector.HFixed as H
import Data.Vector.HFixed.Class
newtype HVecF (xs :: [*]) (f :: * -> *) = HVecF (SmallArray Any)
instance Arity xs => HVectorF (HVecF xs) where
type ElemsF (HVecF xs) = xs
inspectF (HVecF arr)
= runContVecF
$ apply (\(T_insp i a) -> ( unsafeCoerce $ indexSmallArray a i
, T_insp (i+1) a))
(T_insp 0 arr)
constructF = accum
(\(T_con i box) a -> T_con (i+1) (writeToBox (unsafeCoerce a) i box))
(\(T_con _ box) -> HVecF $ runBox len box)
(T_con 0 (Box $ \_ -> return ()))
where
len = arity (Proxy @ xs)
data T_insp (xs :: [*]) = T_insp Int (SmallArray Any)
data T_con (xs :: [*]) = T_con Int (Box Any)
newtype Box a = Box (forall s. SmallMutableArray s a -> ST s ())
writeToBox :: a -> Int -> Box a -> Box a
writeToBox a i (Box f) = Box $ \arr -> f arr >> (writeSmallArray arr i $! a)
runBox :: Int -> Box a -> SmallArray a
runBox size (Box f) = runST $ do arr <- newSmallArray size uninitialised
f arr
unsafeFreezeSmallArray arr
uninitialised :: a
uninitialised = error "Data.Vector.HFixed: uninitialised element"
instance (Show1 f, ArityC Show xs) => Show (HVecF xs f) where
showsPrec _ v = showChar '['
. ( foldr (.) id
$ intersperse (showChar ',')
$ H.foldrF (Proxy @ Show) (\x xs -> showsPrec1 0 x : xs) [] v
)
. showChar ']'
instance (Eq1 f, ArityC Eq xs) => Eq (HVecF xs f) where
v == u = getAll $ H.zipFoldF (Proxy @ Eq) (\x y -> All (eq1 x y)) v u
instance (Ord1 f, ArityC Eq xs, ArityC Ord xs) => Ord (HVecF xs f) where
compare = H.zipFoldF (Proxy :: Proxy Ord) compare1
newtype HVec (xs :: [*]) = HVec (HVecF xs Identity)
instance Arity xs => HVector (HVec xs) where
type Elems (HVec xs) = xs
inspect (HVec v) = inspectF v
construct = HVec <$> constructF
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, ArityC Eq xs) => Ord (HVec xs) where
compare = H.compare
instance (ArityC Monoid xs) => Monoid (HVec xs) where
mempty = H.replicate (Proxy @ Monoid) mempty
mappend = H.zipWith (Proxy @ Monoid) mappend
instance (ArityC NFData xs) => NFData (HVec xs) where
rnf = H.rnf