packages feed

extensible 0.2.8 → 0.2.9

raw patch · 17 files changed

+216/−80 lines, 17 filesdep +binary

Dependencies added: binary

Files

.travis.yml view
@@ -1,10 +1,10 @@ language: haskell
 
 env:
-  - GHCVER=7.8.3
+  - GHCVER=7.8.4
 
 before_install:
   - sudo add-apt-repository -y ppa:hvr/ghc
   - sudo apt-get update
-  - sudo apt-get install -y -qq cabal-install-1.20 ghc-$GHCVER
+  - sudo apt-get install -y -qq cabal-install-1.22 ghc-$GHCVER
   - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH
CHANGELOG.md view
@@ -1,3 +1,10 @@+0.2.9+-----------------------------------------------------+* Renamed `(<?~)` to `(<?!$)`+* Renamed `(<$?~)` to `(<?!~)`+* Refactored `Data.Extensible.Dictionary`+* Supported serialization/deserialization of products using `binary`+ 0.2.8 ----------------------------------------------------- * Improved performance considerably
README.md view
@@ -2,11 +2,12 @@ ======================  [![Build Status](https://travis-ci.org/fumieval/extensible.svg?branch=master)](https://travis-ci.org/fumieval/extensible)+[![Hackage](https://budueba.com/hackage/extensible)](https://hackage.haskell.org/package/extensible)  This package provides extensible poly-kinded data types, including records and polymorphic open unions. -While most rival packages takes O(n) for looking up, this package provides O(log n) access.+It focuses on being neat and fast. -Extensible products can be applied to first-class pattern matching. It is potentially faster than the ordinary pattern matching, since accessing to an element is O(log n).+![Benchmark](benchmark-accessing.png) -Bug reports and contributions are welcome.+Bug reports and contributions are welcome!
benchmarks/AtoZ.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, TypeOperators, GADTs, BangPatterns #-} module AtoZ where import Data.Extensible+import Data.HList hiding (K(..)) import Data.Coerce data A = A Int deriving Show data B = B Int deriving Show@@ -31,15 +32,21 @@  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+extensible26 :: K0 :* AtoZ+extensible26 = 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)++hlist26 :: HList AtoZ+hlist26 = A 0 `HCons` B 1 `HCons` C 2 `HCons` D 3 `HCons` E 4 `HCons` F 5 `HCons` G 6+  `HCons` H 7 `HCons` I 8 `HCons` J 9 `HCons` K 10 `HCons` L 11 `HCons` M 12 `HCons` N 13+  `HCons` O 14 `HCons` P 15 `HCons` Q 16 `HCons` R 17 `HCons` S 18 `HCons` T 19 `HCons` U 20+  `HCons` V 21 `HCons` W 22 `HCons` X 23 `HCons` Y 24 `HCons` Z 25 `HCons` HNil  match26 :: Match K0 Int :* AtoZ match26 = (\(A n) -> n)
benchmarks/membership.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE ViewPatterns, TypeOperators, GADTs #-}+{-# LANGUAGE ViewPatterns, TypeOperators, GADTs, Rank2Types, ScopedTypeVariables #-} import Data.Extensible import Data.Extensible.Internal+import Control.Applicative import Criterion.Main import AtoZ+import Data.HList hiding (K(..)) 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@@ -40,7 +42,62 @@ testExt = match match26  main = defaultMain [-  bgroup "sum" [+   bgroup "product" [+      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+    , bench "E"  $ whnf (\(pluck -> E x) -> x) extensible26+    , bench "F"  $ whnf (\(pluck -> F x) -> x) extensible26+    , bench "G"  $ whnf (\(pluck -> G x) -> x) extensible26+    , bench "H"  $ whnf (\(pluck -> H x) -> x) extensible26+    , bench "I"  $ whnf (\(pluck -> I x) -> x) extensible26+    , bench "J"  $ whnf (\(pluck -> J x) -> x) extensible26+    , bench "K"  $ whnf (\(pluck -> K x) -> x) extensible26+    , bench "L"  $ whnf (\(pluck -> L x) -> x) extensible26+    , bench "M"  $ whnf (\(pluck -> M x) -> x) extensible26+    , bench "N"  $ whnf (\(pluck -> N x) -> x) extensible26+    , bench "O"  $ whnf (\(pluck -> O x) -> x) extensible26+    , bench "P"  $ whnf (\(pluck -> P x) -> x) extensible26+    , bench "Q"  $ whnf (\(pluck -> Q x) -> x) extensible26+    , bench "R"  $ whnf (\(pluck -> R x) -> x) extensible26+    , bench "S"  $ whnf (\(pluck -> S x) -> x) extensible26+    , bench "T"  $ whnf (\(pluck -> T x) -> x) extensible26+    , bench "U"  $ whnf (\(pluck -> U x) -> x) extensible26+    , bench "V"  $ whnf (\(pluck -> V x) -> x) extensible26+    , bench "W"  $ whnf (\(pluck -> W x) -> x) extensible26+    , bench "X"  $ whnf (\(pluck -> X x) -> x) extensible26+    , bench "Y"  $ whnf (\(pluck -> Y x) -> x) extensible26+    , bench "Z"  $ whnf (\(pluck -> Z x) -> x) extensible26+    , bench "A"  $ whnf (\(hOccursFst -> A x) -> x) hlist26+    , bench "B"  $ whnf (\(hOccursFst -> B x) -> x) hlist26+    , bench "C"  $ whnf (\(hOccursFst -> C x) -> x) hlist26+    , bench "D"  $ whnf (\(hOccursFst -> D x) -> x) hlist26+    , bench "E"  $ whnf (\(hOccursFst -> E x) -> x) hlist26+    , bench "F"  $ whnf (\(hOccursFst -> F x) -> x) hlist26+    , bench "G"  $ whnf (\(hOccursFst -> G x) -> x) hlist26+    , bench "H"  $ whnf (\(hOccursFst -> H x) -> x) hlist26+    , bench "I"  $ whnf (\(hOccursFst -> I x) -> x) hlist26+    , bench "J"  $ whnf (\(hOccursFst -> J x) -> x) hlist26+    , bench "K"  $ whnf (\(hOccursFst -> K x) -> x) hlist26+    , bench "L"  $ whnf (\(hOccursFst -> L x) -> x) hlist26+    , bench "M"  $ whnf (\(hOccursFst -> M x) -> x) hlist26+    , bench "N"  $ whnf (\(hOccursFst -> N x) -> x) hlist26+    , bench "O"  $ whnf (\(hOccursFst -> O x) -> x) hlist26+    , bench "P"  $ whnf (\(hOccursFst -> P x) -> x) hlist26+    , bench "Q"  $ whnf (\(hOccursFst -> Q x) -> x) hlist26+    , bench "R"  $ whnf (\(hOccursFst -> R x) -> x) hlist26+    , bench "S"  $ whnf (\(hOccursFst -> S x) -> x) hlist26+    , bench "T"  $ whnf (\(hOccursFst -> T x) -> x) hlist26+    , bench "U"  $ whnf (\(hOccursFst -> U x) -> x) hlist26+    , bench "V"  $ whnf (\(hOccursFst -> V x) -> x) hlist26+    , bench "W"  $ whnf (\(hOccursFst -> W x) -> x) hlist26+    , 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))     , bench "M" $ whnf testExt (bury (M 0))     , bench "T" $ whnf testExt (bury (T 0))@@ -49,13 +106,6 @@     , 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
+ benchmarks/test.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TypeOperators #-}+import Data.Extensible+import AtoZ+import Unsafe.Coerce+import Control.Applicative++-- | @'views' :: Lens' s a -> (a -> r) -> (s -> r)@+views :: ((a -> Const r a) -> (s -> Const r s)) -> (a -> r) -> s -> r+views = unsafeCoerce+{-# INLINE views #-}++pluck' :: (x ∈ xs) => AllOf xs -> x+pluck' = views (sectorAt membership) getK0+{-# INLINE pluck' #-}++main = print (pluck' extensible26 :: A)
extensible.cabal view
@@ -1,5 +1,5 @@ name:                extensible-version:             0.2.8+version:             0.2.9 synopsis:            Extensible, efficient, lens-friendly data types homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -51,7 +51,7 @@     , FlexibleContexts     , FlexibleInstances     , PolyKinds-  build-depends:       base >= 4.7 && <5, template-haskell, deepseq+  build-depends:       base >= 4.7 && <5, template-haskell, deepseq, binary < 1   hs-source-dirs:      src   ghc-options: -Wall -O2   default-language:    Haskell2010
src/Data/Extensible/Dictionary.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds, TypeFamilies, InstanceSigs, UndecidableInstances, MultiParamTypeClasses, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------- --@@ -16,66 +16,88 @@ import Data.Monoid import Data.Extensible.Product import Data.Extensible.Sum-import Data.Extensible.Match import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import qualified Data.Binary as B -type DictOf c g h = forall xs. WrapForall c g xs => h :* xs+-- | Reifiable classes+class Reifiable c where+  -- | The associated dictionary which subsumes essential methods.+  data Dictionary c (h :: k -> *) (x :: k) -dictShow :: forall h. DictOf Show h (Match h (Int -> ShowS))-dictShow = generateFor (Proxy :: Proxy (Instance1 Show h)) $ const $ Match (flip showsPrec)+  -- | Fetch the 'Dictionary'.+  library :: WrapForall c h xs => Dictionary c h :* xs -dictEq :: forall h. DictOf Eq h (Wrap2 h Bool)-dictEq = generateFor (Proxy :: Proxy (Instance1 Eq h)) $ const $ Wrap2 (==)+instance Reifiable Show where+  data Dictionary Show h x = DictShow { getShowsPrec :: Int -> h x -> ShowS }+  library :: forall h xs. WrapForall Show h xs => Dictionary Show h :* xs+  library = generateFor (Proxy :: Proxy (Instance1 Show h)) $ const $ DictShow showsPrec -dictOrd :: forall h. DictOf Ord h (Wrap2 h Ordering)-dictOrd = generateFor (Proxy :: Proxy (Instance1 Ord h)) $ const $ Wrap2 compare+instance Reifiable Eq where+  data Dictionary Eq h x = DictEq { getEq :: h x -> h x -> Bool }+  library :: forall h xs. WrapForall Eq h xs => Dictionary Eq h :* xs+  library = generateFor (Proxy :: Proxy (Instance1 Eq h)) $ const $ DictEq (==) -data WrapMonoid h x = WrapMonoid { unwrapEmpty :: h x, unwrapAppend :: h x -> h x -> h x }+instance Reifiable Ord where+  data Dictionary Ord h x = DictOrd { getCompare :: h x -> h x -> Ordering }+  library :: forall h xs. WrapForall Ord h xs => Dictionary Ord h :* xs+  library = generateFor (Proxy :: Proxy (Instance1 Ord h)) $ const $ DictOrd compare -dictMonoid :: forall h. DictOf Monoid h (WrapMonoid h)-dictMonoid = generateFor (Proxy :: Proxy (Instance1 Monoid h)) $ const $ WrapMonoid mempty mappend+instance Reifiable Monoid where+  data Dictionary Monoid h x = DictMonoid { getMempty :: h x, getMappend :: h x -> h x -> h x }+  library :: forall h xs. WrapForall Monoid h xs => Dictionary Monoid h :* xs+  library = generateFor (Proxy :: Proxy (Instance1 Monoid h)) $ const $ DictMonoid mempty mappend +instance Reifiable B.Binary where+  data Dictionary B.Binary h x = DictBinary { getGet :: B.Get (h x), getPut :: h x -> B.Put }+  library :: forall h xs. WrapForall B.Binary h xs => Dictionary B.Binary h :* xs+  library = generateFor (Proxy :: Proxy (Instance1 B.Binary h)) $ const $ DictBinary B.get B.put+ instance WrapForall Show h xs => Show (h :* xs) where   showsPrec d = showParen (d > 0)     . (.showString "Nil")     . foldr (.) id     . getMerged     . hfoldMap getConst'-    . hzipWith (\(Match f) h -> Const' $ MergeList [f h 0 . showString " <: "]) dictShow+    . hzipWith (\f h -> Const' $ MergeList [getShowsPrec f 0 h . showString " <: "]) library  instance WrapForall Eq h xs => Eq (h :* xs) where   xs == ys = getAll $ hfoldMap (All . getConst')-    $ hzipWith3 (\(Wrap2 f) x y -> Const' (f x y)) dictEq xs ys+    $ hzipWith3 (\f x y -> Const' $ getEq f x y) library xs ys   {-# INLINE (==) #-}  instance (Eq (h :* xs), WrapForall Ord h xs) => Ord (h :* xs) where   compare xs ys = hfoldMap getConst'-    $ hzipWith3 (\(Wrap2 f) x y -> Const' (f x y)) dictOrd xs ys+    $ hzipWith3 (\f x y -> Const' $ getCompare f x y) library xs ys   {-# INLINE compare #-}  instance WrapForall Monoid h xs => Monoid (h :* xs) where-  mempty = hmap unwrapEmpty dictMonoid+  mempty = hmap getMempty library   {-# INLINE mempty #-}-  mappend xs ys = hzipWith3 unwrapAppend dictMonoid xs ys+  mappend xs ys = hzipWith3 getMappend library xs ys   {-# INLINE mappend #-} +instance WrapForall B.Binary h xs => B.Binary (h :* xs) where+  get = generateForA (Proxy :: Proxy (Instance1 B.Binary h)) (const B.get)+  put = flip appEndo (return ()) . hfoldMap getConst' . hzipWith (\dic x -> Const' $ Endo $ (getPut dic x >>)) library+ instance WrapForall Show h xs => Show (h :| xs) where   showsPrec d (UnionAt pos h) = showParen (d > 10) $ showString "embed "-    . runMatch (hlookup pos dictShow) h 11+    . getShowsPrec (hlookup pos library) 11 h  instance WrapForall Eq h xs => Eq (h :| xs) where   UnionAt p g == UnionAt q h = case compareMembership p q of     Left _ -> False-    Right Refl -> unwrap2 (hlookup p dictEq) g h+    Right Refl -> views (sectorAt p) getEq library g h   {-# INLINE (==) #-}  instance (Eq (h :| xs), WrapForall Ord h xs) => Ord (h :| xs) where   UnionAt p g `compare` UnionAt q h = case compareMembership p q of     Left x -> x-    Right Refl -> unwrap2 (hlookup p dictOrd) g h+    Right Refl -> views (sectorAt p) getCompare library g h   {-# INLINE compare #-} +-- | Forall upon a wrapper type WrapForall c h = Forall (Instance1 c h)  -- | Composition for a class and a wrapper
src/Data/Extensible/Inclusion.hs view
@@ -57,6 +57,7 @@ shrink h = hmap (\pos -> hlookup pos h) inclusion {-# INLINE shrink #-} +-- | A lens for a subset (inefficient) subset :: (xs ⊆ ys) => Lens' (h :* ys) (h :* xs) subset f ys = fmap (write ys) $ f (shrink ys) where   write y xs = flip appEndo y
src/Data/Extensible/Internal.hs view
@@ -55,8 +55,8 @@ import Data.Typeable import Language.Haskell.TH import Control.DeepSeq-import Data.Word import Data.Bits+import Data.Word  -- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). ord :: Int -> Q Exp@@ -70,7 +70,7 @@     $ 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 Word8 deriving Typeable+newtype Membership (xs :: [k]) (x :: k) = Membership Word deriving Typeable  instance NFData (Membership xs x) where   rnf (Membership a) = rnf a@@ -85,9 +85,9 @@   compare _ _ = EQ  -- | Embodies a type equivalence to ensure that the 'Membership' points the first element.-runMembership :: Membership (y ': xs) x -> Either (x :~: y) (Membership xs x)-runMembership (Membership 0) = Left (unsafeCoerce Refl)-runMembership (Membership n) = Right (Membership (n - 1))+runMembership :: Membership (y ': xs) x -> (x :~: y -> r) -> (Membership xs x -> r) -> r+runMembership (Membership 0) l _ = l (unsafeCoerce Refl)+runMembership (Membership n) _ r = r (Membership (n - 1)) {-# INLINE runMembership #-}  -- | PRIVILEGED: Compare two 'Membership's.@@ -105,27 +105,31 @@   -> 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))+  Membership n -> if n .&. 1 == 0+    then nr (Membership (unsafeShiftR (n - 1) 1))+    else nl (Membership (unsafeShiftR (n - 1) 1)) {-# INLINE navigate #-}  -- | Ensure that the first element of @xs@ is @x@ data NavHere xs x where   Here :: NavHere (x ': xs) x +-- | The 'Membership' points the first element here :: Membership (x ': xs) x here = Membership 0 {-# INLINE here #-} +-- | The next membership navNext :: Membership xs y -> Membership (x ': xs) y navNext (Membership n) = Membership (n + 1) {-# INLINE navNext #-} +-- | Describes the relation of 'Membership' within a tree navL :: Membership (Half xs) y -> Membership (x ': xs) y navL (Membership x) = Membership (x * 2 + 1) {-# INLINE navL #-} +-- | Describes the relation of 'Membership' within a tree navR :: Membership (Half (Tail xs)) y -> Membership (x ': xs) y navR (Membership x) = Membership (x * 2 + 2) {-# INLINE navR #-}@@ -146,6 +150,7 @@ -- | A type sugar to make type error more readable. data Ambiguous a +-- | Elaborate the result of 'Lookup' type family Check x xs where   Check x '[n] = Expecting n   Check x '[] = Missing x@@ -155,42 +160,49 @@   membership = Membership (theInt (Proxy :: Proxy one))   {-# INLINE membership #-} +-- | Interleaved list type family Half (xs :: [k]) :: [k] where   Half '[] = '[]   Half (x ': y ': zs) = x ': Half zs   Half (x ': '[]) = '[x] +-- | Type-level tail type family Tail (xs :: [k]) :: [k] where   Tail (x ': xs) = xs   Tail '[] = '[] +-- | Type level binary number data Nat = Zero | DNat Nat | SDNat Nat +-- | Converts type naturals into 'Word'. class ToInt n where-  theInt :: proxy n -> Word8+  theInt :: proxy n -> Word  instance ToInt Zero where   theInt _ = 0   {-# INLINE theInt #-}  instance ToInt n => ToInt (DNat n) where-  theInt _ = theInt (Proxy :: Proxy n) `shiftL` 1+  theInt _ = theInt (Proxy :: Proxy n) `unsafeShiftL` 1   {-# INLINE theInt #-}  instance ToInt n => ToInt (SDNat n) where-  theInt _ = (theInt (Proxy :: Proxy n) `shiftL` 1) + 1+  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   Succ Zero = SDNat Zero   Succ (DNat n) = SDNat n   Succ (SDNat n) = DNat (Succ n) +-- | Ideally, it will be 'Map Succ' type family MapSucc (xs :: [Nat]) :: [Nat] where   MapSucc '[] = '[]   MapSucc (x ': xs) = Succ x ': MapSucc xs@@ -204,20 +216,24 @@ lemmaMerging :: p (Merge (Half xs) (Half (Tail xs))) -> p xs lemmaMerging = unsafeCoerce +-- | Type level map type family Map (f :: k -> k) (xs :: [k]) :: [k] where   Map f '[] = '[]   Map f (x ': xs) = f x ': Map f xs +-- | Type level ++ type family (++) (xs :: [k]) (ys :: [k]) :: [k] where   '[] ++ ys = ys   (x ': xs) ++ ys = x ': xs ++ ys  infixr 5 ++ +-- | Type level concat type family Concat (xs :: [[k]]) :: [k] where   Concat '[] = '[]   Concat (x ': xs) = x ++ Concat xs +-- | Type level merging type family Merge (xs :: [k]) (ys :: [k]) :: [k] where   Merge (x ': xs) (y ': ys) = x ': y ': Merge xs ys   Merge xs '[] = xs
src/Data/Extensible/Internal/Rig.hs view
@@ -19,6 +19,7 @@ import Data.Foldable (Foldable) import Data.Traversable (Traversable) +-- | A type synonym for lenses type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s  -- | @'view' :: Lens' s a -> (a -> a) -> (s -> s)@@@ -56,13 +57,9 @@ -- | Turn a wrapper type into one clause that returns @a@. newtype Match h a x = Match { runMatch :: h x -> a } deriving Typeable -newtype Wrap2 h a x = Wrap2 { unwrap2 :: h x -> h x -> a }- -- | Poly-kinded Maybe data Nullable h x = Null | Eine (h x) deriving (Show, Eq, Ord, Typeable) -data Pair g h x = Pair (g x) (h x)- -- | Destruct 'Nullable'. nullable :: r -> (h x -> r) -> Nullable h x -> r nullable r _ Null = r@@ -75,6 +72,7 @@ mapNullable _ Null = Null {-# INLINE mapNullable #-} +-- A list, but with Monoid instance based on merging newtype MergeList a = MergeList { getMerged :: [a] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)  instance Monoid (MergeList a) where
src/Data/Extensible/League.hs view
@@ -45,7 +45,7 @@ {-# INLINE mapFuse #-}  -- | Prepend a clause for @'Match' ('Fuse' x)@ as well as ('<?!').-(<?~) :: (f x -> a) -> Match (Fuse x) a :* fs -> Match (Fuse x) a :* (f ': fs)-(<?~) f = (<:) (Match (f . meltdown))-{-# INLINE (<?~) #-}-infixr 1 <?~+(<?!$) :: (f x -> a) -> Match (Fuse x) a :* fs -> Match (Fuse x) a :* (f ': fs)+(<?!$) f = (<:) (Match (f . meltdown))+{-# INLINE (<?!$) #-}+infixr 1 <?!$
src/Data/Extensible/Plain.hs view
@@ -110,6 +110,7 @@ decFields :: DecsQ -> DecsQ decFields = decFieldsDeriving [] +-- | 'decFields' with additional deriving clauses decFieldsDeriving :: [Name] -> DecsQ -> DecsQ decFieldsDeriving drv' ds = ds >>= fmap concat . mapM mkBody   where
src/Data/Extensible/Product.hs view
@@ -13,7 +13,7 @@ -- ------------------------------------------------------------------------ module Data.Extensible.Product (-  -- * Product+  -- * Basic operations   (:*)(..)   , (<:)   , (<:*)@@ -28,11 +28,16 @@   , hfoldMap   , htraverse   , htabulate+  -- * Lookup   , hlookup   , sector   , sectorAt+  -- * Generation   , Generate(..)+  , generate   , Forall(..)+  , generateFor+  -- * HList   , fromHList   , toHList) where @@ -153,28 +158,39 @@ -- | Given a function that maps types to values, we can "collect" entities all you want. class Generate (xs :: [k]) where   -- | /O(n)/ generates a product with the given function.-  generate :: (forall x. Membership xs x -> h x) -> h :* xs+  generateA :: Applicative f => (forall x. Membership xs x -> f (h x)) -> f (h :* xs)  instance Generate '[] where-  generate _ = Nil-  {-# INLINE generate #-}+  generateA _ = pure Nil+  {-# INLINE generateA #-}  instance (Generate (Half xs), Generate (Half (Tail xs))) => Generate (x ': xs) where-  generate f = Tree (f here) (generate (f . navL)) (generate (f . navR))-  {-# INLINE generate #-}+  generateA f = Tree <$> f here <*> generateA (f . navL) <*> generateA (f . navR)+  {-# INLINE generateA #-} +-- | Pure version of 'generateA'.+generate :: Generate xs => (forall x. Membership xs x -> h x) -> h :* xs+generate f = getK0 (generateA (K0 . f))+ -- | Guarantees the all elements satisfies the predicate. class Forall c (xs :: [k]) where   -- | /O(n)/ Analogous to 'generate', but it also supplies a context @c x@ for every elements in @xs@.-  generateFor :: proxy c -> (forall x. c x => Membership xs x -> h x) -> h :* xs+  generateForA :: Applicative f => proxy c -> (forall x. c x => Membership xs x -> f (h x)) -> f (h :* xs)  instance Forall c '[] where-  generateFor _ _ = Nil-  {-# INLINE generateFor #-}+  generateForA _ _ = pure Nil+  {-# INLINE generateForA #-}  instance (c x, Forall c (Half xs), Forall c (Half (Tail xs))) => Forall c (x ': xs) where-  generateFor proxy f = Tree (f here) (generateFor proxy (f . navL)) (generateFor proxy (f . navR))-  {-# INLINE generateFor #-}+  generateForA proxy f = Tree+    <$> f here+    <*> generateForA proxy (f . navL)+    <*> generateForA proxy (f . navR)+  {-# INLINE generateForA #-}++-- | 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))  -- | Turn a product into 'HList'. toHList :: h :* xs -> HList h xs
src/Data/Extensible/Record.hs view
@@ -112,6 +112,7 @@     , return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases     ] +-- | @[recordType|foo bar baz|] --> Record '["foo", "bar", "baz"]@ recordType :: QuasiQuoter recordType = QuasiQuoter { quoteType = appT (conT ''Record) . foldr (\e t -> promotedConsT `appT` e `appT` t) promotedNilT . map (litT . strTyLit) . words
src/Data/Extensible/Sum.hs view
@@ -35,16 +35,16 @@ hoist f (UnionAt pos h) = UnionAt pos (f h) {-# INLINE hoist #-} --- | /O(log n)/ lift a value.+-- | /O(1)/ lift a value. embed :: (x ∈ xs) => h x -> h :| xs embed = UnionAt membership {-# INLINE embed #-}  -- | /O(1)/ Naive pattern match (<:|) :: (h x -> r) -> (h :| xs -> r) -> h :| (x ': xs) -> r-(<:|) r c = \(UnionAt pos h) -> case runMembership pos of-  Left Refl -> r h-  Right pos' -> c (UnionAt pos' h)+(<:|) r c = \(UnionAt pos h) -> runMembership pos+  (\Refl -> r h)+  (\pos' -> c (UnionAt pos' h)) infixr 1 <:| {-# INLINE (<:|) #-}
src/Data/Extensible/Union.hs view
@@ -10,7 +10,7 @@ -- ------------------------------------------------------------------------ module Data.Extensible.Union (-  (<$?~)+  (<?!~)   , Union(..)   , liftU   , Flux(..)@@ -46,7 +46,7 @@ {-# INLINE mapFlux #-}  -- | Prepend a clause for @'Match' ('Flux' x)@ as well as ('<?!').-(<$?~) :: (forall b. f b -> (b -> x) -> a) -> Match (Flux x) a :* fs -> Match (Flux x) a :* (f ': fs)-(<$?~) f = (<:) $ Match $ \(Flux g m) -> f m g-{-# INLINE (<$?~) #-}-infixr 1 <$?~+(<?!~) :: (forall b. f b -> (b -> x) -> a) -> Match (Flux x) a :* fs -> Match (Flux x) a :* (f ': fs)+(<?!~) f = (<:) $ Match $ \(Flux g m) -> f m g+{-# INLINE (<?!~) #-}+infixr 1 <?!~