diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,3 @@ This package provides `cataM`, `anaM`, and `hyloM`. That means you can have (co)algebras that return a monadic value. - -## Dendromorphisms etc. - -This section of documentation is under construction. diff --git a/recursion-schemes-ext.cabal b/recursion-schemes-ext.cabal --- a/recursion-schemes-ext.cabal +++ b/recursion-schemes-ext.cabal @@ -1,12 +1,12 @@ name: recursion-schemes-ext -version: 1.0.0.0 +version: 1.0.0.1 synopsis: Amateur addenda to recursion-schemes description: This package provides some exotic recursion schemes as well monadic versions of some morphisms. homepage: https://hub.darcs.net/vmchale/recursion-schemes-ext#readme license: BSD3 license-file: LICENSE author: Vanessa McHale -maintainer: vanessa.mchale@reconfigure.io +maintainer: vamchale@gmail.com copyright: Copyright: (c) 2017 Vanessa McHale category: Control build-type: Simple @@ -57,9 +57,8 @@ build-depends: base , recursion-schemes-ext , criterion - , recursion-schemes , deepseq - ghc-options: -O2 + , recursion-schemes default-language: Haskell2010 if flag(development) ghc-options: -Werror diff --git a/src/Data/Functor/Foldable/Exotic.hs b/src/Data/Functor/Foldable/Exotic.hs --- a/src/Data/Functor/Foldable/Exotic.hs +++ b/src/Data/Functor/Foldable/Exotic.hs @@ -25,6 +25,8 @@ , mutu -- * Data type for transformations , Trans + -- * Helper functions + , finish ) where import Control.Arrow @@ -32,8 +34,18 @@ import Control.Lens import Data.Functor.Foldable --- margaritari :: +dock :: (Eq a) => [a] -> a +dock [x] = x +dock [] = undefined +dock (x:ys@(y:_)) + | x == y = y + | otherwise = dock ys +-- | Helper function to force recursion. This can be used alongside 'dendro' to +-- simplify writing a 'Trans' +finish :: (Eq a) => (a -> a) -> a -> a +finish = dock .* iterate + -- | A map of F-algebras type Trans s a = ∀ f. Functor f => (f a -> a) -> f s -> s @@ -43,7 +55,7 @@ -- | Entangle two hylomorphisms. scolio :: (Functor f, Functor g) - => ((f b -> b) -> Trans b b) -- ^ A prism parametric in an F-algebra that allows `b` to inspect itself. + => ((f b -> b) -> Trans b b) -- ^ A pseudoprism parametric in an F-algebra that allows `b` to inspect itself. -> ((a -> f a) -> Lens' a a) -- ^ A lens parametric in an F-coalgebra that allows `b` to inspect itself. -> (g b -> b) -- ^ A g-algebra -> (a -> g a) -- ^ A g-coalgebra @@ -62,7 +74,7 @@ -- | A dendromorphism entangles two catamorphisms dendro :: (Recursive t', Functor f) - => ((f a -> a) -> Trans b b) -- ^ A prism parametric in an F-algebra that allows `b` to inspect itself. + => ((f a -> a) -> Trans b b) -- ^ A pseudoprism parametric in an F-algebra that allows `b` to inspect itself. -> (f a -> a) -- ^ A (Base t)-algebra -> (Base t' b -> b) -- ^ A (Base t')-algebra -> t' -> b diff --git a/test/Examples.hs b/test/Examples.hs --- a/test/Examples.hs +++ b/test/Examples.hs @@ -29,7 +29,7 @@ import Data.Functor.Foldable.TH import GHC.Generics (Generic) --- | We call our co-dependent data types 'Ernie' and 'Bert'. They represent mutually recursive +-- | We call our co-dependent data types 'Ernie' and 'Bert'. data Bert = Bert Ernie | Num Integer | String String @@ -38,28 +38,23 @@ data Ernie = Ernie Bert | Multiply Ernie Ernie - | List [Ernie] deriving (Show, Eq, Generic, NFData) makeBaseFunctor ''Ernie makeBaseFunctor ''Bert --- TODO bifunctor ?? ernieHelper :: (BertF Bert -> Bert) -> Trans Ernie Ernie -ernieHelper alg = (mapErnie g .) -- . (. fmap (mapErnie g)) +ernieHelper alg = (mapErnie g .) where g (Ernie b) = Ernie $ dendro bertHelper ernieAlgebra alg b g x = x mapErnie f (Ernie (Bert e)) = mapErnie f e - mapErnie f (Multiply e e') = Multiply (mapErnie f e) (mapErnie f e') - mapErnie f (List es) = List (mapErnie f <$> es) - mapErnie f e = f e + mapErnie f e = f e -bertHelper :: (ErnieF Ernie -> Ernie) -> Trans Bert Bert -- TODO more flexible data type that allows us to use BertF or whatever -bertHelper alg = (mapBert g .) . (. fmap (mapBert g)) - where g (Bert e) = Bert $ dendro ernieHelper bertAlgebra alg e -- FIXME cata alg e? +bertHelper :: (ErnieF Ernie -> Ernie) -> Trans Bert Bert +bertHelper alg = (mapBert g .) + where g (Bert e) = Bert $ dendro ernieHelper bertAlgebra alg e g x = x mapBert f (Bert (Ernie b)) = mapBert f b - mapBert f (Add b b') = Add (mapBert f b) (mapBert f b') mapBert f x = f x -- | BertF-algebra @@ -75,12 +70,12 @@ -- | Dendromorphism collapsing the tree. Note that we can use the same -- F-algebras here as we would in a normal catamorphism. collapseErnieSyntaxTree :: (Recursive Ernie, Recursive Bert) => Ernie -> Ernie -collapseErnieSyntaxTree = dendro ernieHelper bertAlgebra ernieAlgebra +collapseErnieSyntaxTree = finish $ dendro ernieHelper bertAlgebra ernieAlgebra -- | We can generate two functions by swapping the F-algebras and the dummy -- type. collapseBertSyntaxTree :: (Recursive Bert, Recursive Ernie) => Bert -> Bert -collapseBertSyntaxTree = dendro bertHelper ernieAlgebra bertAlgebra +collapseBertSyntaxTree = finish $ dendro bertHelper ernieAlgebra bertAlgebra -- | Catamorphism, which collapses the tree the usual way. collapseErnieSyntaxTree' :: (Recursive Ernie) => Ernie -> Ernie diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -23,16 +23,20 @@ main :: IO () main = hspec $ - describe "dendro" $ do - parallel $ it "collapses a simple syntax tree" $ + describe "dendro" $ parallel $ do + it "collapses a simple syntax tree" $ collapseBertSyntaxTree bertSum `shouldBe` Num 5 - parallel $ it "collapses both parts of a syntax tree" $ + it "collapses both parts of a syntax tree" $ collapseErnieSyntaxTree ernieMult `shouldBe` resultErnie - parallel $ it "matches solution via catamorphism" $ + it "matches solution via catamorphism" $ collapseErnieSyntaxTree' ernieMult `shouldBe` collapseErnieSyntaxTree ernieMult - parallel $ it "collapses complex syntax trees" $ + it "collapses complex syntax trees" $ collapseBertSyntaxTree bertComplex `shouldBe` Num 18 - parallel $ it "should work would when triply wrapped (1/2)" $ + it "should work would when triply wrapped (1/2)" $ collapseErnieSyntaxTree (Ernie (Bert (Ernie (Num 15)))) `shouldBe` resultErnie - parallel $ it "should work would when triply wrapped (2/2)" $ - collapseErnieSyntaxTree (Ernie (Bert ernieComplex)) `shouldBe` resultErnie + it "should work would when doubly wrapped" $ + collapseBertSyntaxTree (Bert (Ernie (Num 15))) `shouldBe` (Num 15) + it "should work would when triply wrapped (2/3)" $ + collapseBertSyntaxTree (Bert (Ernie bertComplex)) `shouldBe` (Num 18) + it "should work would when triply wrapped (3/3)" $ + collapseBertSyntaxTree (Bert ernieComplex) `shouldBe` (Num 15)