diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,9 +4,6 @@ [recursion-schemes](https://hackage.haskell.org/package/recursion-schemes-5.0.2), including a `cataM`. -At the moment, you should be careful using functions from this package. While -APIs will likely be stable, they may have poor performance. - ## Pitch ### Monadic Functions @@ -64,8 +61,12 @@ makeBaseFunctor ''Ernie makeBaseFunctor ''Bert -entangleFunctors [(''Ernie, ''Bert), (''Bert, ''Ernie)] +bertLens :: Lens' Bert Bert +bertLens = ... +ernieLens :: Lens' Ernie Ernie +ernieLens = ... + bertAlgebra :: BertF Bert -> Bert bertAlgebra (AddF (Num i) (Num j)) = Num $ i + j bertAlgebra x = embed x @@ -75,19 +76,13 @@ ernieAlgebra x = embed x collapseErnieSyntaxTree :: (Recursive Ernie) => Ernie -> Ernie -collapseErnieSyntaxTree = dendro (dummy :: Bert) bertAlgebra ernieAlgebra +collapseErnieSyntaxTree = dendro (dummy :: Bert) ernieLens bertAlgebra ernieAlgebra collapseBertSyntaxTree :: (Recursive Bert) => Bert -> Bert -collapseBertSyntaxTree = dendro (dummy :: Ernie) ernieAlgebra bertAlgebra +collapseBertSyntaxTree = dendro (dummy :: Ernie) bertLens ernieAlgebra bertAlgebra ``` ## Anti-Pitch -Using dendromorphisms rather than catamorphisms is slow. As such, for the above -example, you'd probably pick the catamorphism most of the time. In fact, -dendromorphisms are really only useful on sufficiently complicated projects -where writing correct code would be difficult or inconvenient without them. - -Moreover, the template Haskell is… unwieldy. It'll definitely be shorter and -more elegant once all is said and done, but you do need to be careful to name -everything the "correct" way. +This library is experimental! The API of dendromorphisms and chemamorphisms in +particular is subject to change. diff --git a/recursion-schemes-ext.cabal b/recursion-schemes-ext.cabal --- a/recursion-schemes-ext.cabal +++ b/recursion-schemes-ext.cabal @@ -1,5 +1,5 @@ name: recursion-schemes-ext -version: 0.2.0.1 +version: 0.2.1.0 synopsis: Amateur addenda to recursion-schemes description: This package provides some exotic recursion schemes that I miss when I leave Idris. homepage: https://hub.darcs.net/vmchale/recursion-schemes-ext#readme @@ -25,10 +25,10 @@ library hs-source-dirs: src exposed-modules: Data.Functor.Foldable.Exotic - , Data.Functor.Foldable.Exotic.TH , Data.Functor.Foldable.Examples build-depends: base > 4.9 && < 4.11 , recursion-schemes >= 5.0 + , lens , composition-prelude , deepseq , template-haskell diff --git a/src/Data/Functor/Foldable/Examples.hs b/src/Data/Functor/Foldable/Examples.hs --- a/src/Data/Functor/Foldable/Examples.hs +++ b/src/Data/Functor/Foldable/Examples.hs @@ -22,12 +22,11 @@ , collapseBertSyntaxTree' ) where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Data.Functor.Foldable import Data.Functor.Foldable.Exotic -import Data.Functor.Foldable.Exotic.TH import Data.Functor.Foldable.TH -import GHC.Generics (Generic) +import GHC.Generics (Generic) -- | We call our co-dependent data types 'Ernie' and 'Bert'. They represent mutually recursive data Bert = Bert Ernie @@ -44,15 +43,6 @@ makeBaseFunctor ''Ernie makeBaseFunctor ''Bert -instance Dummy Bert where - dummy = Num 3 - -instance Dummy Ernie where - dummy = Ernie dummy - -entanglePair ''Ernie ''Bert -entanglePair ''Bert ''Ernie - -- | BertF-algebra bertAlgebra :: BertF Bert -> Bert bertAlgebra (AddF (Num i) (Num j)) = Num $ i + j @@ -65,13 +55,13 @@ -- | Dendromorphism collapsing the tree. Note that we can use the same -- F-algebras here as we would in a normal catamorphism. -collapseErnieSyntaxTree :: (Recursive Ernie) => Ernie -> Ernie -collapseErnieSyntaxTree = dendro (dummy :: Bert) bertAlgebra ernieAlgebra +collapseErnieSyntaxTree :: (Recursive Ernie, Recursive Bert) => Ernie -> Ernie +collapseErnieSyntaxTree = dendro undefined bertAlgebra ernieAlgebra -- | We can generate two functions by swapping the F-algebras and the dummy -- type. -collapseBertSyntaxTree :: (Recursive Bert) => Bert -> Bert -collapseBertSyntaxTree = dendro (dummy :: Ernie) ernieAlgebra bertAlgebra +collapseBertSyntaxTree :: (Recursive Bert, Recursive Ernie) => Bert -> Bert +collapseBertSyntaxTree = dendro undefined ernieAlgebra bertAlgebra -- | Catamorphism, which collapses the tree the usual way. collapseErnieSyntaxTree' :: (Recursive Ernie) => Ernie -> Ernie 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 @@ -2,97 +2,72 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnicodeSyntax #-} -- | Several extensions to Edward Kmett's recursion schemes package. The monadic -- recursion schemes and exotic recursion schemes should be stable, but the -- recursion schemes for interdependent data type (and their attendant -- typeclasses) are experimental. module Data.Functor.Foldable.Exotic - ( -- * Classes - SubHom (..) - , SubType (..) - , CoSubHom (..) - , Dummy (..) + ( -- * Monadic recursion schemes - , cataM + cataM , anaM , hyloM -- * Recursion schemes for interdependent data types , dendro - , dendroTri , symplecto , chema -- * Exotic recursion schemes , dicata , micro + , mutu ) where import Control.Arrow import Control.Composition +import Control.Lens import Data.Functor.Foldable --- | Class that yields g-algebra homomorphisms between mutually recursive types. -class (Functor f, Functor g) => SubHom f g a b where - - -- | Homomorphism of g-algebras parametrized by an f-algebra - homo :: (f a -> a) -> (g b -> b) -> (g b -> b) - -class SubType b where - - -- | Resolve nested functions. - switch :: b -> b - --- | Class that yields g-coalgebra homomorphisms between mutually recursive types. -class (Functor f, Functor g) => CoSubHom f g a b where - - -- | Homomorphism of g-coalgebras paramterized by an f-coalgebra - homoCo :: (a -> f a) -> (b -> g b) -> (b -> g b) +--margaritari :: --- | We need this class to make type resolution work. -class Dummy t where - dummy :: t +-- TODO +type UnsafePrism s a = ∀ f. Functor f => (f a -> a) -> f s -> s ---margaritari :: +-- | Just wanted this available somewhere +mutu :: Recursive t => (Base t (b, a) -> b) -> (Base t (b, a) -> a) -> t -> a +mutu f g = snd . cata (f &&& g) -- | Entangle two hylomorphisms. Not the same thing as a symplectomorphism from geometry. -symplecto :: (SubHom g f b b, CoSubHom g f a a) - => (g b -> b) -- ^ A g-algebra +symplecto :: (Functor f, Functor g) + => ((f b -> b) -> UnsafePrism b b) -- ^ A prism 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 -> (f b -> b) -- ^ An f-algebra -> (a -> f a) -- ^ An f-coalgebra -> a -> b -symplecto = homoCo -.* (flip . ((.) .* hylo .* homo)) -- FIXME what the fuck did I do here +symplecto p l alg coalg alg' coalg' = hylo (p alg' alg) (l coalg' coalg) -- Entangle two anamorphisms. -chema :: (CoSubHom (Base t) (Base t') a b, SubType b, Corecursive t') - => t -- ^ dummy type - -> (a -> Base t a) -- A (Base t)-coalgebra - -> (b -> Base t' b) -- A (Base t')-coalgebra +chema :: (Corecursive t', Functor f) + => ((a -> f a) -> Lens' b b) -- ^ A lens parametric in an F-coalgebra that allows `b` to inspect itself. + -> (a -> f a) -- ^ A (Base t)-coalgebra + -> (b -> Base t' b) -- ^ A (Base t')-coalgebra -> b -> t' -chema = const (pseudoana .* homoCo) - where pseudoana g = a where a = embed . fmap (a . switch) . g . switch +chema = (ana .*) -- better idea: have a function to lift any f-algebra into a (f . w)-algebra for w a comonad -- ℤ ∀ ∈ ≠ ≤ ≥ ⇒ → ∧ ∨ ¬ 𝔹 ≡ ∪ ⊕ ∅ -- -- | A dendromorphism entangles two catamorphisms -dendro :: (SubHom (Base t) (Base t') a b, SubType b, Recursive t') - => t -- ^ dummy type - -> (Base t a -> a) -- ^ A (Base t)-algebra +dendro :: (Recursive t', Functor f) + => ((f a -> a) -> UnsafePrism b b) -- ^ A prism 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 -dendro = const (pseudocata .* homo) - where pseudocata f = c where c = switch . f . fmap (switch . c) . project - --- | Entangle three base functors. -dendroTri :: (SubHom (Base t) (Base t') a b, SubType b, Recursive t', SubHom (Base t'') (Base t) c a, SubType a, Recursive t) - => t -- ^ dummy type - -> t'' -- ^ another dummy type - -> (Base t'' c -> c) -- ^ A (Base t'')-algebra - -> (Base t a -> a) -- A (Base t)-algebra - -> (Base t' b -> b) -- A (Base t')-algebra - -> t' -> b -dendroTri = fmap const (switch .** homo -.* (fmap <$> dendro)) +dendro = (cata .*) -- | Catamorphism collapsing along two data types simultaneously. Basically a fancy zygomorphism. dicata :: (Recursive a) => (Base a (b, a) -> b) -> (Base a (b, a) -> a) -> a -> b @@ -113,3 +88,7 @@ -- | A monadic hylomorphism hyloM :: (Functor f, Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b hyloM phi psi = h where h = phi <=< mapM h <=< psi + +-- | Unicode synonym for `cata` +-- 🐱 :: Recursive t => (Base t a -> a) -> t -> a +-- 🐱 = cata diff --git a/src/Data/Functor/Foldable/Exotic/TH.hs b/src/Data/Functor/Foldable/Exotic/TH.hs deleted file mode 100644 --- a/src/Data/Functor/Foldable/Exotic/TH.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Module containing Template Haskell functions to automically intertwine the --- base functors of the given types. -module Data.Functor.Foldable.Exotic.TH - ( -- * Template Haskell helpers - entangleFunctors - , entanglePair - ) where - -import Control.Monad (join) -import Data.Functor.Foldable.Exotic -import Language.Haskell.TH - --- | Entangle a list of functors. As an example, --- --- > entangleFunctors [(''Data, ''Codata)] --- --- will generate --- --- > instance SubHom DataF CodataF Data Codata --- > instance SubType Codata -entangleFunctors :: [(Name, Name)] -> Q [Dec] -entangleFunctors = fmap join . traverse (uncurry entanglePair) - --- | Entangle types, creating a 'SubHom' instance with their base functors. --- Note that this is rather strict with regards to naming. -entanglePair :: Name -> Name -> Q [Dec] -entanglePair sub top = pure [subHomInstance, subTypeInstance] - where - - subTypeInstance = InstanceD Nothing [] (subType `AppT` topT) funTypeDecls - subHomInstance = InstanceD Nothing (fmap (AppT functor) [subFT, topFT]) (subHom `AppT` subFT `AppT` topFT `AppT` subT `AppT` topT) funDecls - - functor = ConT ''Functor - subHom = ConT ''SubHom - subType = ConT ''SubType - - toN = mkName . (++ "F") . show - mN = mkName . show - toF = ConT . toN - subFT = toF sub - topFT = toF top - subT = ConT sub - topT = ConT top - - -- TODO this is kind of sloppy. - getConstructor = mkName . show - - funTypeDecls = [FunD switchN [switchClause, switchBoringClause]] - - switchClause = Clause [ConP (getConstructor top) [ConP (getConstructor sub) [VarP (mkName "a")]]] (NormalB (VarE (mkName "a"))) [] - switchBoringClause = Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) [] - - funDecls = [FunD homoN [homoComplicated, homoSimple]] - dummySig = SigE (VarE dummyN) topT - - homoComplicated = Clause [VarP taN, VarP saN, ConP (toN top) [VarP (mkName "top")]] atlas [] - homoSimple = Clause [WildP, VarP fN, VarP eN] body [] - - atlas = NormalB (ConE (mN top) `AppE` (VarE dendroN `AppE` dummySig `AppE` VarE saN `AppE` VarE taN `AppE` VarE (mkName "top"))) - body = NormalB (VarE fN `AppE` VarE eN) - - homoN = mkName "homo" - switchN = mkName "switch" - dendroN = mkName "dendro" - dummyN = mkName "dummy" - fN = mkName "f" - eN = mkName "e" - saN = mkName "subAlg" - taN = mkName "topAlg"