diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for weave + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, Li-yao Xia + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/Weave/Sig.hsig b/src/Weave/Sig.hsig new file mode 100644 --- /dev/null +++ b/src/Weave/Sig.hsig @@ -0,0 +1,20 @@ +{-# LANGUAGE KindSignatures #-} +-- | The Backpack signature for the shared interface of +-- "Weave.Strict", "Weave.Lazy", and "Weave.Endless". +signature Weave.Sig where + +import Data.Kind (Type) + +-- | The type of weaves (multi-level computations). +-- +-- The 'Applicative' operation @('liftA2')@ combines weaves level-wise. +data Weave :: (Type -> Type) -> Type -> Type + +instance Functor f => Functor (Weave f) +instance Applicative m => Applicative (Weave m) + +-- | A weft is one level of 'Weave'. It is a computation which returns the remaining levels. +weft :: m (Weave m a) -> Weave m a + +-- | Run all the wefts in a 'Weave' sequentially. +mesh :: Monad m => Weave m a -> m a diff --git a/src/Weave/Unfold.hs b/src/Weave/Unfold.hs new file mode 100644 --- /dev/null +++ b/src/Weave/Unfold.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns, BlockArguments, GADTs, LambdaCase, ExplicitNamespaces #-} +-- | Implementations of unfolds using weaves. +-- +-- Also includes some implementations without weaves for comparison. +-- +-- This module is implemented as a Backpack mixin, which imports the signature "Weave.Sig", +-- to be instantiated with "Weave.Strict", "Weave.Lazy", and "Weave.Endless". +module Weave.Unfold where + +import Data.Foldable (traverse_) +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.Tree (Tree(..)) +import Data.Fix (Fix(..)) +import qualified Data.Tree.Binary.Preorder as Binary +import Weave.Sig + +-- | Weave a rose tree. +weave_Tree :: Applicative m => (b -> m (a, [b])) -> b -> m (Weave m (Tree a)) +weave_Tree f = go + where + go b = f b <&> \(a, bs) -> + fmap (Node a) (foldr (\b0 bfs -> liftA2 (:) (weft (go b0)) bfs) (pure []) bs) + +-- | Unfold a rose tree. +weaveM_BF_Tree :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) +weaveM_BF_Tree f b = weave_Tree f b >>= mesh + +-- | Weave a binary tree. +weave_Binary :: Applicative m => (b -> m (Maybe (a, b, b))) -> b -> m (Weave m (Binary.Tree a)) +weave_Binary f = go where + go b = f b <&> \case + Nothing -> pure Binary.Leaf + Just (a, b1, b2) -> (\ ~(x, y) -> Binary.Node a x y) <$> weft ((liftA2 . liftA2) (,) (go b1) (go b2)) + +-- | Unfold a binary tree. +weaveM_BF_Binary :: Monad m => (b -> m (Maybe (a, b, b))) -> b -> m (Binary.Tree a) +weaveM_BF_Binary f b = weave_Binary f b >>= mesh + +-- | Weave an @f@-tree, for any functor @f@. +weaveM_BF_Fix :: (Traversable f, Applicative m) => (b -> m (f b)) -> b -> m (Weave m (Fix f)) +weaveM_BF_Fix f b = f b <&> \t -> Fix <$> traverse (weft . weaveM_BF_Fix f) t + +-- | Unfold an @f@-tree. +unfoldM_BF_Fix :: (Traversable f, Monad m) => (b -> m (f b)) -> b -> m (Fix f) +unfoldM_BF_Fix f b = weaveM_BF_Fix f b >>= mesh + +-- * Pure unfolds + +-- | Purely unfold an @f@-tree, for any functor @f@. +-- +-- This is included for reference; it doesn't use the 'Weave' abstraction. +-- +-- Identical to 'Data.Fix.unfoldFix' from the library @data-fix@. +unfold :: Functor f => (b -> f b) -> b -> Fix f +unfold f b = Fix (unfold f <$> f b) + +-- | Depth-first tree unfold. +-- +-- This is included for reference; it doesn't use the 'Weave' abstraction. +unfoldM_DF :: (Traversable f, Monad m) => (b -> m (f b)) -> b -> m (Fix f) +unfoldM_DF f b = Fix <$> (f b >>= traverse (unfoldM_DF f)) + +-- | Same as 'unfold', implemented using 'unfoldM_DF'. +-- +-- This is included for reference; it doesn't use the 'Weave' abstraction. +unfold_DF :: Traversable f => (b -> f b) -> b -> Fix f +unfold_DF f = runIdentity . unfoldM_DF (pure . f) + +-- | Same as 'unfold', implemented using 'weaveM_BF_Fix'. +unfold_BF :: Traversable f => (b -> f b) -> b -> Fix f +unfold_BF f = runIdentity . (>>= mesh) . weaveM_BF_Fix (pure . f) + +-- * Oblivious unfolds + +-- | Breadth-first unfold. +unfold_BF_ :: (Foldable f, Applicative m) => (b -> m (f b)) -> b -> m (Weave m ()) +unfold_BF_ f b = f b <&> \t -> traverse_ (weft . unfold_BF_ f) t + +-- | Depth-first unfold. +-- +-- This is included for reference; it doesn't use the 'Weave' abstraction. +unfold_DF_ :: (Foldable f, Monad m) => (b -> m (f b)) -> b -> m () +unfold_DF_ f b = f b >>= traverse_ (unfold_DF_ f) diff --git a/src/Weave/Unfold/Oblivious.hs b/src/Weave/Unfold/Oblivious.hs new file mode 100644 --- /dev/null +++ b/src/Weave/Unfold/Oblivious.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LambdaCase #-} +-- | Oblivious unfolds. +-- +-- The usual "@_@" suffix is omitted since it's obvious that they are oblivious. +module Weave.Unfold.Oblivious where + +import Data.Functor ((<&>)) +import Weave.Oblivious + +-- | Weave an @f@-tree. +weave_BF :: (Foldable f, Applicative m) => (s -> m (f s)) -> s -> m (Weave m) +weave_BF f s = f s <&> \t -> foldMap (weft . weave_BF f) t + +-- | Unfold an @f@-tree. +unfold_BF :: (Foldable f, Monad m) => (s -> m (f s)) -> s -> m () +unfold_BF f s = weave_BF f s >>= mesh_ + +-- | Weave a binary tree. +weave_BF_Binary :: Applicative m => (s -> m (Maybe (unit, s, s))) -> s -> m (Weave m) +weave_BF_Binary f s = f s <&> \case + Nothing -> mempty + Just (_, l, r) -> weft (weave_BF_Binary f l) <> weft (weave_BF_Binary f r) + +-- | Unfold a binary tree. +unfold_BF_Binary :: Monad m => (s -> m (Maybe (unit, s, s))) -> s -> m () +unfold_BF_Binary f s = weave_BF_Binary f s >>= mesh_ + +-- | Weave a rose tree. +weave_BF_Tree :: Applicative m => (s -> m (unit, [s])) -> s -> m (Weave m) +weave_BF_Tree f s = f s <&> \(_, bs) -> foldMap (weft . weave_BF_Tree f) bs + +-- | Weave a rose tree. +unfold_BF_Tree :: Monad m => (s -> m (unit, [s])) -> s -> m () +unfold_BF_Tree f s = weave_BF_Tree f s >>= mesh_ diff --git a/weave.cabal b/weave.cabal new file mode 100644 --- /dev/null +++ b/weave.cabal @@ -0,0 +1,80 @@ +cabal-version: 3.0 +name: weave +version: 0.1.0.0 +synopsis: Compositional breadth-first walks +description: + An experimental control structure for defining breadth-first walks in trees + and graphs in a compositional manner. + + @Weave@ is an applicative transformer for multi-level computations. + This library actually defines multiple variants of @Weave@ with different + performance profiles. The most useful ones are "Weave.Lazy" and + "Weave.Oblivious". Two other variants "Weave.Strict" and "Weave.Endless" + are included mainly as curiosities. + + The main application of @Weave@ is to define /breadth-first monadic unfolds/. + Examples of such unfolds for some general-purpose tree structures can be + found under the namespace @Weave.Unfold@, for each variant of @Weave@. + + See also my blog post: + . + + Internally, to avoid duplication, those unfolds are implemented as a Backpack + mixin @Weave.Unfold@. This package might not work with Stack, which doesn't + support Backpack. For minimal dependencies and no backpack, the @weave-core@ + library is also available, containing only the @Weave@ types. +license: BSD-3-Clause +license-file: LICENSE +author: Li-yao Xia +maintainer: lysxia@gmail.com +homepage: https://gitlab.com/lysxia/weave +category: Control +build-type: Simple +extra-doc-files: CHANGELOG.md + +tested-with: GHC == 9.10.1, GHC == 9.12.1 + +common warnings + ghc-options: -Wall + build-depends: base > 4 && < 5 + +library mixin + import: warnings + visibility: public + exposed-modules: + Weave.Unfold + signatures: + Weave.Sig + build-depends: + binary-tree ^>= 0.1, + containers >= 0.7 && < 0.9, + data-fix ^>= 0.3, + transformers ^>= 0.6 + hs-source-dirs: src + default-language: Haskell2010 + +library + import: warnings + exposed-modules: + Weave.Unfold.Oblivious + reexported-modules: + Weave.Strict, + Weave.Lazy, + Weave.Oblivious, + Weave.Endless, + Weave.Unfold.Strict, + Weave.Unfold.Lazy, + Weave.Unfold.Endless + mixins: + mixin (Weave.Unfold as Weave.Unfold.Strict) requires (Weave.Sig as Weave.Strict), + mixin (Weave.Unfold as Weave.Unfold.Lazy) requires (Weave.Sig as Weave.Lazy), + mixin (Weave.Unfold as Weave.Unfold.Endless) requires (Weave.Sig as Weave.Endless) + build-depends: + weave:mixin, + weave-core ^>= 0.1 + hs-source-dirs: src + default-language: Haskell2010 + +source-repository head + type: git + location: https://gitlab.com/lysxia/weave