diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.2.9 +----------------------------------------------------- +* Renamed `( n) diff --git a/benchmarks/membership.hs b/benchmarks/membership.hs --- a/benchmarks/membership.hs +++ b/benchmarks/membership.hs @@ -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 diff --git a/benchmarks/test.hs b/benchmarks/test.hs new file mode 100644 --- /dev/null +++ b/benchmarks/test.hs @@ -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) diff --git a/extensible.cabal b/extensible.cabal --- a/extensible.cabal +++ b/extensible.cabal @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/src/Data/Extensible/League.hs b/src/Data/Extensible/League.hs --- a/src/Data/Extensible/League.hs +++ b/src/Data/Extensible/League.hs @@ -45,7 +45,7 @@ {-# INLINE mapFuse #-} -- | Prepend a clause for @'Match' ('Fuse' x)@ as well as (' a) -> Match (Fuse x) a :* fs -> Match (Fuse x) a :* (f ': fs) -( a) -> Match (Fuse x) a :* fs -> Match (Fuse x) a :* (f ': fs) +( DecsQ decFields = decFieldsDeriving [] +-- | 'decFields' with additional deriving clauses decFieldsDeriving :: [Name] -> DecsQ -> DecsQ decFieldsDeriving drv' ds = ds >>= fmap concat . mapM mkBody where 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 @@ -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 diff --git a/src/Data/Extensible/Record.hs b/src/Data/Extensible/Record.hs --- a/src/Data/Extensible/Record.hs +++ b/src/Data/Extensible/Record.hs @@ -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 diff --git a/src/Data/Extensible/Sum.hs b/src/Data/Extensible/Sum.hs --- a/src/Data/Extensible/Sum.hs +++ b/src/Data/Extensible/Sum.hs @@ -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 (<:|) #-} diff --git a/src/Data/Extensible/Union.hs b/src/Data/Extensible/Union.hs --- a/src/Data/Extensible/Union.hs +++ b/src/Data/Extensible/Union.hs @@ -10,7 +10,7 @@ -- ------------------------------------------------------------------------ module Data.Extensible.Union ( - (<$?~) + ( (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 <$?~ +( (b -> x) -> a) -> Match (Flux x) a :* fs -> Match (Flux x) a :* (f ': fs) +( f m g +{-# INLINE (