diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ +# FUTURE FEATUES +* `HUnion` typeclass to authomatically merge two sets +* `HDiff` typeclass to authomatically calculate difference between two hsets +* Use `Data.Set TypeRep Dynamic` as internal representation of hset to + increase access speed to arbitrary fields +* Add support of updating hset elements (make it not just read only) +* Add lens support + # CHANGELOG +## 1.1.0 +### Added +* `SubHSet` typeclass and instances to, yes, get arbitrary subhsets of + arbitrary hset. +* More type level fun for future stuff. ## 1.0.1 ### Changed * Grammar nazi fixed horrible bugs diff --git a/hset.cabal b/hset.cabal --- a/hset.cabal +++ b/hset.cabal @@ -1,5 +1,5 @@ name: hset -version: 1.0.1 +version: 1.1.0 synopsis: Primitive heterogenous read-only set license: BSD3 license-file: LICENSE @@ -41,6 +41,7 @@ , ScopedTypeVariables , TypeFamilies , TypeOperators + , UndecidableInstances test-suite test type: exitcode-stdio-1.0 @@ -62,6 +63,7 @@ , ScopedTypeVariables , TypeFamilies , TypeOperators + , UndecidableInstances build-depends: HUnit , base >=4.7 && < 5 diff --git a/src/Data/HSet.hs b/src/Data/HSet.hs --- a/src/Data/HSet.hs +++ b/src/Data/HSet.hs @@ -3,6 +3,10 @@ , HGet(..) , HGetable , hask + , SubHSet(..) + , SubHSetable + , hdelete + , hnarrow -- * Work with 'Labeled' elements , hgetLabeled , haskLabeled @@ -81,6 +85,84 @@ hask = do h <- ask return $ hget h + + +{- | Takes subset of some hset, including subset of same elements in +different order + +>>> let x = (HSCons "hello" $ HSCons 1234 $ HSCons 12.123 HSNil) :: HSet '[String, Int, Double] + +>>> subHSet x :: HSet '[Double, Int] +HSCons (12.123) (HSCons (1234) (HSNil)) + +>>> subHSet x :: HSet '[String, Double] +HSCons ("hello") (HSCons (12.123) (HSNil)) + +>>> subHSet x :: HSet '[Int, String] +HSCons (1234) (HSCons ("hello") (HSNil)) + +-} + +class (eq ~ TEq els els2) => SubHSet els els2 eq where + subHSet :: HSet els -> HSet els2 + +instance (eq ~ TEq els '[]) => SubHSet els '[] eq where + subHSet _ = HSNil + +instance ( HGetable els el, 'False ~ Elem el els2 + , SubHSet els els2 subeq + , 'False ~ TEq els (el ': els2) ) + => SubHSet els (el ': els2) 'False where + subHSet h = HSCons (hget h :: el) (subHSet h :: HSet els2) + +instance ( HGetable els el, 'False ~ Elem el els2 + , SubHSet els els2 subeq + , els ~ (el ': els2) + , 'True ~ TEq els (el ': els2) ) + => SubHSet els (el ': els2) 'True where + subHSet h = h + +type SubHSetable els1 els2 eq = (SubHSet els1 els2 eq, eq ~ TEq els1 els2 ) + +{- | Removes element from HSet of specified type + +>>> let x = (HSCons "sdf" $ HSCons 123 HSNil) :: HSet '[String, Int] + +>>> hdelete (Proxy :: Proxy Int) x +HSCons ("sdf") (HSNil) + +>>> hdelete (Proxy :: Proxy String) x +HSCons (123) (HSNil) + +-} + +hdelete :: (SubHSetable els (Delete a els) eq) + => proxy a -> HSet els -> HSet (Delete a els) +hdelete _ = subHSet + +{- | Like 'subHSet' but with proxy for convenience + +>>> let x = (HSCons "hello" $ HSCons 123 $ HSCons 345 HSNil) :: HSet '[String, Int, Integer] + +>>> hnarrow (Proxy :: Proxy '[]) x +HSNil + +>>> hnarrow (Proxy :: Proxy '[String]) x +HSCons ("hello") (HSNil) + +>>> hnarrow (Proxy :: Proxy '[Int, Integer]) x +HSCons (123) (HSCons (345) (HSNil)) + +>>> hnarrow (Proxy :: Proxy '[Integer, Int]) x +HSCons (345) (HSCons (123) (HSNil)) + +-} + +hnarrow :: (SubHSetable els subels eq) + => proxy subels -> HSet els -> HSet subels +hnarrow _ = subHSet + + {- | diff --git a/src/Data/HSet/TypeLevel.hs b/src/Data/HSet/TypeLevel.hs --- a/src/Data/HSet/TypeLevel.hs +++ b/src/Data/HSet/TypeLevel.hs @@ -1,4 +1,16 @@ -module Data.HSet.TypeLevel where +module Data.HSet.TypeLevel + ( Nat(..) + , Elem + , Index + , TEq + , Length + , Append + , Delete + , FirstEQ + , FirstContains + , And + , HSubset + ) where data Nat = Z | S Nat @@ -9,7 +21,52 @@ Elem typ (typ ': typs) = 'True Elem typ1 (typ2 ': typs) = Elem typ1 typs --- | Calculates to Nat kinded type describing the index of first argument in second argument +-- | Calculates to Nat kinded type describing the index of first +-- argument in second argument type family Index (typ :: k) (typs :: [k]) :: Nat where Index t (t ': ts) = 'Z Index t (tt ': ts) = 'S (Index t ts) + +type family TEq (t1 :: k) (t2 :: k) :: Bool where + TEq a a = 'True + TEq a b = 'False + +-- | Type level list length +type family Length (list :: [*]) :: Nat where + Length '[] = 'Z + Length (x ': xs) = 'S (Length xs) + +type family Append (l1 :: [*]) (l2 :: [*]) :: [*] where + Append '[] x = x + Append x '[] = x + Append (x ': xs) ys = x ': (Append xs ys) + +-- | Delete element from type list +type family Delete (typ :: *) (typs :: [*]) :: [*] where + Delete x '[] = '[] + Delete x (x ': ys) = Delete x ys + Delete x (y ': ys) = y ': (Delete x ys) + +-- | First elements of two lists are equal? +type family FirstEQ (list1 :: [*]) (list2 :: [*]) :: Bool where + FirstEQ '[] '[] = 'False + FirstEQ '[] x = 'False + FirstEQ x '[] = 'False + FirstEQ (x ': xs) (x ': ys) = 'True + FirstEQ (x ': xs) (y ': ys) = 'False + +type family FirstContains (list1 :: [*]) (list2 :: [*]) :: Bool where + FirstContains '[] x = 'False + FirstContains x '[] = 'False + FirstContains (x ': xs) els = Elem x els + +type family And (a :: Bool) (b :: Bool) where + And 'False x = 'False + And x 'False = 'False + And x y = 'True + +-- | Checks if the former subset included in the latter one. +type family HSubset (h1 :: [k]) (h2 :: [k]) where + HSubset '[] x = 'True + HSubset x '[] = 'False + HSubset (h1 ': tl2) h2 = And (Elem h1 h2) (HSubset tl2 h2)