packages feed

extensible 0.2 → 0.2.1

raw patch · 5 files changed

+64/−49 lines, 5 files

Files

extensible.cabal view
@@ -1,5 +1,5 @@ name:                extensible-version:             0.2+version:             0.2.1 synopsis:            Poly-kinded, extensible ADTs homepage:            https://github.com/fumieval/extensible description:         Extensible Products/Unions
src/Data/Extensible/Inclusion.hs view
@@ -21,7 +21,7 @@ type xs ⊆ ys = Include ys xs  -- | @ys@ contains @xs@-type Include ys xs = Forall (Member ys) xs+type Include ys = Forall (Member ys)  -- | Reify the inclusion of type level sets. inclusion :: forall xs ys. Include ys xs => Position ys :* xs@@ -31,6 +31,6 @@ shrink :: (xs ⊆ ys) => h :* ys -> h :* xs shrink h = hmap (\pos -> hlookup pos h) inclusion --- | /O(m log n)/ Embed to a larger union.+-- | /O(log n)/ Embed to a larger union. spread :: (xs ⊆ ys) => h :| xs -> h :| ys spread (UnionAt pos h) = UnionAt (hlookup pos inclusion) h
src/Data/Extensible/Plain.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Plain@@ -12,6 +12,8 @@ ------------------------------------------------------------------------ module Data.Extensible.Plain (   K0(..)+  , AllOf+  , OneOf   , (<%)   , pluck   , bury@@ -25,32 +27,46 @@ import Data.Extensible.Match import Data.Typeable import Unsafe.Coerce+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+import Control.Applicative -- | Just a value.-newtype K0 a = K0 { getK0 :: a } deriving (Eq, Ord, Read, Typeable)+newtype K0 a = K0 { getK0 :: a } deriving (Eq, Ord, Read, Typeable, Functor, Foldable, Traversable) +instance Applicative K0 where+  pure = K0+  K0 f <*> K0 a = K0 (f a)++instance Monad K0 where+  return = K0+  K0 a >>= k = k a+ instance Show a => Show (K0 a) where   showsPrec d (K0 a) = showParen (d > 10) $ showString "K0 " . showsPrec 11 a +type AllOf xs = K0 :* xs+type OneOf xs = K0 :| xs+ -- | /O(log n)/ Add a plain value to a product.-(<%) :: x -> K0 :* xs -> K0 :* (x ': xs)+(<%) :: x -> AllOf xs -> AllOf (x ': xs) (<%) = unsafeCoerce (<:*) {-# INLINE (<%) #-} infixr 5 <%  -- | Extract a plain value.-pluck :: (x ∈ xs) => K0 :* xs -> x+pluck :: (x ∈ xs) => AllOf xs -> x pluck = getK0 . hlookup membership  -- | Embed a plain value.-bury :: (x ∈ xs) => x -> K0 :| xs+bury :: (x ∈ xs) => x -> OneOf xs bury = embed . K0  -- | Naive pattern matching for a plain value.-(<%|) :: (x -> r) -> (K0 :| xs -> r) -> K0 :| (x ': xs) -> r+(<%|) :: (x -> r) -> (OneOf xs -> r) -> OneOf (x ': xs) -> r (<%|) = unsafeCoerce (<:|)  -- | /O(log n)/ A lens for a plain value in a product.-record :: (x ∈ xs, Functor f) => (x -> f x) -> (K0 :* xs -> f (K0 :* xs))+record :: (x ∈ xs, Functor f) => (x -> f x) -> (AllOf xs -> f (AllOf xs)) record f = sector $ unsafeCoerce f `asTypeOf` (fmap K0 . f . getK0) {-# INLINE record #-} @@ -58,3 +74,4 @@ (<?%) :: (x -> a) -> Match K0 a :* xs -> Match K0 a :* (x ': xs) (<?%) = unsafeCoerce (<:*) infixr 1 <?%+
src/Data/Extensible/Product.hs view
@@ -18,6 +18,8 @@   -- * Product   (:*)(..)   , (<:*)+  , hhead+  , htail   , huncons   , hmap   , hzipWith@@ -28,7 +30,8 @@   , sector   , sectorAt   , Generate(..)-  , Forall(..)) where+  , Forall(..)+  , ClassComp) where  import Data.Extensible.Internal import Unsafe.Coerce@@ -55,7 +58,11 @@     . showString " <:* "     . showsPrec 6 xs --- | Extract the tail of the product.+-- | /O(1)/ Extract the head element.+hhead :: h :* (x ': xs) -> h x+hhead (Tree a _ _) = a++-- | /O(n)/ Extract the tail of the product. htail :: h :* (x ': xs) -> h :* xs htail (Tree _ a@(Tree h _ _) b) = unsafeCoerce (Tree h) b (htail a) htail (Tree _ Nil _) = unsafeCoerce Nil@@ -98,12 +105,12 @@ htraverse f (Tree h a b) = Tree <$> f h <*> htraverse f a <*> htraverse f b htraverse _ Nil = pure Nil --- | Pick up an elemtnt.+-- | /O(log n)/ Pick up an elemtnt. hlookup :: Position xs x -> h :* xs -> h x hlookup = view . sectorAt {-# INLINE hlookup #-} --- | Composition for a class and a wrapper,+-- | Composition for a class and a wrapper class c (h x) => ClassComp c h x instance c (h x) => ClassComp c h x @@ -128,8 +135,8 @@ newtype WrapOrd h x = WrapOrd { unwrapOrd :: h x -> h x -> Ordering }  -- | /O(log n)/ A lens for a specific element.-sector :: forall h x xs f. (Functor f, x ∈ xs) => (h x -> f (h x)) -> h :* xs -> f (h :* xs)-sector = sectorAt (membership :: Position xs x)+sector :: (Functor f, x ∈ xs) => (h x -> f (h x)) -> h :* xs -> f (h :* xs)+sector = sectorAt membership {-# INLINE sector #-}  view :: ((a -> Const a a) -> (s -> Const a s)) -> s -> a
src/Data/Extensible/Union.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Union@@ -10,10 +10,12 @@ -- Portability :  non-portable -- -------------------------------------------------------------------------module Data.Extensible.Union (K1(..)-  , (<?!)+module Data.Extensible.Union (+  (<$?~)   , Union(..)   , liftU+  , Flux(..)+  , mapFlux   ) where  import Data.Typeable@@ -21,41 +23,30 @@ import Data.Extensible.Sum import Data.Extensible.Product import Data.Extensible.Match-import Unsafe.Coerce --- | Wrap a type that has a kind @* -> *@.-newtype K1 a f = K1 { getK1 :: f a } deriving (Eq, Ord, Read, Typeable)--instance Show (f a) => Show (K1 a f) where-  showsPrec d (K1 a) = showParen (d > 10) $ showString "K1 " . showsPrec 11 a---- | Prepend a clause for a parameterized value.-(<?!) :: (f x -> a) -> Match (K1 x) a :* xs -> Match (K1 x) a :* (f ': fs)-(<?!) = unsafeCoerce (<:*)-infixr 1 <?!+-- | A much more efficient representation for 'Union' of 'Functor's.+newtype Union fs a = Union { getLeague :: Flux a :| fs } deriving Typeable --- | A wrapper for @'K1' a ':|'' fs@ for having a kind @* -> *@.-newtype Union fs a = Union { getUnion :: K1 a :| fs } deriving Typeable+-- | fast fmap+instance Functor (Union fs) where+  fmap f (Union (UnionAt pos s)) = Union (UnionAt pos (mapFlux f s))+  {-# INLINE fmap #-} --- | /O(log n)/ Lift a value.+-- | /O(log n)/ Embed a value. liftU :: (f ∈ fs) => f a -> Union fs a-liftU = Union . embed . K1+liftU = Union . embed . Flux id {-# INLINE liftU #-} -instance Show (Union '[] a) where-  show (Union u) = exhaust u--instance (Show (f a), Show (Union fs a)) => Show (Union (f ': fs) a) where-  showsPrec d (Union u) = (\(K1 f) -> showParen (d > 10) $ showString "liftU " . showsPrec 11 f)-    <:| showsPrec d . Union-    $ u+-- | Flipped <http://hackage.haskell.org/package/kan-extensions/docs/Data-Functor-Coyoneda.html Coyoneda>+data Flux a f where+  Flux :: (a -> b) -> f a -> Flux b f -instance Functor (Union '[]) where-  fmap _ = exhaust . getUnion+-- | 'fmap' for the content.+mapFlux :: (a -> b) -> Flux a f -> Flux b f+mapFlux f (Flux g m) = Flux (f . g) m+{-# INLINE mapFlux #-} --- | slow fmap-instance (Functor f, Functor (Union fs)) => Functor (Union (f ': fs)) where-  fmap f (Union (UnionAt pos (K1 h))) = case runPosition pos of-    Left Refl -> Union $ UnionAt pos $ K1 (fmap f h)-    Right pos' -> case fmap f (Union (UnionAt pos' (K1 h))) of-      Union (UnionAt _ h') -> Union (UnionAt (unsafeCoerce pos) h')+-- | 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+infixr 1 <$?~