recursion-schemes-ext 0.1.1.1 → 0.2.0.0

raw patch · 6 files changed

+196/−193 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• recursion-schemes-ext.cabal +3/−3
• src/Data/Functor/Foldable/Examples.hs +2/−2
• src/Data/Functor/Foldable/Exotic.hs +116/−0
• src/Data/Functor/Foldable/Exotic/TH.hs +75/−0
• src/Data/Functor/Foldable/Extensions.hs +0/−114
• src/Data/Functor/Foldable/Extensions/TH.hs +0/−74

@@ -1,5 +1,5 @@ name:                recursion-schemes-ext-version:             0.1.1.1+version:             0.2.0.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,8 +24,8 @@  library   hs-source-dirs:      src-  exposed-modules:     Data.Functor.Foldable.Extensions-                     , Data.Functor.Foldable.Extensions.TH+  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

@@ -24,8 +24,8 @@  import           Control.DeepSeq                     (NFData) import           Data.Functor.Foldable-import           Data.Functor.Foldable.Extensions-import           Data.Functor.Foldable.Extensions.TH+import           Data.Functor.Foldable.Exotic+import           Data.Functor.Foldable.Exotic.TH import           Data.Functor.Foldable.TH import           GHC.Generics                        (Generic) 

@@ -0,0 +1,116 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | 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+    , anaM+    , hyloM+    -- * Recursion schemes for interdependent data types+    , dendro+    , dendroTri+    , symplecto+    , chema+    -- * Exotic recursion schemes+    , dicata+    , micro+    ) where++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++    -- | 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)++-- | We need this class to make type resolution work.+class Dummy t where+    dummy :: t++--margaritari ::++-- | 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+    -> (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++-- 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+    -> b -> t'+chema = const (pseudoana .* homoCo)+    where pseudoana g = a where a = embed . fmap (a . switch) . g . switch++-- 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+    -> (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))++-- | 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+dicata = fst .** (cata .* (&&&))++-- | A micromorphism is an Elgot algebra specialized to unfolding.+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 (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` id) (ap .* ((<=<) .** (liftM2 fmap (<=<) <$> (mapM .*)))))

@@ -0,0 +1,75 @@+{-# 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"

@@ -1,114 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}---- | 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.Extensions-    ( -- * Classes-      SubHom (..)-    , SubType (..)-    , CoSubHom (..)-    , Dummy (..)-    -- * Monadic recursion schemes-    , cataM-    , anaM-    , hyloM-    -- * Recursion schemes for interdependent data types-    , dendro-    , dendroTri-    , symplecto-    , chema-    -- * Exotic recursion schemes-    , dicata-    , micro-    ) where--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--    -- | 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)---- | We need this class to make type resolution work.-class Dummy t where-    dummy :: t----margaritari ::---- | 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-    -> (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---- 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-    -> b -> t'-chema = const (pseudoana .* homoCo)-    where pseudoana g = a where a = embed . fmap a . g . switch---- | 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)-    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))---- | 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-dicata = fst .** (cata .* (&&&))---- | A micromorphism is an Elgot algebra specialized to unfolding.-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 (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 .*)))))

@@ -1,74 +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.Extensions.TH-    ( -- * Template Haskell helpers-      entangleFunctors-    , entanglePair-    ) where--import           Data.Functor.Foldable.Extensions-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 concat . 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"