├── cabal.project ├── .gitignore ├── cabal.haskell-ci ├── Setup.hs ├── README.md ├── CHANGELOG.md ├── LICENSE ├── data-fix.cabal ├── .github └── workflows │ └── haskell-ci.yml └── src └── Data └── Fix.hs /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | .stack-work 4 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | docspec: True 3 | head-hackage: False 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | data-fix - fixpoint types and recursion schemes 2 | ============================================================== 3 | 4 | Fixpoint types and recursion schemes. If you define your AST as 5 | fixpoint type, you get fold and unfold operations for free. 6 | 7 | ```haskell 8 | Fix f = f (Fix f) 9 | ``` 10 | 11 | Type ``f`` should be a ``Functor`` if you want to use simple 12 | recursion schemes or 'Traversable' if you want to use monadic recursion schemes. 13 | This style allows you to express recursive functions in non-recursive manner. 14 | You can imagine that a non-recursive function holds values of the previous iteration. 15 | 16 | Little example: 17 | 18 | ```haskell 19 | type List a = Fix (L a) 20 | 21 | data L a b = Nil | Cons a b 22 | 23 | instance Functor (L a) where 24 | fmap f x = case x of 25 | Nil -> Nil 26 | Cons a b -> Cons a (f b) 27 | 28 | length :: List a -> Int 29 | length = cata $ \x -> case x of 30 | Nil -> 0 31 | Cons _ n -> n + 1 32 | 33 | sum :: Num a => List a -> a 34 | sum = cata $ \x -> case x of 35 | Nil -> 0 36 | Cons a s -> a + s 37 | ``` 38 | 39 | ### Acknowledgements 40 | 41 | Thanks for contribution to: Matej Kollar, Herbert Valerio Riedel 42 | 43 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.3.4 2 | 3 | - Use quantified constraints superclasses for `Eq`, `Ord`, `NFData` and 4 | `Hashable Fix` instances, when available. 5 | 6 | ## 0.3.3 7 | 8 | - Drop support for GHCs prior 8.6.5 9 | 10 | ## 0.3.2 11 | 12 | - Add `(un)wrapFix/Mu/Nu` 13 | - Support `transformers-0.6` 14 | 15 | ## 0.3.1 16 | 17 | - Update bounds for GHC-9.0 18 | 19 | ## 0.3.0 20 | 21 | - Rename `cata`, `ana` and `hylo` into `foldFix`, `unfoldFix` and `refold. 22 | Old names are now deprecated, and will be eventually removed. 23 | Similarly, rename monadic variants. 24 | - Add `hoistFix` and `hoistFix'` function. 25 | - Add `Hashable` and `NFData` instance. 26 | Latter is available only with `deepseq >=1.4.3.0`, 27 | which provides `NFData1` type-class 28 | - Change `Eq`, `Ord`, `Show` and `Read` instances to use 29 | `Eq1`, `Ord1`, `Show1` and `Read1` instances of a base functor. 30 | - Add least and greatest fixed point types, `Mu` and `Nu`. 31 | - Drop requirement for `Applicative m` in monadic combinators, 32 | `Monad m` is enough. 33 | - Remove `~>` alias for `refold` (`hylo`). 34 | - Extend the GHC support window. 35 | There is nothing magical in this package. 36 | - Mark `Data.Fix` as Trustworthy (Safe Haskell) 37 | - Make `refold` (and `refoldM`) more efficient. 38 | This results in different effect ordering for `refoldM`. 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Anton Kholomiov 2010 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Anton Kholomiov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /data-fix.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | Name: data-fix 3 | Version: 0.3.4 4 | x-revision: 1 5 | License: BSD-3-Clause 6 | License-file: LICENSE 7 | Author: Anton Kholomiov, Edward Kmett, Oleg Grenrus 8 | Maintainer: 9 | Category: Data 10 | Synopsis: Fixpoint data types 11 | Build-Type: Simple 12 | Description: 13 | Fixpoint types and recursion schemes. If you define your AST as 14 | fixpoint type, you get fold and unfold operations for free. 15 | . 16 | Thanks for contribution to: Matej Kollar, Herbert Valerio Riedel 17 | 18 | Stability: Experimental 19 | 20 | Homepage: https://github.com/spell-music/data-fix 21 | Bug-Reports: https://github.com/spell-music/data-fix/issues 22 | 23 | Tested-With: 24 | GHC ==8.6.5 25 | || ==8.8.4 26 | || ==8.10.7 27 | || ==9.0.2 28 | || ==9.2.8 29 | || ==9.4.8 30 | || ==9.6.6 31 | || ==9.8.4 32 | || ==9.10.1 33 | || ==9.12.1 34 | 35 | extra-source-files: 36 | CHANGELOG.md 37 | 38 | Source-repository head 39 | Type: git 40 | Location: https://github.com/spell-music/data-fix 41 | 42 | library 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | ghc-options: -Wall 46 | exposed-modules: Data.Fix 47 | 48 | ghc-options: -Wno-trustworthy-safe 49 | ghc-options: 50 | -Wincomplete-uni-patterns -Wincomplete-record-updates 51 | -Wredundant-constraints -Widentities -Wmissing-export-lists 52 | 53 | build-depends: 54 | , base >=4.12.0.0 && <4.22 55 | , deepseq >=1.4.4.0 && <1.6 56 | , hashable >=1.4.4.0 && <1.6 57 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20241220 12 | # 13 | # REGENDATA ("0.19.20241220",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | fail-fast: false 82 | steps: 83 | - name: apt-get install 84 | run: | 85 | apt-get update 86 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 87 | - name: Install GHCup 88 | run: | 89 | mkdir -p "$HOME/.ghcup/bin" 90 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 91 | chmod a+x "$HOME/.ghcup/bin/ghcup" 92 | - name: Install cabal-install (prerelease) 93 | run: | 94 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 95 | "$HOME/.ghcup/bin/ghcup" install cabal 3.15.0.0.2024.10.3 || (cat "$HOME"/.ghcup/logs/*.* && false) 96 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.15.0.0.2024.10.3 -vnormal+nowrap" >> "$GITHUB_ENV" 97 | - name: Install GHC (GHCup) 98 | if: matrix.setup-method == 'ghcup' 99 | run: | 100 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 101 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 102 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 103 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 104 | echo "HC=$HC" >> "$GITHUB_ENV" 105 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 106 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 107 | env: 108 | HCKIND: ${{ matrix.compilerKind }} 109 | HCNAME: ${{ matrix.compiler }} 110 | HCVER: ${{ matrix.compilerVersion }} 111 | - name: Set PATH and environment variables 112 | run: | 113 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 114 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 115 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 116 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 117 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 118 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 119 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 120 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 121 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 122 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 123 | env: 124 | HCKIND: ${{ matrix.compilerKind }} 125 | HCNAME: ${{ matrix.compiler }} 126 | HCVER: ${{ matrix.compilerVersion }} 127 | - name: env 128 | run: | 129 | env 130 | - name: write cabal config 131 | run: | 132 | mkdir -p $CABAL_DIR 133 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 166 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 167 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 168 | rm -f cabal-plan.xz 169 | chmod a+x $HOME/.cabal/bin/cabal-plan 170 | cabal-plan --version 171 | - name: install cabal-docspec 172 | run: | 173 | mkdir -p $HOME/.cabal/bin 174 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 175 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 176 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 177 | rm -f cabal-docspec.xz 178 | chmod a+x $HOME/.cabal/bin/cabal-docspec 179 | cabal-docspec --version 180 | - name: checkout 181 | uses: actions/checkout@v4 182 | with: 183 | path: source 184 | - name: initial cabal.project for sdist 185 | run: | 186 | touch cabal.project 187 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 188 | cat cabal.project 189 | - name: sdist 190 | run: | 191 | mkdir -p sdist 192 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 193 | - name: unpack 194 | run: | 195 | mkdir -p unpacked 196 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 197 | - name: generate cabal.project 198 | run: | 199 | PKGDIR_data_fix="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/data-fix-[0-9.]*')" 200 | echo "PKGDIR_data_fix=${PKGDIR_data_fix}" >> "$GITHUB_ENV" 201 | rm -f cabal.project cabal.project.local 202 | touch cabal.project 203 | touch cabal.project.local 204 | echo "packages: ${PKGDIR_data_fix}" >> cabal.project 205 | echo "package data-fix" >> cabal.project 206 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 207 | cat >> cabal.project <> cabal.project.local 210 | cat cabal.project 211 | cat cabal.project.local 212 | - name: dump install plan 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 215 | cabal-plan 216 | - name: restore cache 217 | uses: actions/cache/restore@v4 218 | with: 219 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 220 | path: ~/.cabal/store 221 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 222 | - name: install dependencies 223 | run: | 224 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 225 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 226 | - name: build w/o tests 227 | run: | 228 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 229 | - name: build 230 | run: | 231 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 232 | - name: docspec 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 235 | cabal-docspec $ARG_COMPILER 236 | - name: cabal check 237 | run: | 238 | cd ${PKGDIR_data_fix} || false 239 | ${CABAL} -vnormal check 240 | - name: haddock 241 | run: | 242 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 243 | - name: unconstrained build 244 | run: | 245 | rm -f cabal.project.local 246 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 247 | - name: save cache 248 | if: always() 249 | uses: actions/cache/save@v4 250 | with: 251 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 252 | path: ~/.cabal/store 253 | -------------------------------------------------------------------------------- /src/Data/Fix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | 8 | -- needed for Data instance 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | #define HAS_POLY_TYPEABLE MIN_VERSION_base(4,7,0) 12 | #define HAS_QUANTIFIED_FUNCTOR_CLASSES MIN_VERSION_base(4,18,0) 13 | 14 | #if HAS_POLY_TYPEABLE 15 | {-# LANGUAGE StandaloneDeriving #-} 16 | #endif 17 | 18 | -- | Fixed points of a functor. 19 | -- 20 | -- Type @f@ should be a 'Functor' if you want to use 21 | -- simple recursion schemes or 'Traversable' if you want to 22 | -- use monadic recursion schemes. This style allows you to express 23 | -- recursive functions in non-recursive manner. 24 | -- You can imagine that a non-recursive function 25 | -- holds values of the previous iteration. 26 | -- 27 | -- An example: 28 | -- 29 | -- First we define a base functor. The arguments @b@ are recursion points. 30 | -- 31 | -- >>> data ListF a b = Nil | Cons a b deriving (Show, Functor) 32 | -- 33 | -- The list is then a fixed point of 'ListF' 34 | -- 35 | -- >>> type List a = Fix (ListF a) 36 | -- 37 | -- We can write @length@ function. Note that the function we give 38 | -- to 'foldFix' is not recursive. Instead the results 39 | -- of recursive calls are in @b@ positions, and we need to deal 40 | -- only with one layer of the structure. 41 | -- 42 | -- >>> :{ 43 | -- let length :: List a -> Int 44 | -- length = foldFix $ \x -> case x of 45 | -- Nil -> 0 46 | -- Cons _ n -> n + 1 47 | -- :} 48 | -- 49 | -- If you already have recursive type, like '[Int]', 50 | -- you can first convert it to `Fix (ListF a)` and then `foldFix`. 51 | -- Alternatively you can use @recursion-schemes@ combinators 52 | -- which work directly on recursive types. 53 | -- 54 | module Data.Fix ( 55 | -- * Fix 56 | Fix (..), 57 | hoistFix, 58 | hoistFix', 59 | foldFix, 60 | unfoldFix, 61 | wrapFix, 62 | unwrapFix, 63 | -- * Mu - least fixed point 64 | Mu (..), 65 | hoistMu, 66 | foldMu, 67 | unfoldMu, 68 | wrapMu, 69 | unwrapMu, 70 | -- * Nu - greatest fixed point 71 | Nu (..), 72 | hoistNu, 73 | foldNu, 74 | unfoldNu, 75 | wrapNu, 76 | unwrapNu, 77 | -- * Refolding 78 | refold, 79 | -- * Monadic variants 80 | foldFixM, 81 | unfoldFixM, 82 | refoldM, 83 | -- * Deprecated aliases 84 | cata, ana, hylo, 85 | cataM, anaM, hyloM, 86 | ) where 87 | 88 | -- Explicit imports help dodge unused imports warnings, 89 | -- as we say what we want from Prelude 90 | import Data.Traversable (Traversable (..)) 91 | import Prelude (Eq (..), Functor (..), Monad (..), Ord (..), Read (..), Show (..), showParen, showString, ($), (.), (=<<)) 92 | 93 | #ifdef __GLASGOW_HASKELL__ 94 | #if !HAS_POLY_TYPEABLE 95 | import Prelude (const, error, undefined) 96 | #endif 97 | #endif 98 | 99 | import Control.Monad (liftM) 100 | import Data.Function (on) 101 | import Data.Functor.Classes (Eq1, Ord1, Read1, Show1, readsPrec1, showsPrec1) 102 | import Data.Hashable (Hashable (..)) 103 | import Data.Hashable.Lifted (Hashable1, hashWithSalt1) 104 | import Data.Typeable (Typeable) 105 | import GHC.Generics (Generic) 106 | import Text.Read (Lexeme (Ident), Read (..), lexP, parens, prec, readS_to_Prec, step) 107 | 108 | #if MIN_VERSION_deepseq(1,4,3) 109 | import Control.DeepSeq (NFData (..), NFData1, rnf1) 110 | #endif 111 | 112 | #if HAS_POLY_TYPEABLE 113 | import Data.Data (Data) 114 | #else 115 | import Data.Data 116 | #endif 117 | 118 | #if !HAS_QUANTIFIED_FUNCTOR_CLASSES 119 | import Data.Functor.Classes (compare1, eq1) 120 | #endif 121 | 122 | -- $setup 123 | -- >>> :set -XDeriveFunctor 124 | -- >>> import Prelude 125 | -- >>> import Data.Functor.Classes 126 | -- >>> data ListF a b = Nil | Cons a b deriving (Show, Functor) 127 | -- 128 | -- >>> :{ 129 | -- >>> instance Show a => Show1 (ListF a) where 130 | -- >>> liftShowsPrec _ _ d Nil = showString "Nil" 131 | -- >>> liftShowsPrec sp _ d (Cons a b) = showParen (d > 10) $ showString "Cons " . showsPrec 11 a . showChar ' ' . sp 11 b 132 | -- >>> :} 133 | -- 134 | -- >>> :{ 135 | -- >>> let elimListF n c Nil = 0 136 | -- >>> elimListF n c (Cons a b) = c a b 137 | -- >>> :} 138 | 139 | ------------------------------------------------------------------------------- 140 | -- Fix 141 | ------------------------------------------------------------------------------- 142 | 143 | -- | A fix-point type. 144 | newtype Fix f = Fix { unFix :: f (Fix f) } 145 | deriving (Generic) 146 | 147 | -- | Change base functor in 'Fix'. 148 | hoistFix :: Functor f => (forall a. f a -> g a) -> Fix f -> Fix g 149 | hoistFix nt = go where go (Fix f) = Fix (nt (fmap go f)) 150 | 151 | -- | Like 'hoistFix' but 'fmap'ping over @g@. 152 | hoistFix' :: Functor g => (forall a. f a -> g a) -> Fix f -> Fix g 153 | hoistFix' nt = go where go (Fix f) = Fix (fmap go (nt f)) 154 | 155 | -- | Fold 'Fix'. 156 | -- 157 | -- >>> let fp = unfoldFix (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int) 158 | -- >>> foldFix (elimListF 0 (+)) fp 159 | -- 6 160 | -- 161 | foldFix :: Functor f => (f a -> a) -> Fix f -> a 162 | foldFix f = go where go = f . fmap go . unFix 163 | 164 | -- | Unfold 'Fix'. 165 | -- 166 | -- >>> unfoldFix (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int) 167 | -- Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil)))))))) 168 | -- 169 | unfoldFix :: Functor f => (a -> f a) -> a -> Fix f 170 | unfoldFix f = go where go = Fix . fmap go . f 171 | 172 | -- | Wrap 'Fix'. 173 | -- 174 | -- >>> let x = unfoldFix (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int) 175 | -- >>> wrapFix (Cons 10 x) 176 | -- Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))))) 177 | -- 178 | -- @since 0.3.2 179 | -- 180 | wrapFix :: f (Fix f) -> Fix f 181 | wrapFix = Fix 182 | 183 | -- | Unwrap 'Fix'. 184 | -- 185 | -- >>> let x = unfoldFix (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int) 186 | -- >>> unwrapFix x 187 | -- Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))) 188 | -- 189 | -- @since 0.3.2 190 | -- 191 | unwrapFix :: Fix f -> f (Fix f) 192 | unwrapFix = unFix 193 | 194 | ------------------------------------------------------------------------------- 195 | -- Functor instances 196 | ------------------------------------------------------------------------------- 197 | 198 | instance Eq1 f => Eq (Fix f) where 199 | #if HAS_QUANTIFIED_FUNCTOR_CLASSES 200 | Fix a == Fix b = a == b 201 | #else 202 | Fix a == Fix b = eq1 a b 203 | #endif 204 | 205 | instance Ord1 f => Ord (Fix f) where 206 | #if HAS_QUANTIFIED_FUNCTOR_CLASSES 207 | compare (Fix a) (Fix b) = compare a b 208 | min (Fix a) (Fix b) = Fix (min a b) 209 | max (Fix a) (Fix b) = Fix (max a b) 210 | Fix a >= Fix b = a >= b 211 | Fix a > Fix b = a > b 212 | Fix a < Fix b = a < b 213 | Fix a <= Fix b = a <= b 214 | #else 215 | compare (Fix a) (Fix b) = compare1 a b 216 | #endif 217 | 218 | instance Show1 f => Show (Fix f) where 219 | showsPrec d (Fix a) = 220 | showParen (d >= 11) 221 | $ showString "Fix " 222 | . showsPrec1 11 a 223 | 224 | #ifdef __GLASGOW_HASKELL__ 225 | instance Read1 f => Read (Fix f) where 226 | readPrec = parens $ prec 10 $ do 227 | Ident "Fix" <- lexP 228 | fmap Fix (step (readS_to_Prec readsPrec1)) 229 | #endif 230 | 231 | ------------------------------------------------------------------------------- 232 | -- hashable 233 | ------------------------------------------------------------------------------- 234 | 235 | instance Hashable1 f => Hashable (Fix f) where 236 | #if MIN_VERSION_hashable(1,5,0) 237 | hash (Fix x) = hash x 238 | hashWithSalt salt (Fix x) = hashWithSalt salt x 239 | #else 240 | hashWithSalt salt = hashWithSalt1 salt . unFix 241 | #endif 242 | 243 | ------------------------------------------------------------------------------- 244 | -- deepseq 245 | ------------------------------------------------------------------------------- 246 | 247 | #if MIN_VERSION_deepseq(1,4,3) 248 | instance NFData1 f => NFData (Fix f) where 249 | #if MIN_VERSION_deepseq(1,5,0) 250 | rnf (Fix a) = rnf a 251 | #else 252 | rnf = rnf1 . unFix 253 | #endif 254 | #endif 255 | 256 | ------------------------------------------------------------------------------- 257 | -- Typeable and Data 258 | ------------------------------------------------------------------------------- 259 | 260 | #ifdef __GLASGOW_HASKELL__ 261 | #if HAS_POLY_TYPEABLE 262 | deriving instance Typeable Fix 263 | deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f) 264 | #else 265 | instance Typeable1 f => Typeable (Fix f) where 266 | typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)] 267 | where asArgsTypeOf :: f a -> Fix f -> f a 268 | asArgsTypeOf = const 269 | 270 | fixTyCon :: TyCon 271 | #if MIN_VERSION_base(4,4,0) 272 | fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix" 273 | #else 274 | fixTyCon = mkTyCon "Data.Functor.Foldable.Fix" 275 | #endif 276 | {-# NOINLINE fixTyCon #-} 277 | 278 | instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where 279 | gfoldl f z (Fix a) = z Fix `f` a 280 | toConstr _ = fixConstr 281 | gunfold k z c = case constrIndex c of 282 | 1 -> k (z (Fix)) 283 | _ -> error "gunfold" 284 | dataTypeOf _ = fixDataType 285 | 286 | fixConstr :: Constr 287 | fixConstr = mkConstr fixDataType "Fix" [] Prefix 288 | 289 | fixDataType :: DataType 290 | fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr] 291 | #endif 292 | #endif 293 | 294 | ------------------------------------------------------------------------------- 295 | -- Mu 296 | ------------------------------------------------------------------------------- 297 | 298 | -- | Least fixed point. Efficient folding. 299 | newtype Mu f = Mu { unMu :: forall a. (f a -> a) -> a } 300 | 301 | instance (Functor f, Eq1 f) => Eq (Mu f) where 302 | (==) = (==) `on` foldMu Fix 303 | 304 | instance (Functor f, Ord1 f) => Ord (Mu f) where 305 | compare = compare `on` foldMu Fix 306 | 307 | instance (Functor f, Show1 f) => Show (Mu f) where 308 | showsPrec d f = showParen (d > 10) $ 309 | showString "unfoldMu unFix " . showsPrec 11 (foldMu Fix f) 310 | 311 | #ifdef __GLASGOW_HASKELL__ 312 | instance (Functor f, Read1 f) => Read (Mu f) where 313 | readPrec = parens $ prec 10 $ do 314 | Ident "unfoldMu" <- lexP 315 | Ident "unFix" <- lexP 316 | fmap (unfoldMu unFix) (step readPrec) 317 | #endif 318 | 319 | -- | Change base functor in 'Mu'. 320 | hoistMu :: (forall a. f a -> g a) -> Mu f -> Mu g 321 | hoistMu n (Mu mk) = Mu $ \roll -> mk (roll . n) 322 | 323 | -- | Fold 'Mu'. 324 | -- 325 | -- >>> let mu = unfoldMu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int) 326 | -- >>> foldMu (elimListF 0 (+)) mu 327 | -- 6 328 | foldMu :: (f a -> a) -> Mu f -> a 329 | foldMu f (Mu mk) = mk f 330 | 331 | -- | Unfold 'Mu'. 332 | -- 333 | -- >>> unfoldMu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int) 334 | -- unfoldMu unFix (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil))))))))) 335 | unfoldMu :: Functor f => (a -> f a) -> a -> Mu f 336 | unfoldMu f x = Mu $ \mk -> refold mk f x 337 | 338 | -- | Wrap 'Mu'. 339 | -- 340 | -- >>> let x = unfoldMu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int) 341 | -- >>> wrapMu (Cons 10 x) 342 | -- unfoldMu unFix (Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))))) 343 | -- 344 | -- @since 0.3.2 345 | -- 346 | wrapMu :: Functor f => f (Mu f) -> Mu f 347 | wrapMu fx = Mu $ \f -> f (fmap (foldMu f) fx) 348 | 349 | -- | Unwrap 'Mu'. 350 | -- 351 | -- >>> let x = unfoldMu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int) 352 | -- >>> unwrapMu x 353 | -- Cons 0 (unfoldMu unFix (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))) 354 | -- 355 | -- @since 0.3.2 356 | -- 357 | unwrapMu :: Functor f => Mu f -> f (Mu f) 358 | unwrapMu = foldMu (fmap wrapMu) 359 | 360 | ------------------------------------------------------------------------------- 361 | -- Nu 362 | ------------------------------------------------------------------------------- 363 | 364 | -- | Greatest fixed point. Efficient unfolding. 365 | data Nu f = forall a. Nu (a -> f a) a 366 | 367 | instance (Functor f, Eq1 f) => Eq (Nu f) where 368 | (==) = (==) `on` foldNu Fix 369 | 370 | instance (Functor f, Ord1 f) => Ord (Nu f) where 371 | compare = compare `on` foldNu Fix 372 | 373 | instance (Functor f, Show1 f) => Show (Nu f) where 374 | showsPrec d f = showParen (d > 10) $ 375 | showString "unfoldNu unFix " . showsPrec 11 (foldNu Fix f) 376 | 377 | #ifdef __GLASGOW_HASKELL__ 378 | instance (Functor f, Read1 f) => Read (Nu f) where 379 | readPrec = parens $ prec 10 $ do 380 | Ident "unfoldNu" <- lexP 381 | Ident "unFix" <- lexP 382 | fmap (unfoldNu unFix) (step readPrec) 383 | #endif 384 | 385 | -- | Change base functor in 'Nu'. 386 | hoistNu :: (forall a. f a -> g a) -> Nu f -> Nu g 387 | hoistNu n (Nu next seed) = Nu (n . next) seed 388 | 389 | -- | Fold 'Nu'. 390 | -- 391 | -- >>> let nu = unfoldNu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int) 392 | -- >>> foldNu (elimListF 0 (+)) nu 393 | -- 6 394 | -- 395 | foldNu :: Functor f => (f a -> a) -> Nu f -> a 396 | foldNu f (Nu next seed) = refold f next seed 397 | 398 | -- | Unfold 'Nu'. 399 | -- 400 | -- >>> unfoldNu (\i -> if i < 4 then Cons i (i + 1) else Nil) (0 :: Int) 401 | -- unfoldNu unFix (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix (Cons 3 (Fix Nil))))))))) 402 | unfoldNu :: (a -> f a) -> a -> Nu f 403 | unfoldNu = Nu 404 | 405 | -- | Wrap 'Nu'. 406 | -- 407 | -- >>> let x = unfoldNu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int) 408 | -- >>> wrapNu (Cons 10 x) 409 | -- unfoldNu unFix (Fix (Cons 10 (Fix (Cons 0 (Fix (Cons 1 (Fix (Cons 2 (Fix Nil))))))))) 410 | -- 411 | -- @since 0.3.2 412 | -- 413 | wrapNu :: Functor f => f (Nu f) -> Nu f 414 | wrapNu = unfoldNu (fmap unwrapNu) 415 | 416 | -- | Unwrap 'Nu'. 417 | -- 418 | -- >>> let x = unfoldNu (\i -> if i < 3 then Cons i (i + 1) else Nil) (0 :: Int) 419 | -- >>> unwrapNu x 420 | -- Cons 0 (unfoldNu unFix (Fix (Cons 1 (Fix (Cons 2 (Fix Nil)))))) 421 | -- 422 | -- @since 0.3.2 423 | -- 424 | unwrapNu :: Functor f => Nu f -> f (Nu f) 425 | unwrapNu (Nu f x) = fmap (Nu f) (f x) 426 | 427 | ------------------------------------------------------------------------------- 428 | -- refold 429 | ------------------------------------------------------------------------------- 430 | 431 | -- | Refold one recursive type into another, one layer at the time. 432 | -- 433 | refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b 434 | refold f g = h where h = f . fmap h . g 435 | 436 | ------------------------------------------------------------------------------- 437 | -- Monadic variants 438 | ------------------------------------------------------------------------------- 439 | 440 | -- | Monadic 'foldFix'. 441 | -- 442 | foldFixM:: (Monad m, Traversable t) 443 | => (t a -> m a) -> Fix t -> m a 444 | foldFixM f = go where go = (f =<<) . mapM go . unFix 445 | 446 | -- | Monadic anamorphism. 447 | unfoldFixM :: (Monad m, Traversable t) 448 | => (a -> m (t a)) -> (a -> m (Fix t)) 449 | unfoldFixM f = go where go = liftM Fix . (mapM go =<<) . f 450 | 451 | -- | Monadic hylomorphism. 452 | refoldM :: (Monad m, Traversable t) 453 | => (t b -> m b) -> (a -> m (t a)) -> (a -> m b) 454 | refoldM phi psi = go where go = (phi =<<) . (mapM go =<<) . psi 455 | 456 | ------------------------------------------------------------------------------- 457 | -- Deprecated aliases 458 | ------------------------------------------------------------------------------- 459 | 460 | -- | Catamorphism or generic function fold. 461 | cata :: Functor f => (f a -> a) -> (Fix f -> a) 462 | cata = foldFix 463 | {-# DEPRECATED cata "Use foldFix" #-} 464 | 465 | -- | Anamorphism or generic function unfold. 466 | ana :: Functor f => (a -> f a) -> (a -> Fix f) 467 | ana = unfoldFix 468 | {-# DEPRECATED ana "Use unfoldFix" #-} 469 | 470 | -- | Hylomorphism is anamorphism followed by catamorphism. 471 | hylo :: Functor f => (f b -> b) -> (a -> f a) -> (a -> b) 472 | hylo = refold 473 | {-# DEPRECATED hylo "Use refold" #-} 474 | 475 | -- | Monadic catamorphism. 476 | cataM :: (Monad m, Traversable t) 477 | => (t a -> m a) -> Fix t -> m a 478 | cataM = foldFixM 479 | {-# DEPRECATED cataM "Use foldFixM" #-} 480 | 481 | -- | Monadic anamorphism. 482 | anaM :: (Monad m, Traversable t) 483 | => (a -> m (t a)) -> (a -> m (Fix t)) 484 | anaM = unfoldFixM 485 | {-# DEPRECATED anaM "Use unfoldFixM" #-} 486 | 487 | -- | Monadic hylomorphism. 488 | hyloM :: (Monad m, Traversable t) 489 | => (t b -> m b) -> (a -> m (t a)) -> (a -> m b) 490 | hyloM = refoldM 491 | {-# DEPRECATED hyloM "Use refoldM" #-} 492 | --------------------------------------------------------------------------------