data-fix 0.0.7 → 0.3.4
raw patch · 3 files changed
Files
- CHANGELOG.md +38/−0
- data-fix.cabal +35/−15
- src/Data/Fix.hs +451/−78
+ CHANGELOG.md view
@@ -0,0 +1,38 @@+## 0.3.4++- Use quantified constraints superclasses for `Eq`, `Ord`, `NFData` and+ `Hashable Fix` instances, when available.++## 0.3.3++- Drop support for GHCs prior 8.6.5++## 0.3.2++- Add `(un)wrapFix/Mu/Nu`+- Support `transformers-0.6`++## 0.3.1++- Update bounds for GHC-9.0++## 0.3.0++- Rename `cata`, `ana` and `hylo` into `foldFix`, `unfoldFix` and `refold.+ Old names are now deprecated, and will be eventually removed.+ Similarly, rename monadic variants.+- Add `hoistFix` and `hoistFix'` function.+- Add `Hashable` and `NFData` instance.+ Latter is available only with `deepseq >=1.4.3.0`,+ which provides `NFData1` type-class+- Change `Eq`, `Ord`, `Show` and `Read` instances to use+ `Eq1`, `Ord1`, `Show1` and `Read1` instances of a base functor.+- Add least and greatest fixed point types, `Mu` and `Nu`.+- Drop requirement for `Applicative m` in monadic combinators,+ `Monad m` is enough.+- Remove `~>` alias for `refold` (`hylo`).+- Extend the GHC support window.+ There is nothing magical in this package.+- Mark `Data.Fix` as Trustworthy (Safe Haskell)+- Make `refold` (and `refoldM`) more efficient.+ This results in different effect ordering for `refoldM`.
data-fix.cabal view
@@ -1,14 +1,14 @@+cabal-version: 2.2 Name: data-fix-Version: 0.0.7-Cabal-Version: >= 1.10-License: BSD3+Version: 0.3.4+License: BSD-3-Clause License-file: LICENSE-Author: Anton Kholomiov+Author: Anton Kholomiov, Edward Kmett, Oleg Grenrus Maintainer: <anton.kholomiov@gmail.com> Category: Data Synopsis: Fixpoint data types Build-Type: Simple-Description: +Description: Fixpoint types and recursion schemes. If you define your AST as fixpoint type, you get fold and unfold operations for free. .@@ -16,19 +16,39 @@ Stability: Experimental -Homepage: https://github.com/anton-k/data-fix-Bug-Reports: https://github.com/anton-k/data-fix/issues+Homepage: https://github.com/spell-music/data-fix+Bug-Reports: https://github.com/spell-music/data-fix/issues +Tested-With:+ GHC ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.6+ || ==9.8.2+ || ==9.10.1++extra-source-files:+ CHANGELOG.md+ Source-repository head Type: git- Location: https://github.com/anton-k/data-fix+ Location: https://github.com/spell-music/data-fix -Library- Default-Language: Haskell2010- Build-depends: base >= 4.7, base < 5- Hs-source-dirs: src/+library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ exposed-modules: Data.Fix - ghc-options: -Wall+ ghc-options: -Wno-trustworthy-safe+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities -Wmissing-export-lists - Exposed-modules: - Data.Fix+ build-depends:+ , base >=4.12.0.0 && <4.21+ , deepseq >=1.4.4.0 && <1.6+ , hashable >=1.4.4.0 && <1.6
src/Data/Fix.hs view
@@ -1,13 +1,21 @@-{-# Language- FlexibleContexts,- UndecidableInstances,- TypeSynonymInstances,- DeriveGeneric,- DeriveDataTypeable,- StandaloneDeriving #-}--- | Fix-point type. It allows to define generic recurion schemes.------ > Fix f = f (Fix f)+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}++-- needed for Data instance+{-# LANGUAGE UndecidableInstances #-}++#define HAS_POLY_TYPEABLE MIN_VERSION_base(4,7,0)+#define HAS_QUANTIFIED_FUNCTOR_CLASSES MIN_VERSION_base(4,18,0)++#if HAS_POLY_TYPEABLE+{-# LANGUAGE StandaloneDeriving #-}+#endif++-- | Fixed points of a functor. -- -- Type @f@ should be a 'Functor' if you want to use -- simple recursion schemes or 'Traversable' if you want to@@ -16,103 +24,468 @@ -- You can imagine that a non-recursive function -- holds values of the previous iteration. ----- Little example:+-- An example: ----- > type List a = Fix (L a)--- >--- > data L a b = Nil | Cons a b--- >--- > instance Functor (L a) where--- > fmap f x = case x of--- > Nil -> Nil--- > Cons a b -> Cons a (f b)--- >--- > length :: List a -> Int--- > length = cata $ \x -> case x of--- > Nil -> 0--- > Cons _ n -> n + 1--- >--- > sum :: Num a => List a -> a--- > sum = cata $ \x -> case x of--- > Nil -> 0--- > Cons a s -> a + s-+-- First we define a base functor. The arguments @b@ are recursion points.+--+-- >>> data ListF a b = Nil | Cons a b deriving (Show, Functor)+--+-- The list is then a fixed point of 'ListF'+--+-- >>> type List a = Fix (ListF a)+--+-- We can write @length@ function. Note that the function we give+-- to 'foldFix' is not recursive. Instead the results+-- of recursive calls are in @b@ positions, and we need to deal+-- only with one layer of the structure.+--+-- >>> :{+-- let length :: List a -> Int+-- length = foldFix $ \x -> case x of+-- Nil -> 0+-- Cons _ n -> n + 1+-- :}+--+-- If you already have recursive type, like '[Int]',+-- you can first convert it to `Fix (ListF a)` and then `foldFix`.+-- Alternatively you can use @recursion-schemes@ combinators+-- which work directly on recursive types.+-- module Data.Fix (- Fix(..)- -- * Simple recursion- -- | Type @f@ should be a 'Functor'. They transform- -- non-recursive functions to recursive ones.- , cata- , ana- , hylo- , (~>)- -- * Monadic recursion- -- | Type @f@ should be a 'Traversable'.- , cataM- , anaM- , hyloM- )-where+ -- * Fix+ Fix (..),+ hoistFix,+ hoistFix',+ foldFix,+ unfoldFix,+ wrapFix,+ unwrapFix,+ -- * Mu - least fixed point+ Mu (..),+ hoistMu,+ foldMu,+ unfoldMu,+ wrapMu,+ unwrapMu,+ -- * Nu - greatest fixed point+ Nu (..),+ hoistNu,+ foldNu,+ unfoldNu,+ wrapNu,+ unwrapNu,+ -- * Refolding+ refold,+ -- * Monadic variants+ foldFixM,+ unfoldFixM,+ refoldM,+ -- * Deprecated aliases+ cata, ana, hylo,+ cataM, anaM, hyloM,+) where -import GHC.Generics-import Control.Applicative+-- Explicit imports help dodge unused imports warnings,+-- as we say what we want from Prelude+import Data.Traversable (Traversable (..))+import Prelude (Eq (..), Functor (..), Monad (..), Ord (..), Read (..), Show (..), showParen, showString, ($), (.), (=<<))++#ifdef __GLASGOW_HASKELL__+#if !HAS_POLY_TYPEABLE+import Prelude (const, error, undefined)+#endif+#endif++import Control.Monad (liftM)+import Data.Function (on)+import Data.Functor.Classes (Eq1, Ord1, Read1, Show1, readsPrec1, showsPrec1)+import Data.Hashable (Hashable (..))+import Data.Hashable.Lifted (Hashable1, hashWithSalt1)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Text.Read (Lexeme (Ident), Read (..), lexP, parens, prec, readS_to_Prec, step)++#if MIN_VERSION_deepseq(1,4,3)+import Control.DeepSeq (NFData (..), NFData1, rnf1)+#endif++#if HAS_POLY_TYPEABLE+import Data.Data (Data)+#else import Data.Data-import Data.Function (on)-import Data.Traversable+#endif +#if !HAS_QUANTIFIED_FUNCTOR_CLASSES+import Data.Functor.Classes (compare1, eq1)+#endif++-- $setup+-- >>> :set -XDeriveFunctor+-- >>> import Prelude+-- >>> import Data.Functor.Classes+-- >>> data ListF a b = Nil | Cons a b deriving (Show, Functor)+--+-- >>> :{+-- >>> instance Show a => Show1 (ListF a) where+-- >>> liftShowsPrec _ _ d Nil = showString "Nil"+-- >>> liftShowsPrec sp _ d (Cons a b) = showParen (d > 10) $ showString "Cons " . showsPrec 11 a . showChar ' ' . sp 11 b+-- >>> :}+--+-- >>> :{+-- >>> let elimListF n c Nil = 0+-- >>> elimListF n c (Cons a b) = c a b+-- >>> :}++-------------------------------------------------------------------------------+-- Fix+-------------------------------------------------------------------------------+ -- | A fix-point type.-newtype Fix f = Fix { unFix :: f (Fix f) } deriving (Generic, Typeable)+newtype Fix f = Fix { unFix :: f (Fix f) }+ deriving (Generic)++-- | Change base functor in 'Fix'.+hoistFix :: Functor f => (forall a. f a -> g a) -> Fix f -> Fix g+hoistFix nt = go where go (Fix f) = Fix (nt (fmap go f))++-- | Like 'hoistFix' but 'fmap'ping over @g@.+hoistFix' :: Functor g => (forall a. f a -> g a) -> Fix f -> Fix g+hoistFix' nt = go where go (Fix f) = Fix (fmap go (nt f))++-- | Fold 'Fix'.+--+-- >>> let fp = unfoldFix (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> foldFix (elimListF 0 (+)) fp+-- 6+--+foldFix :: Functor f => (f a -> a) -> Fix f -> a+foldFix f = go where go = f . fmap go . unFix++-- | Unfold 'Fix'.+--+-- >>> unfoldFix (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)+-- Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil))))))))+--+unfoldFix :: Functor f => (a -> f a) -> a -> Fix f+unfoldFix f = go where go = Fix . fmap go . f++-- | Wrap 'Fix'.+--+-- >>> let x = unfoldFix (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> wrapFix (Cons 10 x)+-- Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))))+--+-- @since 0.3.2+--+wrapFix :: f (Fix f) -> Fix f+wrapFix = Fix++-- | Unwrap 'Fix'.+--+-- >>> let x = unfoldFix (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> unwrapFix x+-- Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))+--+-- @since 0.3.2+--+unwrapFix :: Fix f -> f (Fix f)+unwrapFix = unFix++-------------------------------------------------------------------------------+-- Functor instances+-------------------------------------------------------------------------------++instance Eq1 f => Eq (Fix f) where+#if HAS_QUANTIFIED_FUNCTOR_CLASSES+ Fix a == Fix b = a == b+#else+ Fix a == Fix b = eq1 a b+#endif++instance Ord1 f => Ord (Fix f) where+#if HAS_QUANTIFIED_FUNCTOR_CLASSES+ compare (Fix a) (Fix b) = compare a b+ min (Fix a) (Fix b) = Fix (min a b)+ max (Fix a) (Fix b) = Fix (max a b)+ Fix a >= Fix b = a >= b+ Fix a > Fix b = a > b+ Fix a < Fix b = a < b+ Fix a <= Fix b = a <= b+#else+ compare (Fix a) (Fix b) = compare1 a b+#endif++instance Show1 f => Show (Fix f) where+ showsPrec d (Fix a) =+ showParen (d >= 11)+ $ showString "Fix "+ . showsPrec1 11 a++#ifdef __GLASGOW_HASKELL__+instance Read1 f => Read (Fix f) where+ readPrec = parens $ prec 10 $ do+ Ident "Fix" <- lexP+ fmap Fix (step (readS_to_Prec readsPrec1))+#endif++-------------------------------------------------------------------------------+-- hashable+-------------------------------------------------------------------------------++instance Hashable1 f => Hashable (Fix f) where+#if MIN_VERSION_hashable(1,5,0)+ hash (Fix x) = hash x+ hashWithSalt salt (Fix x) = hashWithSalt salt x+#else+ hashWithSalt salt = hashWithSalt1 salt . unFix+#endif++-------------------------------------------------------------------------------+-- deepseq+-------------------------------------------------------------------------------++#if MIN_VERSION_deepseq(1,4,3)+instance NFData1 f => NFData (Fix f) where+#if MIN_VERSION_deepseq(1,5,0)+ rnf (Fix a) = rnf a +#else+ rnf = rnf1 . unFix+#endif+#endif++-------------------------------------------------------------------------------+-- Typeable and Data+-------------------------------------------------------------------------------++#ifdef __GLASGOW_HASKELL__+#if HAS_POLY_TYPEABLE+deriving instance Typeable Fix deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)+#else+instance Typeable1 f => Typeable (Fix f) where+ typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]+ where asArgsTypeOf :: f a -> Fix f -> f a+ asArgsTypeOf = const --- standard instances+fixTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"+#else+fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"+#endif+{-# NOINLINE fixTyCon #-} -instance Show (f (Fix f)) => Show (Fix f) where- showsPrec n x = showParen (n > 10) $ \s ->- "Fix " ++ showsPrec 11 (unFix x) s+instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where+ gfoldl f z (Fix a) = z Fix `f` a+ toConstr _ = fixConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z (Fix))+ _ -> error "gunfold"+ dataTypeOf _ = fixDataType -instance Read (f (Fix f)) => Read (Fix f) where- readsPrec d = readParen (d > 10) $ \r ->- [(Fix m, t) | ("Fix", s) <- lex r, (m, t) <- readsPrec 11 s]+fixConstr :: Constr+fixConstr = mkConstr fixDataType "Fix" [] Prefix -instance Eq (f (Fix f)) => Eq (Fix f) where- (==) = (==) `on` unFix+fixDataType :: DataType+fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]+#endif+#endif -instance Ord (f (Fix f)) => Ord (Fix f) where- compare = compare `on` unFix+-------------------------------------------------------------------------------+-- Mu+------------------------------------------------------------------------------- +-- | Least fixed point. Efficient folding.+newtype Mu f = Mu { unMu :: forall a. (f a -> a) -> a } --- recursion+instance (Functor f, Eq1 f) => Eq (Mu f) where+ (==) = (==) `on` foldMu Fix +instance (Functor f, Ord1 f) => Ord (Mu f) where+ compare = compare `on` foldMu Fix++instance (Functor f, Show1 f) => Show (Mu f) where+ showsPrec d f = showParen (d > 10) $+ showString "unfoldMu unFix " . showsPrec 11 (foldMu Fix f)++#ifdef __GLASGOW_HASKELL__+instance (Functor f, Read1 f) => Read (Mu f) where+ readPrec = parens $ prec 10 $ do+ Ident "unfoldMu" <- lexP+ Ident "unFix" <- lexP+ fmap (unfoldMu unFix) (step readPrec)+#endif++-- | Change base functor in 'Mu'.+hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g+hoistMu n (Mu mk) = Mu $ \roll -> mk (roll . n)++-- | Fold 'Mu'.+--+-- >>> let mu = unfoldMu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> foldMu (elimListF 0 (+)) mu+-- 6+foldMu :: (f a -> a) -> Mu f -> a+foldMu f (Mu mk) = mk f++-- | Unfold 'Mu'.+--+-- >>> unfoldMu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)+-- unfoldMu unFix (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil)))))))))+unfoldMu :: Functor f => (a -> f a) -> a -> Mu f+unfoldMu f x = Mu $ \mk -> refold mk f x++-- | Wrap 'Mu'.+--+-- >>> let x = unfoldMu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> wrapMu (Cons 10 x)+-- unfoldMu unFix (Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))))))+--+-- @since 0.3.2+--+wrapMu :: Functor f => f (Mu f) -> Mu f+wrapMu fx = Mu $ \f -> f (fmap (foldMu f) fx)++-- | Unwrap 'Mu'.+--+-- >>> let x = unfoldMu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> unwrapMu x+-- Cons 0 (unfoldMu unFix (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))+--+-- @since 0.3.2+--+unwrapMu :: Functor f => Mu f -> f (Mu f)+unwrapMu = foldMu (fmap wrapMu)++-------------------------------------------------------------------------------+-- Nu+-------------------------------------------------------------------------------++-- | Greatest fixed point. Efficient unfolding.+data Nu f = forall a. Nu (a -> f a) a++instance (Functor f, Eq1 f) => Eq (Nu f) where+ (==) = (==) `on` foldNu Fix++instance (Functor f, Ord1 f) => Ord (Nu f) where+ compare = compare `on` foldNu Fix++instance (Functor f, Show1 f) => Show (Nu f) where+ showsPrec d f = showParen (d > 10) $+ showString "unfoldNu unFix " . showsPrec 11 (foldNu Fix f)++#ifdef __GLASGOW_HASKELL__+instance (Functor f, Read1 f) => Read (Nu f) where+ readPrec = parens $ prec 10 $ do+ Ident "unfoldNu" <- lexP+ Ident "unFix" <- lexP+ fmap (unfoldNu unFix) (step readPrec)+#endif++-- | Change base functor in 'Nu'.+hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g+hoistNu n (Nu next seed) = Nu (n . next) seed++-- | Fold 'Nu'.+--+-- >>> let nu = unfoldNu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> foldNu (elimListF 0 (+)) nu+-- 6+--+foldNu :: Functor f => (f a -> a) -> Nu f -> a+foldNu f (Nu next seed) = refold f next seed++-- | Unfold 'Nu'.+--+-- >>> unfoldNu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int)+-- unfoldNu unFix (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil)))))))))+unfoldNu :: (a -> f a) -> a -> Nu f+unfoldNu = Nu++-- | Wrap 'Nu'.+--+-- >>> let x = unfoldNu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> wrapNu (Cons 10 x)+-- unfoldNu unFix (Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))))))+--+-- @since 0.3.2+--+wrapNu :: Functor f => f (Nu f) -> Nu f+wrapNu = unfoldNu (fmap unwrapNu)++-- | Unwrap 'Nu'.+--+-- >>> let x = unfoldNu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int)+-- >>> unwrapNu x+-- Cons 0 (unfoldNu unFix (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))+--+-- @since 0.3.2+--+unwrapNu :: Functor f => Nu f -> f (Nu f)+unwrapNu (Nu f x) = fmap (Nu f) (f x)++-------------------------------------------------------------------------------+-- refold+-------------------------------------------------------------------------------++-- | Refold one recursive type into another, one layer at the time.+--+refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b+refold f g = h where h = f . fmap h . g++-------------------------------------------------------------------------------+-- Monadic variants+-------------------------------------------------------------------------------++-- | Monadic 'foldFix'.+--+foldFixM:: (Monad m, Traversable t)+ => (t a -> m a) -> Fix t -> m a+foldFixM f = go where go = (f =<<) . mapM go . unFix++-- | Monadic anamorphism.+unfoldFixM :: (Monad m, Traversable t)+ => (a -> m (t a)) -> (a -> m (Fix t))+unfoldFixM f = go where go = liftM Fix . (mapM go =<<) . f++-- | Monadic hylomorphism.+refoldM :: (Monad m, Traversable t)+ => (t b -> m b) -> (a -> m (t a)) -> (a -> m b)+refoldM phi psi = go where go = (phi =<<) . (mapM go =<<) . psi++-------------------------------------------------------------------------------+-- Deprecated aliases+-------------------------------------------------------------------------------+ -- | Catamorphism or generic function fold. cata :: Functor f => (f a -> a) -> (Fix f -> a)-cata f = f . fmap (cata f) . unFix+cata = foldFix+{-# DEPRECATED cata "Use foldFix" #-} -- | Anamorphism or generic function unfold. ana :: Functor f => (a -> f a) -> (a -> Fix f)-ana f = Fix . fmap (ana f) . f+ana = unfoldFix+{-# DEPRECATED ana "Use unfoldFix" #-} -- | Hylomorphism is anamorphism followed by catamorphism. hylo :: Functor f => (f b -> b) -> (a -> f a) -> (a -> b)-hylo phi psi = cata phi . ana psi---- | Infix version of @hylo@.-(~>) :: Functor f => (a -> f a) -> (f b -> b) -> (a -> b)-psi ~> phi = phi . fmap (hylo phi psi) . psi---- monadic recursion+hylo = refold+{-# DEPRECATED hylo "Use refold" #-} -- | Monadic catamorphism.-cataM :: (Applicative m, Monad m, Traversable t)+cataM :: (Monad m, Traversable t) => (t a -> m a) -> Fix t -> m a-cataM f = (f =<<) . traverse (cataM f) . unFix+cataM = foldFixM+{-# DEPRECATED cataM "Use foldFixM" #-} -- | Monadic anamorphism.-anaM :: (Applicative m, Monad m, Traversable t)+anaM :: (Monad m, Traversable t) => (a -> m (t a)) -> (a -> m (Fix t))-anaM f = fmap Fix . (traverse (anaM f) =<<) . f+anaM = unfoldFixM+{-# DEPRECATED anaM "Use unfoldFixM" #-} -- | Monadic hylomorphism.-hyloM :: (Applicative m, Monad m, Traversable t)+hyloM :: (Monad m, Traversable t) => (t b -> m b) -> (a -> m (t a)) -> (a -> m b)-hyloM phi psi = (cataM phi =<<) . anaM psi-+hyloM = refoldM+{-# DEPRECATED hyloM "Use refoldM" #-}