recursion 2.2.3.0 → 2.2.4.0
raw patch · 4 files changed
+226/−50 lines, 4 files
Files
- CHANGELOG.md +10/−0
- recursion.cabal +10/−6
- src/Control/Recursion.hs +159/−44
- src/Control/Recursion/GHC.hs +47/−0
CHANGELOG.md view
@@ -1,5 +1,15 @@ # recursion +## 2.2.4.0++* Move `transverse`, `cotransverse`, and `hoist` to new module+ `Control.Recursion.GHC`+* `recursion` now builds with `eta`++## 2.2.3.1++* Add doctests+ ## 2.2.3.0 * Add `hypo`
recursion.cabal view
@@ -1,10 +1,10 @@ cabal-version: 1.18 name: recursion-version: 2.2.3.0+version: 2.2.4.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale-maintainer: vanessa.mchale@iohk.io+maintainer: vamchale@gmail.com author: Vanessa McHale bug-reports: https://hub.darcs.net/vmchale/recursion/issues synopsis: A recursion schemes library for GHC.@@ -40,13 +40,17 @@ build-depends: base >=4.9 && <5, composition-prelude -any- - if flag(development)++ if !impl(eta -any)+ exposed-modules:+ Control.Recursion.GHC++ if (flag(development) && !impl(ghc >=8.8)) ghc-options: -Werror- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Wnoncanonical-monad-instances- + if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists
src/Control/Recursion.hs view
@@ -57,10 +57,7 @@ -- * Helper functions , lambek , colambek- , hoist , refix- , transverse- , cotransverse ) where import Control.Arrow ((&&&))@@ -69,7 +66,7 @@ import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import Data.Traversable (Traversable (..))+-- import Data.Traversable (Traversable (..)) import GHC.Generics import Numeric.Natural (Natural) @@ -136,7 +133,7 @@ project = lambek instance Functor f => Corecursive (Mu f) where- embed m = Mu (\f -> f (fmap (cata f) m))+ embed μ = Mu (\f -> f (fmap (cata f) μ)) instance Recursive [a] where project [] = Nil@@ -164,6 +161,19 @@ eitherM l r = (either l r =<<) -- | Catamorphism. Folds a structure. (see [here](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.41.125&rep=rep1&type=pdf))+--+-- >>> :{+-- let {+-- sum' :: (Num a) => [a] -> a ;+-- sum' = cata a+-- where+-- a Nil = 0+-- a (Cons x xs) = x + xs+-- }+-- :}+--+-- >>> sum' [1..100]+-- 5050 cata :: (Recursive t) => (Base t a -> a) -> t -> a cata f = c where c = f . fmap c . project {-# NOINLINE [0] cata #-}@@ -246,6 +256,23 @@ where a' = embed . fmap (ana (e . project) . a') . g -- | A mutumorphism.+--+-- >>> :{+-- let {+-- even' :: Natural -> Bool ;+-- even' = mutu o e+-- where+-- o :: Maybe (Bool, Bool) -> Bool+-- o Nothing = False+-- o (Just (_, b)) = b+-- e :: Maybe (Bool, Bool) -> Bool+-- e Nothing = True+-- e (Just (_, b)) = b+-- }+-- :}+--+-- >>> even' 10+-- True mutu :: (Recursive t) => (Base t (a, a) -> a) -> (Base t (a, a) -> a) -> t -> a mutu f g = snd . cata (f &&& g) @@ -260,10 +287,46 @@ scolio = fst .** (cata .* (&&&)) -- | Zygomorphism (see [here](http://www.iis.sinica.edu.tw/~scm/pub/mds.pdf) for a neat example)+--+-- >>> :set -XTypeFamilies+-- >>> import Data.Char (toUpper, toLower)+-- >>> :{+-- let {+-- spongebobZygo :: String -> String ;+-- spongebobZygo = zygo a pa+-- where+-- a :: ListF Char Bool -> Bool+-- a Nil = False+-- a (Cons ' ' b) = b+-- a (Cons ',' b) = b+-- a (Cons _ b) = not b+-- pa :: ListF Char (Bool, String) -> String+-- pa Nil = ""+-- pa (Cons c (True, s)) = toUpper c : s+-- pa (Cons c (False, s)) = toLower c : s+-- }+-- :}+--+-- >>> spongebobZygo "Hello, World"+-- "HeLlO, wOrLd" zygo :: (Recursive t) => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a zygo f g = snd . cata (\x -> (f (fmap fst x), g x)) -- | Paramorphism+--+-- >>> :{+-- let {+-- dedup :: Eq a => [a] -> [a] ;+-- dedup = para pa+-- where+-- pa :: Eq a => ListF a ([a], [a]) -> [a]+-- pa Nil = []+-- pa (Cons x (past, xs)) = if x `elem` past then xs else x:xs+-- }+-- :}+--+-- >>> dedup [1,1,2]+-- [1,2] para :: (Recursive t, Corecursive t) => (Base t (t, a) -> a) -> t -> a para f = snd . cata (\x -> (embed (fmap fst x), f x)) @@ -279,6 +342,22 @@ where g = h . e . fmap g . k -- | Mendler's catamorphism+--+-- >>> import Data.Word (Word64)+-- >>> let asFix = cata Fix+-- >>> let base = (2 ^ (64 :: Int)) :: Integer+-- >>> :{+-- let {+-- wordListToInteger :: [Word64] -> Integer ;+-- wordListToInteger = mcata ma . asFix+-- where+-- ma f (Cons x xs) = fromIntegral x + base * f xs+-- ma _ Nil = 0+-- }+-- :}+--+-- >>> wordListToInteger [1,0,1]+-- 340282366920938463463374607431768211457 mcata :: (forall y. ((y -> c) -> f y -> c)) -> Fix f -> c mcata ψ = mc where mc = ψ mc . unFix @@ -287,6 +366,25 @@ mhisto ψ = mh where mh = ψ mh unFix . unFix -- | Elgot algebra (see [this paper](https://arxiv.org/abs/cs/0609040))+--+-- >>> :{+-- let {+-- collatzLength :: Integer -> Integer ;+-- collatzLength = elgot a pc+-- where+-- pc :: Integer -> Either Integer (ListF Integer Integer)+-- pc 1 = Left 1+-- pc n+-- | n `mod` 2 == 0 = Right $ Cons n (div n 2)+-- | otherwise = Right $ Cons n (3 * n + 1)+-- a :: ListF Integer Integer -> Integer+-- a Nil = 0+-- a (Cons _ x) = x + 1+-- }+-- :}+--+-- >>> collatzLength 2223+-- 183 elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a elgot φ ψ = h where h = either id (φ . fmap h) . ψ @@ -295,56 +393,73 @@ micro = elgot embed -- | Co-(Elgot algebra)+--+-- >>> import Data.Word (Word64)+-- >>> let base = (2 ^ (64 :: Int)) :: Integer+-- >>> :{+-- let {+-- integerToWordList :: Integer -> [Word64] ;+-- integerToWordList = coelgot pa c+-- where+-- c i = Cons (fromIntegral (i `mod` (2 ^ (64 :: Int)))) (i `div` (2 ^ (64 :: Int)))+-- pa (i, ws) | i < 2 ^ (64 :: Int) = [fromIntegral i]+-- | otherwise = embed ws+-- }+-- :}+--+-- >>> integerToWordList 340282366920938463463374607431768211457+-- [1,0,1] coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b coelgot φ ψ = h where h = φ . (\x -> (x, fmap h . ψ $ x)) -- | Apomorphism. Compare 'micro'.+--+-- >>> :{+-- let {+-- isInteger :: (RealFrac a) => a -> Bool ;+-- isInteger = idem (realToFrac . floor)+-- where+-- idem f x = x == f x+-- }+-- :}+--+-- >>> :{+-- let {+-- continuedFraction :: (RealFrac a, Integral b) => a -> [b] ;+-- continuedFraction = apo pc+-- where+-- pc x+-- | isInteger x = go $ Left []+-- | otherwise = go $ Right alpha+-- where+-- alpha = 1 / (x - realToFrac (floor x))+-- go = Cons (floor x)+-- }+-- :}+--+-- >>> take 13 $ continuedFraction pi+-- [3,7,15,1,292,1,1,1,2,1,3,1,14]+--+-- >>> :{+-- let {+-- integerToWordList :: Integral a => a -> a -> [a] ;+-- integerToWordList base = apo pc+-- where+-- pc i | i < base = Cons (fromIntegral i) (Left [])+-- | otherwise = Cons (fromIntegral (i `mod` base)) (Right (i `div` base))+-- }+-- :}+--+-- >>> integerToWordList 2 5+-- [1,0,1] apo :: (Corecursive t) => (a -> Base t (Either t a)) -> a -> t-apo g = a where a = embed . fmap (either id a) . g+apo ψ = a where a = embed . fmap (either id a) . ψ -- | Hypomorphism. -- -- @since 2.2.3.0 hypo :: (Recursive t, Corecursive t) => (a -> Base t (Either t a)) -> (Base t (t, b) -> b) -> a -> b hypo φ ψ = para ψ . apo φ---- | Should satisfy:------ @--- 'transverse' 'sequenceA' = 'pure'--- @-transverse :: (Recursive s, Corecursive t, Functor f)- => (forall a. Base s (f a) -> f (Base t a))- -> s- -> f t-transverse = cata . (fmap embed .)--cotransverse :: (Recursive s, Corecursive t, Functor f)- => (forall a. f (Base s a) -> Base t (f a))- -> f s- -> t-cotransverse = ana . (. fmap project)--hoist :: (Recursive s, Corecursive t)- => (forall a. Base s a -> Base t a)- -> s- -> t-hoist = cata . (embed .)-{-# NOINLINE [0] hoist #-}--hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g-hoistMu η (Mu f) = Mu (f . (. η))--hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g-hoistNu ν (Nu f x) = Nu (ν . f) x--{-# RULES- "hoist/hoistMu" forall (η :: forall a. f a -> f a) (f :: forall a. (f a -> a) -> a). hoist η (Mu f) = hoistMu η (Mu f);- #-}--{-# RULES- "hoist/hoistNu" forall (η :: forall a. f a -> f a) (f :: a -> f a) x. hoist η (Nu f x) = hoistNu η (Nu f x);- #-} refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t refix = cata embed
+ src/Control/Recursion/GHC.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE RankNTypes #-}++-- | This module contains GHC-specific functions+module Control.Recursion.GHC ( transverse+ , cotransverse+ , hoist+ ) where++import Control.Recursion++-- | Should satisfy:+--+-- @+-- 'transverse' 'sequenceA' = 'pure'+-- @+transverse :: (Recursive s, Corecursive t, Functor f)+ => (forall a. Base s (f a) -> f (Base t a))+ -> s+ -> f t+transverse = cata . (fmap embed .)++cotransverse :: (Recursive s, Corecursive t, Functor f)+ => (forall a. f (Base s a) -> Base t (f a))+ -> f s+ -> t+cotransverse = ana . (. fmap project)++hoist :: (Recursive s, Corecursive t)+ => (forall a. Base s a -> Base t a)+ -> s+ -> t+hoist = cata . (embed .)+{-# NOINLINE [0] hoist #-}++hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g+hoistMu η (Mu f) = Mu (f . (. η))++hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g+hoistNu ν (Nu f x) = Nu (ν . f) x++{-# RULES+ "hoist/hoistMu" forall (η :: forall a. f a -> f a) (f :: forall a. (f a -> a) -> a). hoist η (Mu f) = hoistMu η (Mu f);+ #-}++{-# RULES+ "hoist/hoistNu" forall (η :: forall a. f a -> f a) (f :: a -> f a) x. hoist η (Nu f x) = hoistNu η (Nu f x);+ #-}