summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorvmchale <>2017-10-12 05:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-10-12 05:21:00 (GMT)
commit9ddaff413a37faa0639f6b1c50773a665cb21356 (patch)
treeb19bc0366e1406611959b3d32294b4d4cb0b29dd
parenteb4ecd28ebe026fa08a5065ca9600a14bdc73dfe (diff)
version 0.2.1.0HEAD0.2.1.0master
-rw-r--r--README.md23
-rw-r--r--recursion-schemes-ext.cabal4
-rw-r--r--src/Data/Functor/Foldable/Examples.hs22
-rw-r--r--src/Data/Functor/Foldable/Exotic.hs81
-rw-r--r--src/Data/Functor/Foldable/Exotic/TH.hs75
5 files changed, 47 insertions, 158 deletions
diff --git a/README.md b/README.md
index 50307d4..97b3c33 100644
--- a/README.md
+++ b/README.md
@@ -4,9 +4,6 @@ This adds several functions to
[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,7 +61,11 @@ data Ernie = Ernie Bert
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
@@ -75,19 +76,13 @@ ernieAlgebra (MultiplyF (Ernie (Num i)) (Ernie (Num j))) = Ernie . Num $ i * j
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
index 040726b..78f0077 100644
--- 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 @@ Flag development {
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
index f618d5a..3328ba9 100644
--- a/src/Data/Functor/Foldable/Examples.hs
+++ b/src/Data/Functor/Foldable/Examples.hs
@@ -22,12 +22,11 @@ module Data.Functor.Foldable.Examples ( -- * Data Types
, 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 @@ data Ernie = Ernie Bert
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 @@ ernieAlgebra x = embed x
-- | 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
index 00897f2..d0d7723 100644
--- 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 @@ anaM psi = a where a = (fmap embed . mapM a) <=< psi
-- | 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
index a64f343..0000000
--- 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"