recursion-schemes-ext 0.1.0.5 → 0.1.1.0

raw patch · 6 files changed

+108/−44 lines, 6 filesdep +template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• README.md +4/−0
• recursion-schemes-ext.cabal +7/−5
• src/Data/Functor/Foldable/Examples.hs +9/−26
• src/Data/Functor/Foldable/Extensions.hs +23/−12
• src/Data/Functor/Foldable/Extensions/TH.hs +64/−0
• stack.yaml +1/−1

@@ -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.

@@ -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

@@ -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 

@@ -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 .*)))))

@@ -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"

@@ -1,4 +1,4 @@-resolver: lts-9.0+resolver: lts-9.1 packages: - '.' extra-deps: