{- | Description: records where elements are stored in unboxed arrays

The public interface is exported from <Data-HList-CommonMain.html#t:RecordU RecordU>

-}
module Data.HList.RecordU where

import Data.Array.Unboxed
import Data.HList.FakePrelude
import Data.HList.Record
import Data.HList.HList

import Data.HList.HArray
import LensDefs

import Data.HList.Labelable

import Unsafe.Coerce

-- * Type definitions
-- ** RecordUS

{- | 'RecordUS' is stored as a 'HList' of 'RecordU' 
to allow the 'RecordUS' to contain elements of different
types, so long all of the types can be put into an unboxed
array ('UArray').

It is advantageous (at least space-wise) to sort the record to keep
elements with the same types elements adjacent. See 'SortForRecordUS'
for more details.  -}
newtype RecordUS (x :: [*]) =
    RecordUS Any -- ^ Any here is the @HList u@
                 -- given @'RecordUSCxt' x u@

-- | connect the unpacked @x@ representation with the
-- corresponding list of RecordU @u@ representation.
class RecordUSCxt (x :: [*]) (u :: [*]) | x -> u, u -> x where
  {- | @O(1)@ should be possible to implement this without
  unsafeCoerce, but we want to hide the @u@ parameter _and_
  keep the RecordUSCxt as a class (instead of a type
  family) because of 'HEq'. In some cases it is possible
  to have instances that do not actually respect the functional
  dependency, but this should be safe if the check is not
  disabled (by using @-XDysfunctionalDependencies@
  <https://phabricator.haskell.org/D69>, or ghc-7.6) -}
  recordUSToHList :: RecordUS x -> HList u
  recordUSToHList (RecordUS Any
x) = Any -> HList u
forall a b. a -> b
unsafeCoerce Any
x

  -- | @O(1)@ should be possible to implement this without
  -- unsafeCoerce
  hListToRecordUS :: HList u -> RecordUS x
  hListToRecordUS HList u
x = Any -> RecordUS x
forall (x :: [*]). Any -> RecordUS x
RecordUS (HList u -> Any
forall a b. a -> b
unsafeCoerce HList u
x)

-- | the only instance
instance (HGroupBy EqTagValue x g, HMapUnboxF g u) => RecordUSCxt x u

data EqTagValue
instance HEqByFn EqTagValue
instance (txv ~ Tagged x v,
          tyw ~ Tagged y w,
          HEq v w b) => HEqBy EqTagValue txv tyw b

-- | proof that @'hMap' 'UnboxF' :: r xs -> r us@ can determine
-- @xs@ from @us@ and @us@ from @xs@
class HMapUnboxF (xs :: [*]) (us :: [*]) | xs -> us, us -> xs
instance HMapUnboxF '[] '[]
instance HMapUnboxF xs us => HMapUnboxF (HList x ': xs) (RecordU x ': us)


instance (RecordUSCxt x u, Show (HList u)) => Show (RecordUS x) where
    showsPrec :: Int -> RecordUS x -> ShowS
showsPrec Int
n RecordUS x
r = (String
"RecordUS " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HList u -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n (RecordUS x -> HList u
forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
RecordUS x -> HList u
recordUSToHList RecordUS x
r)

-- ** RecordU

{- | A type which behaves similarly to 'Record', except
all elements must fit in the same 'UArray'. A consequence of
this is that @RecordU@ has the following properties:

* it is strict in the element types

* it cannot do type-changing updates of 'RecordU', except if
  the function applies to all elements

* it probably is slower to update the very first elements
  of the 'RecordU'

The benefit is that lookups should be faster and records
should take up less space. However benchmarks done with
a slow 'HNat2Integral' do not suggest that RecordU is
faster than Record.
-}
newtype RecordU l = RecordU (UArray Int (GetElemTy l))

type family GetElemTy (x :: [*]) :: *
type instance GetElemTy (Tagged label v ': rest) = v

deriving instance (Show (UArray Int (GetElemTy l))) => Show (RecordU l)
deriving instance (Read (UArray Int (GetElemTy l))) => Read (RecordU l)
deriving instance (Eq  (UArray Int (GetElemTy l))) => Eq  (RecordU l)
deriving instance (Ord (UArray Int (GetElemTy l))) => Ord (RecordU l)

{- | Reorders a 'Record' such that the 'RecordUS' made from it takes up
less space

'Bad' has alternating Double and Int fields

>>> bad
Record{x=1.0,i=2,y=3.0,j=4}

4 arrays containing one element each are needed when this
Record is stored as a RecordUS

>>> recordToRecordUS bad
RecordUS H[RecordU (array (0,0) [(0,1.0)]),RecordU (array (0,0) [(0,2)]),RecordU (array (0,0) [(0,3.0)]),RecordU (array (0,0) [(0,4)])]

It is possible to sort the record

>>> sortForRecordUS bad
Record{x=1.0,y=3.0,i=2,j=4}

This allows the same content to be stored in
two unboxed arrays

>>> recordToRecordUS (sortForRecordUS bad)
RecordUS H[RecordU (array (0,1) [(0,1.0),(1,3.0)]),RecordU (array (0,1) [(0,2),(1,4)])]

-}
class SortForRecordUS x x' | x -> x' where
    sortForRecordUS :: Record x -> Record x'

instance SortForRecordUS '[] '[] where
    sortForRecordUS :: Record '[] -> Record '[]
sortForRecordUS = Record '[] -> Record '[]
forall a. a -> a
id

instance (HPartitionEq EqTagValue x (x ': xs) xi xo,
          SortForRecordUS xo xo',
          sorted ~ HAppendListR xi xo',
          HAppendList xi xo') =>
  SortForRecordUS (x ': xs) sorted where
  sortForRecordUS :: Record (x : xs) -> Record sorted
sortForRecordUS (Record HList (x : xs)
xs) = HList sorted -> Record sorted
forall (r :: [*]). HList r -> Record r
Record (HList xi -> HList xo' -> HList (HAppendListR xi xo')
forall (l1 :: [*]) (l2 :: [*]).
HAppendList l1 l2 =>
HList l1 -> HList l2 -> HList (HAppendListR l1 l2)
hAppendList HList xi
xi HList xo'
xo')
    where
      f :: Proxy EqTagValue
f  = Proxy EqTagValue
forall k (t :: k). Proxy t
Proxy :: Proxy EqTagValue
      x1 :: Proxy x
x1 = Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x
      (HList xi
xi,HList xo
xo) = Proxy EqTagValue
-> Proxy x -> HList (x : xs) -> (HList xi, HList xo)
forall k k (f :: k) (x1 :: k) (xs :: [*]) (xi :: [*]) (xo :: [*]).
HPartitionEq f x1 xs xi xo =>
Proxy f -> Proxy x1 -> HList xs -> (HList xi, HList xo)
hPartitionEq Proxy EqTagValue
f Proxy x
x1 HList (x : xs)
xs
      Record HList xo'
xo' = Record xo -> Record xo'
forall (x :: [*]) (x' :: [*]).
SortForRecordUS x x' =>
Record x -> Record x'
sortForRecordUS (HList xo -> Record xo
forall (r :: [*]). HList r -> Record r
Record HList xo
xo)

-------------------------------------------------------------- 
-- * Lookup

-- | works expected. See examples attached to 'bad'.
instance (HFindLabel l r n,
          HLookupByHNatUS n u (Tagged l v),
          HasField l (Record r) v,
          RecordUSCxt r u) =>
  HasField l (RecordUS r) v where
  hLookupByLabel :: Label l -> RecordUS r -> v
hLookupByLabel Label l
_ RecordUS r
u = case Proxy n -> HList u -> Tagged l v
forall (n :: HNat) (us :: [*]) e.
HLookupByHNatUS n us e =>
Proxy n -> HList us -> e
hLookupByHNatUS Proxy n
n (RecordUS r -> HList u
forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
RecordUS x -> HList u
recordUSToHList RecordUS r
u) of Tagged v
v -> v
v
    where n :: Proxy n
n = Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n

class HLookupByHNatUS (n :: HNat) (us :: [*]) (e :: *) | n us -> e where
  hLookupByHNatUS :: Proxy n -> HList us -> e

class HLookupByHNatUS1 (r :: Either HNat HNat) (n :: HNat) (u :: [*]) (us :: [*]) (e :: *)
        | r n u us -> e where
  hLookupByHNatUS1 :: Proxy r -> Proxy n -> RecordU u -> HList us -> e

instance (r ~ HSubtract (HLength u) n,
          RecordU u ~ ru,
          HLookupByHNatUS1 r n u us e) =>
  HLookupByHNatUS n (ru ': us) e where
  hLookupByHNatUS :: Proxy n -> HList (ru : us) -> e
hLookupByHNatUS Proxy n
n (HCons u us) = Proxy r -> Proxy n -> RecordU u -> HList us -> e
forall (r :: Either HNat HNat) (n :: HNat) (u :: [*]) (us :: [*])
       e.
HLookupByHNatUS1 r n u us e =>
Proxy r -> Proxy n -> RecordU u -> HList us -> e
hLookupByHNatUS1 (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r) Proxy n
n ru
RecordU u
u HList us
us

instance (HNat2Integral n,
         HLookupByHNatR n u ~ le,
         le ~ Tagged l e,
         IArray UArray e,
         e ~ GetElemTy u) => HLookupByHNatUS1 (Left t) n u us le where
  hLookupByHNatUS1 :: Proxy ('Left t) -> Proxy n -> RecordU u -> HList us -> le
hLookupByHNatUS1 Proxy ('Left t)
_ Proxy n
n (RecordU UArray Int (GetElemTy u)
u) HList us
_us = e -> Tagged l e
forall k (s :: k) b. b -> Tagged s b
Tagged (UArray Int e
UArray Int (GetElemTy u)
u UArray Int e -> Int -> e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Proxy n -> Int
forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral Proxy n
n)

instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where
  hLookupByHNatUS1 :: Proxy ('Right t) -> Proxy n -> RecordU u -> HList us -> e
hLookupByHNatUS1 Proxy ('Right t)
_ Proxy n
_ RecordU u
_ = Proxy t -> HList us -> e
forall (n :: HNat) (us :: [*]) e.
HLookupByHNatUS n us e =>
Proxy n -> HList us -> e
hLookupByHNatUS (Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t)

-- | @HSubtract a b@ is @Left (a-b)@, @Right (b-a)@ or @Right HZero@
type family HSubtract (n1 :: HNat) (n2 :: HNat) :: Either HNat HNat

type instance HSubtract HZero HZero = Right HZero
type instance HSubtract (HSucc x) (HSucc y) = HSubtract x y
type instance HSubtract HZero (HSucc y) = Right (HSucc y)
type instance HSubtract (HSucc y) HZero = Left (HSucc y)




-------------------------------------------------------------- 
-- * Conversion of RecordUS

-- ** with the actual representation

-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@
recordUS :: p (RecordUS x) (f (RecordUS x)) -> p (HList u) (f (HList u))
recordUS p (RecordUS x) (f (RecordUS x))
r = (HList u -> RecordUS x)
-> (RecordUS x -> HList u)
-> p (RecordUS x) (f (RecordUS x))
-> p (HList u) (f (HList u))
forall (p :: * -> * -> *) (f :: * -> *) s a b t.
(Profunctor p, Functor f) =>
(s -> a) -> (b -> t) -> p a (f b) -> p s (f t)
iso HList u -> RecordUS x
forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
HList u -> RecordUS x
hListToRecordUS RecordUS x -> HList u
forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
RecordUS x -> HList u
recordUSToHList p (RecordUS x) (f (RecordUS x))
r

{- | @Iso (HList s) (RecordUS a)@

@s@ is a HList of 'RecordU' while @a :: [*]@
is list of @Tagged label value@

-}
recordUS' :: p (RecordUS x) (f (RecordUS x)) -> p (HList u) (f (HList u))
recordUS' p (RecordUS x) (f (RecordUS x))
r = (p (RecordUS x) (f (RecordUS x)) -> p (HList u) (f (HList u)))
-> p (RecordUS x) (f (RecordUS x)) -> p (HList u) (f (HList u))
forall k1 k2 optic (p :: k1 -> k2 -> *) (a :: k1) (f :: k1 -> k2)
       (s :: k1).
(optic ~ (p a (f a) -> p s (f s))) =>
optic -> optic
isSimple p (RecordUS x) (f (RecordUS x)) -> p (HList u) (f (HList u))
forall (p :: * -> * -> *) (f :: * -> *) (x :: [*]) (g :: [*])
       (x :: [*]) (g :: [*]) (u :: [*]) (u :: [*]).
(Profunctor p, Functor f, HGroupBy EqTagValue x g,
 HGroupBy EqTagValue x g, HMapUnboxF g u, HMapUnboxF g u) =>
p (RecordUS x) (f (RecordUS x)) -> p (HList u) (f (HList u))
recordUS p (RecordUS x) (f (RecordUS x))
r

-- ** with 'Record'

-- | @view unboxedS@ or @^. unboxedS@ are preferred
recordToRecordUS :: forall x g u.
   (HMapCxt HList UnboxF g u,
    HMapUnboxF g u,
    HGroupBy EqTagValue x g,
    RecordUSCxt x u)
   => Record x -> RecordUS x
recordToRecordUS :: Record x -> RecordUS x
recordToRecordUS (Record HList x
x) = HList u -> RecordUS x
forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
HList u -> RecordUS x
hListToRecordUS HList u
u
  where
    u :: HList u
    u :: HList u
u = UnboxF -> HList g -> HList u
forall (a :: [*]) (b :: [*]) (r :: [*] -> *) f.
(SameLength' a b, SameLength' b a, HMapAux r f a b) =>
f -> r a -> r b
hMap UnboxF
UnboxF HList g
g 

    g :: HList g
    g :: HList g
g = Proxy EqTagValue -> HList x -> HList g
forall t (f :: t) (as :: [*]) (gs :: [*]).
HGroupBy f as gs =>
Proxy f -> HList as -> HList gs
hGroupBy (Proxy EqTagValue
forall k (t :: k). Proxy t
Proxy :: Proxy EqTagValue) HList x
x

-- | @^. from unboxedS@ is preferred
recordUSToRecord :: forall u g x.
  (HConcatFD g x,
   HMapCxt HList BoxF u g,
   HMapUnboxF g u,
   RecordUSCxt x u
  ) => RecordUS x -> Record x
recordUSToRecord :: RecordUS x -> Record x
recordUSToRecord RecordUS x
rus = HList x -> Record x
forall (r :: [*]). HList r -> Record r
Record (HList g -> HList x
forall (xxs :: [*]) (xs :: [*]).
HConcatFD xxs xs =>
HList xxs -> HList xs
hConcatFD HList g
g)
  where
    g :: HList g
    g :: HList g
g = BoxF -> HList u -> HList g
forall (a :: [*]) (b :: [*]) (r :: [*] -> *) f.
(SameLength' a b, SameLength' b a, HMapAux r f a b) =>
f -> r a -> r b
hMap BoxF
BoxF (RecordUS x -> HList u
forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
RecordUS x -> HList u
recordUSToHList RecordUS x
rus)

-- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@
unboxedS :: p (RecordUS x) (f (RecordUS x)) -> p (Record x) (f (Record x))
unboxedS p (RecordUS x) (f (RecordUS x))
r = (Record x -> RecordUS x)
-> (RecordUS x -> Record x)
-> p (RecordUS x) (f (RecordUS x))
-> p (Record x) (f (Record x))
forall (p :: * -> * -> *) (f :: * -> *) s a b t.
(Profunctor p, Functor f) =>
(s -> a) -> (b -> t) -> p a (f b) -> p s (f t)
iso Record x -> RecordUS x
forall (x :: [*]) (g :: [*]) (u :: [*]).
(HMapCxt HList UnboxF g u, HMapUnboxF g u, HGroupBy EqTagValue x g,
 RecordUSCxt x u) =>
Record x -> RecordUS x
recordToRecordUS RecordUS x -> Record x
forall (u :: [*]) (g :: [*]) (x :: [*]).
(HConcatFD g x, HMapCxt HList BoxF u g, HMapUnboxF g u,
 RecordUSCxt x u) =>
RecordUS x -> Record x
recordUSToRecord p (RecordUS x) (f (RecordUS x))
r

-- | @Iso' (Record x) (RecordUS x)@
unboxedS' :: p (RecordUS x) (f (RecordUS x)) -> p (Record x) (f (Record x))
unboxedS' p (RecordUS x) (f (RecordUS x))
r = (p (RecordUS x) (f (RecordUS x)) -> p (Record x) (f (Record x)))
-> p (RecordUS x) (f (RecordUS x)) -> p (Record x) (f (Record x))
forall k1 k2 optic (p :: k1 -> k2 -> *) (a :: k1) (f :: k1 -> k2)
       (s :: k1).
(optic ~ (p a (f a) -> p s (f s))) =>
optic -> optic
isSimple p (RecordUS x) (f (RecordUS x)) -> p (Record x) (f (Record x))
forall (g :: [*]) (u :: [*]) (g :: [*]) (u :: [*]) (x :: [*])
       (x :: [*]) (p :: * -> * -> *) (f :: * -> *).
(HMapUnboxF g u, HMapUnboxF g u, HGroupBy EqTagValue x g,
 HGroupBy EqTagValue x g, Profunctor p, Functor f, HConcatFD g x,
 SameLength' u g, SameLength' g u, SameLength' u g, SameLength' g u,
 HMapAux HList UnboxF g u, HMapAux HList BoxF u g) =>
p (RecordUS x) (f (RecordUS x)) -> p (Record x) (f (Record x))
unboxedS p (RecordUS x) (f (RecordUS x))
r



-- | all elements of the list have the same type
class ElemTyEq (xs :: [*])

instance 
 (t1v ~ Tagged t1 v,
  t2v ~ Tagged t2 v,  
  ElemTyEq (tv2 ': rest)) =>
  ElemTyEq (tv1 ': tv2 ': rest)

instance t1v ~ Tagged t v => ElemTyEq (t1v ': rest)
instance ElemTyEq '[]


instance (IArray UArray v,
          v ~ GetElemTy ls,
          HFindLabel l ls n,
          HNat2Integral n)
    => HasField l (RecordU ls) v where
  hLookupByLabel :: Label l -> RecordU ls -> v
hLookupByLabel Label l
_ (RecordU UArray Int (GetElemTy ls)
ls) = UArray Int v
UArray Int (GetElemTy ls)
ls UArray Int v -> Int -> v
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Proxy n -> Int
forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n)


instance (r ~ r',
          v ~ GetElemTy r,
          HFindLabel l r n,
          HNat2Integral n,
          IArray UArray v,
          HasField l (Record r') v)
    => HUpdateAtLabel RecordU l v r r' where
  hUpdateAtLabel :: Label l -> v -> RecordU r -> RecordU r'
hUpdateAtLabel Label l
_ v
v (RecordU UArray Int (GetElemTy r)
r) = UArray Int (GetElemTy r') -> RecordU r'
forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU (UArray Int v
UArray Int (GetElemTy r)
r UArray Int v -> [(Int, v)] -> UArray Int v
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Proxy n -> Int
forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n), v
v)])


{- | analogous flip '//'. Similar to '.<++.', except it is restricted
to cases where the left argument holds a subset of elements.

-}
class HUpdateMany lv rx where
    hUpdateMany :: Record lv -> rx -> rx

instance (RecordValues lv,
          HList2List (RecordValuesR lv) v,
          HFindMany (LabelsOf lv) (LabelsOf r) ixs,
          IArray UArray v,
          v ~ GetElemTy r,
          HNats2Integrals ixs) =>
  HUpdateMany lv (RecordU r) where
  hUpdateMany :: Record lv -> RecordU r -> RecordU r
hUpdateMany Record lv
lv (RecordU UArray Int (GetElemTy r)
r) = UArray Int (GetElemTy r) -> RecordU r
forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU (UArray Int v
UArray Int (GetElemTy r)
r UArray Int v -> [(Int, v)] -> UArray Int v
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// ([Int] -> [v] -> [(Int, v)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ixs (HList (RecordValuesR lv) -> [v]
forall (l :: [*]) e. HList2List l e => HList l -> [e]
hList2List (Record lv -> HList (RecordValuesR lv)
forall (r :: [*]).
RecordValues r =>
Record r -> HList (RecordValuesR r)
recordValues Record lv
lv))))
     where ixs :: [Int]
ixs = Proxy ixs -> [Int]
forall (ns :: [HNat]) i.
(HNats2Integrals ns, Integral i) =>
Proxy ns -> [i]
hNats2Integrals (Proxy ixs
forall k (t :: k). Proxy t
Proxy :: Proxy ixs)

-- | implementation in terms of '.<++.'
instance (HLeftUnion lv x lvx,
          HRLabelSet x,
          HLabelSet (LabelsOf x),
          HRearrange (LabelsOf x) lvx x)
  => HUpdateMany lv (Record x) where
    hUpdateMany :: Record lv -> Record x -> Record x
hUpdateMany Record lv
lv Record x
x = Record lvx -> Record x
forall (l :: [*]) (r :: [*]).
(HLabelSet (LabelsOf l), HRearrange3 (LabelsOf l) r l,
 SameLength' (LabelsOf l) r, SameLength' r (LabelsOf l),
 SameLength' r l, SameLength' l r) =>
Record r -> Record l
hRearrange' (Record lv
lv Record lv -> Record x -> Record lvx
forall (r :: [*]) (r' :: [*]) (r'' :: [*]).
HLeftUnion r r' r'' =>
Record r -> Record r' -> Record r''
.<++. Record x
x)

-- | behaves like @map 'HFind'@
class HFindMany (ls :: [k]) (r :: [k]) (ns :: [HNat]) | ls r  -> ns
instance (HFind l r n,
          HFindMany ls r ns) => HFindMany (l ': ls) r (n ': ns)

instance HFindMany '[] r '[]

instance (ApplyAB f (GetElemTy x) (GetElemTy y),
          IArray UArray (GetElemTy y),
          IArray UArray (GetElemTy x)) => HMapAux RecordU f x y where
    hMapAux :: f -> RecordU x -> RecordU y
hMapAux f
f (RecordU UArray Int (GetElemTy x)
x) = UArray Int (GetElemTy y) -> RecordU y
forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU ((GetElemTy x -> GetElemTy y)
-> UArray Int (GetElemTy x) -> UArray Int (GetElemTy y)
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap (f -> GetElemTy x -> GetElemTy y
forall f a b. ApplyAB f a b => f -> a -> b
applyAB f
f) UArray Int (GetElemTy x)
x)

-- | 'hMap' specialized to 'RecordU'
hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y
hMapRU :: f -> RecordU x -> RecordU y
hMapRU f
f = f -> RecordU x -> RecordU y
forall (a :: [*]) (b :: [*]) (r :: [*] -> *) f.
(SameLength' a b, SameLength' b a, HMapAux r f a b) =>
f -> r a -> r b
hMap f
f


-- | @Iso (Record x) (Record y) (RecordU x) (RecordU y)@
unboxed :: forall x y f p.
  (Profunctor p,
   Functor f,
   RecordToRecordU x,
   RecordUToRecord y)
  => RecordU x `p` f (RecordU y)
  -> Record x `p` f (Record y)
unboxed :: p (RecordU x) (f (RecordU y)) -> p (Record x) (f (Record y))
unboxed p (RecordU x) (f (RecordU y))
r = (Record x -> RecordU x)
-> (RecordU y -> Record y)
-> p (RecordU x) (f (RecordU y))
-> p (Record x) (f (Record y))
forall (p :: * -> * -> *) (f :: * -> *) s a b t.
(Profunctor p, Functor f) =>
(s -> a) -> (b -> t) -> p a (f b) -> p s (f t)
iso Record x -> RecordU x
forall (x :: [*]). RecordToRecordU x => Record x -> RecordU x
recordToRecordU RecordU y -> Record y
forall (x :: [*]). RecordUToRecord x => RecordU x -> Record x
recordUToRecord p (RecordU x) (f (RecordU y))
r

-- | @Iso' (Record x) (RecordU x)@
unboxed' :: p (RecordU y) (f (RecordU y)) -> p (Record y) (f (Record y))
unboxed' p (RecordU y) (f (RecordU y))
x = (p (RecordU y) (f (RecordU y)) -> p (Record y) (f (Record y)))
-> p (RecordU y) (f (RecordU y)) -> p (Record y) (f (Record y))
forall k1 k2 optic (p :: k1 -> k2 -> *) (a :: k1) (f :: k1 -> k2)
       (s :: k1).
(optic ~ (p a (f a) -> p s (f s))) =>
optic -> optic
isSimple p (RecordU y) (f (RecordU y)) -> p (Record y) (f (Record y))
forall (x :: [*]) (y :: [*]) (f :: * -> *) (p :: * -> * -> *).
(Profunctor p, Functor f, RecordToRecordU x, RecordUToRecord y) =>
p (RecordU x) (f (RecordU y)) -> p (Record x) (f (Record y))
unboxed p (RecordU y) (f (RecordU y))
x


class RecordToRecordU x where
    recordToRecordU :: Record x -> RecordU x

instance (
    RecordValues x,
    HList2List (RecordValuesR x) (GetElemTy x),
    HNat2Integral n,
    HLengthEq x n,
    IArray UArray (GetElemTy x)
   ) => RecordToRecordU x where
  recordToRecordU :: Record x -> RecordU x
recordToRecordU (rx :: Record x
rx@(Record HList x
x)) = UArray Int (GetElemTy x) -> RecordU x
forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU (UArray Int (GetElemTy x) -> RecordU x)
-> UArray Int (GetElemTy x) -> RecordU x
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [GetElemTy x] -> UArray Int (GetElemTy x)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray
          (Int
0, Proxy n -> Int
forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral (HList x -> Proxy n
forall (l :: [*]) (n :: HNat). HLengthEq l n => HList l -> Proxy n
hLength HList x
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          (HList (RecordValuesR x) -> [GetElemTy x]
forall (l :: [*]) e. HList2List l e => HList l -> [e]
hList2List (Record x -> HList (RecordValuesR x)
forall (r :: [*]).
RecordValues r =>
Record r -> HList (RecordValuesR r)
recordValues Record x
rx))
 
class RecordUToRecord x where
    recordUToRecord :: RecordU x -> Record x

instance (
    HMapCxt HList TaggedFn (RecordValuesR x) x,
    IArray UArray (GetElemTy x),
    HList2List (RecordValuesR x) (GetElemTy x) 
  ) => RecordUToRecord x where
  recordUToRecord :: RecordU x -> Record x
recordUToRecord (RecordU UArray Int (GetElemTy x)
b) = case [GetElemTy x] -> Maybe (HList (RecordValuesR x))
forall (l :: [*]) e. HList2List l e => [e] -> Maybe (HList l)
list2HList ([GetElemTy x] -> Maybe (HList (RecordValuesR x)))
-> [GetElemTy x] -> Maybe (HList (RecordValuesR x))
forall a b. (a -> b) -> a -> b
$ UArray Int (GetElemTy x) -> [GetElemTy x]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int (GetElemTy x)
b of
          Maybe (HList (RecordValuesR x))
Nothing -> String -> Record x
forall a. HasCallStack => String -> a
error String
"Data.HList.RecordU.recordUToRecord impossibly too few elements"
          Just HList (RecordValuesR x)
y0 -> HList x -> Record x
forall (r :: [*]). HList r -> Record r
Record (HList x -> Record x) -> HList x -> Record x
forall a b. (a -> b) -> a -> b
$ TaggedFn -> HList (RecordValuesR x) -> HList x
forall (a :: [*]) (b :: [*]) (r :: [*] -> *) f.
(SameLength' a b, SameLength' b a, HMapAux r f a b) =>
f -> r a -> r b
hMap TaggedFn
TaggedFn (HList (RecordValuesR x)
y0 :: HList (RecordValuesR x))



-- * definitions for doctest examples
type Bad =
         [Tagged "x" Double,
          Tagged "i" Int,
          Tagged "y" Double,
          Tagged "j" Int]

{- | HasField instances

[@RecordUS@]

>>> let r = recordToRecordUS (sortForRecordUS bad)
>>> let s = recordToRecordUS bad

>>> let x = Label :: Label "x"
>>> let y = Label :: Label "y"
>>> let i = Label :: Label "i"
>>> let j = Label :: Label "j"

>>> (r .!. x, r .!. i, r .!. y, r .!. j)
(1.0,2,3.0,4)

>>> (s .!. x, s .!. i, s .!. y, s .!. j)
(1.0,2,3.0,4)


[@RecordU@]

>>> let t = recordToRecordU bad1
>>> (t .!. x, t .!. y)
(1.0,2.0)

>>> hUpdateAtLabel x 3 t .!. x
3.0

-}
bad :: Record Bad
bad :: Record Bad
bad = Double -> Tagged "x" Double
forall k (s :: k) b. b -> Tagged s b
Tagged Double
1 Tagged "x" Double
-> Record '[Tagged "i" Int, Tagged "y" Double, Tagged "j" Int]
-> HExtendR
     (Tagged "x" Double)
     (Record '[Tagged "i" Int, Tagged "y" Double, Tagged "j" Int])
forall e l. HExtend e l => e -> l -> HExtendR e l
.*. Int -> Tagged "i" Int
forall k (s :: k) b. b -> Tagged s b
Tagged Int
2 Tagged "i" Int
-> Record '[Tagged "y" Double, Tagged "j" Int]
-> HExtendR
     (Tagged "i" Int) (Record '[Tagged "y" Double, Tagged "j" Int])
forall e l. HExtend e l => e -> l -> HExtendR e l
.*. Double -> Tagged "y" Double
forall k (s :: k) b. b -> Tagged s b
Tagged Double
3 Tagged "y" Double
-> Record '[Tagged "j" Int]
-> HExtendR (Tagged "y" Double) (Record '[Tagged "j" Int])
forall e l. HExtend e l => e -> l -> HExtendR e l
.*. Int -> Tagged "j" Int
forall k (s :: k) b. b -> Tagged s b
Tagged Int
4 Tagged "j" Int
-> Record '[] -> HExtendR (Tagged "j" Int) (Record '[])
forall e l. HExtend e l => e -> l -> HExtendR e l
.*. Record '[]
emptyRecord

bad1 :: Record [Tagged "x" Double, Tagged "y" Double]
bad1 :: Record '[Tagged "x" Double, Tagged "y" Double]
bad1 = Double -> Tagged "x" Double
forall k (s :: k) b. b -> Tagged s b
Tagged Double
1 Tagged "x" Double
-> Record '[Tagged "y" Double]
-> HExtendR (Tagged "x" Double) (Record '[Tagged "y" Double])
forall e l. HExtend e l => e -> l -> HExtendR e l
.*. Double -> Tagged "y" Double
forall k (s :: k) b. b -> Tagged s b
Tagged Double
2 Tagged "y" Double
-> Record '[] -> HExtendR (Tagged "y" Double) (Record '[])
forall e l. HExtend e l => e -> l -> HExtendR e l
.*. Record '[]
emptyRecord

-- * Implementation Details

data UnboxF = UnboxF
instance (hx ~ HList x, ux ~ RecordU x,
          RecordToRecordU x) =>
  ApplyAB UnboxF hx ux where
  applyAB :: UnboxF -> hx -> ux
applyAB UnboxF
_ = Record x -> RecordU x
forall (x :: [*]). RecordToRecordU x => Record x -> RecordU x
recordToRecordU (Record x -> RecordU x)
-> (HList x -> Record x) -> HList x -> RecordU x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HList x -> Record x
forall (r :: [*]). HList r -> Record r
Record

data BoxF = BoxF

instance (ux ~ RecordU x,
         hx ~ HList x,
         RecordUToRecord x) =>
  ApplyAB BoxF ux hx where
  applyAB :: BoxF -> ux -> hx
applyAB BoxF
_ ux
ux = case RecordU x -> Record x
forall (x :: [*]). RecordUToRecord x => RecordU x -> Record x
recordUToRecord ux
RecordU x
ux of Record HList x
hx -> hx
HList x
hx


-- | make a @Lens' (RecordU s) a@
instance (s ~ t, a ~ b,
          IArray UArray a, a ~ GetElemTy s,
          HLensCxt x RecordU s t a b)
        => Labelable x RecordU s t a b where
            type LabelableTy RecordU = LabelableLens
            hLens' :: Label x -> LabeledOptic x RecordU s t a b
hLens' Label x
x = Label x
-> forall (f :: * -> *).
   Functor f =>
   (b -> f b) -> RecordU t -> f (RecordU t)
forall k (x :: k) (r :: [*] -> *) (s :: [*]) (t :: [*]) a b.
HLens x r s t a b =>
Label x
-> forall (f :: * -> *). Functor f => (a -> f b) -> r s -> f (r t)
hLens Label x
x

{- TODO
instance Labelable x RecordUS to p f s t a b where
instance (r ~ r', HasField l (Record r) v)
      => HUpdateAtLabel RecordUS l v r r' where
  hUpdateAtLabel = error "recordus hupdateatlabel"

Benchmarks
-}