HList 0.4.0.0 → 0.4.1.0

raw patch · 12 files changed

+575/−498 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog +7/−0
• Data/HList/CommonMain.hs +22/−2
• Data/HList/FakePrelude.hs +17/−0
• Data/HList/HList.hs +50/−22
• Data/HList/Record.hs +5/−1
• Data/HList/RecordU.hs +433/−0
• Data/HList/TIP.hs +1/−1
• Data/HList/Variant.hs +2/−2
• Data/HList/broken/RecordU.hs +0/−462
• HList.cabal +6/−1
• examples/Properties/LengthDependent.hs +17/−3
• examples/Properties/LengthIndependent.hs +15/−4

@@ -1,3 +1,10 @@+3 Aug 2015+0.4.1 Release++Add RecordU.hs, a record type with elements stored in unboxed arrays++Documentation fixes (Thor Michael Støre)+ 5 May 2015 0.4 Release 

@@ -31,7 +31,22 @@  -- name.  , module Data.HList.RecordPuns + -- ** Unpacked / Unboxed Records+ , RecordU+ , RecordUS+ , SortForRecordUS(..)+ , HUpdateMany(..)+ , hMapRU + -- *** internals for types+ , HFindMany, HNats2Integrals(..)++ , RecordUSCxt+ , HLookupByHNatUS, HLookupByHNatUS1+ , HSubtract, HMapUnboxF, UnboxF+ , BoxF, EqTagValue, GetElemTy, ElemTyEq+ , RecordToRecordU, RecordUToRecord+  -- * HList  -- | A subset of "Data.HList.HList" is re-exported.  , module Data.HList.HList@@ -122,6 +137,12 @@   -- ** HList and TIP  , tipHList, tipHList'+ -- ** Record and RecordU+ , unboxed, unboxed'+ -- ** Record and RecordUS+ , unboxedS, unboxedS'+ -- ** Record and Variant+ , hMaybied, hMaybied'   -- ** Newtype wrappers  -- $convention these isos unwrap/wrap the newtypes 'TIP' 'TIC' and@@ -131,8 +152,6 @@  , ticVariant, ticVariant'  , tipRecord, tipRecord' - -- ** Record and Variant- , hMaybied, hMaybied'  -- *** implementation  , VariantToHMaybied(variantToHMaybied)  , HMaybiedToVariantFs@@ -230,6 +249,7 @@  import Data.HList.Keyword import Data.HList.RecordPuns+import Data.HList.RecordU  {- $label6demo #label6demo# 

@@ -502,11 +502,28 @@ class HNat2Integral (n::HNat) where     hNat2Integral :: Integral i => Proxy n -> i +type family HNat2Nat (n :: HNat) :: Nat+type instance HNat2Nat HZero = 0+type instance HNat2Nat (HSucc n) = 1 + HNat2Nat n++#if MIN_VERSION_base(4,7,0)+{- Instead convert HNat to GHC.TypeLits.'Nat' with 'HNat2Nat' and use functions+from that module to produce the 'Integer' -}+instance KnownNat (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (natVal (Proxy :: Proxy (HNat2Nat n)))+#else+{- doesn't work: gives "No instance for (SingI Nat (1 + (1 + 0)))"+instance SingI (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (fromSing (sing :: Sing (HNat2Nat n)))+-}++-- | a slow (at runtime) implementation for ghc 7.6: instance HNat2Integral HZero where     hNat2Integral _ = 0  instance HNat2Integral n => HNat2Integral (HSucc n) where     hNat2Integral n = hNat2Integral (hPred n) + 1+#endif   class HNats2Integrals (ns :: [HNat]) where

@@ -92,6 +92,17 @@ like the algebraic data type. Furthermore, nonsense values like @HCons 1 2 :: HCons Int Int@ cannot be written with the data family. +A variation on the data family version is++> data instance HList '[] = HNil+> newtype instance HList (x ': xs) = HCons1 (x, HList xs)+> pattern HCons x xs = HCons1 (x, xs)++This allows HList to have a nominal role, but on the other+hand the PatternSynonym is not supported with ghc-7.6 and+exhaustiveness checking is not as good (warnings for _ being+unmatched)+ -}  @@ -594,6 +605,7 @@ applyAB f :: a -> Maybe a  f is applied to different types:+ >>> hIterate three f () H[(),Just (),Just (Just ())] @@ -626,28 +638,44 @@ Works in ghci... puzzling as what is different in doctest (it isn't @-XExtendedDefaultRules@) -> hConcat $ hBuild (hBuild 1 2 3) (hBuild 'a' "abc")-+>>> let a = hEnd $ hBuild 1 2 3+>>> let b = hEnd $ hBuild 'a' "abc"+>>> hConcat $ hBuild a b H[1, 2, 3, 'a', "abc"] - -}-class HConcat (a :: [*]) where-    type HConcatR a :: [*]-    hConcat :: HList a -> HList (HConcatR a)--instance HConcat '[] where-    type HConcatR '[] = '[]-    hConcat _ = HNil+type HConcat xs = HConcatFD xs (HConcatR xs) -instance (x ~ HList t, HConcat xs, HAppendList t (HConcatR xs)) => HConcat (x ': xs) where-    type HConcatR (x ': xs) = HAppendListR (UnHList x) (HConcatR xs)-    hConcat (x `HCons` xs) = x `hAppendList` hConcat xs+hConcat :: HConcat xs => HList xs -> HList (HConcatR xs)+hConcat x = hConcatFD x +type family HConcatR (a :: [*]) :: [*]+type instance HConcatR '[] = '[]+type instance HConcatR (x ': xs) = HAppendListR (UnHList x) (HConcatR xs)  type family UnHList a :: [*] type instance UnHList (HList a) = a +-- for the benefit of ghc-7.10.1+class HConcatFD xxs xs | xxs -> xs+    where hConcatFD :: HList xxs -> HList xs++instance HConcatFD '[] '[] where+    hConcatFD _ = HNil++instance (HConcatFD as bs, HAppendFD a bs cs) => HConcatFD (HList a ': as) cs where+    hConcatFD (HCons x xs) = x `hAppendFD` hConcatFD xs++class HAppendFD a b ab | a b -> ab where+    hAppendFD :: HList a -> HList b -> HList ab++instance HAppendFD '[] b b where+    hAppendFD _ b = b++instance HAppendFD as bs cs => HAppendFD (a ': as) bs (a ': cs) where+    hAppendFD (HCons a as) bs = a `HCons` hAppendFD as bs++ -- -------------------------------------------------------------------------- -- * traversing HLists @@ -867,7 +895,7 @@ -- -- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b] ----- Likewise for mapM_.+-- Likewise for 'mapM_'. -- -- See 'hSequence' if the result list should also be heterogenous. @@ -875,7 +903,9 @@ hMapM f =  hMapOut f  -- | GHC doesn't like its own type.--- hMapM_  :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()+--+-- > hMapM_ :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()+-- -- Without explicit type signature, it's Ok. Sigh. -- Anyway, Hugs does insist on a better type. So we restrict as follows: --@@ -1165,7 +1195,8 @@   -- | Annotate list with a type-level Boolean--- hFlag :: HMapCxt (HAddTag (Proxy True)) l r => HList l -> HList r+--+-- > hFlag :: HMapCxt (HAddTag (Proxy True)) l r => HList l -> HList r hFlag l = hAddTag hTrue l  @@ -1493,13 +1524,10 @@       | f x y -> fst snd, fst snd -> y where   hSpanEqBy :: Proxy f -> x -> HList y -> (HList fst, HList snd) -instance (HSpanEqBy1 f x y revFst snd,-          HReverse revFst fst,--          HRevApp revFst snd y)+instance (HSpanEqBy1 f x y fst snd,+          HAppendListR fst snd ~ y)     => HSpanEqBy f x y fst snd where-  hSpanEqBy f x y =  case hSpanEqBy1 f x y of-                      (revFst, second) -> (hReverse revFst, second)+  hSpanEqBy f x y =  hSpanEqBy1 f x y  class HSpanEqBy1 (f :: t) (x :: *) (y :: [*]) (i :: [*]) (o :: [*])       | f x y -> i o where

@@ -1139,15 +1139,18 @@  suppose we have a function that should be applied to every element of a record:+ >>> let circSucc_ x | x == maxBound = minBound | otherwise = succ x -> :t circSucc_+>>> :t circSucc_ circSucc_ :: (Eq a, Enum a, Bounded a) => a -> a  Use a shortcut ('Fun') to create a value that has an appropriate 'ApplyAB' instance:+ >>> let circSucc = Fun circSucc_ :: Fun '[Eq,Enum,Bounded] '()  Confirm that we got Fun right:+ >>> :t applyAB circSucc applyAB circSucc :: (Bounded b, Enum b, Eq b) => b -> b @@ -1155,6 +1158,7 @@ False  define the actual record:+ >>> let r = x .=. 'a' .*. y .=. False .*. emptyRecord >>> r Record{x='a',y=False}

@@ -0,0 +1,433 @@+{- | 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+import GHC.Exts (Any)++-- * 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 x) = unsafeCoerce x++  -- | @O(1)@ should be possible to implement this without+  -- unsafeCoerce+  hListToRecordUS :: HList u -> RecordUS x+  hListToRecordUS x = RecordUS (unsafeCoerce 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 n r = ("RecordUS " ++) . showsPrec n (recordUSToHList 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 = 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 xs) = Record (hAppendList xi xo')+    where+      f  = Proxy :: Proxy EqTagValue+      x1 = Proxy :: Proxy x+      (xi,xo) = hPartitionEq f x1 xs+      Record xo' = sortForRecordUS (Record 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 _ u = case hLookupByHNatUS n (recordUSToHList u) of Tagged v -> v+    where n = 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 n (HCons u us) = hLookupByHNatUS1 (Proxy :: Proxy r) n u 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 _ n (RecordU u) _us = Tagged (u ! hNat2Integral n)++instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where+  hLookupByHNatUS1 _ _ _ = hLookupByHNatUS (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) (Record b)@+recordUS r = iso hListToRecordUS recordUSToHList r++{- | @Iso (HList s) (RecordUS a)@++@s@ is a HList of 'RecordU' while @a :: [*]@+is list of @Tagged label value@++-}+recordUS' r = simple (recordUS 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) = hListToRecordUS u+  where+    u :: HList u+    u = hMap UnboxF g ++    g :: HList g+    g = hGroupBy (Proxy :: Proxy EqTagValue) 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 rus = Record (hConcatFD g)+  where+    g :: HList g+    g = hMap BoxF (recordUSToHList rus)++-- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@+unboxedS r = iso recordToRecordUS recordUSToRecord r++-- | @Iso' (Record x) (RecordUS x)@+unboxedS' r = simple (unboxedS 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 _ (RecordU ls) = ls ! hNat2Integral (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 _ v (RecordU r) = RecordU (r // [(hNat2Integral (Proxy :: Proxy n), 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 lv (RecordU r) = RecordU (r // (zip ixs (hList2List (recordValues lv))))+     where ixs = hNats2Integrals (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 lv x = hRearrange' (lv .<++. 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 (amap (applyAB f) x)++-- | 'hMap' specialized to 'RecordU'+hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y+hMapRU f = hMap 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 r = iso recordToRecordU recordUToRecord r++-- | @Iso' (Record x) (RecordU x)@+unboxed' x = simple (unboxed 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 (rx @ (Record x)) = RecordU $ listArray+          (0, hNat2Integral (hLength x) - 1)+          (hList2List (recordValues 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 b) = case list2HList $ elems b of+          Nothing -> error "Data.HList.RecordU.recordUToRecord impossibly too few elements"+          Just y0 -> Record $ hMap TaggedFn (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 = Tagged 1 .*. Tagged 2 .*. Tagged 3 .*. Tagged 4 .*. emptyRecord++bad1 :: Record [Tagged "x" Double, Tagged "y" Double]+bad1 = Tagged 1 .*. Tagged 2 .*. emptyRecord++-- * Implementation Details++data UnboxF = UnboxF+instance (hx ~ HList x, ux ~ RecordU x,+          RecordToRecordU x) =>+  ApplyAB UnboxF hx ux where+  applyAB _ = recordToRecordU . Record++data BoxF = BoxF++instance (ux ~ RecordU x,+         hx ~ HList x,+         RecordUToRecord x) =>+  ApplyAB BoxF ux hx where+  applyAB _ ux = case recordUToRecord ux of Record hx -> 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' = hLens++{- 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"+-}

@@ -192,7 +192,7 @@ simplifying types containing type variables (in ghc-7.8 and 7.6): <http://stackoverflow.com/questions/24110410/> -With ghc-7.10 (http://ghc.haskell.org/trac/ghc/ticket/10009) the FD version is superior+With ghc-7.10 (<http://ghc.haskell.org/trac/ghc/ticket/10009>) the FD version is superior to the TF version:  @

@@ -458,12 +458,12 @@  If we instead had -type X a b c = Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]+> type X a b c = Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]  Then we could write:  > gunfold1 :: (forall b r. Data b => (b -> r) -> c r)-          -> Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]+>          -> Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c] > gunfold1 f c = case constrIndex c of >       1 -> f mkA >       2 -> f mkB

@@ -1,462 +0,0 @@-{- | Description: records where elements are stored in unboxed arrays--XXX works with ghc-7.8 and 7.6. Broken with GHC-7.10 RC1 on account of ghc-bug #10009--The public interface is exported from <Data-HList-CommonMain.html#t:RecordU RecordU>--Export list (from CommonMain.hs)--@- -- ** Unpacked / Unboxed Records- , RecordU- , RecordUS- , SortForRecordUS(..)- , HUpdateMany(..)- , hMapRU-- -- *** internals for types- , HFindMany, HNats2Integrals(..)-- , RecordUSCxt- , HLookupByHNatUS, HLookupByHNatUS1- , HSubtract, HMapUnboxF, UnboxF- , BoxF, EqTagValue, GetElemTy, ElemTyEq- , RecordToRecordU, RecordUToRecord---- -- ** Record and RecordU- , unboxed, unboxed'- -- ** Record and RecordUS- , unboxedS, unboxedS'-@--}-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 Data.HList.HOccurs-import LensDefs--import Data.HList.Labelable--import Unsafe.Coerce-import GHC.Exts (Any)---- * 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 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 x) = unsafeCoerce x--  -- | @O(1)@ should be possible to implement this without-  -- unsafeCoerce-  hListToRecordUS :: HList u -> RecordUS x-  hListToRecordUS x = RecordUS (unsafeCoerce 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 n r = ("RecordUS " ++) . showsPrec n (recordUSToHList 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 updates the very first elements-  of the 'RecordU'--The benefit is that lookups should be faster and records-should take up less space. However benchmarks 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 = 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 xs) = Record (hAppendList xi xo')-    where-      f  = Proxy :: Proxy EqTagValue-      x1 = Proxy :: Proxy x-      (xi,xo) = hPartitionEq f x1 xs-      Record xo' = sortForRecordUS (Record 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 _ u = case hLookupByHNatUS n (recordUSToHList u) of Tagged v -> v-    where n = 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 n (HCons u us) = hLookupByHNatUS1 (Proxy :: Proxy r) n u 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 _ n (RecordU u) _us = Tagged (u ! hNat2Integral n)--instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where-  hLookupByHNatUS1 _ _ _ = hLookupByHNatUS (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) (Record b)@-recordUS r = iso hListToRecordUS recordUSToHList r--{- | @Iso (HList s) (RecordUS a)@--@s@ is a HList of 'RecordU' while @a :: [*]@-is list of @Tagged label value@---}-recordUS' r = simple (recordUS 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) = hListToRecordUS u-  where-    u :: HList u-    u = hMap UnboxF g --    g :: HList g-    g = hGroupBy (Proxy :: Proxy EqTagValue) x---- | @^. from unboxedS@ is preferred-recordUSToRecord :: forall u g x.-  (HConcatR g ~ x,-   HConcat g,-   HMapCxt HList BoxF u g,-   HMapUnboxF g u,-   RecordUSCxt x u-  ) => RecordUS x -> Record x-recordUSToRecord rus = Record (hConcat g)-  where-    g :: HList g-    g = hMap BoxF (recordUSToHList rus)---- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@-unboxedS r = iso recordToRecordUS recordUSToRecord r---- | @Iso' (Record x) (RecordUS x)@-unboxedS' r = simple (unboxedS 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 _ (RecordU ls) = ls ! hNat2Integral (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 _ v (RecordU r) = RecordU (r // [(hNat2Integral (Proxy :: Proxy n), 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 lv (RecordU r) = RecordU (r // (zip ixs (hList2List (recordValues lv))))-     where ixs = hNats2Integrals (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 lv x = hRearrange' (lv .<++. 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 (amap (applyAB f) x)---- | 'hMap' specialized to 'RecordU'-hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y-hMapRU f = hMap 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 r = iso recordToRecordU recordUToRecord r---- | @Iso' (Record x) (RecordU x)@-unboxed' x = simple (unboxed x)---class RecordToRecordU x where-    recordToRecordU :: Record x -> RecordU x--instance (-    RecordValues x,-    HList2List (RecordValuesR x) (GetElemTy x),-    HNat2Integral (HLength x),-    IArray UArray (GetElemTy x)-   ) => RecordToRecordU x where-  recordToRecordU (rx @ (Record x)) = RecordU $ listArray-          (0, hNat2Integral (hLength x) - 1)-          (hList2List (recordValues 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 b) = case list2HList $ elems b of-          Nothing -> error "Data.HList.RecordU.recordUToRecord impossibly too few elements"-          Just y0 -> Record $ hMap TaggedFn (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 = Tagged 1 .*. Tagged 2 .*. Tagged 3 .*. Tagged 4 .*. emptyRecord--bad1 :: Record [Tagged "x" Double, Tagged "y" Double]-bad1 = Tagged 1 .*. Tagged 2 .*. emptyRecord---- * Implementation Details--data UnboxF = UnboxF-instance (hx ~ HList x, ux ~ RecordU x,-          RecordToRecordU x) =>-  ApplyAB UnboxF hx ux where-  applyAB _ = recordToRecordU . Record--data BoxF = BoxF--instance (ux ~ RecordU x,-         hx ~ HList x,-         RecordUToRecord x) =>-  ApplyAB BoxF ux hx where-  applyAB _ ux = case recordUToRecord ux of Record hx -> 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' = hLens--{- 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"--}

@@ -1,5 +1,5 @@ Name:                HList-Version:             0.4.0.0+Version:             0.4.1.0 Category:            Data Synopsis:            Heterogeneous lists Description:         HList provides many operations to create and manipulate@@ -49,6 +49,10 @@   Description: use Data.Type.Equality.== to define the instance of HEq                instead of overlapping instances (in Data.HList.TypeEqO)                (needs ghc >= 7.8)+              .+               This version does not allow `HEq x [x] f` to lead to+               f ~ False, unlike the version with overlapping instances.+               See <https://ghc.haskell.org/trac/ghc/ticket/9918>  library   Build-Depends:       base >= 4.6 && < 4.9,@@ -80,6 +84,7 @@                        Data.HList.MakeLabels,                        Data.HList.Record,                        Data.HList.RecordPuns,+                       Data.HList.RecordU,                        Data.HList.TIC,                        Data.HList.TIP,                        Data.HList.TIPtuple,

@@ -45,7 +45,15 @@ rKN :: (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n     -> Int     -> ExpQ-rKN takeK n = [| \proxy -> do+rKN = rKN' (litT . numTyLit)+++rKN' ::+    (Integer -> TypeQ) -- ^ make the label+    -> (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n+    -> Int+    -> ExpQ+rKN' mkLab takeK n = [| \proxy -> do         $(recs [| arbitrary `asTypeOf` return proxy |])             `asTypeOf` return $sig          |]@@ -75,10 +83,15 @@            -- taggedN 1 == [t| Tagged 1 x1 |]           taggedN :: Integer -> TypeQ-          taggedN i = [t| Tagged $(litT (numTyLit i)) $(varT (mkName ("x"++show i))) |]+          taggedN i = [t| Tagged $(mkLab i) $(varT (mkName ("x"++show i))) |] +-- | > $(rN n) :: a -> Record [Tagged 1 a, Tagged 2 a, ... Tagged n a] rN n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN (take 1) n) proxy |] ++-- | > $(rNstr n) :: a -> Record [Tagged "1" a, Tagged "2" a, ... Tagged n a]+rNstr n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN' (litT . strTyLit . show) (take 1) n) proxy |]+ vN :: Int -> ExpQ vN n = [| \proxy -> do        let toV :: Gen (Record a) -> Variant a@@ -249,7 +262,8 @@       return $ xy `eq` hZip x y  #if __GLASGOW_HASKELL__ < 710- -- XXX doesn't work with ghc-7.10 RC1+  -- XXX doesn't work with ghc-7.10.1+  -- (should be fixed for 7.10.2)   it "hZip/hZip2" $ property $ do       x <- genHL (BoolN True :: BoolN "x")       y <- genHL (BoolN True :: BoolN "y")

@@ -289,6 +289,14 @@           r.!.l2 `eq` v2,           p1 `eq` p ] +  it "Record hLookupByLabelM" $ property $ do+    v :: BoolN "v" <- arbitrary+    w :: BoolN "v" <- arbitrary+    let r = [pun| v |]+    return $ conjoin+      [ hLookupByLabelM (Label :: Label "v") r w `eq` v,+        hLookupByLabelM (Label :: Label "w") r w `eq` w ]+   it "HOccurs HList" $ do     property $ do       x <- arbitrary@@ -343,9 +351,15 @@       b :: Bool <- arbitrary       let h = hEnd $ hBuild a b           v = lx_ .=. a .*. mkVariant1 ly_ b+          r = (unlabeled # h) `asLabelsOf` pLabel3++          -- ghc-7.8 can't use pLabel5 (due to a lack of Typeable "x")+          pLabel3 = lx_ .*. ly_ .*. emptyProxy+          pLabel5 = lx .*. ly .*. emptyProxy -- Proxy :: Proxy ["x","y"]       return $ conjoin         [ gread (gshow h) === [(h, "")],-          gread (gshow v) === [(v, "")] ]+          gread (gshow v) === [(v, "")],+          gread (gshow r) === [(r, "")] ]    it "Enum" $ do     show [ mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool]) .. maxBound ]@@ -388,8 +402,6 @@           ]  --{- RecordU is disabled for now   it "unboxed" $ do     property $ do       (x :: Bool) <- arbitrary@@ -418,7 +430,6 @@           ru .!. ly === y,           ru .!. lz === z,           r === ru ^. from unboxedS ]-         -}    it "monoid0" $ do     mempty `shouldBe` HNil