diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +0.2.10 +----------------------------------------------------- +* Optimized `sector` (~2x) + 0.2.9 ----------------------------------------------------- * Renamed `( A x) -> x) extensible26 + bench "Data" $ whnf (\(getZ -> Z x) -> x) data26 + , bench "A" $ whnf (\(pluck -> A x) -> x) extensible26 , bench "B" $ whnf (\(pluck -> B x) -> x) extensible26 , bench "C" $ whnf (\(pluck -> C x) -> x) extensible26 , bench "D" $ whnf (\(pluck -> D x) -> x) extensible26 @@ -95,7 +97,6 @@ , bench "X" $ whnf (\(hOccursFst -> X x) -> x) hlist26 , bench "Y" $ whnf (\(hOccursFst -> Y x) -> x) hlist26 , bench "Z" $ whnf (\(hOccursFst -> Z x) -> x) hlist26 - ] , bgroup "sum" [ bench "A" $ whnf testExt (bury (A 0)) @@ -107,7 +108,5 @@ , bench "T_" $ whnf testNaive (C19 (T 0)) , bench "Z_" $ whnf testNaive (C25 (Z 0)) ] - , bgroup "tuple" [ - bench "A" $ whnf (\(a,b,c,d,e,f,g,h,i,j,k,l,M res,n,o,p,q,r,s,t,u,v,w,x,y,z) -> res) tuple26 - ] + ] diff --git a/examples/test.hs b/examples/test.hs new file mode 100644 --- /dev/null +++ b/examples/test.hs @@ -0,0 +1,7 @@ +import Data.Extensible + +test = (42 :: Int) <% "hoge" <% False <% Nil + +value = pluck test :: Int + +main = print value diff --git a/extensible.cabal b/extensible.cabal --- a/extensible.cabal +++ b/extensible.cabal @@ -1,5 +1,5 @@ name: extensible -version: 0.2.9 +version: 0.2.10 synopsis: Extensible, efficient, lens-friendly data types homepage: https://github.com/fumieval/extensible bug-reports: http://github.com/fumieval/extensible/issues diff --git a/src/Data/Extensible/Dictionary.hs b/src/Data/Extensible/Dictionary.hs --- a/src/Data/Extensible/Dictionary.hs +++ b/src/Data/Extensible/Dictionary.hs @@ -83,7 +83,7 @@ instance WrapForall Show h xs => Show (h :| xs) where showsPrec d (UnionAt pos h) = showParen (d > 10) $ showString "embed " - . getShowsPrec (hlookup pos library) 11 h + . views (sectorAt pos) getShowsPrec library 11 h instance WrapForall Eq h xs => Eq (h :| xs) where UnionAt p g == UnionAt q h = case compareMembership p q of diff --git a/src/Data/Extensible/Inclusion.hs b/src/Data/Extensible/Inclusion.hs --- a/src/Data/Extensible/Inclusion.hs +++ b/src/Data/Extensible/Inclusion.hs @@ -54,7 +54,7 @@ -- | /O(m log n)/ Select some elements. shrink :: (xs ⊆ ys) => h :* ys -> h :* xs -shrink h = hmap (\pos -> hlookup pos h) inclusion +shrink h = hmap (`hlookup` h) inclusion {-# INLINE shrink #-} -- | A lens for a subset (inefficient) @@ -66,7 +66,7 @@ -- | /O(log n)/ Embed to a larger union. spread :: (xs ⊆ ys) => h :| xs -> h :| ys -spread (UnionAt pos h) = UnionAt (hlookup pos inclusion) h +spread (UnionAt pos h) = views (sectorAt pos) UnionAt inclusion h {-# INLINE spread #-} -- | The inverse of 'inclusion'. @@ -83,5 +83,5 @@ -- | Narrow the range of the sum, if possible. retrench :: (Generate ys, xs ⊆ ys) => h :| ys -> Nullable ((:|) h) xs -retrench (UnionAt pos h) = flip UnionAt h `mapNullable` hlookup pos coinclusion +retrench (UnionAt pos h) = views (sectorAt pos) (mapNullable (`UnionAt`h)) coinclusion {-# INLINE retrench #-} diff --git a/src/Data/Extensible/Internal.hs b/src/Data/Extensible/Internal.hs --- a/src/Data/Extensible/Internal.hs +++ b/src/Data/Extensible/Internal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables, BangPatterns, StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | @@ -16,6 +16,7 @@ -- A bunch of combinators that contains magic ------------------------------------------------------------------------ module Data.Extensible.Internal (Membership + , getMemberId , runMembership , compareMembership , ord @@ -25,14 +26,20 @@ , navNext , navL , navR + , (:*)(..) , Member(..) , (∈)() , Nat(..) , ToInt(..) , Lookup + , ListIndex + , LookupTree(..) , Succ , MapSucc + , Pred + , Div2 , Half + , Head , Tail , lemmaHalfTail , lemmaMerging @@ -53,7 +60,7 @@ import Control.Monad import Unsafe.Coerce import Data.Typeable -import Language.Haskell.TH +import Language.Haskell.TH hiding (Pred) import Control.DeepSeq import Data.Bits import Data.Word @@ -70,8 +77,52 @@ $ conT ''Membership `appT` pure t `appT` varT (names !! n) -- | The position of @x@ in the type level set @xs@. -newtype Membership (xs :: [k]) (x :: k) = Membership Word deriving Typeable +newtype Membership (xs :: [k]) (x :: k) = Membership { getMemberId :: Word } deriving Typeable +-- | Lookup types +type family ListIndex (n :: Nat) (xs :: [k]) :: k where + ListIndex Zero (x ': xs) = x + ListIndex (SDNat n) (y ': xs) = ListIndex n (Half xs) + ListIndex (DNat n) xs = ListIndex n (Half xs) + +type family Pred (n :: Nat) :: Nat where + Pred (SDNat Zero) = Zero + Pred (SDNat n) = DNat n + Pred (DNat n) = SDNat (Pred n) + Pred Zero = Zero + +type family Div2 (n :: Nat) :: Nat where + Div2 (SDNat n) = n + Div2 (DNat n) = n + Div2 Zero = Zero + +-- | The extensible product type +data (h :: k -> *) :* (s :: [k]) where + Nil :: h :* '[] + Tree :: !(h x) + -> h :* Half xs + -> h :* Half (Tail xs) + -> h :* (x ': xs) + +deriving instance Typeable (:*) + +class LookupTree (n :: Nat) (xs :: [k]) x | n xs -> x where + lookupTree :: Functor f => proxy n + -> (h x -> f (h x)) + -> h :* xs -> f (h :* xs) + +instance LookupTree Zero (x ': xs) x where + lookupTree _ f (Tree h a b) = fmap (\h' -> Tree h' a b) (f h) + {-# INLINE lookupTree #-} + +instance LookupTree n (Half xs) x => LookupTree (SDNat n) (t ': xs) x where + lookupTree _ f (Tree h a b) = fmap (\a' -> Tree h a' b) (lookupTree (Proxy :: Proxy n) f a) + {-# INLINE lookupTree #-} + +instance LookupTree (Pred n) (Half (Tail xs)) x => LookupTree (DNat n) (t ': xs) x where + lookupTree _ f (Tree h a b) = fmap (\b' -> Tree h a b') (lookupTree (Proxy :: Proxy (Div2 (Pred (DNat n)))) (unsafeCoerce f) b) + {-# INLINE lookupTree #-} + instance NFData (Membership xs x) where rnf (Membership a) = rnf a @@ -137,8 +188,10 @@ -- | Unicode flipped alias for 'Member' type x ∈ xs = Member xs x --- | @Member x xs@ or @x ∈ xs@ indicates that @x@ is an element of @xs@. -class Member (xs :: [k]) (x :: k) where +type family Head (xs :: [k]) :: k where + Head (x ': xs) = x + +class (LookupTree (Head (Lookup x xs)) xs x) => Member xs x where membership :: Membership xs x -- | A type sugar to make type error more readable. @@ -156,10 +209,16 @@ Check x '[] = Missing x Check x xs = Ambiguous x -instance (Check x (Lookup x xs) ~ Expecting one, ToInt one) => Member xs x where +instance (Check x (Lookup x xs) ~ Expecting one, ToInt one, LookupTree (Head (Lookup x xs)) xs x) => Member xs x where membership = Membership (theInt (Proxy :: Proxy one)) {-# INLINE membership #-} +-- | Lookup types +type family Lookup (x :: k) (xs :: [k]) :: [Nat] where + Lookup x (x ': xs) = Zero ': Lookup x xs + Lookup x (y ': ys) = MapSucc (Lookup x ys) + Lookup x '[] = '[] + -- | Interleaved list type family Half (xs :: [k]) :: [k] where Half '[] = '[] @@ -189,12 +248,6 @@ instance ToInt n => ToInt (SDNat n) where theInt _ = (theInt (Proxy :: Proxy n) `unsafeShiftL` 1) + 1 {-# INLINE theInt #-} - --- | Lookup types -type family Lookup (x :: k) (xs :: [k]) :: [Nat] where - Lookup x (x ': xs) = Zero ': Lookup x xs - Lookup x (y ': ys) = MapSucc (Lookup x ys) - Lookup x '[] = '[] -- | The successor of the number type family Succ (x :: Nat) :: Nat where diff --git a/src/Data/Extensible/Internal/Rig.hs b/src/Data/Extensible/Internal/Rig.hs --- a/src/Data/Extensible/Internal/Rig.hs +++ b/src/Data/Extensible/Internal/Rig.hs @@ -23,12 +23,12 @@ type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s -- | @'view' :: Lens' s a -> (a -> a) -> (s -> s)@ -view :: ((a -> Const a a) -> (s -> Const a s)) -> s -> a +view :: ((a -> Const a a) -> s -> Const a s) -> s -> a view l = views l id {-# INLINE view #-} -- | @'views' :: Lens' s a -> (a -> r) -> (s -> r)@ -views :: ((a -> Const r a) -> (s -> Const r s)) -> (a -> r) -> s -> r +views :: ((a -> Const r a) -> s -> Const r s) -> (a -> r) -> s -> r views = unsafeCoerce {-# INLINE views #-} diff --git a/src/Data/Extensible/Product.hs b/src/Data/Extensible/Product.hs --- a/src/Data/Extensible/Product.hs +++ b/src/Data/Extensible/Product.hs @@ -45,20 +45,9 @@ import Data.Extensible.Internal.Rig import Data.Extensible.Internal.HList import Unsafe.Coerce -import Data.Typeable import Control.Applicative import Data.Monoid --- | The extensible product type -data (h :: k -> *) :* (s :: [k]) where - Nil :: h :* '[] - Tree :: !(h x) - -> h :* Half xs - -> h :* Half (Tail xs) - -> h :* (x ': xs) - -deriving instance Typeable (:*) - -- | /O(1)/ Extract the head element. hhead :: h :* (x ': xs) -> h x hhead (Tree a _ _) = a @@ -140,8 +129,8 @@ {-# INLINE htabulate #-} -- | /O(log n)/ A lens for a specific element. -sector :: (x ∈ xs) => Lens' (h :* xs) (h x) -sector = sectorAt membership +sector :: forall h x xs. (x ∈ xs) => Lens' (h :* xs) (h x) +sector = lookupTree (Proxy :: Proxy (Head (Lookup x xs))) {-# INLINE sector #-} -- | /O(log n)/ A lens for a value in a known position. @@ -171,6 +160,7 @@ -- | Pure version of 'generateA'. generate :: Generate xs => (forall x. Membership xs x -> h x) -> h :* xs generate f = getK0 (generateA (K0 . f)) +{-# INLINE generate #-} -- | Guarantees the all elements satisfies the predicate. class Forall c (xs :: [k]) where @@ -191,6 +181,7 @@ -- | Pure version of 'generateForA'. generateFor :: Forall c xs => proxy c -> (forall x. c x => Membership xs x -> h x) -> h :* xs generateFor p f = getK0 (generateForA p (K0 . f)) +{-# INLINE generateFor #-} -- | Turn a product into 'HList'. toHList :: h :* xs -> HList h xs