recursive-zipper (empty) → 0.0.0.0

raw patch · 7 files changed

+290/−0 lines, 7 filesdep +basedep +comonaddep +containerssetup-changed

Dependencies added: base, comonad, containers, free, lens, mtl, recursion-schemes, transformers

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +6/−0
Setup.hs +2/−0
recursive-zipper.cabal +45/−0
src/Zipper/Recursive.hs +36/−0
src/Zipper/Recursive/Internal.hs +168/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for recursion-zipper++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++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 Author name here nor the names of other+      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+OWNER 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.

+ README.md view

@@ -0,0 +1,6 @@+# recursive-zipper++A zipper-type for self-recursive types like ASTs or JSON.++Provide efficient access to a leaf node of such a structure, and a mechanism for+navigating around, folding, etc.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ recursive-zipper.cabal view

@@ -0,0 +1,45 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           recursive-zipper+version:        0.0.0.0+synopsis:       Zippers over recursive data structures.+description:    Please see the README on GitHub at <https://github.com/ChrisPenner/recursive-zipper#readme>+category:       Data+homepage:       https://github.com/ChrisPenner/recursive-zipper#readme+bug-reports:    https://github.com/ChrisPenner/recursive-zipper/issues+author:         Chris Penner+maintainer:     example@example.com+copyright:      2021 Chris Penner+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/ChrisPenner/recursive-zipper++library+  exposed-modules:+      Zipper.Recursive+      Zipper.Recursive.Internal+  other-modules:+      Paths_recursive_zipper+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , comonad+    , containers+    , free+    , lens+    , mtl+    , recursion-schemes+    , transformers+  default-language: Haskell2010

+ src/Zipper/Recursive.hs view

@@ -0,0 +1,36 @@+module Zipper.Recursive+  ( -- * Core type+    Z.Zipper,+    Z.Idx,++    -- * Constructing Zippers+    Z.zipper,+    Z.fromRecursive,+    Z.tagged,++    -- * Movement+    Z.down,+    Z.up,+    Z.sibling,+    Z.tug,++    -- * Folding and flattening+    Z.rezip,+    Z.flatten,+    Z.fold,++    -- * Getters+    Z.focus,+    Z.branches,+    Z.currentIndex,++    -- * Optics+    Z.focus_,+    Z.unwrapped_,+    Z.branches_,+    Z.children_,+    Z.ichildren_,+  )+  where++import Zipper.Recursive.Internal as Z

+ src/Zipper/Recursive/Internal.hs view

@@ -0,0 +1,168 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Zipper.Recursive.Internal where++import qualified Control.Comonad as Comonad+import Control.Comonad.Cofree+import qualified Control.Comonad.Cofree as Cofree+import qualified Control.Comonad.Trans.Cofree as CofreeF+import Control.Lens hiding (children, (:<))+import Control.Monad+import Data.Functor.Classes+import qualified Data.Functor.Foldable as FF+import Data.Maybe++-- | Alias for constraints required for many zipper operations.+type Idx i f a = (Ixed (f (Cofree f a)), IxValue (f (Cofree f a)) ~ (Cofree f a), Index (f (Cofree f a)) ~ i)++-- | The core zipper type+data Zipper i (f :: * -> *) a = Zipper+  { parents :: [(i, Cofree f a)],+    focus :: Cofree f a+  }+  deriving (Functor)++deriving instance (Eq1 f, Eq i, Eq a) => Eq (Zipper i f a)++deriving instance (Ord1 f, Ord i, Ord a) => Ord (Zipper i f a)++-- | Get the location of the current selection within its parent if we have one.+-- @O(1)+currentIndex :: Zipper i f a -> Maybe i+currentIndex (Zipper ((i, _) : _) _) = Just i+currentIndex _ = Nothing++-- | Get the path to the current value from the root of the structure.+-- @O(depth)+currentPath :: Zipper i f a -> [i]+currentPath (Zipper parents _) = reverse $ fmap fst parents++-- | Focus the tag at the current position.+focus_ :: Lens' (Zipper i f a) a+focus_ f (Zipper parents foc) = Zipper parents <$> (foc & _extract %%~ f)++-- | Focus the currently selected sub-tree as a 'Cofree'+unwrapped_ :: Lens' (Zipper i f a) (Cofree f a)+unwrapped_ f (Zipper parents foc) = Zipper parents <$> f foc++-- TODO: implement proper comonad instance+-- extract :: Zipper i f a -> a+-- extract (Zipper _ (a :< _)) = a++-- instance Functor f => Comonad (Zipper i f) where+--   extract = extract . _focus+--   duplicate :: forall f a. (Zipper i f a) -> Zipper i f (Zipper i f a)+--   duplicate z@(Zipper parents foc) = Zipper (zipWith (\z (i,_) -> (i, z)) rezippedParents parents) (foc $> z)+--     where+--       rezippedParents :: [Zipper i f a]+--       rezippedParents = unfoldr go z+--       go current =+--         let x = up current+--          in liftA2 (,) x x+--       -- go (current, []) = Nothing+--       -- go :: (Zipper i f a, [(i, Cofree f a)]) -> Maybe (_, Cofree f a)+--       -- go = _++-- | A useful combinator for chaining operations which might fail.+-- If an operation fails, the original zipper is returned.+--+-- E.g.+--+-- >>> tug up z+tug :: (a -> Maybe a) -> a -> a+tug f a = fromMaybe a (f a)++-- | Create a zipper over a cofree structure+zipper :: Cofree f a -> Zipper i f a+zipper f = Zipper [] f++-- | Create a zipper from a recursive type, tagging it with '()'+fromRecursive :: FF.Recursive t => t -> Zipper i (FF.Base t) ()+fromRecursive t = zipper $ Cofree.unfold (((),) . FF.project) t++-- | Create a zipper from a recursive type, given a function to generate annotations.+tagged :: FF.Recursive t => (t -> a) -> t -> Zipper i (FF.Base t) a+tagged f t = zipper $ Cofree.unfold (\x -> (f x, FF.project x)) t++-- | Select the subtree at the given location.+-- @O(1)@+down :: (Idx i f a) => i -> Zipper i f a -> Maybe (Zipper i f a)+down i (Zipper parents current) = Zipper ((i, current) : parents) <$> (current ^? _unwrap . ix i)++-- | Select the parent of the current location.+-- @O(1)@+up :: Idx i f a => Zipper i f a -> Maybe (Zipper i f a)+up (Zipper ((i, p) : parents) current) = Just $ Zipper parents (p & _unwrap . ix i .~ current)+up _ = Nothing++-- | Re-zip the entire tree.+-- @O(d)@+rezip :: Idx i f a => Zipper i f a -> Cofree f a+rezip z = case up z of+  Nothing -> focus z+  Just p -> rezip p++-- | Rezip, forget all tags, and flatten the structure.+-- @O(d)@+flatten :: (FF.Corecursive f, Idx i (FF.Base f) a) => Zipper i (FF.Base f) a -> f+flatten = FF.cata alg . rezip+  where+    alg (_ CofreeF.:< fv) = FF.embed fv++-- | Move to the sibling which is located at 'i' in its parent.+-- @O(1)@+--+-- @@+-- sibling i = up >=> down i+-- @@+sibling :: Idx i f a => i -> Zipper i f a -> Maybe (Zipper i f a)+sibling i = up >=> down i++-- parentTags :: Traversal' (Zipper i f a) a+-- parentTags f (Zipper parents foc) = Zipper <$> (forwards (parents & traversed . _2 . _extract %%~ Backwards . f)) <*> pure foc++-- | Traversal over all subtrees of the current location.+children_ :: Traversable f => Traversal' (Zipper i f a) (Cofree f a)+children_ f (Zipper parents current) = Zipper parents <$> (current & _unwrap . traversed %%~ f)++-- | Indexed traversal over all subtrees of the current location.+ichildren_ :: TraversableWithIndex i f => IndexedTraversal' i (Zipper i f a) (Cofree f a)+ichildren_ f (Zipper parents current) = Zipper parents <$> (current & _unwrap . itraversed %%@~ \i a -> indexed f i a)++-- | Get the base-functor at the current location.+-- @O(1)+branches :: Zipper i f a -> f (Cofree f a)+branches (Zipper _ (_ :< cs)) = cs++-- | A lens over the base-functor at the current location.+branches_ :: Lens' (Zipper i f a) (f (Cofree f a))+branches_ = lens getter setter+  where+    getter (Zipper _ (_ :< f)) = f+    setter (Zipper p (a :< _)) f = (Zipper p (a :< f))++-- retag :: Functor f => (a -> f b -> b) -> Cofree f a -> Cofree f b+-- retag f (a :< fr) =+--   let cs = fmap (retag f) fr+--    in (f a $ fmap Comonad.extract cs) :< cs++-- | Fold a zipper from bottom to top.+-- @O(n)+fold :: (Functor f, Idx i f a) => (a -> f r -> r) -> Zipper i f a -> r+fold f = FF.cata (\(a CofreeF.:< fr) -> f a fr) . rezip