packages feed

extensible 0.2.7 → 0.2.8

raw patch · 10 files changed

+185/−38 lines, 10 filesdep +deepseq

Dependencies added: deepseq

Files

CHANGELOG.md view
@@ -1,9 +1,13 @@+0.2.8+-----------------------------------------------------+* Improved performance considerably+ 0.2.7 ----------------------------------------------------- * Added `accessing` * Added `decFields` and `decFieldsDeriving` * Renamed `Position` to `Membership`-*+ 0.2.6 ----------------------------------------------------- * Right-associated `(++)`
+ benchmarks/AtoZ.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds, TypeOperators, GADTs, BangPatterns #-}+module AtoZ where+import Data.Extensible+import Data.Coerce+data A = A Int deriving Show+data B = B Int deriving Show+data C = C Int deriving Show+data D = D Int deriving Show+data E = E Int deriving Show+data F = F Int deriving Show+data G = G Int deriving Show+data H = H Int deriving Show+data I = I Int deriving Show+data J = J Int deriving Show+data K = K Int deriving Show+data L = L Int deriving Show+data M = M Int deriving Show+data N = N Int deriving Show+data O = O Int deriving Show+data P = P Int deriving Show+data Q = Q Int deriving Show+data R = R Int deriving Show+data S = S Int deriving Show+data T = T Int deriving Show+data U = U Int deriving Show+data V = V Int deriving Show+data W = W Int deriving Show+data X = X Int deriving Show+data Y = Y Int deriving Show+data Z = Z Int deriving Show++type AtoZ = [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]++blah26 :: K0 :* AtoZ+blah26 = 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 <% 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)++match26 :: Match K0 Int :* AtoZ+match26 = (\(A n) -> n)+  <?% (\(B n) -> n)+  <?% (\(C n) -> n)+  <?% (\(D n) -> n)+  <?% (\(E n) -> n)+  <?% (\(F n) -> n)+  <?% (\(G n) -> n)+  <?% (\(H n) -> n)+  <?% (\(I n) -> n)+  <?% (\(J n) -> n)+  <?% (\(K n) -> n)+  <?% (\(L n) -> n)+  <?% (\(M n) -> n)+  <?% (\(N n) -> n)+  <?% (\(O n) -> n)+  <?% (\(P n) -> n)+  <?% (\(Q n) -> n)+  <?% (\(R n) -> n)+  <?% (\(S n) -> n)+  <?% (\(T n) -> n)+  <?% (\(U n) -> n)+  <?% (\(V n) -> n)+  <?% (\(W n) -> n)+  <?% (\(X n) -> n)+  <?% (\(Y n) -> n)+  <?% (\(Z n) -> n)+  <?% Nil
+ benchmarks/membership.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ViewPatterns, TypeOperators, GADTs #-}+import Data.Extensible+import Data.Extensible.Internal+import Criterion.Main+import AtoZ+import Unsafe.Coerce++data Sum = C0 A|C1 B|C2 C|C3 D|C4 E|C5 F|C6 G|C7 H|C8 I|C9 J|C10 K |C11 L|C12 M+  |C13 N|C14 O|C15 P|C16 Q|C17 R|C18 S|C19 T|C20 U|C21 V|C22 W|C23 X|C24 Y|C25 Z++testNaive :: Sum -> Int+testNaive (C0 (A n)) = n+testNaive (C1 (B n)) = n+testNaive (C2 (C n)) = n+testNaive (C3 (D n)) = n+testNaive (C4 (E n)) = n+testNaive (C5 (F n)) = n+testNaive (C6 (G n)) = n+testNaive (C7 (H n)) = n+testNaive (C8 (I n)) = n+testNaive (C9 (J n)) = n+testNaive (C10 (K n)) = n+testNaive (C11 (L n)) = n+testNaive (C12 (M n)) = n+testNaive (C13 (N n)) = n+testNaive (C14 (O n)) = n+testNaive (C15 (P n)) = n+testNaive (C16 (Q n)) = n+testNaive (C17 (R n)) = n+testNaive (C18 (S n)) = n+testNaive (C19 (T n)) = n+testNaive (C20 (U n)) = n+testNaive (C21 (V n)) = n+testNaive (C22 (W n)) = n+testNaive (C23 (X n)) = n+testNaive (C24 (Y n)) = n+testNaive (C25 (Z n)) = n++testExt :: K0 :| AtoZ -> Int+testExt = match match26++main = defaultMain [+  bgroup "sum" [+     bench "A" $ whnf testExt (bury (A 0))+    , bench "M" $ whnf testExt (bury (M 0))+    , bench "T" $ whnf testExt (bury (T 0))+    , bench "Z" $ whnf testExt (bury (Z 0))+    , bench "A_" $ whnf testNaive  (C0 (A 0))+    , bench "M_" $ whnf testNaive (C12 (M 0))+    , bench "T_" $ whnf testNaive (C19 (T 0))+    , bench "Z_" $ whnf testNaive (C25 (Z 0))+    ]+  , bgroup "product" [+      bench "A" $ whnf (\(pluck -> A x) -> x) blah26+    , bench "G"  $ whnf (\(pluck -> G x) -> x) blah26+    , bench "N"  $ whnf (\(pluck -> N x) -> x) blah26+    , bench "T"  $ whnf (\(pluck -> T x) -> x) blah26+    , bench "Z" $ whnf (\(pluck -> Z x) -> x) blah26+    ]+  , 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+    ]+  ]
extensible.cabal view
@@ -1,5 +1,5 @@ name:                extensible-version:             0.2.7+version:             0.2.8 synopsis:            Extensible, efficient, lens-friendly data types homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -15,6 +15,7 @@  extra-source-files:   examples/*.hs+  benchmarks/*.hs   .gitignore   .travis.yml   README.md@@ -50,7 +51,7 @@     , FlexibleContexts     , FlexibleInstances     , PolyKinds-  build-depends:       base >= 4.7 && <5, template-haskell+  build-depends:       base >= 4.7 && <5, template-haskell, deepseq   hs-source-dirs:      src-  ghc-options: -Wall+  ghc-options: -Wall -O2   default-language:    Haskell2010
src/Data/Extensible/Dictionary.hs view
@@ -16,6 +16,7 @@ import Data.Monoid import Data.Extensible.Product import Data.Extensible.Sum+import Data.Extensible.Match import Data.Extensible.Internal import Data.Extensible.Internal.Rig
src/Data/Extensible/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE TemplateHaskell #-}@@ -18,7 +19,7 @@   , runMembership   , compareMembership   , ord-  , Nav(..)+  , NavHere(..)   , navigate   , here   , navNext@@ -53,6 +54,9 @@ import Unsafe.Coerce import Data.Typeable import Language.Haskell.TH+import Control.DeepSeq+import Data.Word+import Data.Bits  -- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). ord :: Int -> Q Exp@@ -66,8 +70,11 @@     $ 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 Int deriving Typeable+newtype Membership (xs :: [k]) (x :: k) = Membership Word8 deriving Typeable +instance NFData (Membership xs x) where+  rnf (Membership a) = rnf a+ instance Show (Membership xs x) where   show (Membership n) = "$(ord " ++ show n ++ ")" @@ -83,22 +90,29 @@ runMembership (Membership n) = Right (Membership (n - 1)) {-# INLINE runMembership #-} +-- | PRIVILEGED: Compare two 'Membership's. compareMembership :: Membership xs x -> Membership xs y -> Either Ordering (x :~: y) compareMembership (Membership m) (Membership n) = case compare m n of   EQ -> Right (unsafeCoerce Refl)   x -> Left x {-# INLINE compareMembership #-} -navigate :: Membership xs x -> Nav xs x-navigate (Membership 0) = unsafeCoerce Here-navigate (Membership n) = let (m, r) = divMod (n - 1) 2 in case r of-  0 -> unsafeCoerce $ NavL $ Membership m-  _ -> unsafeCoerce $ NavR $ Membership m+-- | PRIVILEGED: Navigate a tree.+navigate :: (NavHere xs x -> r)+  -> (Membership (Half (Tail xs)) x -> r)+  -> (Membership (Half (Tail (Tail xs))) x -> r)+  -> Membership xs x+  -> r+navigate h nl nr = \case+  Membership 0 -> h (unsafeCoerce Here)+  Membership n -> let !x = n - 1 in if testBit x 0+    then nr (Membership (shiftR x 1))+    else nl (Membership (shiftR x 1))+{-# INLINE navigate #-} -data Nav xs x where-  Here :: Nav (x ': xs) x-  NavL :: Membership (Half xs) x -> Nav (e ': xs) x-  NavR :: Membership (Half (Tail xs)) x -> Nav (e ': xs) x+-- | Ensure that the first element of @xs@ is @x@+data NavHere xs x where+  Here :: NavHere (x ': xs) x  here :: Membership (x ': xs) x here = Membership 0@@ -138,7 +152,7 @@   Check x xs = Ambiguous x  instance (Check x (Lookup x xs) ~ Expecting one, ToInt one) => Member xs x where-  membership = Membership $ theInt (Proxy :: Proxy one)+  membership = Membership (theInt (Proxy :: Proxy one))   {-# INLINE membership #-}  type family Half (xs :: [k]) :: [k] where@@ -152,27 +166,19 @@  data Nat = Zero | DNat Nat | SDNat Nat -retagD :: (Proxy n -> a) -> proxy (DNat n) -> a-retagD f _ = f Proxy-{-# INLINE retagD #-}--retagSD :: (Proxy n -> a) -> proxy (SDNat n) -> a-retagSD f _ = f Proxy-{-# INLINE retagSD #-}- class ToInt n where-  theInt :: proxy n -> Int+  theInt :: proxy n -> Word8  instance ToInt Zero where   theInt _ = 0   {-# INLINE theInt #-}  instance ToInt n => ToInt (DNat n) where-  theInt = (*2) <$> retagD theInt+  theInt _ = theInt (Proxy :: Proxy n) `shiftL` 1   {-# INLINE theInt #-}  instance ToInt n => ToInt (SDNat n) where-  theInt = (+1) <$> (*2) <$> retagSD theInt+  theInt _ = (theInt (Proxy :: Proxy n) `shiftL` 1) + 1   {-# INLINE theInt #-}  type family Lookup (x :: k) (xs :: [k]) :: [Nat] where@@ -194,6 +200,7 @@ lemmaHalfTail _ = unsafeCoerce {-# INLINE lemmaHalfTail #-} +-- | GHC can't prove this lemmaMerging :: p (Merge (Half xs) (Half (Tail xs))) -> p xs lemmaMerging = unsafeCoerce
src/Data/Extensible/Match.hs view
@@ -33,7 +33,7 @@  -- | /O(log n)/ Perform pattern matching. match :: Match h a :* xs -> h :| xs -> a-match p (UnionAt pos h) = runMatch (hlookup pos p) h+match p = \(UnionAt pos h) -> views (sectorAt pos) runMatch p h {-# INLINE match #-}  -- | Flipped `match`
src/Data/Extensible/Plain.hs view
@@ -51,7 +51,7 @@  -- | Extract a plain value. pluck :: (x ∈ xs) => AllOf xs -> x-pluck = getK0 . hlookup membership+pluck = views sector getK0 {-# INLINE pluck #-}  -- | Embed a plain value.
src/Data/Extensible/Product.hs view
@@ -140,14 +140,14 @@ {-# INLINE sector #-}  -- | /O(log n)/ A lens for a value in a known position.-sectorAt :: forall h x xs f. Functor f => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs)-sectorAt pos0 f = go pos0 where-  go :: forall t. Membership t x -> h :* t -> f (h :* t)-  go pos (Tree h a b) = case navigate pos of-    Here -> fmap (\h' -> Tree h' a b) (f h)-    NavL p -> fmap (\a' -> Tree h a' b) $ go p a-    NavR p -> fmap (\b' -> Tree h a b') $ go p b-  go _ Nil = error "Impossible"+sectorAt :: forall f h x xs. Functor f => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs)+sectorAt pos f = flip go pos where+  go :: forall t. h :* t -> Membership t x -> f (h :* t)+  go (Tree h a b) = navigate+    (\Here -> fmap (\h' -> Tree h' a b) (f h))+    (fmap (\a' -> Tree h a' b) . go a)+    (fmap (\b' -> Tree h a b') . go b)+  go Nil = error "Impossible" {-# INLINE sectorAt #-}  -- | Given a function that maps types to values, we can "collect" entities all you want.
src/Data/Extensible/Sum.hs view
@@ -27,7 +27,7 @@  -- | The extensible sum type data (h :: k -> *) :| (s :: [k]) where-  UnionAt :: Membership xs x -> h x -> h :| xs+  UnionAt :: !(Membership xs x) -> h x -> h :| xs deriving instance Typeable (:|)  -- | Change the wrapper.