{- | 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) = 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 = forall (x :: [*]). Any -> RecordUS x
RecordUS (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 " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
n (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 = 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) = forall (r :: [*]). HList r -> Record r
Record (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  = forall {k} (t :: k). Proxy t
Proxy :: Proxy EqTagValue
      x1 :: Proxy x
x1 = forall {k} (t :: k). Proxy t
Proxy :: Proxy x
      (HList xi
xi,HList xo
xo) = forall {k} {k1} (f :: k) (x1 :: k1) (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' = forall (x :: [*]) (x' :: [*]).
SortForRecordUS x x' =>
Record x -> Record x'
sortForRecordUS (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 forall (n :: HNat) (us :: [*]) e.
HLookupByHNatUS n us e =>
Proxy n -> HList us -> e
hLookupByHNatUS Proxy n
n (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 = 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 ru
u HList us
us) = 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 (forall {k} (t :: k). Proxy t
Proxy :: Proxy r) Proxy n
n ru
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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged (UArray Int (GetElemTy u)
u forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! 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
_ = forall (n :: HNat) (us :: [*]) e.
HLookupByHNatUS n us e =>
Proxy n -> HList us -> e
hLookupByHNatUS (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 = forall (p :: * -> * -> *) (f :: * -> *) s a b t.
(Profunctor p, Functor f) =>
(s -> a) -> (b -> t) -> p a (f b) -> p s (f t)
iso forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
HList u -> RecordUS x
hListToRecordUS 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 = 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 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 :: 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 HList x
x) = forall (x :: [*]) (u :: [*]).
RecordUSCxt x u =>
HList u -> RecordUS x
hListToRecordUS HList u
u
  where
    u :: HList u
    u :: HList u
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 = forall t (f :: t) (as :: [*]) (gs :: [*]).
HGroupBy f as gs =>
Proxy f -> HList as -> HList gs
hGroupBy (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 :: 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
rus = forall (r :: [*]). HList r -> Record r
Record (forall (xxs :: [*]) (xs :: [*]).
HConcatFD xxs xs =>
HList xxs -> HList xs
hConcatFD HList g
g)
  where
    g :: HList g
    g :: HList g
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 (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 = forall (p :: * -> * -> *) (f :: * -> *) s a b t.
(Profunctor p, Functor f) =>
(s -> a) -> (b -> t) -> p a (f b) -> p s (f t)
iso forall (x :: [*]) (g :: [*]) (u :: [*]).
(HMapCxt HList UnboxF g u, HMapUnboxF g u, HGroupBy EqTagValue x g,
 RecordUSCxt x u) =>
Record x -> RecordUS x
recordToRecordUS 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 = 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 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 (GetElemTy ls)
ls forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral (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 :: SameLength r r' => Label l -> v -> RecordU r -> RecordU r'
hUpdateAtLabel Label l
_ v
v (RecordU UArray Int (GetElemTy r)
r) = forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU (UArray Int (GetElemTy r)
r forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral (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) = forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU (UArray Int (GetElemTy r)
r forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ixs (forall (l :: [*]) e. HList2List l e => HList l -> [e]
hList2List (forall (r :: [*]).
RecordValues r =>
Record r -> HList (RecordValuesR r)
recordValues Record lv
lv))))
     where ixs :: [Int]
ixs = forall (ns :: [HNat]) i.
(HNats2Integrals ns, Integral i) =>
Proxy ns -> [i]
hNats2Integrals (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 = forall {l :: [*]} {r :: [*]}.
(HLabelSet (LabelsOf l), HRearrange3 (LabelsOf l) r l,
 SameLength' r l, SameLength' r (LabelsOf l), SameLength' l r,
 SameLength' (LabelsOf l) r) =>
Record r -> Record l
hRearrange' (Record lv
lv 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 :: SameLength x y => f -> RecordU x -> RecordU y
hMapAux f
f (RecordU UArray Int (GetElemTy x)
x) = forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU (forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap (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 :: forall f (x :: [*]) (y :: [*]).
HMapCxt RecordU f x y =>
f -> RecordU x -> RecordU y
hMapRU f
f = 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 :: 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 x) (f (RecordU y))
r = forall (p :: * -> * -> *) (f :: * -> *) s a b t.
(Profunctor p, Functor f) =>
(s -> a) -> (b -> t) -> p a (f b) -> p s (f t)
iso forall (x :: [*]). RecordToRecordU x => Record x -> RecordU x
recordToRecordU 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 = 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 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)) = forall (l :: [*]). UArray Int (GetElemTy l) -> RecordU l
RecordU forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray
          (Int
0, forall (n :: HNat) i. (HNat2Integral n, Integral i) => Proxy n -> i
hNat2Integral (forall (l :: [*]) (n :: HNat). HLengthEq l n => HList l -> Proxy n
hLength HList x
x) forall a. Num a => a -> a -> a
- Int
1)
          (forall (l :: [*]) e. HList2List l e => HList l -> [e]
hList2List (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 forall (l :: [*]) e. HList2List l e => [e] -> Maybe (HList l)
list2HList forall a b. (a -> b) -> a -> b
$ 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 -> forall a. HasCallStack => String -> a
error String
"Data.HList.RecordU.recordUToRecord impossibly too few elements"
          Just HList (RecordValuesR x)
y0 -> forall (r :: [*]). HList r -> Record r
Record forall a b. (a -> b) -> a -> b
$ 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
  '[Tagged "x" Double, Tagged "i" Int, Tagged "y" Double,
    Tagged "j" Int]
bad = forall {k} (s :: k) b. b -> Tagged s b
Tagged Double
1 forall e l. HExtend e l => e -> l -> HExtendR e l
.*. forall {k} (s :: k) b. b -> Tagged s b
Tagged Int
2 forall e l. HExtend e l => e -> l -> HExtendR e l
.*. forall {k} (s :: k) b. b -> Tagged s b
Tagged Double
3 forall e l. HExtend e l => e -> l -> HExtendR e l
.*. forall {k} (s :: k) b. b -> Tagged s b
Tagged Int
4 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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged Double
1 forall e l. HExtend e l => e -> l -> HExtendR e l
.*. forall {k} (s :: k) b. b -> Tagged s b
Tagged Double
2 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
_ = forall (x :: [*]). RecordToRecordU x => Record x -> RecordU x
recordToRecordU forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (x :: [*]). RecordUToRecord x => RecordU x -> Record x
recordUToRecord ux
ux of Record HList x
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 = 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
-}