diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/Data/HList/CommonMain.hs b/Data/HList/CommonMain.hs --- a/Data/HList/CommonMain.hs +++ b/Data/HList/CommonMain.hs @@ -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# diff --git a/Data/HList/FakePrelude.hs b/Data/HList/FakePrelude.hs --- a/Data/HList/FakePrelude.hs +++ b/Data/HList/FakePrelude.hs @@ -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 diff --git a/Data/HList/HList.hs b/Data/HList/HList.hs --- a/Data/HList/HList.hs +++ b/Data/HList/HList.hs @@ -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 diff --git a/Data/HList/Record.hs b/Data/HList/Record.hs --- a/Data/HList/Record.hs +++ b/Data/HList/Record.hs @@ -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} diff --git a/Data/HList/RecordU.hs b/Data/HList/RecordU.hs new file mode 100644 --- /dev/null +++ b/Data/HList/RecordU.hs @@ -0,0 +1,433 @@ +{- | Description: records where elements are stored in unboxed arrays + +The public interface is exported from + +-} +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@ + , 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" +-} diff --git a/Data/HList/TIP.hs b/Data/HList/TIP.hs --- a/Data/HList/TIP.hs +++ b/Data/HList/TIP.hs @@ -192,7 +192,7 @@ simplifying types containing type variables (in ghc-7.8 and 7.6): -With ghc-7.10 (http://ghc.haskell.org/trac/ghc/ticket/10009) the FD version is superior +With ghc-7.10 () the FD version is superior to the TF version: @ diff --git a/Data/HList/Variant.hs b/Data/HList/Variant.hs --- a/Data/HList/Variant.hs +++ b/Data/HList/Variant.hs @@ -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 diff --git a/Data/HList/broken/RecordU.hs b/Data/HList/broken/RecordU.hs deleted file mode 100644 --- a/Data/HList/broken/RecordU.hs +++ /dev/null @@ -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 - -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@ - , 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" --} diff --git a/HList.cabal b/HList.cabal --- a/HList.cabal +++ b/HList.cabal @@ -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 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, diff --git a/examples/Properties/LengthDependent.hs b/examples/Properties/LengthDependent.hs --- a/examples/Properties/LengthDependent.hs +++ b/examples/Properties/LengthDependent.hs @@ -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") diff --git a/examples/Properties/LengthIndependent.hs b/examples/Properties/LengthIndependent.hs --- a/examples/Properties/LengthIndependent.hs +++ b/examples/Properties/LengthIndependent.hs @@ -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