├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.markdown ├── Setup.hs ├── examples ├── brackets.hs ├── btree.hs ├── redblack.hs └── tree.hs ├── src └── Data │ ├── Biunfoldable.hs │ ├── Triunfoldable.hs │ ├── Unfoldable.hs │ └── Unfolder.hs └── unfoldable.cabal /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'unfoldable.cabal' 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.11.20210222 12 | # 13 | # REGENDATA ("0.11.20210222",["github","unfoldable.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - GHC ${{ matrix.ghc }} 22 | runs-on: ubuntu-22.04 23 | container: 24 | image: buildpack-deps:bionic 25 | continue-on-error: ${{ matrix.allow-failure }} 26 | strategy: 27 | matrix: 28 | include: 29 | - ghc: 9.0.1 30 | allow-failure: false 31 | - ghc: 8.10.2 32 | allow-failure: false 33 | - ghc: 8.8.4 34 | allow-failure: false 35 | fail-fast: false 36 | steps: 37 | - name: apt 38 | run: | 39 | apt-get update 40 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common 41 | apt-add-repository -y 'ppa:hvr/ghc' 42 | apt-get update 43 | apt-get install -y ghc-$GHC_VERSION cabal-install-3.4 44 | env: 45 | GHC_VERSION: ${{ matrix.ghc }} 46 | - name: Set PATH and environment variables 47 | run: | 48 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 49 | echo "LANG=C.UTF-8" >> $GITHUB_ENV 50 | echo "CABAL_DIR=$HOME/.cabal" >> $GITHUB_ENV 51 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> $GITHUB_ENV 52 | HC=/opt/ghc/$GHC_VERSION/bin/ghc 53 | echo "HC=$HC" >> $GITHUB_ENV 54 | echo "HCPKG=/opt/ghc/$GHC_VERSION/bin/ghc-pkg" >> $GITHUB_ENV 55 | echo "HADDOCK=/opt/ghc/$GHC_VERSION/bin/haddock" >> $GITHUB_ENV 56 | echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> $GITHUB_ENV 57 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 58 | echo "HCNUMVER=$HCNUMVER" >> $GITHUB_ENV 59 | echo "ARG_TESTS=--enable-tests" >> $GITHUB_ENV 60 | echo "ARG_BENCH=--enable-benchmarks" >> $GITHUB_ENV 61 | echo "HEADHACKAGE=false" >> $GITHUB_ENV 62 | echo "ARG_COMPILER=--ghc --with-compiler=$HC" >> $GITHUB_ENV 63 | echo "GHCJSARITH=0" >> $GITHUB_ENV 64 | env: 65 | GHC_VERSION: ${{ matrix.ghc }} 66 | - name: env 67 | run: | 68 | env 69 | - name: write cabal config 70 | run: | 71 | mkdir -p $CABAL_DIR 72 | cat >> $CABAL_CONFIG < cabal-plan.xz 101 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 102 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 103 | rm -f cabal-plan.xz 104 | chmod a+x $HOME/.cabal/bin/cabal-plan 105 | cabal-plan --version 106 | - name: checkout 107 | uses: actions/checkout@v2 108 | with: 109 | path: source 110 | - name: initial cabal.project for sdist 111 | run: | 112 | touch cabal.project 113 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 114 | cat cabal.project 115 | - name: sdist 116 | run: | 117 | mkdir -p sdist 118 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 119 | - name: unpack 120 | run: | 121 | mkdir -p unpacked 122 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 123 | - name: generate cabal.project 124 | run: | 125 | PKGDIR_unfoldable="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/unfoldable-[0-9.]*')" 126 | echo "PKGDIR_unfoldable=${PKGDIR_unfoldable}" >> $GITHUB_ENV 127 | touch cabal.project 128 | touch cabal.project.local 129 | echo "packages: ${PKGDIR_unfoldable}" >> cabal.project 130 | echo "package unfoldable" >> cabal.project 131 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 132 | cat >> cabal.project <> cabal.project.local 135 | cat cabal.project 136 | cat cabal.project.local 137 | - name: dump install plan 138 | run: | 139 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 140 | cabal-plan 141 | - name: cache 142 | uses: actions/cache@v2 143 | with: 144 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }} 145 | path: ~/.cabal/store 146 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 147 | - name: install dependencies 148 | run: | 149 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 150 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 151 | - name: build w/o tests 152 | run: | 153 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 154 | - name: build 155 | run: | 156 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 157 | - name: cabal check 158 | run: | 159 | cd ${PKGDIR_unfoldable} || false 160 | ${CABAL} -vnormal check 161 | - name: haddock 162 | run: | 163 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 164 | - name: unconstrained build 165 | run: | 166 | rm -f cabal.project.local 167 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 168 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Lines that start with '#' are comments. 2 | # For a project mostly in C, the following would be a good set of 3 | # exclude patterns (uncomment them if you want to use them): 4 | # *.[oa] 5 | # *~ 6 | dist/ 7 | dist-newstyle/ 8 | .stack-work/ 9 | .cabal-sandbox/ 10 | *.hi 11 | *.nix 12 | *.o 13 | *.p_hi 14 | *.prof 15 | stack.yaml* 16 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 1.0 2 | --- 3 | * improved generic implementation of `unfold` 4 | * improved implementation of `arbitraryDefault` 5 | * lifted `QuickCheck` upper bound to 3.0 6 | * updated to `containers` 0.6 7 | 8 | 0.9.6 9 | ----- 10 | * updated to `one-liner` 1.0 11 | 12 | 0.9.5 13 | ----- 14 | * updated to `QuickCheck` 2.11 15 | 16 | 0.9.4 17 | ----- 18 | * updated to `QuickCheck` 2.10 19 | 20 | 0.9.3 21 | ----- 22 | * updated to `one-liner` 0.9 23 | 24 | 0.9.2 25 | ----- 26 | * use one-liner for the generic implementation of `unfold` 27 | 28 | 0.9.1 29 | ----- 30 | * added `Nth` unfolder 31 | * added brackets example 32 | 33 | 0.9 34 | --- 35 | * added `chooseMap` method 36 | * added instances from `containers` 37 | * improved `ListT` instance 38 | 39 | 0.8.4 40 | ----- 41 | * updated to `QuickCheck` 2.9 42 | 43 | 0.8.3 44 | ----- 45 | * updated to `transformers` 0.5 46 | 47 | 0.8.2 48 | ----- 49 | * updated to `QuickCheck` 2.8 50 | 51 | 0.8.1 52 | ----- 53 | * added changelog 54 | * updated to `transformers` 0.4.1.0 55 | * added `Data.Functor.Sum` instance for `Unfoldable` 56 | 57 | 0.8 58 | --- 59 | * new implementation of `arbitraryDefault` 60 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, Sjoerd Visscher 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 Sjoerd Visscher 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 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | Unfoldable 2 | ========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/unfoldable.svg)](https://hackage.haskell.org/package/unfoldable) [![Build Status](https://github.com/sjoerdvisscher/unfoldable/workflows/Haskell-CI/badge.svg)](https://github.com/sjoerdvisscher/unfoldable/actions?query=workflow%3AHaskell-CI) 5 | 6 | Class of data structures that can be unfolded. 7 | 8 | Just as there's a Foldable class, there should also be an Unfoldable class. 9 | This package provides one. Example unfolds are: 10 | 11 | * Random values 12 | * Enumeration of all values (depth-first or breadth-first) 13 | * Convert from a list 14 | 15 | Some examples can be found in the examples directory. 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/brackets.hs: -------------------------------------------------------------------------------- 1 | -- From https://byorgey.wordpress.com/2016/10/25/adventures-in-enumerating-balanced-brackets/ 2 | import Data.Unfolder 3 | import Data.MemoTrie (memo) 4 | import Control.Applicative 5 | 6 | enumBrackets :: Unfolder f => f String 7 | enumBrackets = enumBracketsTail 0 8 | 9 | enumBracketsTail :: Unfolder f => Int -> f String 10 | enumBracketsTail = enumBracketsTail' 11 | where 12 | -- Ensure memoization happens for a specific `f` 13 | enumBracketsTail' = memo enumBracketsTail'' 14 | enumBracketsTail'' 0 = pure "" <|> choose [('(':) <$> enumBracketsTail' 1] 15 | enumBracketsTail'' c = 16 | choose [('(':) <$> enumBracketsTail' (c+1)] 17 | <|> 18 | ((')':) <$> enumBracketsTail' (c-1)) 19 | 20 | 21 | {- 22 | 23 | >>> enumBrackets 3 :: [String] 24 | ["((()))","(()())","(())()","()(())","()()()"] 25 | >>> getNth (enumBrackets 40) 16221270422764920820 26 | "((((((((()((())()(()()()())(()))((()()()()(()((()())))((()())))))))()))()())()))" 27 | >>> size (enumBrackets 100) 28 | 896519947090131496687170070074100632420837521538745909320 29 | 30 | -} 31 | -------------------------------------------------------------------------------- /examples/btree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | import Data.Unfoldable 3 | import Data.Unfolder 4 | 5 | import Data.Maybe 6 | import System.Random 7 | 8 | 9 | data TB a = LB a | BB (TB (a, a)) deriving (Show, Foldable) 10 | 11 | instance Unfoldable TB where 12 | unfold fa = choose 13 | [ LB <$> fa 14 | , BB <$> unfold ((,) <$> fa <*> fa) 15 | ] 16 | 17 | btree8 :: TB Int 18 | btree8 = fromJust $ fromList [0..7] 19 | 20 | btreeShapes :: [TB ()] 21 | btreeShapes = take 5 unfold_ 22 | 23 | randomBTree :: IO (TB Bool) 24 | randomBTree = getStdRandom randomDefault 25 | -------------------------------------------------------------------------------- /examples/redblack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | import Data.Unfoldable 11 | import Data.Unfolder 12 | 13 | import Data.Maybe 14 | import System.Random 15 | import Data.List (intercalate) 16 | 17 | -- Red-Black tree implementation adapted from https://gist.github.com/2660297 18 | data Nat = Zero | Succ Nat 19 | data NatW :: Nat -> * where 20 | ZeroW :: NatW 'Zero 21 | SuccW :: NatW n -> NatW ('Succ n) 22 | 23 | data RedBlack = Black | Red 24 | 25 | data RedBlackTree a where 26 | T :: Node 'Black n a -> RedBlackTree a 27 | deriving instance Show a => Show (RedBlackTree a) 28 | 29 | data Node :: RedBlack -> Nat -> * -> * where 30 | Leaf :: Node 'Black 'Zero a 31 | B :: Node cL n a -> a -> Node cR n a -> Node 'Black ('Succ n) a 32 | R :: Node 'Black n a -> a -> Node 'Black n a -> Node 'Red n a 33 | deriving instance Show a => Show (Node c n a) 34 | 35 | instance Unfoldable RedBlackTree where 36 | unfold = u ZeroW 37 | where 38 | u :: forall n f a. (Unfoldable (Node 'Black n), Unfolder f) 39 | => NatW n -> f a -> f (RedBlackTree a) 40 | u n fa = choose 41 | [ T <$> (unfold :: f a -> f (Node 'Black n a)) fa 42 | , u (SuccW n) fa 43 | ] 44 | 45 | instance Unfoldable (Node 'Black 'Zero) where 46 | unfold _ = choose [ pure Leaf ] 47 | 48 | instance Unfoldable (Node 'Black n) => Unfoldable (Node 'Black ('Succ n)) where 49 | unfold = u 50 | where 51 | u :: forall f a. Unfolder f => f a -> f (Node 'Black ('Succ n) a) 52 | u fa = choose 53 | [ B <$> b <*> fa <*> b 54 | , B <$> b <*> fa <*> r 55 | , B <$> r <*> fa <*> b 56 | , B <$> r <*> fa <*> r 57 | ] 58 | where 59 | r :: f (Node 'Red n a) 60 | r = unfold fa 61 | b :: f (Node 'Black n a) 62 | b = unfold fa 63 | 64 | instance Unfoldable (Node 'Black n) => Unfoldable (Node 'Red n) where 65 | unfold fa = choose [ R <$> unfold fa <*> fa <*> unfold fa ] 66 | 67 | rbtree :: Int -> RedBlackTree Int 68 | rbtree l = fromJust $ fromList [0..l] 69 | 70 | rbtreeShapes :: Int -> [RedBlackTree ()] 71 | rbtreeShapes d = limitDepth d unfold_ 72 | 73 | randomRBTree :: IO (RedBlackTree Bool) 74 | randomRBTree = getStdRandom randomDefault 75 | 76 | newtype Formula = Formula [Integer] 77 | instance Show Formula where 78 | show (Formula xs) 79 | | all (== 0) xs = "0" 80 | | otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [(0::Int)..] 81 | where 82 | showOne (x, 0) = show x 83 | showOne (1, 1) = "x" 84 | showOne (x, 1) = show x ++ "x" 85 | showOne (1, n) = "x^" ++ show n 86 | showOne (x, n) = show x ++ "x^" ++ show n 87 | 88 | add, mul :: [Integer] -> [Integer] -> [Integer] 89 | add xs [] = xs 90 | add [] ys = ys 91 | add (x:xs) (y:ys) = (x + y) : add xs ys 92 | mul _ [] = [] 93 | mul [] _ = [] 94 | mul (x:xs) (y:ys) = (x * y) : add (map (x*) ys) (add (map (y*) xs) (0 : mul xs ys)) 95 | 96 | instance Num Formula where 97 | fromInteger x = Formula [x] 98 | Formula xs + Formula ys = Formula (add xs ys) 99 | Formula xs * Formula ys = Formula (mul xs ys) 100 | 101 | varX :: Formula 102 | varX = Formula [0, 1] 103 | 104 | -- See http://oeis.org/A001137 105 | rbFormula :: Int -> NumConst Formula (RedBlackTree a) 106 | rbFormula d = ala (limitDepth d) unfold (NumConst varX) 107 | -------------------------------------------------------------------------------- /examples/tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveGeneric, DeriveAnyClass #-} 2 | 3 | import GHC.Generics 4 | import Data.Unfoldable 5 | import Data.Unfolder 6 | 7 | import Data.Maybe 8 | import Test.QuickCheck.Gen (sample, resize, Gen) 9 | 10 | 11 | data Tree a = Empty | Node (Tree a) a (Tree a) deriving (Show, Generic1, Foldable, Unfoldable) 12 | 13 | tree7 :: Tree Int 14 | tree7 = fromJust $ fromList [0..6] 15 | 16 | treeShapes :: [Tree ()] 17 | treeShapes = take 20 unfoldBF_ 18 | 19 | treeShapes' :: [Tree ()] 20 | treeShapes' = take 20 $ bfsBySum unfold_ 21 | 22 | arbitraryTrees :: Int -> IO () 23 | arbitraryTrees size = sample (resize size arbitraryDefault :: Gen (Tree ())) 24 | 25 | data Pair a = Pair a a 26 | deriving (Show, Functor, Foldable, Generic1, Unfoldable) 27 | data PerfectTree a = Leaf a | Branch (PerfectTree (Pair a)) 28 | deriving (Show, Functor, Foldable, Generic1, Unfoldable) 29 | 30 | ptreeShapes :: [PerfectTree ()] 31 | ptreeShapes = take 5 unfoldBF_ 32 | -------------------------------------------------------------------------------- /src/Data/Biunfoldable.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Biunfoldable 4 | -- Copyright : (c) Sjoerd Visscher 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Class of data structures with 2 type arguments that can be unfolded. 12 | ----------------------------------------------------------------------------- 13 | {-# LANGUAGE Safe #-} 14 | module Data.Biunfoldable 15 | ( 16 | 17 | -- * Biunfoldable 18 | Biunfoldable(..) 19 | , biunfold_ 20 | , biunfoldBF 21 | , biunfoldBF_ 22 | 23 | -- ** Specific unfolds 24 | , biunfoldr 25 | , fromLists 26 | , randomDefault 27 | , arbitraryDefault 28 | 29 | ) 30 | where 31 | 32 | import Control.Applicative 33 | import Data.Unfolder 34 | import Data.Functor.Constant 35 | import Control.Monad.Trans.State 36 | import qualified System.Random as R 37 | import Test.QuickCheck (Arbitrary(..), Gen, sized, resize) 38 | import Data.Maybe 39 | 40 | -- | Data structures with 2 type arguments (kind @* -> * -> *@) that can be unfolded. 41 | -- 42 | -- For example, given a data type 43 | -- 44 | -- > data Tree a b = Empty | Leaf a | Node (Tree a b) b (Tree a b) 45 | -- 46 | -- a suitable instance would be 47 | -- 48 | -- > instance Biunfoldable Tree where 49 | -- > biunfold fa fb = choose 50 | -- > [ pure Empty 51 | -- > , Leaf <$> fa 52 | -- > , Node <$> biunfold fa fb <*> fb <*> biunfold fa fb 53 | -- > ] 54 | -- 55 | -- i.e. it follows closely the instance for 'Bitraversable', but instead of matching on an input value, 56 | -- we 'choose' from a list of all cases. 57 | class Biunfoldable t where 58 | -- | Given a way to generate elements, return a way to generate structures containing those elements. 59 | biunfold :: Unfolder f => f a -> f b -> f (t a b) 60 | 61 | -- | Unfold the structure, always using @()@ as elements. 62 | biunfold_ :: (Biunfoldable t, Unfolder f) => f (t () ()) 63 | biunfold_ = biunfold (pure ()) (pure ()) 64 | 65 | -- | Breadth-first unfold, which orders the result by the number of 'choose' calls. 66 | biunfoldBF :: (Biunfoldable t, Unfolder f) => f a -> f b -> f (t a b) 67 | biunfoldBF = ala2 bfs biunfold 68 | 69 | -- | Unfold the structure breadth-first, always using @()@ as elements. 70 | biunfoldBF_ :: (Biunfoldable t, Unfolder f) => f (t () ()) 71 | biunfoldBF_ = bfs biunfold_ 72 | 73 | -- | @biunfoldr@ builds a data structure from a seed value. 74 | biunfoldr :: Biunfoldable t => (c -> Maybe (a, c)) -> (c -> Maybe (b, c)) -> c -> Maybe (t a b) 75 | biunfoldr fa fb z = terminate . flip runStateT z $ biunfoldBF (StateT $ maybeToList . fa) (StateT $ maybeToList . fb) 76 | where 77 | terminate [] = Nothing 78 | terminate ((t, c):ts) = if isNothing (fa c) && isNothing (fb c) then Just t else terminate ts 79 | 80 | -- | Create a data structure using the lists as input. 81 | -- This can fail because there might not be a data structure with the same number 82 | -- of element positions as the number of elements in the lists. 83 | fromLists :: Biunfoldable t => [a] -> [b] -> Maybe (t a b) 84 | fromLists = curry $ biunfoldr unconsA unconsB 85 | where 86 | unconsA ([], _) = Nothing 87 | unconsA (a:as, bs) = Just (a, (as, bs)) 88 | unconsB (_, []) = Nothing 89 | unconsB (as, b:bs) = Just (b, (as, bs)) 90 | 91 | -- | Generate a random value, can be used as default instance for 'R.Random'. 92 | randomDefault :: (R.Random a, R.Random b, R.RandomGen g, Biunfoldable t) => g -> (t a b, g) 93 | randomDefault = runState . getRandom $ biunfold (Random . state $ R.random) (Random . state $ R.random) 94 | 95 | -- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'. 96 | arbitraryDefault :: (Arbitrary a, Arbitrary b, Biunfoldable t) => Gen (t a b) 97 | arbitraryDefault = let Arb _ _ gen = biunfold arbUnit arbUnit in 98 | fromMaybe (error "Failed to generate a value.") <$> gen 99 | 100 | instance Biunfoldable Either where 101 | biunfold fa fb = choose 102 | [ Left <$> fa 103 | , Right <$> fb 104 | ] 105 | 106 | instance Biunfoldable (,) where 107 | biunfold fa fb = choose 108 | [ (,) <$> fa <*> fb ] 109 | 110 | instance Biunfoldable Constant where 111 | biunfold fa _ = choose 112 | [ Constant <$> fa ] 113 | -------------------------------------------------------------------------------- /src/Data/Triunfoldable.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Triunfoldable 4 | -- Copyright : (c) Sjoerd Visscher 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Class of data structures with 3 type arguments that can be unfolded. 12 | ----------------------------------------------------------------------------- 13 | {-# LANGUAGE Safe #-} 14 | module Data.Triunfoldable 15 | ( 16 | 17 | -- * Triunfoldable 18 | Triunfoldable(..) 19 | , triunfold_ 20 | , triunfoldBF 21 | , triunfoldBF_ 22 | 23 | -- ** Specific unfolds 24 | , triunfoldr 25 | , fromLists 26 | , randomDefault 27 | , arbitraryDefault 28 | 29 | ) 30 | where 31 | 32 | import Control.Applicative 33 | import Data.Unfolder 34 | import Data.Functor.Constant 35 | import Control.Monad.Trans.State 36 | import qualified System.Random as R 37 | import Test.QuickCheck (Arbitrary(..), Gen, sized, resize) 38 | import Data.Maybe 39 | 40 | -- | Data structures with 3 type arguments (kind @* -> * -> * -> *@) that can be unfolded. 41 | -- 42 | -- For example, given a data type 43 | -- 44 | -- > data Tree a b c = Empty | Leaf a | Node (Tree a b c) b (Tree a b c) 45 | -- 46 | -- a suitable instance would be 47 | -- 48 | -- > instance Triunfoldable Tree where 49 | -- > triunfold fa fb fc = choose 50 | -- > [ pure Empty 51 | -- > , Leaf <$> fa 52 | -- > , Node <$> triunfold fa fb fc <*> fb <*> triunfold fa fb fc 53 | -- > ] 54 | -- 55 | -- i.e. it follows closely the instance for 'Biunfoldable', but for 3 type arguments instead of 2. 56 | 57 | class Triunfoldable t where 58 | -- | Given a way to generate elements, return a way to generate structures containing those elements. 59 | triunfold :: Unfolder f => f a -> f b -> f c -> f (t a b c) 60 | 61 | -- | Unfold the structure, always using @()@ as elements. 62 | triunfold_ :: (Triunfoldable t, Unfolder f) => f (t () () ()) 63 | triunfold_ = triunfold (pure ()) (pure ()) (pure ()) 64 | 65 | -- | Breadth-first unfold, which orders the result by the number of 'choose' calls. 66 | triunfoldBF :: (Triunfoldable t, Unfolder f) => f a -> f b -> f c -> f (t a b c) 67 | triunfoldBF = ala3 bfs triunfold 68 | 69 | -- | Unfold the structure breadth-first, always using @()@ as elements. 70 | triunfoldBF_ :: (Triunfoldable t, Unfolder f) => f (t () () ()) 71 | triunfoldBF_ = bfs triunfold_ 72 | 73 | -- | @triunfoldr@ builds a data structure from a seed value. 74 | triunfoldr :: Triunfoldable t => (d -> Maybe (a, d)) -> (d -> Maybe (b, d)) -> (d -> Maybe (c, d)) -> d -> Maybe (t a b c) 75 | triunfoldr fa fb fc z = terminate . flip runStateT z $ triunfoldBF (StateT $ maybeToList . fa) (StateT $ maybeToList . fb) (StateT $ maybeToList . fc) 76 | where 77 | terminate [] = Nothing 78 | terminate ((t, d):ts) = if (isNothing (fa d) && isNothing (fb d) && isNothing (fc d)) then Just t else terminate ts 79 | 80 | 81 | -- | Create a data structure using the lists as input. 82 | -- This can fail because there might not be a data structure with the same number 83 | -- of element positions as the number of elements in the lists. 84 | fromLists :: Triunfoldable t => [a] -> [b] -> [c] -> Maybe (t a b c) 85 | fromLists = curry3 $ triunfoldr unconsA unconsB unconsC 86 | where 87 | unconsA ([], _, _) = Nothing 88 | unconsA (a:as, bs, cs) = Just (a, (as, bs, cs)) 89 | unconsB (_, [], _) = Nothing 90 | unconsB (as, b:bs, cs) = Just (b, (as, bs, cs)) 91 | unconsC (_, _, []) = Nothing 92 | unconsC (as, bs, c:cs) = Just (c, (as, bs, cs)) 93 | 94 | -- | Generate a random value, can be used as default instance for 'R.Random'. 95 | randomDefault :: (R.Random a, R.Random b, R.Random c, R.RandomGen g, Triunfoldable t) => g -> (t a b c, g) 96 | randomDefault = runState . getRandom $ triunfold (Random . state $ R.random) (Random . state $ R.random) (Random . state $ R.random) 97 | 98 | -- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'. 99 | arbitraryDefault :: (Arbitrary a, Arbitrary b, Arbitrary c, Triunfoldable t) => Gen (t a b c) 100 | arbitraryDefault = let Arb _ gen = triunfold arbUnit arbUnit arbUnit in 101 | fromMaybe (error "Failed to generate a value.") <$> sized (\n -> resize (n + 1) gen) 102 | 103 | 104 | curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d 105 | curry3 f a b c = f (a,b,c) 106 | 107 | instance Triunfoldable (,,) where 108 | triunfold fa fb fc = choose 109 | [ (,,) <$> fa <*> fb <*> fc ] 110 | 111 | -------------------------------------------------------------------------------- /src/Data/Unfoldable.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Unfoldable 4 | -- Copyright : (c) Sjoerd Visscher 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Class of data structures that can be unfolded. 12 | ----------------------------------------------------------------------------- 13 | {-# LANGUAGE CPP, Safe, TupleSections #-} 14 | #ifdef GENERICS 15 | {-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, TypeApplications #-} 16 | #endif 17 | module Data.Unfoldable 18 | ( 19 | 20 | -- * Unfoldable 21 | Unfoldable(..) 22 | , unfold_ 23 | , unfoldBF 24 | , unfoldBF_ 25 | 26 | -- ** Specific unfolds 27 | , unfoldr 28 | , fromList 29 | , leftMost 30 | , rightMost 31 | , allDepthFirst 32 | , allToDepth 33 | , allBreadthFirst 34 | , randomDefault 35 | , arbitraryDefault 36 | 37 | ) 38 | where 39 | 40 | import Control.Applicative 41 | import Data.Unfolder 42 | import Data.Functor.Compose 43 | import Data.Functor.Constant 44 | import Data.Functor.Identity 45 | import Data.Functor.Product 46 | import Data.Functor.Reverse 47 | import Data.Functor.Sum 48 | import Control.Monad.Trans.State 49 | import qualified System.Random as R 50 | import Test.QuickCheck (Arbitrary(..), Gen, sized, resize) 51 | import Data.Maybe 52 | import qualified Data.Sequence as S 53 | import qualified Data.Tree as T 54 | 55 | #ifdef GENERICS 56 | import GHC.Generics 57 | import Generics.OneLiner 58 | #endif 59 | 60 | -- | Data structures that can be unfolded. 61 | -- 62 | -- For example, given a data type 63 | -- 64 | -- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) 65 | -- 66 | -- a suitable instance would be 67 | -- 68 | -- > instance Unfoldable Tree where 69 | -- > unfold fa = choose 70 | -- > [ pure Empty 71 | -- > , Leaf <$> fa 72 | -- > , Node <$> unfold fa <*> fa <*> unfold fa 73 | -- > ] 74 | -- 75 | -- i.e. it follows closely the instance for 'Traversable', but instead of matching on an input value, 76 | -- we 'choose' from a list of all cases. 77 | -- 78 | -- Instead of manually writing the `Unfoldable` instance, you can add a @deriving@ `Generic1` 79 | -- to your datatype and declare an `Unfoldable` instance without giving a definition for `unfold`. 80 | -- 81 | -- For example the previous example can be simplified to just: 82 | -- 83 | -- > {-# LANGUAGE DeriveGeneric #-} 84 | -- > 85 | -- > import GHC.Generics 86 | -- > 87 | -- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) deriving Generic1 88 | -- > 89 | -- > instance Unfoldable Tree 90 | class Unfoldable t where 91 | -- | Given a way to generate elements, return a way to generate structures containing those elements. 92 | unfold :: Unfolder f => f a -> f (t a) 93 | 94 | #ifdef GENERICS 95 | default unfold :: (ADT1 t, Constraints1 t Unfoldable, Unfolder f) => f a -> f (t a) 96 | unfold = choose . getCompose . createA1 @Unfoldable (Compose . pure . unfold . asum' . getCompose) . Compose . pure 97 | where 98 | asum' [] = empty 99 | asum' [a] = a 100 | asum' (a:as) = a <|> asum' as 101 | {-# INLINE unfold #-} 102 | #endif 103 | 104 | -- | Unfold the structure, always using @()@ as elements. 105 | unfold_ :: (Unfoldable t, Unfolder f) => f (t ()) 106 | unfold_ = unfold (pure ()) 107 | 108 | -- | Breadth-first unfold, which orders the result by the number of 'choose' calls. 109 | unfoldBF :: (Unfoldable t, Unfolder f) => f a -> f (t a) 110 | unfoldBF = ala bfs unfold 111 | 112 | -- | Unfold the structure breadth-first, always using @()@ as elements. 113 | unfoldBF_ :: (Unfoldable t, Unfolder f) => f (t ()) 114 | unfoldBF_ = bfs unfold_ 115 | 116 | -- | @unfoldr@ builds a data structure from a seed value. It can be specified as: 117 | -- 118 | -- > unfoldr f z == fromList (Data.List.unfoldr f z) 119 | unfoldr :: Unfoldable t => (b -> Maybe (a, b)) -> b -> Maybe (t a) 120 | unfoldr f z = terminate . flip runStateT z . unfoldBF . StateT $ maybeToList . f 121 | where 122 | terminate [] = Nothing 123 | terminate ((t, b):ts) = if isNothing (f b) then Just t else terminate ts 124 | 125 | -- | Create a data structure using the list as input. 126 | -- This can fail because there might not be a data structure with the same number 127 | -- of element positions as the number of elements in the list. 128 | fromList :: Unfoldable t => [a] -> Maybe (t a) 129 | fromList = unfoldr uncons 130 | where 131 | uncons [] = Nothing 132 | uncons (a:as) = Just (a, as) 133 | 134 | -- | Always choose the first constructor. 135 | leftMost :: Unfoldable t => Maybe (t ()) 136 | leftMost = unfold_ 137 | 138 | -- | Always choose the last constructor. 139 | rightMost :: Unfoldable t => Maybe (t ()) 140 | rightMost = getDualA unfold_ 141 | 142 | -- | Generate all the values depth-first. 143 | allDepthFirst :: Unfoldable t => [t ()] 144 | allDepthFirst = unfold_ 145 | 146 | -- | Generate all the values upto a given depth, depth-first. 147 | allToDepth :: Unfoldable t => Int -> [t ()] 148 | allToDepth d = limitDepth d unfold_ 149 | 150 | -- | Generate all the values breadth-first. 151 | allBreadthFirst :: Unfoldable t => [t ()] 152 | allBreadthFirst = unfoldBF_ 153 | 154 | -- | Generate a random value, can be used as default instance for 'R.Random'. 155 | randomDefault :: (R.Random a, R.RandomGen g, Unfoldable t) => g -> (t a, g) 156 | randomDefault = runState . getRandom . unfold . Random . state $ R.random 157 | 158 | -- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'. 159 | arbitraryDefault :: (Arbitrary a, Unfoldable t) => Gen (t a) 160 | arbitraryDefault = let Arb _ _ gen = unfold arbUnit in 161 | fromMaybe (error "Failed to generate a value.") <$> gen 162 | 163 | instance Unfoldable [] where 164 | unfold fa = go where 165 | go = choose 166 | [ pure [] 167 | , (:) <$> fa <*> go ] 168 | 169 | instance Unfoldable Maybe where 170 | unfold fa = choose 171 | [ pure Nothing 172 | , Just <$> fa 173 | ] 174 | 175 | instance (Bounded a, Enum a) => Unfoldable (Either a) where 176 | unfold fa = choose 177 | [ Left <$> boundedEnum 178 | , Right <$> fa 179 | ] 180 | 181 | instance (Bounded a, Enum a) => Unfoldable ((,) a) where 182 | unfold fa = choose 183 | [ (,) <$> boundedEnum <*> fa ] 184 | 185 | instance Unfoldable Identity where 186 | unfold fa = choose 187 | [ Identity <$> fa ] 188 | 189 | instance (Bounded a, Enum a) => Unfoldable (Constant a) where 190 | unfold _ = choose 191 | [ Constant <$> boundedEnum ] 192 | 193 | instance (Unfoldable p, Unfoldable q) => Unfoldable (Product p q) where 194 | unfold fa = choose 195 | [ Pair <$> unfold fa <*> unfold fa ] 196 | 197 | instance (Unfoldable p, Unfoldable q) => Unfoldable (Sum p q) where 198 | unfold fa = choose 199 | [ InL <$> unfold fa 200 | , InR <$> unfold fa 201 | ] 202 | 203 | instance (Unfoldable p, Unfoldable q) => Unfoldable (Compose p q) where 204 | unfold fa = choose 205 | [ Compose <$> unfold (unfold fa) ] 206 | 207 | instance Unfoldable f => Unfoldable (Reverse f) where 208 | unfold fa = choose 209 | [ Reverse <$> getDualA (unfold (DualA fa)) ] 210 | 211 | instance Unfoldable S.Seq where 212 | unfold fa = go where 213 | go = choose 214 | [ pure empty 215 | , (S.<|) <$> fa <*> go ] 216 | 217 | instance Unfoldable T.Tree where 218 | unfold fa = go where 219 | go = choose [ T.Node <$> fa <*> unfold go ] 220 | -------------------------------------------------------------------------------- /src/Data/Unfolder.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Unfolder 4 | -- Copyright : (c) Sjoerd Visscher 2014 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Unfolders provide a way to unfold data structures. 12 | -- They are basically 'Alternative' instances, but the 'choose' method 13 | -- allows the unfolder to do something special for the recursive positions 14 | -- of the data structure. 15 | ----------------------------------------------------------------------------- 16 | {-# LANGUAGE 17 | GeneralizedNewtypeDeriving 18 | , RankNTypes 19 | , Trustworthy 20 | , CPP 21 | #-} 22 | 23 | #if !defined(MIN_VERSION_containers) 24 | #define MIN_VERSION_containers(x,y,z) 0 25 | #endif 26 | 27 | module Data.Unfolder 28 | ( 29 | 30 | -- * Unfolder 31 | Unfolder(..) 32 | , chooseMonadDefault 33 | , chooseMapMonadDefault 34 | 35 | , between 36 | , betweenD 37 | , boundedEnum 38 | , boundedEnumD 39 | 40 | -- ** Unfolder instances 41 | , Random(..) 42 | 43 | , Arb(..) 44 | , arbUnit 45 | 46 | , NumConst(..) 47 | , Nth(..) 48 | 49 | -- * UnfolderTransformer 50 | , UnfolderTransformer(..) 51 | , ala 52 | , ala2 53 | , ala3 54 | 55 | -- ** UnfolderTransformer instances 56 | , DualA(..) 57 | 58 | , NT(..) 59 | , WithRec(..) 60 | , withRec 61 | , limitDepth 62 | 63 | , BFS(..) 64 | , Split 65 | , bfs 66 | , bfsBySum 67 | ) 68 | where 69 | 70 | import Control.Applicative 71 | import Control.Monad 72 | import Control.Arrow (ArrowZero, ArrowPlus) 73 | 74 | import Data.Functor.Product 75 | import Data.Functor.Compose 76 | import Data.Functor.Reverse 77 | import Control.Applicative.Backwards 78 | import Control.Applicative.Lift 79 | import Control.Monad.Trans.Except 80 | import Control.Monad.Trans.List 81 | import Control.Monad.Trans.Maybe 82 | import Control.Monad.Trans.RWS 83 | import Control.Monad.Trans.Reader 84 | import Control.Monad.Trans.State 85 | import Control.Monad.Trans.Writer 86 | 87 | import qualified System.Random as R 88 | import Test.QuickCheck (Arbitrary(..), Gen, oneof, elements, frequency, sized, resize) 89 | 90 | import Data.Monoid (Monoid(..)) 91 | import Data.Maybe (catMaybes) 92 | import qualified Data.Sequence as S 93 | 94 | 95 | -- | Unfolders provide a way to unfold data structures. 96 | -- The methods have default implementations in terms of 'Alternative', 97 | -- but you can implement 'chooseMap' to act on recursive positions of the 98 | -- data structure, or simply to provide a faster implementation than 99 | -- 'foldr ((<|>) . f) empty'. 100 | class Alternative f => Unfolder f where 101 | -- | Choose one of the values from the list. 102 | choose :: [f a] -> f a 103 | choose = chooseMap id 104 | -- | Choose one of the values from the list and apply the given function. 105 | chooseMap :: (a -> f b) -> [a] -> f b 106 | chooseMap f = foldr ((<|>) . f) empty 107 | -- | Given a number 'n', return a number between '0' and 'n - 1'. 108 | chooseInt :: Int -> f Int 109 | chooseInt n = chooseMap pure [0 .. n - 1] 110 | 111 | -- | If an unfolder is monadic, 'choose' can be implemented in terms of 'chooseInt'. 112 | chooseMonadDefault :: (Monad m, Unfolder m) => [m a] -> m a 113 | chooseMonadDefault ms = chooseInt (length ms) >>= (ms !!) 114 | 115 | -- | If an unfolder is monadic, 'chooseMap' can be implemented in terms of 'chooseInt'. 116 | chooseMapMonadDefault :: (Monad m, Unfolder m) => (a -> m b) -> [a] -> m b 117 | chooseMapMonadDefault f as = chooseInt (length as) >>= f . (as !!) 118 | 119 | -- | If a datatype is enumerable, we can use 'chooseInt' to generate a value. 120 | -- This is the function to use if you want to unfold a datatype that has no type arguments (has kind @*@). 121 | between :: (Unfolder f, Enum a) => a -> a -> f a 122 | between lb ub = (\x -> toEnum (x + fromEnum lb)) <$> chooseInt (1 + fromEnum ub - fromEnum lb) 123 | 124 | -- | If a datatype is also bounded, we can choose between all possible values. 125 | -- 126 | -- > boundedEnum = between minBound maxBound 127 | boundedEnum :: (Unfolder f, Bounded a, Enum a) => f a 128 | boundedEnum = between minBound maxBound 129 | 130 | -- | 'betweenD' uses 'choose' to generate a value. It chooses between the lower bound and one 131 | -- of the higher values. This means that f.e. breadth-first unfolding and arbitrary will prefer 132 | -- lower values. 133 | betweenD :: (Unfolder f, Enum a) => a -> a -> f a 134 | betweenD lb0 ub = betweenD' lb0 (fromEnum ub - fromEnum lb0) 135 | where 136 | betweenD' lb n | n < 0 = empty 137 | | otherwise = choose [pure lb, betweenD' (succ lb) (pred n)] 138 | 139 | -- | > boundedEnumD = betweenD minBound maxBound 140 | boundedEnumD :: (Unfolder f, Bounded a, Enum a) => f a 141 | boundedEnumD = betweenD minBound maxBound 142 | 143 | 144 | 145 | -- | Derived instance. 146 | instance MonadPlus m => Unfolder (WrappedMonad m) 147 | 148 | -- | Derived instance. 149 | instance (ArrowZero a, ArrowPlus a) => Unfolder (WrappedArrow a b) 150 | 151 | -- | Don't choose but return all items. 152 | instance Unfolder [] where 153 | choose = concat 154 | chooseMap = concatMap 155 | chooseInt n = [0 .. n - 1] 156 | 157 | -- | Always choose the first item. 158 | instance Unfolder Maybe where 159 | choose = foldr const Nothing 160 | chooseMap f = foldr (const . f) Nothing 161 | chooseInt 0 = Nothing 162 | chooseInt _ = Just 0 163 | 164 | -- | Derived instance. 165 | instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where 166 | chooseMap f as = Pair (chooseMap (fstP . f) as) (chooseMap (sndP . f) as) 167 | where 168 | fstP (Pair p _) = p 169 | sndP (Pair _ q) = q 170 | chooseInt n = Pair (chooseInt n) (chooseInt n) 171 | 172 | -- | Derived instance. 173 | instance (Unfolder p, Applicative q) => Unfolder (Compose p q) where 174 | chooseMap f = Compose . chooseMap (getCompose . f) 175 | chooseInt n = Compose $ pure <$> chooseInt n 176 | 177 | -- | Derived instance. 178 | instance Unfolder f => Unfolder (Reverse f) where 179 | chooseMap f = Reverse . chooseMap (getReverse . f) 180 | chooseInt n = Reverse $ chooseInt n 181 | 182 | -- | Derived instance. 183 | instance Unfolder f => Unfolder (Backwards f) where 184 | chooseMap f = Backwards . chooseMap (forwards . f) 185 | chooseInt n = Backwards $ chooseInt n 186 | 187 | -- | Derived instance. 188 | instance Unfolder f => Unfolder (Lift f) 189 | 190 | -- | Derived instance. 191 | instance (Functor m, Monad m, Monoid e) => Unfolder (ExceptT e m) 192 | 193 | -- | Derived instance. 194 | instance Applicative f => Unfolder (ListT f) where 195 | {-# INLINABLE chooseMap #-} 196 | chooseMap f = ListT . foldr appRun (pure []) 197 | where 198 | appRun x ys = (++) <$> runListT (f x) <*> ys 199 | chooseInt n = ListT $ pure [0 .. n - 1] 200 | 201 | -- | Derived instance. 202 | instance (Functor m, Monad m) => Unfolder (MaybeT m) where 203 | chooseMap _ [] = MaybeT (return Nothing) 204 | chooseMap f (a : as) = MaybeT $ do 205 | res <- runMaybeT (f a) 206 | case res of 207 | Nothing -> runMaybeT $ chooseMap f as 208 | Just _ -> return res 209 | chooseInt 0 = MaybeT $ return Nothing 210 | chooseInt _ = MaybeT $ return (Just 0) 211 | 212 | -- | Derived instance. 213 | instance (Monoid w, MonadPlus m, Unfolder m) => Unfolder (RWST r w s m) where 214 | chooseMap f as = RWST $ \r s -> chooseMap (\a -> runRWST (f a) r s) as 215 | 216 | -- | Derived instance. 217 | instance (MonadPlus m, Unfolder m) => Unfolder (StateT s m) where 218 | chooseMap f as = StateT $ \s -> chooseMap (\a -> f a `runStateT` s) as 219 | 220 | -- | Derived instance. 221 | instance Unfolder m => Unfolder (ReaderT r m) where 222 | chooseMap f as = ReaderT $ \r -> chooseMap (\a -> f a `runReaderT` r) as 223 | 224 | -- | Derived instance. 225 | instance (Monoid w, Unfolder m) => Unfolder (WriterT w m) where 226 | chooseMap f = WriterT . chooseMap (runWriterT . f) 227 | 228 | -- | Don't choose but return all items. 229 | instance Unfolder S.Seq where 230 | #if MIN_VERSION_containers(0,5,6) 231 | chooseInt n = S.fromFunction n id 232 | #endif 233 | 234 | 235 | newtype Random g m a = Random { getRandom :: StateT g m a } 236 | deriving (Functor, Applicative, Monad) 237 | instance (Functor m, Monad m, R.RandomGen g) => Alternative (Random g m) where 238 | empty = choose [] 239 | a <|> b = choose [a, b] 240 | instance (Functor m, Monad m, R.RandomGen g) => MonadPlus (Random g m) where 241 | mzero = choose [] 242 | mplus a b = choose [a, b] 243 | -- | Choose randomly. 244 | instance (Functor m, Monad m, R.RandomGen g) => Unfolder (Random g m) where 245 | choose = chooseMonadDefault 246 | chooseMap = chooseMapMonadDefault 247 | chooseInt n = Random . StateT $ return . R.randomR (0, n - 1) 248 | 249 | 250 | -- | A variant of Test.QuickCheck.Gen, with failure 251 | -- and a count of the number of recursive positions and parameter positions. 252 | data Arb a = Arb Int Int (Gen (Maybe a)) 253 | 254 | instance Functor Arb where 255 | fmap f (Arb r p g) = Arb r p $ fmap (fmap f) g 256 | 257 | instance Applicative Arb where 258 | pure = Arb 0 0 . pure . pure 259 | Arb r1 p1 ff <*> Arb r2 p2 fx = Arb (r1 + r2) (p1 + p2) $ liftA2 (<*>) ff fx 260 | 261 | instance Alternative Arb where 262 | empty = Arb 0 0 (pure Nothing) 263 | Arb r1 p1 g1 <|> Arb r2 p2 g2 = Arb (r1 + r2) (p1 + p2) $ g1 >>= \a -> g2 >>= \b -> Just <$> elements (catMaybes [a, b]) 264 | 265 | -- | Limit the depth of the generated data structure by 266 | -- dividing the given size by the number of recursive positions. 267 | instance Unfolder Arb where 268 | choose as = Arb 1 0 $ sized g 269 | where 270 | g n = freq $ foldMap f as 271 | where 272 | (recPosCount, parPosCount) = foldr (\(Arb r p _) (rc, pc) -> (r + rc, p + pc)) (0, 0) as 273 | recSize = (n - parPosCount) `div` max 1 recPosCount 274 | f (Arb r p gen) = if (r > 0 && recSize < 0) || (n == 0 && r + p > 0) then [] else [(3 + r * recSize, resize (max 0 recSize) gen)] 275 | freq [] = pure Nothing 276 | freq as = frequency as 277 | 278 | arbUnit :: Arbitrary a => Arb a 279 | arbUnit = Arb 0 1 (Just <$> arbitrary) 280 | 281 | 282 | -- | Variant of 'Data.Functor.Constant' that does multiplication of the constants for @\<*>@ and addition for @\<|>@. 283 | newtype NumConst a x = NumConst { getNumConst :: a } deriving (Eq, Show) 284 | instance Functor (NumConst a) where 285 | fmap _ (NumConst a) = NumConst a 286 | instance Num a => Applicative (NumConst a) where 287 | pure _ = NumConst 1 288 | NumConst a <*> NumConst b = NumConst $ a * b 289 | instance Num a => Alternative (NumConst a) where 290 | empty = NumConst 0 291 | NumConst a <|> NumConst b = NumConst $ a + b 292 | -- | Unfolds to a constant numeric value. Useful for counting shapes. 293 | instance Num a => Unfolder (NumConst a) 294 | 295 | 296 | data Nth a = Nth 297 | { size :: Integer 298 | , getNth :: Integer -> a 299 | } 300 | instance Functor Nth where 301 | fmap f (Nth sizeA as) = Nth sizeA (f . as) 302 | instance Applicative Nth where 303 | pure a = Nth 1 (const a) 304 | Nth sizeF fs <*> Nth sizeA as = Nth (sizeF * sizeA) $ \n -> 305 | let (l, r) = n `divMod` sizeA in fs l (as r) 306 | instance Alternative Nth where 307 | empty = Nth 0 (const undefined) 308 | Nth sizeA as <|> Nth sizeB bs = Nth (sizeA + sizeB) $ \n -> 309 | if n < sizeA then as n else bs (n - sizeA) 310 | -- | Get the nth value from the sequence of all possible values. 311 | instance Unfolder Nth where 312 | chooseInt n = Nth (toInteger n) fromInteger 313 | 314 | 315 | -- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds. 316 | class UnfolderTransformer t where 317 | -- | Lift a computation from the argument unfolder to the constructed unfolder. 318 | lift :: Unfolder f => f a -> t f a 319 | 320 | -- | Run an unfolding function with one argument using an 'UnfolderTransformer', given a way to run the transformer. 321 | ala :: (UnfolderTransformer t, Unfolder f) => (t f b -> f b) -> (t f a -> t f b) -> f a -> f b 322 | ala lower f = lower . f . lift 323 | 324 | -- | Run an unfolding function with two arguments using an 'UnfolderTransformer', given a way to run the transformer. 325 | ala2 :: (UnfolderTransformer t, Unfolder f) => (t f c -> f c) -> (t f a -> t f b -> t f c) -> f a -> f b -> f c 326 | ala2 lower f = ala lower . f . lift 327 | 328 | -- | Run an unfolding function with three arguments using an 'UnfolderTransformer', given a way to run the transformer. 329 | ala3 :: (UnfolderTransformer t, Unfolder f) => (t f d -> f d) -> (t f a -> t f b -> t f c -> t f d) -> f a -> f b -> f c -> f d 330 | ala3 lower f = ala2 lower . f . lift 331 | 332 | 333 | -- | 'DualA' flips the @\<|>@ operator from `Alternative`. 334 | newtype DualA f a = DualA { getDualA :: f a } 335 | deriving (Eq, Show, Functor, Applicative) 336 | 337 | instance Alternative f => Alternative (DualA f) where 338 | empty = DualA empty 339 | DualA a <|> DualA b = DualA (b <|> a) 340 | 341 | -- | Reverse the list passed to choose. 342 | instance Unfolder f => Unfolder (DualA f) where 343 | chooseMap f = DualA . chooseMap (getDualA . f) . reverse 344 | chooseInt n = DualA $ (\x -> n - 1 - x) <$> chooseInt n 345 | 346 | instance UnfolderTransformer DualA where 347 | lift = DualA 348 | 349 | 350 | -- | Natural transformations 351 | data NT f g = NT { getNT :: forall a. f a -> g a } 352 | 353 | newtype WithRec f a = WithRec { getWithRec :: ReaderT (Int -> NT f f) f a } 354 | deriving (Functor, Applicative, Alternative) 355 | 356 | -- | Applies a certain function depending on the depth at every recursive position. 357 | instance Unfolder f => Unfolder (WithRec f) where 358 | chooseMap h as = WithRec . ReaderT $ \f -> 359 | getNT (f 0) $ chooseMap (withRec (f . succ) . h) as 360 | 361 | instance UnfolderTransformer WithRec where 362 | lift = WithRec . ReaderT . const 363 | 364 | -- | Apply a certain function of type @f a -> f a@ to the result of a 'choose'. 365 | -- The depth is passed as 'Int', so you can apply a different function at each depth. 366 | -- Because of a @forall@, the function needs to be wrapped in a 'NT' constructor. 367 | -- See 'limitDepth' for an example how to use this function. 368 | withRec :: (Int -> NT f f) -> WithRec f a -> f a 369 | withRec f = (`runReaderT` f) . getWithRec 370 | 371 | -- | Limit the depth of an unfolding. 372 | limitDepth :: Unfolder f => Int -> WithRec f a -> f a 373 | limitDepth m = withRec (\d -> NT $ if d == m then const empty else id) 374 | 375 | 376 | 377 | -- | Return a generator of values of a given depth. 378 | -- Returns 'Nothing' if there are no values of that depth or deeper. 379 | -- The depth is the number of 'choose' calls. 380 | newtype BFS f x = BFS { getBFS :: (Int, Split) -> Maybe [f x] } 381 | 382 | type Split = Int -> [(Int, Int)] 383 | 384 | instance Functor f => Functor (BFS f) where 385 | fmap f = BFS . (fmap (map (fmap f)) .) . getBFS 386 | 387 | instance Applicative f => Applicative (BFS f) where 388 | pure = packBFS . pure 389 | BFS ff <*> BFS fx = BFS $ \(d, split) -> flattenBFS $ 390 | [ liftA2 (liftA2 (<*>)) (ff (i, split)) (fx (j, split)) | (i, j) <- split d ] 391 | 392 | instance Applicative f => Alternative (BFS f) where 393 | empty = BFS $ \(d, _) -> if d == 0 then Just [] else Nothing 394 | BFS fa <|> BFS fb = BFS $ \d -> flattenBFS [fa d, fb d] 395 | 396 | -- | Choose between values of a given depth only. 397 | instance Applicative f => Unfolder (BFS f) where 398 | chooseMap f as = BFS $ \(d, split) -> if d == 0 then Just [] else flattenBFS (map (\a -> f a `getBFS` (d - 1, split)) as) 399 | 400 | instance UnfolderTransformer BFS where 401 | lift = packBFS 402 | 403 | bySum :: Split 404 | bySum d = [(i, d - i)| i <- [0 .. d]] 405 | 406 | byMax :: Split 407 | byMax d = [(i, d)| i <- [0 .. d - 1]] ++ [(d, i)| i <- [0 .. d]] 408 | 409 | bfsBy :: Unfolder f => Split -> BFS f x -> f x 410 | bfsBy split (BFS f) = choose (loop 0) where loop d = maybe [] (++ loop (d + 1)) (f (d, split)) 411 | 412 | -- | Change the order of unfolding to be breadth-first, by maximum depth of the components. 413 | bfs :: Unfolder f => BFS f x -> f x 414 | bfs = bfsBy byMax 415 | 416 | -- | Change the order of unfolding to be breadth-first, by the sum of depths of the components. 417 | bfsBySum :: Unfolder f => BFS f x -> f x 418 | bfsBySum = bfsBy bySum 419 | 420 | packBFS :: f x -> BFS f x 421 | packBFS r = BFS $ \(d, _) -> if d == 0 then Just [r] else Nothing 422 | 423 | flattenBFS :: [Maybe [a]] -> Maybe [a] 424 | flattenBFS ms = case catMaybes ms of 425 | [] -> Nothing 426 | ms' -> Just (concat ms') 427 | -------------------------------------------------------------------------------- /unfoldable.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.10 2 | name: unfoldable 3 | version: 1.0.1 4 | synopsis: Class of data structures that can be unfolded. 5 | description: Just as there's a Foldable class, there should also be an Unfoldable class. 6 | . 7 | This package provides one. Example unfolds are: 8 | . 9 | * Random values 10 | . 11 | * Enumeration of all values (depth-first or breadth-first) 12 | . 13 | * Convert from a list 14 | . 15 | Some examples can be found in the examples directory. 16 | homepage: https://github.com/sjoerdvisscher/unfoldable 17 | bug-reports: https://github.com/sjoerdvisscher/unfoldable/issues 18 | license: BSD3 19 | license-file: LICENSE 20 | author: Sjoerd Visscher 21 | maintainer: sjoerd@w3future.com 22 | category: Generics 23 | build-type: Simple 24 | tested-with: GHC==9.0.1, GHC==8.10.2, GHC==8.8.4 25 | 26 | 27 | extra-Source-Files: 28 | CHANGELOG.md 29 | examples/*.hs 30 | src/Data/Triunfoldable.hs 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | 36 | exposed-modules: 37 | Data.Unfolder 38 | Data.Unfoldable 39 | Data.Biunfoldable 40 | 41 | build-depends: 42 | base >= 4 && < 5 43 | , containers >= 0.5 && < 0.7 44 | , transformers >= 0.4 && < 0.6 45 | , random >= 1.0 && < 1.3 46 | , QuickCheck >= 2.7.3 && < 3.0 47 | 48 | if impl(ghc >= 7.6) && impl(ghc < 9) 49 | cpp-options: -DGENERICS 50 | build-depends: 51 | ghc-prim >= 0.2 52 | , one-liner >= 0.9 && < 2.0 53 | 54 | if impl(ghc >= 9.0) 55 | cpp-options: -DGENERICS 56 | build-depends: 57 | ghc-prim >= 0.2 58 | , one-liner >= 2.0 && < 3.0 59 | 60 | other-extensions: 61 | GeneralizedNewtypeDeriving 62 | , RankNTypes 63 | , Safe 64 | , Trustworthy 65 | , CPP 66 | 67 | source-repository head 68 | type: git 69 | location: git://github.com/sjoerdvisscher/unfoldable.git 70 | --------------------------------------------------------------------------------