diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -81,3 +81,7 @@ 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. 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.1.0.5 +version: 0.1.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 @@ -24,15 +24,17 @@ library hs-source-dirs: src exposed-modules: Data.Functor.Foldable.Extensions - Data.Functor.Foldable.Examples + , Data.Functor.Foldable.Extensions.TH + , Data.Functor.Foldable.Examples build-depends: base > 4.9 && < 4.11 , recursion-schemes >= 5.0 , composition-prelude , deepseq + , template-haskell default-language: Haskell2010 if flag(development) ghc-options: -Werror - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-import-lists + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates test-suite recursion-schemes-test type: exitcode-stdio-1.0 @@ -45,7 +47,7 @@ default-language: Haskell2010 if flag(development) ghc-options: -Werror - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-import-lists + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates benchmark recursion-schemes-bench type: exitcode-stdio-1.0 @@ -58,7 +60,7 @@ default-language: Haskell2010 if flag(development) ghc-options: -Werror - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-import-lists + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates source-repository head type: git 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 @@ -19,12 +19,12 @@ , collapseBertSyntaxTree' ) where -import Control.DeepSeq (NFData) -import Data.Functor.Foldable (Recursive, cata, embed) -import Data.Functor.Foldable.Extensions (Dummy (dummy), SubHom (homo), - SubType (switch), dendro) -import Data.Functor.Foldable.TH (makeBaseFunctor) -import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Functor.Foldable +import Data.Functor.Foldable.Extensions +import Data.Functor.Foldable.Extensions.TH +import Data.Functor.Foldable.TH +import GHC.Generics (Generic) -- | We call our co-dependent data types 'Ernie' and 'Bert'. They represent mutually recursive data Bert = Bert Ernie @@ -51,25 +51,8 @@ instance Dummy Ernie where dummy = Ernie dummy -instance SubHom ErnieF BertF Ernie Bert where - - homo ea alberta (BertF e) = Bert $ dendro (dummy :: Bert) alberta ea e - homo _ f b = f b - -instance SubType Bert where - - switch (Bert (Ernie b)) = b - switch x = x - -instance SubHom BertF ErnieF Bert Ernie where - - homo alberta ea (ErnieF b) = Ernie $ dendro (dummy :: Ernie) ea alberta b - homo _ f e = f e - -instance SubType Ernie where - - switch (Ernie (Bert e)) = e - switch x = x +entanglePair ''Ernie ''Bert +entanglePair ''Bert ''Ernie bertAlgebra :: BertF Bert -> Bert bertAlgebra (AddF (Num i) (Num j)) = Num $ i + j @@ -80,7 +63,7 @@ ernieAlgebra (MultiplyF (Ernie (Num i)) (Ernie (Num j))) = Ernie . Num $ i * j ernieAlgebra x = embed x --- | Dendromorphism collapsing the tree +-- | Dendromorphism collapsing the tree. collapseErnieSyntaxTree :: (Recursive Ernie) => Ernie -> Ernie collapseErnieSyntaxTree = dendro (dummy :: Bert) bertAlgebra ernieAlgebra diff --git a/src/Data/Functor/Foldable/Extensions.hs b/src/Data/Functor/Foldable/Extensions.hs --- a/src/Data/Functor/Foldable/Extensions.hs +++ b/src/Data/Functor/Foldable/Extensions.hs @@ -2,26 +2,31 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Functor.Foldable.Extensions - ( dicata + ( -- | Functions + dicata , dendro , dendroTri , micro , symplecto , chema + -- | Monadic recursion schemes , cataM + , anaM + , hyloM + -- | Classes , SubHom (..) , SubType (..) , CoSubHom (..) , Dummy (..) ) where -import Control.Arrow ((&&&)) -import Control.Composition (fix, (-.*), (.*), (.**)) -import Control.Monad ((<=<)) -import Data.Functor.Foldable (Base, Corecursive, Recursive, cata, - elgot, embed, hylo, project) +import Control.Arrow +import Control.Composition +import Control.Monad +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 @@ -43,11 +48,10 @@ -- | Resolve nested functions coswitch :: a -> a +-- | We need this class to make type resolution work. class Dummy t where dummy :: t --- Delta functor: just the diagonal :) - --margaritari :: -- | Entangle two hylomorphisms. Not the same thing as a symplectomorphism from geometry. @@ -67,15 +71,13 @@ chema = pseudoana .* homoCo where pseudoana g = a where a = embed . fmap a . g . switch --- FIXME maybe run the catamorphism on the inner bit? - -- | A dendromorphism allows us to entangle 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 -> (Base t' b -> b) -- ^ A (Base t')-algebra -> t' -> b -dendro = const ((pseudocata .* homo)) +dendro = const (pseudocata .* homo) where pseudocata f = c where c = switch . f . fmap c . project -- | Entangle three base functors. @@ -96,5 +98,14 @@ micro :: (Corecursive a) => (b -> Either a (Base a b)) -> b -> a micro = elgot embed +-- | A monadic catamorphism cataM :: (Recursive t, Traversable (Base t), Monad m) => (Base t a -> m a) -> (t -> m a) -cataM phi = fix ((phi <=<) . (project -.* mapM)) +cataM phi = fix (fmap (phi <=<) (project -.* mapM)) + +-- | A monadic anamorphism +anaM :: (Corecursive t, Traversable (Base t), Monad m) => (a -> m (Base t a)) -> (a -> m t) +anaM = fix (fmap embed .** ((=<<) .* (fmap traverse) >=> fmap)) + +-- | A monadic hylomorphism +hyloM :: (Functor f, Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b +hyloM = fix (fmap (flip flip id) (ap .* ((<=<) .** (liftM2 fmap (<=<) <$> (mapM .*))))) diff --git a/src/Data/Functor/Foldable/Extensions/TH.hs b/src/Data/Functor/Foldable/Extensions/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Foldable/Extensions/TH.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Functor.Foldable.Extensions.TH + ( -- | Template Haskell helpers + entangleFunctors + , entanglePair + ) where + +import Data.Functor.Foldable.Extensions +import Language.Haskell.TH + +-- | Make the abscissae a subtype of the ordinates. +entangleFunctors :: [(Name, Name)] -> Q [Dec] +entangleFunctors = fmap concat . traverse (uncurry entanglePair) + +-- | Entangle two functors, creating a 'SubHom' instance. 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" diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.0 +resolver: lts-9.1 packages: - '.' extra-deps: