packages feed

extensible 0.2.9 → 0.2.10

raw patch · 10 files changed

+126/−42 lines, 10 files

Files

CHANGELOG.md view
@@ -1,3 +1,7 @@+0.2.10+-----------------------------------------------------+* Optimized `sector` (~2x)+ 0.2.9 ----------------------------------------------------- * Renamed `(<?~)` to `(<?!$)`
benchmarks/AtoZ.hs view
@@ -38,9 +38,39 @@   <% O 14 <% P 15 <% Q 16 <% R 17 <% S 18 <% T 19 <% U 20   <% V 21 <% W 22 <% X 23 <% Y 24 <% Z 25 <% Nil -tuple26 :: (A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z)-tuple26 = (A 0, B 1, C 2, D 3, E 4, F 5, G 6, H 7, I 8, J 9, K 10, L 11, M 12-  , N 13, O 14, P 15, Q 16, R 17, S 18, T 19, U 20, V 21, W 22, X 23, Y 24, Z 25)+data Data26 = Data26+  { getA :: A+  , getB :: B+  , getC :: C+  , getD :: D+  , getE :: E+  , getF :: F+  , getG :: G+  , getH :: H+  , getI :: I+  , getJ :: J+  , getK :: K+  , getL :: L+  , getM :: M+  , getN :: N+  , getO :: O+  , getP :: P+  , getQ :: Q+  , getR :: R+  , getS :: S+  , getT :: T+  , getU :: U+  , getV :: V+  , getW :: W+  , getX :: X+  , getY :: Y+  , getZ :: Z+  }++data26 :: Data26+data26 = Data26 (A 0) (B 1) (C 2) (D 3) (E 4) (F 5) (G 6) (H 7) (I 8) (J 9) (K 10)+  (L 11) (M 12) (N 13) (O 14) (P 15) (Q 16) (R 17) (S 18) (T 19) (U 20) (V 21)+  (W 22) (X 23) (Y 24) (Z 25)  hlist26 :: HList AtoZ hlist26 = A 0 `HCons` B 1 `HCons` C 2 `HCons` D 3 `HCons` E 4 `HCons` F 5 `HCons` G 6
benchmarks/membership.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE ViewPatterns, TypeOperators, GADTs, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, PolyKinds, ViewPatterns, TypeFamilies, TypeOperators, GADTs, Rank2Types, ScopedTypeVariables, DataKinds #-} import Data.Extensible import Data.Extensible.Internal+import Data.Extensible.Internal.Rig import Control.Applicative import Criterion.Main import AtoZ@@ -43,7 +44,8 @@  main = defaultMain [    bgroup "product" [-      bench "A" $ whnf (\(pluck -> 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-    ]+   ]
+ examples/test.hs view
@@ -0,0 +1,7 @@+import Data.Extensible++test = (42 :: Int) <% "hoge" <% False <% Nil++value = pluck test :: Int++main = print value
extensible.cabal view
@@ -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
src/Data/Extensible/Dictionary.hs view
@@ -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
src/Data/Extensible/Inclusion.hs view
@@ -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 #-}
src/Data/Extensible/Internal.hs view
@@ -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
src/Data/Extensible/Internal/Rig.hs view
@@ -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 #-}
src/Data/Extensible/Product.hs view
@@ -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