summer 0.3.1.1 → 0.3.2.0

raw patch · 3 files changed

+28/−19 lines, 3 files

Files

• src/Data/Prodder.hs +26/−17
• summer.cabal +1/−1
• test/Test.hs +1/−1

@@ -37,8 +37,10 @@   , Consume(consume, extend1, cmap, produceB)   , produce   , empty-  , ToList(toList)+  , FoldProd(foldProd)+  , toList   , type ForAll+  , atType     -- ** Efficient Iterative Construction   , buildProd   , ProdBuilder@@ -73,6 +75,7 @@ import GHC.Exts (Any, Constraint) import Unsafe.Coerce (unsafeCoerce) import Data.Functor.Identity (Identity (..))+import Data.Functor.Const (Const (..)) import Data.Vector (Vector) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV@@ -84,6 +87,11 @@ -- | An extensible product type newtype Prod (xs :: [*]) = UnsafeProd { unProd :: Vector Any } +-- | Lens to modify one element of a product.+atType :: forall a b xs f. (a `HasIndexIn` xs, Functor f) => (a -> f b) -> Prod xs -> f (Prod (Replace a b xs))+atType f (UnsafeProd v) = fmap (\b -> UnsafeProd $ v V.// [(fromIntegral i, unsafeCoerce b)]) (f (unsafeCoerce (v V.! fromIntegral i))) where+  i = index @a @xs+ -- | A type for constructing products with linear memory use. newtype ProdBuilder (xs :: [*]) = UnsafeProdBuilder { unProdBuilder :: forall s. STRef s Int -> V.MVector s Any -> ST s () } @@ -153,7 +161,7 @@  -- | Extract a value at a particular index extract :: forall x xs. x `HasIndexIn` xs => Prod xs -> x-extract (UnsafeProd v) = unsafeCoerce $ v V.! fromIntegral (index @x @xs)+extract = getConst . atType @x @() @xs Const {-# INLINE CONLIKE extract #-}  -- | Takes the tail of a product after the nth element.@@ -186,15 +194,11 @@ type family Replace x y xs where   Replace x y (x ': xs) = y ': xs   Replace x y (z ': xs) = z ': Replace x y xs+  Replace x y '[] = '[]  -- | Replaces one type with another via a function remap :: forall x y xs. x `HasIndexIn` xs => (x -> y) -> Prod xs -> Prod (Replace x y xs)-remap f (UnsafeProd v) = UnsafeProd (update `V.imap` v) where-  update :: Int -> Any -> Any-  update (fromIntegral -> n) a-    | n == index @x @xs = unsafeCoerce $ f $ unsafeCoerce a-    | otherwise = a-  {-# INLINE CONLIKE update #-}+remap f = runIdentity . atType @x @y @xs (Identity . f) {-# INLINE CONLIKE remap #-}  -- | This is a reified pattern match on an extensible product@@ -291,15 +295,20 @@   select prod f = select @_ @_ @a prod (f (extract @x prod))   {-# INLINE CONLIKE select #-} --- | A class for turning a 'Prod' into a regular list using a--- function which takes an argument only constrained by a 'Constraint'--- each element of the product has.-class ForAll c xs => ToList c xs where-  toList :: (forall a. c a => a -> b) -> Prod xs -> [b]+-- | A class for folding over a 'Prod' using a function which only requires that+-- every element of the product satisfy a certain constraint.+class ForAll c xs => FoldProd c xs where+  foldProd :: Monoid m => (forall a. c a => a -> m) -> Prod xs -> m -instance ToList c '[] where-  toList _f _p = []+instance FoldProd c '[] where+  foldProd _f _p = mempty -instance (c x, ToList c xs) => ToList c (x ': xs) where-  toList f p = f x : toList @c f (dropFirst p) where+instance (c x, FoldProd c xs) => FoldProd c (x ': xs) where+  foldProd f p = f x <> foldProd @c f (dropFirst p) where     x = extract @x p++toList :: forall c xs a. FoldProd c xs => (forall x. c x => x -> a) -> Prod xs -> [a]+toList f = foldProd @c (pure . f)++class x `Contains` y where+  eject :: x -> y

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                summer-version:             0.3.1.1+version:             0.3.2.0 synopsis:            An implementation of extensible products and sums description:         An implementation of extensible products and sums. license:             MIT

@@ -93,7 +93,7 @@         [ (empty == buildProd emptyB, "prodBuilder does not work 0")         , (produce (\f -> f "Hello") == buildProd (consB "Hello" emptyB), "prodBuilder does not work 1")         ]-    toListTest = do+    foldProdTest = do       let x :: Prod '[String, Bool] = produce \f -> f "Hello" True       requires         [ (toList @Show show x == [show "Hello", show True], "toList does not work 0")