{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE Rank2Types           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Heterogeneous vector parametric in its elements
module Data.Vector.HFixed.HVec (
    -- * Generic heterogeneous vector
    HVec
  , HVecF
  ) where

import Control.Monad.ST        (ST,runST)
import Data.Functor.Identity   (Identity(..))
import Data.Functor.Classes
import Control.DeepSeq         (NFData(..))
import Data.Semigroup          (Semigroup(..))
import Data.Monoid             (All(..))
import Data.List               (intersperse,intercalate)
import Data.Primitive.SmallArray ( SmallArray, SmallMutableArray, newSmallArray
                                 , writeSmallArray, indexSmallArray
                                 , unsafeFreezeSmallArray)
import GHC.Exts                (Any)
import Unsafe.Coerce           (unsafeCoerce)

import qualified Data.Vector.HFixed     as H
import Data.Vector.HFixed.Class



----------------------------------------------------------------
-- HVecF
----------------------------------------------------------------

-- | Heterogeneous vector parametrized by common type constructor.
newtype HVecF (xs :: [*]) (f :: * -> *) = HVecF (SmallArray Any)

instance Arity xs => HVectorF (HVecF xs) where
  type ElemsF (HVecF xs) = xs
  inspectF :: HVecF xs f -> TFun f (ElemsF (HVecF xs)) a -> a
inspectF (HVecF SmallArray Any
arr)
    = ContVecF xs f -> forall r. TFun f xs r -> r
forall α (xs :: [α]) (f :: α -> *).
ContVecF xs f -> forall r. TFun f xs r -> r
runContVecF
    (ContVecF xs f -> forall r. TFun f xs r -> r)
-> ContVecF xs f -> forall r. TFun f xs r -> r
forall a b. (a -> b) -> a -> b
$ (forall a (as :: [*]). T_insp (a : as) -> (f a, T_insp as))
-> T_insp xs -> ContVecF xs f
forall α (xs :: [α]) (t :: [α] -> *) (f :: α -> *).
Arity xs =>
(forall (a :: α) (as :: [α]). t (a : as) -> (f a, t as))
-> t xs -> ContVecF xs f
apply (\(T_insp i a) -> ( Any -> f a
forall a b. a -> b
unsafeCoerce (Any -> f a) -> Any -> f a
forall a b. (a -> b) -> a -> b
$ SmallArray Any -> Int -> Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Any
a Int
i
                              , Int -> SmallArray Any -> T_insp as
forall (xs :: [*]). Int -> SmallArray Any -> T_insp xs
T_insp (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SmallArray Any
a))
            (Int -> SmallArray Any -> T_insp xs
forall (xs :: [*]). Int -> SmallArray Any -> T_insp xs
T_insp Int
0 SmallArray Any
arr)
  {-# INLINE inspectF #-}
  constructF :: TFun f (ElemsF (HVecF xs)) (HVecF xs f)
constructF = (forall a (as :: [*]). T_con (a : as) -> f a -> T_con as)
-> (T_con '[] -> HVecF xs f) -> T_con xs -> TFun f xs (HVecF xs f)
forall α (xs :: [α]) (t :: [α] -> *) (f :: α -> *) b.
Arity xs =>
(forall (a :: α) (as :: [α]). t (a : as) -> f a -> t as)
-> (t '[] -> b) -> t xs -> TFun f xs b
accum
    (\(T_con i box) f a
a -> Int -> Box Any -> T_con as
forall (xs :: [*]). Int -> Box Any -> T_con xs
T_con (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Any -> Int -> Box Any -> Box Any
forall a. a -> Int -> Box a -> Box a
writeToBox (f a -> Any
forall a b. a -> b
unsafeCoerce f a
a) Int
i Box Any
box))
    (\(T_con Int
_ Box Any
box)   -> SmallArray Any -> HVecF xs f
forall (xs :: [*]) (f :: * -> *). SmallArray Any -> HVecF xs f
HVecF (SmallArray Any -> HVecF xs f) -> SmallArray Any -> HVecF xs f
forall a b. (a -> b) -> a -> b
$ Int -> Box Any -> SmallArray Any
forall a. Int -> Box a -> SmallArray a
runBox Int
len Box Any
box)
    (Int -> Box Any -> T_con xs
forall (xs :: [*]). Int -> Box Any -> T_con xs
T_con Int
0 ((forall s. SmallMutableArray s Any -> ST s ()) -> Box Any
forall a. (forall s. SmallMutableArray s a -> ST s ()) -> Box a
Box ((forall s. SmallMutableArray s Any -> ST s ()) -> Box Any)
-> (forall s. SmallMutableArray s Any -> ST s ()) -> Box Any
forall a b. (a -> b) -> a -> b
$ \SmallMutableArray s Any
_ -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
    where
    len :: Int
len = Proxy xs -> Int
forall α (xs :: [α]) (p :: [α] -> *). Arity xs => p xs -> Int
arity (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)
  {-# INLINE constructF #-}

data T_insp (xs :: [*]) = T_insp Int (SmallArray Any)
data T_con  (xs :: [*]) = T_con  Int (Box Any)

-- Helper data type for creating of array
newtype Box a = Box (forall s. SmallMutableArray s a -> ST s ())

writeToBox :: a -> Int -> Box a -> Box a
{-# INLINE writeToBox #-}
writeToBox :: a -> Int -> Box a -> Box a
writeToBox a
a Int
i (Box forall s. SmallMutableArray s a -> ST s ()
f) = (forall s. SmallMutableArray s a -> ST s ()) -> Box a
forall a. (forall s. SmallMutableArray s a -> ST s ()) -> Box a
Box ((forall s. SmallMutableArray s a -> ST s ()) -> Box a)
-> (forall s. SmallMutableArray s a -> ST s ()) -> Box a
forall a b. (a -> b) -> a -> b
$ \SmallMutableArray s a
arr -> SmallMutableArray s a -> ST s ()
forall s. SmallMutableArray s a -> ST s ()
f SmallMutableArray s a
arr ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (SmallMutableArray (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
arr Int
i (a -> ST s ()) -> a -> ST s ()
forall a b. (a -> b) -> a -> b
$! a
a)

runBox :: Int -> Box a -> SmallArray a
{-# INLINE runBox #-}
runBox :: Int -> Box a -> SmallArray a
runBox Int
size (Box forall s. SmallMutableArray s a -> ST s ()
f) = (forall s. ST s (SmallArray a)) -> SmallArray a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (SmallArray a)) -> SmallArray a)
-> (forall s. ST s (SmallArray a)) -> SmallArray a
forall a b. (a -> b) -> a -> b
$ do SmallMutableArray s a
arr <- Int -> a -> ST s (SmallMutableArray (PrimState (ST s)) a)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
size a
forall a. a
uninitialised
                                 SmallMutableArray s a -> ST s ()
forall s. SmallMutableArray s a -> ST s ()
f SmallMutableArray s a
arr
                                 SmallMutableArray (PrimState (ST s)) a -> ST s (SmallArray a)
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
unsafeFreezeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
arr

uninitialised :: a
uninitialised :: a
uninitialised = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.Vector.HFixed: uninitialised element"


instance (Show1 f, ArityC Show xs) => Show (HVecF xs f) where
  showsPrec :: Int -> HVecF xs f -> ShowS
showsPrec Int
_ HVecF xs f
v = Char -> ShowS
showChar Char
'['
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id
                  ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
',')
                  ([ShowS] -> [ShowS]) -> [ShowS] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ Proxy Show
-> (forall a. Show a => f a -> [ShowS] -> [ShowS])
-> [ShowS]
-> HVecF xs f
-> [ShowS]
forall (v :: (* -> *) -> *) (c :: * -> Constraint) (f :: * -> *) b.
(HVectorF v, ArityC c (ElemsF v)) =>
Proxy c -> (forall a. c a => f a -> b -> b) -> b -> v f -> b
H.foldrF (Proxy Show
forall k (t :: k). Proxy t
Proxy @Show) (\f a
x [ShowS]
xs -> Int -> f a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 Int
0 f a
x ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [ShowS]
xs) [] HVecF xs f
v
                  )
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'
instance (Eq1 f, ArityC Eq xs) => Eq (HVecF xs f) where
  HVecF xs f
v == :: HVecF xs f -> HVecF xs f -> Bool
== HVecF xs f
u = All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$ Proxy Eq
-> (forall a. Eq a => f a -> f a -> All)
-> HVecF xs f
-> HVecF xs f
-> All
forall (v :: (* -> *) -> *) (c :: * -> Constraint) m (f :: * -> *).
(HVectorF v, ArityC c (ElemsF v), Monoid m) =>
Proxy c -> (forall a. c a => f a -> f a -> m) -> v f -> v f -> m
H.zipFoldF (Proxy Eq
forall k (t :: k). Proxy t
Proxy @Eq) (\f a
x f a
y -> Bool -> All
All (f a -> f a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 f a
x f a
y)) HVecF xs f
v HVecF xs f
u
instance (Ord1 f, ArityC Eq xs, ArityC Ord xs) => Ord (HVecF xs f) where
  compare :: HVecF xs f -> HVecF xs f -> Ordering
compare = Proxy Ord
-> (forall a. Ord a => f a -> f a -> Ordering)
-> HVecF xs f
-> HVecF xs f
-> Ordering
forall (v :: (* -> *) -> *) (c :: * -> Constraint) m (f :: * -> *).
(HVectorF v, ArityC c (ElemsF v), Monoid m) =>
Proxy c -> (forall a. c a => f a -> f a -> m) -> v f -> v f -> m
H.zipFoldF (Proxy Ord
forall k (t :: k). Proxy t
Proxy :: Proxy Ord) forall a. Ord a => f a -> f a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

----------------------------------------------------------------
-- HVec
----------------------------------------------------------------

-- | Generic heterogeneous vector
newtype HVec (xs :: [*]) = HVec (HVecF xs Identity)

instance Arity xs => HVector (HVec xs) where
  type Elems (HVec xs) = xs
  inspect :: HVec xs -> Fun (Elems (HVec xs)) a -> a
inspect (HVec HVecF xs Identity
v) = HVecF xs Identity -> TFun Identity (ElemsF (HVecF xs)) a -> a
forall α (v :: (α -> *) -> *) (f :: α -> *) a.
HVectorF v =>
v f -> TFun f (ElemsF v) a -> a
inspectF HVecF xs Identity
v
  construct :: Fun (Elems (HVec xs)) (HVec xs)
construct = HVecF xs Identity -> HVec xs
forall (xs :: [*]). HVecF xs Identity -> HVec xs
HVec (HVecF xs Identity -> HVec xs)
-> TFun Identity xs (HVecF xs Identity)
-> TFun Identity xs (HVec xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TFun Identity xs (HVecF xs Identity)
forall α (v :: (α -> *) -> *) (f :: α -> *).
HVectorF v =>
TFun f (ElemsF v) (v f)
constructF
  {-# INLINE inspect   #-}
  {-# INLINE construct #-}

instance (ArityC Show xs) => Show (HVec xs) where
  show :: HVec xs -> [Char]
show HVec xs
v
    = [Char]
"[" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (Proxy Show
-> (forall a. Show a => a -> [[Char]] -> [[Char]])
-> [[Char]]
-> HVec xs
-> [[Char]]
forall v (c :: * -> Constraint) b.
(HVector v, ArityC c (Elems v)) =>
Proxy c -> (forall a. c a => a -> b -> b) -> b -> v -> b
H.foldr (Proxy Show
forall k (t :: k). Proxy t
Proxy :: Proxy Show) (\a
x [[Char]]
xs -> a -> [Char]
forall a. Show a => a -> [Char]
show a
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs) [] HVec xs
v) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

instance (ArityC Eq xs) => Eq (HVec xs) where
  == :: HVec xs -> HVec xs -> Bool
(==) = HVec xs -> HVec xs -> Bool
forall v. (HVector v, ArityC Eq (Elems v)) => v -> v -> Bool
H.eq
  {-# INLINE (==) #-}

-- NOTE: We need to add `Eq (HVec xs)' since GHC cannot deduce that
--       `ArityC Ord xs => ArityC Eq xs' for all xs
instance (ArityC Ord xs, ArityC Eq xs) => Ord (HVec xs) where
  compare :: HVec xs -> HVec xs -> Ordering
compare = HVec xs -> HVec xs -> Ordering
forall v. (HVector v, ArityC Ord (Elems v)) => v -> v -> Ordering
H.compare
  {-# INLINE compare #-}

instance (ArityC Monoid xs
-- NOTE: Sadly we cannot infer `ArityC Semigroup' xs from `ArityC Monoid xs'
--       Thus we have to specify both
#if MIN_VERSION_base(4,11,0)
         , ArityC Semigroup xs
#endif
         ) => Monoid (HVec xs) where
  mempty :: HVec xs
mempty  = Proxy Monoid -> (forall x. Monoid x => x) -> HVec xs
forall v (c :: * -> Constraint).
(HVector v, ArityC c (Elems v)) =>
Proxy c -> (forall x. c x => x) -> v
H.replicate (Proxy Monoid
forall k (t :: k). Proxy t
Proxy @Monoid) forall x. Monoid x => x
mempty
  mappend :: HVec xs -> HVec xs -> HVec xs
mappend = Proxy Monoid
-> (forall a. Monoid a => a -> a -> a)
-> HVec xs
-> HVec xs
-> HVec xs
forall v (c :: * -> Constraint).
(HVector v, ArityC c (Elems v)) =>
Proxy c -> (forall a. c a => a -> a -> a) -> v -> v -> v
H.zipWith   (Proxy Monoid
forall k (t :: k). Proxy t
Proxy @Monoid) forall a. Monoid a => a -> a -> a
mappend
  {-# INLINE mempty  #-}
  {-# INLINE mappend #-}

instance (ArityC Semigroup xs) => Semigroup (HVec xs) where
  <> :: HVec xs -> HVec xs -> HVec xs
(<>) = Proxy Semigroup
-> (forall a. Semigroup a => a -> a -> a)
-> HVec xs
-> HVec xs
-> HVec xs
forall v (c :: * -> Constraint).
(HVector v, ArityC c (Elems v)) =>
Proxy c -> (forall a. c a => a -> a -> a) -> v -> v -> v
H.zipWith   (Proxy Semigroup
forall k (t :: k). Proxy t
Proxy @Semigroup) forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE (<>) #-}

instance (ArityC NFData xs) => NFData (HVec xs) where
  rnf :: HVec xs -> ()
rnf = HVec xs -> ()
forall v. (HVector v, ArityC NFData (Elems v)) => v -> ()
H.rnf
  {-# INLINE rnf #-}