unfoldable 0.6.0 → 0.6.0.1

raw patch · 10 files changed

+967/−851 lines, 10 filesdep ~QuickChecksetup-changedPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

+ Data.Triunfoldable: arbitraryDefault :: (Arbitrary a, Arbitrary b, Arbitrary c, Triunfoldable t) => Gen (t a b c)

+ Data.Triunfoldable: class Triunfoldable t

+ Data.Triunfoldable: fromLists :: Triunfoldable t => [a] -> [b] -> [c] -> Maybe (t a b c)

+ Data.Triunfoldable: instance Triunfoldable (,,)

+ Data.Triunfoldable: randomDefault :: (Random a, Random b, Random c, RandomGen g, Triunfoldable t) => g -> (t a b c, g)

+ Data.Triunfoldable: triunfold :: (Triunfoldable t, Unfolder f) => f a -> f b -> f c -> f (t a b c)

+ Data.Triunfoldable: triunfoldBF :: (Triunfoldable t, Unfolder f) => f a -> f b -> f c -> f (t a b c)

+ Data.Triunfoldable: triunfoldBF_ :: (Triunfoldable t, Unfolder f) => f (t () () ())

+ Data.Triunfoldable: triunfold_ :: (Triunfoldable t, Unfolder f) => f (t () () ())

+ Data.Triunfoldable: triunfoldr :: Triunfoldable t => (d -> Maybe (a, d)) -> (d -> Maybe (b, d)) -> (d -> Maybe (c, d)) -> d -> Maybe (t a b c)

+ Data.Unfolder: 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

Files

LICENSE +30/−30
Setup.hs +2/−2
examples/btree.hs +24/−24
examples/redblack.hs +106/−106
examples/tree.hs +25/−25
src/Data/Biunfoldable.hs +112/−112
src/Data/Triunfoldable.hs +110/−0
src/Data/Unfoldable.hs +168/−168
src/Data/Unfolder.hs +345/−340
unfoldable.cabal +45/−44

LICENSE view

@@ -1,30 +1,30 @@-Copyright (c)2012, Sjoerd Visscher--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Sjoerd Visscher nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c)2012, Sjoerd Visscher
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Sjoerd Visscher nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs view

@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain

examples/btree.hs view

@@ -1,24 +1,24 @@-import Control.Applicative-import Data.Unfoldable-import Data.Unfolder--import Data.Maybe-import System.Random---data TB a = LB a | BB (TB (a, a)) deriving Show--instance Unfoldable TB where-  unfold fa = choose-    [ LB <$> fa-    , BB <$> unfold ((,) <$> fa <*> fa)-    ]--btree8 :: TB Int-btree8 = fromJust $ fromList [0..7]--btreeShapes :: [TB ()]-btreeShapes = take 5 unfold_--randomBTree :: IO (TB Bool)-randomBTree = getStdRandom randomDefault+import Control.Applicative
+import Data.Unfoldable
+import Data.Unfolder
+
+import Data.Maybe
+import System.Random
+
+
+data TB a = LB a | BB (TB (a, a)) deriving Show
+
+instance Unfoldable TB where
+  unfold fa = choose
+    [ LB <$> fa
+    , BB <$> unfold ((,) <$> fa <*> fa)
+    ]
+
+btree8 :: TB Int
+btree8 = fromJust $ fromList [0..7]
+
+btreeShapes :: [TB ()]
+btreeShapes = take 5 unfold_
+
+randomBTree :: IO (TB Bool)
+randomBTree = getStdRandom randomDefault

examples/redblack.hs view

@@ -1,107 +1,107 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}--import Control.Applicative-import Data.Unfoldable-import Data.Unfolder--import Data.Maybe-import System.Random-import Data.List (intercalate)---- red-black tree implementation adapted from https://gist.github.com/2660297-data Nat = Zero | Succ Nat deriving (Eq, Ord, Show)-data NatW :: Nat -> * where-  ZeroW :: NatW Zero-  SuccW :: NatW n -> NatW (Succ n)--data RedBlack = Black | Red deriving (Eq, Ord, Show)--data RedBlackTree a where -  T :: Node Black n a -> RedBlackTree a-deriving instance Show a => Show (RedBlackTree a)--data Node :: RedBlack -> Nat -> * -> * where-  Leaf :: Node Black Zero a-  B :: Node cL    n a -> a -> Node cR    n a -> Node Black (Succ n) a-  R :: Node Black n a -> a -> Node Black n a -> Node Red    n       a-deriving instance Show a => Show (Node c n a)--instance Unfoldable RedBlackTree where-  unfold = u ZeroW-    where-      u :: forall n f a. (Unfoldable (Node Black n), Unfolder f) -        => NatW n -> f a -> f (RedBlackTree a)-      u n fa = choose -        [ T <$> (unfold :: Unfolder f => f a -> f (Node Black n a)) fa-        , u (SuccW n) fa-        ]-  -instance Unfoldable (Node Black Zero) where-  unfold _ = choose [ pure Leaf ]--instance Unfoldable (Node Black n) => Unfoldable (Node Black (Succ n)) where-  unfold = u-    where-      u :: forall f a. Unfolder f => f a -> f (Node Black (Succ n) a)-      u fa = choose -        [ B <$> b <*> fa <*> b-        , B <$> b <*> fa <*> r-        , B <$> r <*> fa <*> b-        , B <$> r <*> fa <*> r-        ]-        where-          r :: Unfolder f => f (Node Red n a)-          r = unfold fa-          b :: Unfolder f => f (Node Black n a)-          b = unfold fa--instance Unfoldable (Node Black n) => Unfoldable (Node Red n) where-  unfold fa = choose [ R <$> unfold fa <*> fa <*> unfold fa ]--rbtree :: Int -> RedBlackTree Int-rbtree l = fromJust $ fromList [0..l]--rbtreeShapes :: Int -> [RedBlackTree ()]-rbtreeShapes d = limitDepth d unfold_--randomRBTree :: IO (RedBlackTree Bool)-randomRBTree = getStdRandom randomDefault--newtype Formula = Formula [Integer]-instance Show Formula where-  show (Formula xs) -    | all (== 0) xs = "0"-    | otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [0..]-        where-          showOne (x, 0) = show x-          showOne (1, 1) = "x"-          showOne (x, 1) = show x ++ "x"-          showOne (1, n) = "x^" ++ show n-          showOne (x, n) = show x ++ "x^" ++ show n--add, mul :: [Integer] -> [Integer] -> [Integer]-add xs [] = xs-add [] ys = ys-add (x:xs) (y:ys) = (x + y) : add xs ys-mul _ [] = []-mul [] _ = []-mul (x:xs) (y:ys) = (x * y) : add (map (x*) ys) (add (map (y*) xs) (0 : mul xs ys))--instance Num Formula where-  fromInteger x = Formula [x]-  Formula xs + Formula ys = Formula (add xs ys)-  Formula xs * Formula ys = Formula (mul xs ys)--x :: Formula-x = Formula [0, 1]---- See http://oeis.org/A001137-rbFormula :: Int -> NumConst Formula (RedBlackTree a)+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+import Control.Applicative
+import Data.Unfoldable
+import Data.Unfolder
+
+import Data.Maybe
+import System.Random
+import Data.List (intercalate)
+
+-- red-black tree implementation adapted from https://gist.github.com/2660297
+data Nat = Zero | Succ Nat deriving (Eq, Ord, Show)
+data NatW :: Nat -> * where
+  ZeroW :: NatW Zero
+  SuccW :: NatW n -> NatW (Succ n)
+
+data RedBlack = Black | Red deriving (Eq, Ord, Show)
+
+data RedBlackTree a where 
+  T :: Node Black n a -> RedBlackTree a
+deriving instance Show a => Show (RedBlackTree a)
+
+data Node :: RedBlack -> Nat -> * -> * where
+  Leaf :: Node Black Zero a
+  B :: Node cL    n a -> a -> Node cR    n a -> Node Black (Succ n) a
+  R :: Node Black n a -> a -> Node Black n a -> Node Red    n       a
+deriving instance Show a => Show (Node c n a)
+
+instance Unfoldable RedBlackTree where
+  unfold = u ZeroW
+    where
+      u :: forall n f a. (Unfoldable (Node Black n), Unfolder f) 
+        => NatW n -> f a -> f (RedBlackTree a)
+      u n fa = choose 
+        [ T <$> (unfold :: Unfolder f => f a -> f (Node Black n a)) fa
+        , u (SuccW n) fa
+        ]
+  
+instance Unfoldable (Node Black Zero) where
+  unfold _ = choose [ pure Leaf ]
+
+instance Unfoldable (Node Black n) => Unfoldable (Node Black (Succ n)) where
+  unfold = u
+    where
+      u :: forall f a. Unfolder f => f a -> f (Node Black (Succ n) a)
+      u fa = choose 
+        [ B <$> b <*> fa <*> b
+        , B <$> b <*> fa <*> r
+        , B <$> r <*> fa <*> b
+        , B <$> r <*> fa <*> r
+        ]
+        where
+          r :: Unfolder f => f (Node Red n a)
+          r = unfold fa
+          b :: Unfolder f => f (Node Black n a)
+          b = unfold fa
+
+instance Unfoldable (Node Black n) => Unfoldable (Node Red n) where
+  unfold fa = choose [ R <$> unfold fa <*> fa <*> unfold fa ]
+
+rbtree :: Int -> RedBlackTree Int
+rbtree l = fromJust $ fromList [0..l]
+
+rbtreeShapes :: Int -> [RedBlackTree ()]
+rbtreeShapes d = limitDepth d unfold_
+
+randomRBTree :: IO (RedBlackTree Bool)
+randomRBTree = getStdRandom randomDefault
+
+newtype Formula = Formula [Integer]
+instance Show Formula where
+  show (Formula xs) 
+    | all (== 0) xs = "0"
+    | otherwise = intercalate " + " $ map showOne $ filter ((/=0) . fst) $ zip xs [0..]
+        where
+          showOne (x, 0) = show x
+          showOne (1, 1) = "x"
+          showOne (x, 1) = show x ++ "x"
+          showOne (1, n) = "x^" ++ show n
+          showOne (x, n) = show x ++ "x^" ++ show n
+
+add, mul :: [Integer] -> [Integer] -> [Integer]
+add xs [] = xs
+add [] ys = ys
+add (x:xs) (y:ys) = (x + y) : add xs ys
+mul _ [] = []
+mul [] _ = []
+mul (x:xs) (y:ys) = (x * y) : add (map (x*) ys) (add (map (y*) xs) (0 : mul xs ys))
+
+instance Num Formula where
+  fromInteger x = Formula [x]
+  Formula xs + Formula ys = Formula (add xs ys)
+  Formula xs * Formula ys = Formula (mul xs ys)
+
+x :: Formula
+x = Formula [0, 1]
+
+-- See http://oeis.org/A001137
+rbFormula :: Int -> NumConst Formula (RedBlackTree a)
 rbFormula d = ala (limitDepth d) unfold (NumConst x)

examples/tree.hs view

@@ -1,25 +1,25 @@-import Control.Applicative-import Data.Unfoldable-import Data.Unfolder--import Data.Maybe-import System.Random---data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) deriving Show--instance Unfoldable Tree where-  unfold fa = choose-    [ pure Empty-    , Leaf <$> fa-    , Node <$> unfold fa <*> fa <*> unfold fa-    ]-    -tree7 :: Tree Int-tree7 = fromJust $ fromList [0..6]--treeShapes :: [Tree ()]-treeShapes = take 10 unfoldBF_--randomTree :: IO (Tree Bool)-randomTree = getStdRandom randomDefault+import Control.Applicative
+import Data.Unfoldable
+import Data.Unfolder
+
+import Data.Maybe
+import System.Random
+
+
+data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) deriving Show
+
+instance Unfoldable Tree where
+  unfold fa = choose
+    [ pure Empty
+    , Leaf <$> fa
+    , Node <$> unfold fa <*> fa <*> unfold fa
+    ]
+    
+tree7 :: Tree Int
+tree7 = fromJust $ fromList [0..6]
+
+treeShapes :: [Tree ()]
+treeShapes = take 10 unfoldBF_
+
+randomTree :: IO (Tree Bool)
+randomTree = getStdRandom randomDefault

src/Data/Biunfoldable.hs view

@@ -1,112 +1,112 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Biunfoldable--- Copyright   :  (c) Sjoerd Visscher 2012--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  sjoerd@w3future.com--- Stability   :  experimental--- Portability :  non-portable------ Class of data structures with 2 type arguments that can be unfolded.-------------------------------------------------------------------------------module Data.Biunfoldable -  (--  -- * Biunfoldable-    Biunfoldable(..)-  , biunfold_-  , biunfoldBF-  , biunfoldBF_--  -- ** Specific unfolds-  , biunfoldr-  , fromLists-  , randomDefault-  , arbitraryDefault--  ) -  where--import Control.Applicative-import Data.Unfolder-import Data.Functor.Constant-import Control.Monad.Trans.State-import qualified System.Random as R-import Test.QuickCheck.Arbitrary (Arbitrary(..))-import Test.QuickCheck.Gen (Gen(..))-import Data.Maybe---- | Data structures with 2 type arguments (kind @* -> * -> *@) that can be unfolded.------ For example, given a data type------ > data Tree a b = Empty | Leaf a | Node (Tree a b) b (Tree a b)------ a suitable instance would be------ > instance Biunfoldable Tree where--- >   biunfold fa fb = choose--- >     [ pure Empty--- >     , Leaf <$> fa--- >     , Node <$> biunfold fa fb <*> fb <*> biunfold fa fb--- >     ]------ i.e. it follows closely the instance for 'Bitraversable', but instead of matching on an input value,--- we 'choose' from a list of all cases.-class Biunfoldable t where-  -- | Given a way to generate elements, return a way to generate structures containing those elements.-  biunfold :: Unfolder f => f a -> f b -> f (t a b)---- | Unfold the structure, always using @()@ as elements.-biunfold_ :: (Biunfoldable t, Unfolder f) => f (t () ())-biunfold_ = biunfold (pure ()) (pure ())---- | Breadth-first unfold, which orders the result by the number of 'choose' calls.-biunfoldBF :: (Biunfoldable t, Unfolder f) => f a -> f b -> f (t a b)-biunfoldBF = ala2 bfs biunfold---- | Unfold the structure breadth-first, always using @()@ as elements.-biunfoldBF_ :: (Biunfoldable t, Unfolder f) => f (t () ())-biunfoldBF_ = bfs biunfold_---- | @biunfoldr@ builds a data structure from a seed value.-biunfoldr :: Biunfoldable t => (c -> Maybe (a, c)) -> (c -> Maybe (b, c)) -> c -> Maybe (t a b)-biunfoldr fa fb z = terminate . flip runStateT z $ biunfoldBF (StateT $ maybeToList . fa) (StateT $ maybeToList . fb)-  where-    terminate [] = Nothing-    terminate ((t, c):ts) = if isNothing (fa c) && isNothing (fb c) then Just t else terminate ts---- | Create a data structure using the lists as input.--- This can fail because there might not be a data structure with the same number--- of element positions as the number of elements in the lists.-fromLists :: Biunfoldable t => [a] -> [b] -> Maybe (t a b)-fromLists = curry $ biunfoldr unconsA unconsB-  where-    unconsA ([], _) = Nothing-    unconsA (a:as, bs) = Just (a, (as, bs))-    unconsB (_, []) = Nothing-    unconsB (as, b:bs) = Just (b, (as, bs))---- | Generate a random value, can be used as default instance for 'R.Random'.-randomDefault :: (R.Random a, R.Random b, R.RandomGen g, Biunfoldable t) => g -> (t a b, g)-randomDefault = runState . getRandom $ biunfold (Random . state $ R.random) (Random . state $ R.random)---- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'.-arbitraryDefault :: (Arbitrary a, Arbitrary b, Biunfoldable t) => Gen (t a b)-arbitraryDefault = MkGen $ \r n -> let Arb _ f = biunfold arbUnit arbUnit in -  fromMaybe (error "Failed to generate a value.") (f r (n + 1))--instance Biunfoldable Either where-  biunfold fa fb = choose -    [ Left <$> fa-    , Right <$> fb-    ]--instance Biunfoldable (,) where-  biunfold fa fb = choose -    [ (,) <$> fa <*> fb ]--instance Biunfoldable Constant where-  biunfold fa _ = choose -    [ Constant <$> fa ]+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Biunfoldable
+-- Copyright   :  (c) Sjoerd Visscher 2012
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  sjoerd@w3future.com
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Class of data structures with 2 type arguments that can be unfolded.
+-----------------------------------------------------------------------------
+module Data.Biunfoldable 
+  (
+
+  -- * Biunfoldable
+    Biunfoldable(..)
+  , biunfold_
+  , biunfoldBF
+  , biunfoldBF_
+
+  -- ** Specific unfolds
+  , biunfoldr
+  , fromLists
+  , randomDefault
+  , arbitraryDefault
+
+  ) 
+  where
+
+import Control.Applicative
+import Data.Unfolder
+import Data.Functor.Constant
+import Control.Monad.Trans.State
+import qualified System.Random as R
+import Test.QuickCheck.Arbitrary (Arbitrary(..))
+import Test.QuickCheck.Gen (Gen(..))
+import Data.Maybe
+
+-- | Data structures with 2 type arguments (kind @* -> * -> *@) that can be unfolded.
+--
+-- For example, given a data type
+--
+-- > data Tree a b = Empty | Leaf a | Node (Tree a b) b (Tree a b)
+--
+-- a suitable instance would be
+--
+-- > instance Biunfoldable Tree where
+-- >   biunfold fa fb = choose
+-- >     [ pure Empty
+-- >     , Leaf <$> fa
+-- >     , Node <$> biunfold fa fb <*> fb <*> biunfold fa fb
+-- >     ]
+--
+-- i.e. it follows closely the instance for 'Bitraversable', but instead of matching on an input value,
+-- we 'choose' from a list of all cases.
+class Biunfoldable t where
+  -- | Given a way to generate elements, return a way to generate structures containing those elements.
+  biunfold :: Unfolder f => f a -> f b -> f (t a b)
+
+-- | Unfold the structure, always using @()@ as elements.
+biunfold_ :: (Biunfoldable t, Unfolder f) => f (t () ())
+biunfold_ = biunfold (pure ()) (pure ())
+
+-- | Breadth-first unfold, which orders the result by the number of 'choose' calls.
+biunfoldBF :: (Biunfoldable t, Unfolder f) => f a -> f b -> f (t a b)
+biunfoldBF = ala2 bfs biunfold
+
+-- | Unfold the structure breadth-first, always using @()@ as elements.
+biunfoldBF_ :: (Biunfoldable t, Unfolder f) => f (t () ())
+biunfoldBF_ = bfs biunfold_
+
+-- | @biunfoldr@ builds a data structure from a seed value.
+biunfoldr :: Biunfoldable t => (c -> Maybe (a, c)) -> (c -> Maybe (b, c)) -> c -> Maybe (t a b)
+biunfoldr fa fb z = terminate . flip runStateT z $ biunfoldBF (StateT $ maybeToList . fa) (StateT $ maybeToList . fb)
+  where
+    terminate [] = Nothing
+    terminate ((t, c):ts) = if isNothing (fa c) && isNothing (fb c) then Just t else terminate ts
+
+-- | Create a data structure using the lists as input.
+-- This can fail because there might not be a data structure with the same number
+-- of element positions as the number of elements in the lists.
+fromLists :: Biunfoldable t => [a] -> [b] -> Maybe (t a b)
+fromLists = curry $ biunfoldr unconsA unconsB
+  where
+    unconsA ([], _) = Nothing
+    unconsA (a:as, bs) = Just (a, (as, bs))
+    unconsB (_, []) = Nothing
+    unconsB (as, b:bs) = Just (b, (as, bs))
+
+-- | Generate a random value, can be used as default instance for 'R.Random'.
+randomDefault :: (R.Random a, R.Random b, R.RandomGen g, Biunfoldable t) => g -> (t a b, g)
+randomDefault = runState . getRandom $ biunfold (Random . state $ R.random) (Random . state $ R.random)
+
+-- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'.
+arbitraryDefault :: (Arbitrary a, Arbitrary b, Biunfoldable t) => Gen (t a b)
+arbitraryDefault = MkGen $ \r n -> let Arb _ f = biunfold arbUnit arbUnit in 
+  fromMaybe (error "Failed to generate a value.") (f r (n + 1))
+
+instance Biunfoldable Either where
+  biunfold fa fb = choose 
+    [ Left <$> fa
+    , Right <$> fb
+    ]
+
+instance Biunfoldable (,) where
+  biunfold fa fb = choose 
+    [ (,) <$> fa <*> fb ]
+
+instance Biunfoldable Constant where
+  biunfold fa _ = choose 
+    [ Constant <$> fa ]

+ src/Data/Triunfoldable.hs view

@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Triunfoldable
+-- Copyright   :  (c) Sjoerd Visscher 2012
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  sjoerd@w3future.com
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Class of data structures with 3 type arguments that can be unfolded.
+-----------------------------------------------------------------------------
+module Data.Triunfoldable 
+  (
+
+  -- * Triunfoldable
+    Triunfoldable(..)
+  , triunfold_
+  , triunfoldBF
+  , triunfoldBF_
+
+  -- ** Specific unfolds
+  , triunfoldr
+  , fromLists
+  , randomDefault
+  , arbitraryDefault
+
+  ) 
+  where
+
+import Control.Applicative
+import Data.Unfolder
+import Data.Functor.Constant
+import Control.Monad.Trans.State
+import qualified System.Random as R
+import Test.QuickCheck.Arbitrary (Arbitrary(..))
+import Test.QuickCheck.Gen (Gen(..))
+import Data.Maybe
+
+-- | Data structures with 3 type arguments (kind @* -> * -> * -> *@) that can be unfolded.
+--
+-- For example, given a data type
+--
+-- > data Tree a b c = Empty | Leaf a | Node (Tree a b c) b (Tree a b c)
+--
+-- a suitable instance would be
+--
+-- > instance Triunfoldable Tree where
+-- >   triunfold fa fb fc = choose
+-- >     [ pure Empty
+-- >     , Leaf <$> fa
+-- >     , Node <$> triunfold fa fb fc <*> fb <*> triunfold fa fb fc
+-- >     ]
+--
+-- i.e. it follows closely the instance for 'Biunfoldable', but for 3 type arguments instead of 2.
+
+class Triunfoldable t where
+  -- | Given a way to generate elements, return a way to generate structures containing those elements.
+  triunfold :: Unfolder f => f a -> f b -> f c -> f (t a b c)
+
+-- | Unfold the structure, always using @()@ as elements.
+triunfold_ :: (Triunfoldable t, Unfolder f) => f (t () () ())
+triunfold_ = triunfold (pure ()) (pure ()) (pure ())
+
+-- | Breadth-first unfold, which orders the result by the number of 'choose' calls.
+triunfoldBF :: (Triunfoldable t, Unfolder f) => f a -> f b -> f c -> f (t a b c)
+triunfoldBF = ala3 bfs triunfold
+
+-- | Unfold the structure breadth-first, always using @()@ as elements.
+triunfoldBF_ :: (Triunfoldable t, Unfolder f) => f (t () () ())
+triunfoldBF_ = bfs triunfold_
+
+-- | @triunfoldr@ builds a data structure from a seed value.
+triunfoldr :: Triunfoldable t => (d -> Maybe (a, d)) -> (d -> Maybe (b, d)) -> (d -> Maybe (c, d)) -> d -> Maybe (t a b c)
+triunfoldr fa fb fc z = terminate . flip runStateT z $ triunfoldBF (StateT $ maybeToList . fa) (StateT $ maybeToList . fb) (StateT $ maybeToList . fc)
+  where
+    terminate [] = Nothing
+    terminate ((t, d):ts) = if (isNothing (fa d) && isNothing (fb d) && isNothing (fc d)) then Just t else terminate ts
+
+
+-- | Create a data structure using the lists as input.
+-- This can fail because there might not be a data structure with the same number
+-- of element positions as the number of elements in the lists.
+fromLists :: Triunfoldable t => [a] -> [b] -> [c] -> Maybe (t a b c)
+fromLists = curry3 $ triunfoldr unconsA unconsB unconsC
+  where
+    unconsA ([], _, _) = Nothing
+    unconsA (a:as, bs, cs) = Just (a, (as, bs, cs))
+    unconsB (_, [], _) = Nothing
+    unconsB (as, b:bs, cs) = Just (b, (as, bs, cs))
+    unconsC (_, _, []) = Nothing
+    unconsC (as, bs, c:cs) = Just (c, (as, bs, cs))
+
+-- | Generate a random value, can be used as default instance for 'R.Random'.
+randomDefault :: (R.Random a, R.Random b, R.Random c, R.RandomGen g, Triunfoldable t) => g -> (t a b c, g)
+randomDefault = runState . getRandom $ triunfold (Random . state $ R.random) (Random . state $ R.random) (Random . state $ R.random)
+
+-- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'.
+arbitraryDefault :: (Arbitrary a, Arbitrary b, Arbitrary c, Triunfoldable t) => Gen (t a b c)
+arbitraryDefault = MkGen $ \r n -> let Arb _ f = triunfold arbUnit arbUnit arbUnit in 
+  fromMaybe (error "Failed to generate a value.") (f r (n + 1))
+
+
+curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
+curry3 f a b c = f (a,b,c)
+
+instance Triunfoldable (,,) where
+  triunfold fa fb fc = choose 
+    [ (,,) <$> fa <*> fb <*> fc ]
+

src/Data/Unfoldable.hs view

@@ -1,169 +1,169 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Unfoldable--- Copyright   :  (c) Sjoerd Visscher 2012--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  sjoerd@w3future.com--- Stability   :  experimental--- Portability :  non-portable------ Class of data structures that can be unfolded.-------------------------------------------------------------------------------module Data.Unfoldable -  (-  -  -- * Unfoldable-    Unfoldable(..)-  , unfold_-  , unfoldBF-  , unfoldBF_-  -  -- ** Specific unfolds-  , unfoldr-  , fromList-  , leftMost-  , rightMost-  , allDepthFirst-  , allToDepth-  , allBreadthFirst-  , randomDefault-  , arbitraryDefault-  -  ) -  where-    -import Control.Applicative-import Data.Unfolder-import Data.Functor.Compose-import Data.Functor.Constant-import Data.Functor.Identity-import Data.Functor.Product-import Data.Functor.Reverse-import Control.Monad.Trans.State-import qualified System.Random as R-import Test.QuickCheck.Arbitrary (Arbitrary(..))-import Test.QuickCheck.Gen (Gen(..))-import Data.Maybe---- | Data structures that can be unfolded.------ For example, given a data type------ > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)------ a suitable instance would be------ > instance Unfoldable Tree where--- >   unfold fa = choose--- >     [ pure Empty--- >     , Leaf <$> fa--- >     , Node <$> unfold fa <*> fa <*> unfold fa--- >     ]------ i.e. it follows closely the instance for 'Traversable', but instead of matching on an input value,--- we 'choose' from a list of all cases.-class Unfoldable t where-  -- | Given a way to generate elements, return a way to generate structures containing those elements.-  unfold :: Unfolder f => f a -> f (t a)---- | Unfold the structure, always using @()@ as elements.-unfold_ :: (Unfoldable t, Unfolder f) => f (t ())-unfold_ = unfold (pure ())---- | Breadth-first unfold, which orders the result by the number of 'choose' calls.-unfoldBF :: (Unfoldable t, Unfolder f) => f a -> f (t a)-unfoldBF = ala bfs unfold---- | Unfold the structure breadth-first, always using @()@ as elements.-unfoldBF_ :: (Unfoldable t, Unfolder f) => f (t ())-unfoldBF_ = bfs unfold_---- | @unfoldr@ builds a data structure from a seed value. It can be specified as:--- --- > unfoldr f z == fromList (Data.List.unfoldr f z)-unfoldr :: Unfoldable t => (b -> Maybe (a, b)) -> b -> Maybe (t a)-unfoldr f z = terminate . flip runStateT z . unfoldBF . StateT $ maybeToList . f-  where-    terminate [] = Nothing-    terminate ((t, b):ts) = if isNothing (f b) then Just t else terminate ts---- | Create a data structure using the list as input.--- This can fail because there might not be a data structure with the same number--- of element positions as the number of elements in the list.-fromList :: Unfoldable t => [a] -> Maybe (t a)-fromList = unfoldr uncons-  where-    uncons [] = Nothing-    uncons (a:as) = Just (a, as)---- | Always choose the first constructor.-leftMost :: Unfoldable t => Maybe (t ())-leftMost = unfold_---- | Always choose the last constructor.-rightMost :: Unfoldable t => Maybe (t ())-rightMost = getDualA unfold_---- | Generate all the values depth-first.-allDepthFirst :: Unfoldable t => [t ()]-allDepthFirst = unfold_---- | Generate all the values upto a given depth, depth-first.-allToDepth :: Unfoldable t => Int -> [t ()]-allToDepth d = limitDepth d unfold_---- | Generate all the values breadth-first.-allBreadthFirst :: Unfoldable t => [t ()]-allBreadthFirst = unfoldBF_---- | Generate a random value, can be used as default instance for 'R.Random'.-randomDefault :: (R.Random a, R.RandomGen g, Unfoldable t) => g -> (t a, g)-randomDefault = runState . getRandom . unfold . Random . state $ R.random---- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'.-arbitraryDefault :: (Arbitrary a, Unfoldable t) => Gen (t a)-arbitraryDefault = MkGen $ \r n -> let Arb _ f = unfold arbUnit in -  fromMaybe (error "Failed to generate a value.") (f r (n + 1))--instance Unfoldable [] where-  unfold fa = choose -    [ pure []-    , (:) <$> fa <*> unfold fa-    ]--instance Unfoldable Maybe where-  unfold fa = choose -    [ pure Nothing-    , Just <$> fa-    ]--instance (Bounded a, Enum a) => Unfoldable (Either a) where-  unfold fa = choose -    [ Left <$> boundedEnum-    , Right <$> fa-    ]--instance (Bounded a, Enum a) => Unfoldable ((,) a) where-  unfold fa = choose -    [ (,) <$> boundedEnum <*> fa ]--instance Unfoldable Identity where-  unfold fa = choose -    [ Identity <$> fa ]--instance (Bounded a, Enum a) => Unfoldable (Constant a) where-  unfold _ = choose -    [ Constant <$> boundedEnum ]-  -instance (Unfoldable p, Unfoldable q) => Unfoldable (Product p q) where-  unfold fa = choose-    [ Pair <$> unfold fa <*> unfold fa ]--instance (Unfoldable p, Unfoldable q) => Unfoldable (Compose p q) where-  unfold fa = choose-    [ Compose <$> unfold (unfold fa) ]--instance Unfoldable f => Unfoldable (Reverse f) where-  unfold fa = choose+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Unfoldable
+-- Copyright   :  (c) Sjoerd Visscher 2012
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  sjoerd@w3future.com
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Class of data structures that can be unfolded.
+-----------------------------------------------------------------------------
+module Data.Unfoldable 
+  (
+  
+  -- * Unfoldable
+    Unfoldable(..)
+  , unfold_
+  , unfoldBF
+  , unfoldBF_
+  
+  -- ** Specific unfolds
+  , unfoldr
+  , fromList
+  , leftMost
+  , rightMost
+  , allDepthFirst
+  , allToDepth
+  , allBreadthFirst
+  , randomDefault
+  , arbitraryDefault
+  
+  ) 
+  where
+    
+import Control.Applicative
+import Data.Unfolder
+import Data.Functor.Compose
+import Data.Functor.Constant
+import Data.Functor.Identity
+import Data.Functor.Product
+import Data.Functor.Reverse
+import Control.Monad.Trans.State
+import qualified System.Random as R
+import Test.QuickCheck.Arbitrary (Arbitrary(..))
+import Test.QuickCheck.Gen (Gen(..))
+import Data.Maybe
+
+-- | Data structures that can be unfolded.
+--
+-- For example, given a data type
+--
+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
+--
+-- a suitable instance would be
+--
+-- > instance Unfoldable Tree where
+-- >   unfold fa = choose
+-- >     [ pure Empty
+-- >     , Leaf <$> fa
+-- >     , Node <$> unfold fa <*> fa <*> unfold fa
+-- >     ]
+--
+-- i.e. it follows closely the instance for 'Traversable', but instead of matching on an input value,
+-- we 'choose' from a list of all cases.
+class Unfoldable t where
+  -- | Given a way to generate elements, return a way to generate structures containing those elements.
+  unfold :: Unfolder f => f a -> f (t a)
+
+-- | Unfold the structure, always using @()@ as elements.
+unfold_ :: (Unfoldable t, Unfolder f) => f (t ())
+unfold_ = unfold (pure ())
+
+-- | Breadth-first unfold, which orders the result by the number of 'choose' calls.
+unfoldBF :: (Unfoldable t, Unfolder f) => f a -> f (t a)
+unfoldBF = ala bfs unfold
+
+-- | Unfold the structure breadth-first, always using @()@ as elements.
+unfoldBF_ :: (Unfoldable t, Unfolder f) => f (t ())
+unfoldBF_ = bfs unfold_
+
+-- | @unfoldr@ builds a data structure from a seed value. It can be specified as:
+-- 
+-- > unfoldr f z == fromList (Data.List.unfoldr f z)
+unfoldr :: Unfoldable t => (b -> Maybe (a, b)) -> b -> Maybe (t a)
+unfoldr f z = terminate . flip runStateT z . unfoldBF . StateT $ maybeToList . f
+  where
+    terminate [] = Nothing
+    terminate ((t, b):ts) = if isNothing (f b) then Just t else terminate ts
+
+-- | Create a data structure using the list as input.
+-- This can fail because there might not be a data structure with the same number
+-- of element positions as the number of elements in the list.
+fromList :: Unfoldable t => [a] -> Maybe (t a)
+fromList = unfoldr uncons
+  where
+    uncons [] = Nothing
+    uncons (a:as) = Just (a, as)
+
+-- | Always choose the first constructor.
+leftMost :: Unfoldable t => Maybe (t ())
+leftMost = unfold_
+
+-- | Always choose the last constructor.
+rightMost :: Unfoldable t => Maybe (t ())
+rightMost = getDualA unfold_
+
+-- | Generate all the values depth-first.
+allDepthFirst :: Unfoldable t => [t ()]
+allDepthFirst = unfold_
+
+-- | Generate all the values upto a given depth, depth-first.
+allToDepth :: Unfoldable t => Int -> [t ()]
+allToDepth d = limitDepth d unfold_
+
+-- | Generate all the values breadth-first.
+allBreadthFirst :: Unfoldable t => [t ()]
+allBreadthFirst = unfoldBF_
+
+-- | Generate a random value, can be used as default instance for 'R.Random'.
+randomDefault :: (R.Random a, R.RandomGen g, Unfoldable t) => g -> (t a, g)
+randomDefault = runState . getRandom . unfold . Random . state $ R.random
+
+-- | Provides a QuickCheck generator, can be used as default instance for 'Arbitrary'.
+arbitraryDefault :: (Arbitrary a, Unfoldable t) => Gen (t a)
+arbitraryDefault = MkGen $ \r n -> let Arb _ f = unfold arbUnit in 
+  fromMaybe (error "Failed to generate a value.") (f r (n + 1))
+
+instance Unfoldable [] where
+  unfold fa = choose 
+    [ pure []
+    , (:) <$> fa <*> unfold fa
+    ]
+
+instance Unfoldable Maybe where
+  unfold fa = choose 
+    [ pure Nothing
+    , Just <$> fa
+    ]
+
+instance (Bounded a, Enum a) => Unfoldable (Either a) where
+  unfold fa = choose 
+    [ Left <$> boundedEnum
+    , Right <$> fa
+    ]
+
+instance (Bounded a, Enum a) => Unfoldable ((,) a) where
+  unfold fa = choose 
+    [ (,) <$> boundedEnum <*> fa ]
+
+instance Unfoldable Identity where
+  unfold fa = choose 
+    [ Identity <$> fa ]
+
+instance (Bounded a, Enum a) => Unfoldable (Constant a) where
+  unfold _ = choose 
+    [ Constant <$> boundedEnum ]
+  
+instance (Unfoldable p, Unfoldable q) => Unfoldable (Product p q) where
+  unfold fa = choose
+    [ Pair <$> unfold fa <*> unfold fa ]
+
+instance (Unfoldable p, Unfoldable q) => Unfoldable (Compose p q) where
+  unfold fa = choose
+    [ Compose <$> unfold (unfold fa) ]
+
+instance Unfoldable f => Unfoldable (Reverse f) where
+  unfold fa = choose
     [ Reverse <$> getDualA (unfold (DualA fa)) ]

src/Data/Unfolder.hs view

@@ -1,340 +1,345 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Unfolder--- Copyright   :  (c) Sjoerd Visscher 2012--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  sjoerd@w3future.com--- Stability   :  experimental--- Portability :  non-portable------ Unfolders provide a way to unfold data structures.--- They are basically 'Alternative' instances, but the 'choose' method--- allows the unfolder to do something special for the recursive positions--- of the data structure.-------------------------------------------------------------------------------{-# LANGUAGE -    ScopedTypeVariables-  , GeneralizedNewtypeDeriving-  , RankNTypes-  #-}-module Data.Unfolder -  (-  -  -- * Unfolder-    Unfolder(..)-  , chooseMonadDefault-  -  , boundedEnum-  -  -- ** Unfolder instances-  , Random(..)--  , Arb(..)-  , arbUnit-  -  , NumConst(..)-  -  -- * UnfolderTransformer-  , UnfolderTransformer(..)-  , ala-  , ala2-  -  -- ** UnfolderTransformer instances-  , DualA(..)--  , NT(..)-  , WithRec(..)-  , withRec-  , limitDepth-  -  , BFS(..)-  , bfs-  ) -  where --import Control.Applicative-import Control.Monad-import Control.Arrow (ArrowZero, ArrowPlus)--import Data.Functor.Product-import Data.Functor.Compose-import Data.Functor.Reverse-import Control.Applicative.Backwards-import Control.Applicative.Lift-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.RWS-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State-import Control.Monad.Trans.Writer--import qualified System.Random as R-import Test.QuickCheck.Arbitrary (Arbitrary(..))-import Test.QuickCheck.Gen (Gen(..))--import Data.Monoid (Monoid(..))-import Data.Maybe (catMaybes, listToMaybe)-import Data.Foldable (asum)-import Data.Traversable (traverse)---- | Unfolders provide a way to unfold data structures.--- The methods have default implementations in terms of 'Alternative',--- but you can implement 'choose' to act on recursive positions of the--- data structure, or simply to provide a faster implementation than 'asum'.-class Alternative f => Unfolder f where-  -- | Choose one of the values from the list.-  choose :: [f x] -> f x-  choose = asum-  -- | Given a number 'n', return a number between '0' and 'n - 1'.-  chooseInt :: Int -> f Int-  chooseInt n = choose $ map pure [0 .. n - 1]---- | If an unfolder is monadic, 'choose' can be implemented in terms of 'chooseInt'.-chooseMonadDefault :: (Monad m, Unfolder m) => [m x] -> m x-chooseMonadDefault ms = chooseInt (length ms) >>= (ms !!)---- | If a datatype is bounded and enumerable, we can use 'chooseInt' to generate a value.--- This is the function to use if you want to unfold a datatype that has no type arguments (has kind *).-boundedEnum :: forall f a. (Unfolder f, Bounded a, Enum a) => f a-boundedEnum = (\x -> toEnum (x + lb)) <$> chooseInt (1 + ub - lb)-  where-    lb = fromEnum (minBound :: a)-    ub = fromEnum (maxBound :: a)---- | Derived instance.-instance MonadPlus m => Unfolder (WrappedMonad m)---- | Derived instance.-instance (ArrowZero a, ArrowPlus a) => Unfolder (WrappedArrow a b)---- | Don't choose but return all items.-instance Unfolder [] where-  choose = concat-  chooseInt n = [0 .. n - 1]---- | Always choose the first item.-instance Unfolder Maybe where-  choose [] = Nothing-  choose ms = head ms-  chooseInt 0 = Nothing-  chooseInt _ = Just 0---- | Derived instance.-instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where-  choose ps = Pair (choose $ map fstP ps) (choose $ map sndP ps)-    where-      fstP (Pair p _) = p-      sndP (Pair _ q) = q-  chooseInt n = Pair (chooseInt n) (chooseInt n)---- | Derived instance.-instance (Unfolder p, Applicative q) => Unfolder (Compose p q) where-  choose = Compose . choose . map getCompose-  chooseInt n = Compose $ pure <$> chooseInt n---- | Derived instance.-instance Unfolder f => Unfolder (Reverse f) where-  choose = Reverse . choose . map getReverse-  chooseInt n = Reverse $ chooseInt n---- | Derived instance.-instance Unfolder f => Unfolder (Backwards f) where-  choose = Backwards . choose . map forwards-  chooseInt n = Backwards $ chooseInt n---- | Derived instance.-instance Unfolder f => Unfolder (Lift f)---- | Derived instance.-instance (Functor m, Monad m, Error e) => Unfolder (ErrorT e m)---- | Derived instance.-instance Applicative f => Unfolder (ListT f) where-  choose ms = ListT $ concat <$> traverse runListT ms-  chooseInt n = ListT $ pure [0 .. n - 1]---- | Derived instance.-instance (Functor m, Monad m) => Unfolder (MaybeT m) where-  choose ms = MaybeT $ listToMaybe . catMaybes <$> mapM runMaybeT ms-  chooseInt 0 = MaybeT $ return Nothing-  chooseInt _ = MaybeT $ return (Just 0)-  --- | Derived instance.-instance (Monoid w, MonadPlus m, Unfolder m) => Unfolder (RWST r w s m) where-  choose ms = RWST $ \r s -> choose $ map (\m -> runRWST m r s) ms---- | Derived instance.-instance (MonadPlus m, Unfolder m) => Unfolder (StateT s m) where-  choose ms = StateT $ \s -> choose $ map (`runStateT` s) ms---- | Derived instance.-instance Unfolder m => Unfolder (ReaderT r m) where-  choose ms = ReaderT $ \r -> choose $ map (`runReaderT` r) ms-  --- | Derived instance.-instance (Monoid w, Unfolder m) => Unfolder (WriterT w m) where-  choose = WriterT . choose . map runWriterT----newtype Random g m a = Random { getRandom :: StateT g m a } -  deriving (Functor, Applicative, Monad)-instance (Functor m, Monad m, R.RandomGen g) => Alternative (Random g m) where-  empty = choose []-  a <|> b = choose [a, b]-instance (Functor m, Monad m, R.RandomGen g) => MonadPlus (Random g m) where-  mzero = choose []-  mplus a b = choose [a, b]--- | Choose randomly.-instance (Functor m, Monad m, R.RandomGen g) => Unfolder (Random g m) where-  choose = chooseMonadDefault-  chooseInt 0 = Random . StateT $ const (fail "Random chooseInt 0")-  chooseInt n = Random . StateT $ return . R.randomR (0, n - 1)----- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds. -class UnfolderTransformer t where-  -- | Lift a computation from the argument unfolder to the constructed unfolder.-  lift :: Unfolder f => f a -> t f a---- | Run an unfolding function with one argument using an 'UnfolderTransformer', given a way to run the transformer.-ala :: (UnfolderTransformer t, Unfolder f) => (t f b -> f b) -> (t f a -> t f b) -> f a -> f b-ala lower f = lower . f . lift---- | Run an unfolding function with two arguments using an 'UnfolderTransformer', given a way to run the transformer.-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-ala2 lower f = ala lower . f . lift----- | 'DualA' flips the @\<|>@ operator from `Alternative`.-newtype DualA f a = DualA { getDualA :: f a }-  deriving (Eq, Show, Functor, Applicative)--instance Alternative f => Alternative (DualA f) where-  empty = DualA empty-  DualA a <|> DualA b = DualA (b <|> a)---- | Reverse the list passed to choose.-instance Unfolder f => Unfolder (DualA f) where-  choose = DualA . choose . reverse . map getDualA-  chooseInt n = DualA $ (\x -> n - 1 - x) <$> chooseInt n--instance UnfolderTransformer DualA where-  lift = DualA----- | Natural transformations-data NT f g = NT { getNT :: forall a. f a -> g a }--newtype WithRec f a = WithRec { getWithRec :: ReaderT (Int -> NT f f) f a }-  deriving (Functor, Applicative, Alternative)---- | Applies a certain function depending on the depth at every recursive position.-instance Unfolder f => Unfolder (WithRec f) where-  choose ms = WithRec . ReaderT $ \f -> -    getNT (f 0) $ choose (map (\(WithRec (ReaderT m)) -> m (f . succ)) ms)--instance UnfolderTransformer WithRec where-  lift = WithRec . ReaderT . const---- | Apply a certain function of type @f a -> f a@ to the result of a 'choose'.--- The depth is passed as 'Int', so you can apply a different function at each depth.--- Because of a @forall@, the function needs to be wrapped in a 'NT' constructor.--- See 'limitDepth' for an example how to use this function.-withRec :: (Int -> NT f f) -> WithRec f a -> f a-withRec f = (`runReaderT` f) . getWithRec---- | Limit the depth of an unfolding.-limitDepth :: Unfolder f => Int -> WithRec f a -> f a-limitDepth m = withRec (\d -> NT $ if d == m then const empty else id)------ | Return a generator of values of a given depth.--- Returns 'Nothing' if there are no values of that depth or deeper.--- The depth is the number of 'choose' calls.-newtype BFS f x = BFS { getBFS :: Int -> Maybe [f x] }--instance Functor f => Functor (BFS f) where -  fmap f = BFS . (fmap (map (fmap f)) .) . getBFS--instance Applicative f => Applicative (BFS f) where-  pure = packBFS . pure-  BFS ff <*> BFS fx = BFS $ \d -> flattenBFS $-    [ liftA2 (liftA2 (<*>)) (ff i) (fx d) | i <- [0 .. d - 1] ] ++-    [ liftA2 (liftA2 (<*>)) (ff d) (fx i) | i <- [0 .. d] ]--instance Applicative f => Alternative (BFS f) where-  empty = BFS $ \d -> if d == 0 then Just [] else Nothing-  BFS fa <|> BFS fb = BFS $ \d -> flattenBFS [fa d, fb d]-  --- | Choose between values of a given depth only.-instance Applicative f => Unfolder (BFS f) where-  choose ms = BFS $ \d -> if d == 0 then Just [] else flattenBFS (map (`getBFS` (d - 1)) ms)--instance UnfolderTransformer BFS where-  lift = packBFS---- | Change the order of unfolding to be breadth-first.-bfs :: Unfolder f => BFS f x -> f x-bfs (BFS f) = choose (loop 0) where loop d = maybe [] (++ loop (d + 1)) (f d)--packBFS :: f x -> BFS f x-packBFS r = BFS $ \d -> if d == 0 then Just [r] else Nothing--flattenBFS :: [Maybe [a]] -> Maybe [a]-flattenBFS ms = case catMaybes ms of-  [] -> Nothing-  ms' -> Just (concat ms')----- | A variant of Test.QuickCheck.Gen, with failure --- and a count of the number of recursive positions.-data Arb a = Arb Int (R.StdGen -> Int -> Maybe a)--instance Functor Arb where-  fmap f (Arb i g) = Arb i $ fmap (fmap (fmap f)) g--instance Applicative Arb where-  pure = Arb 0 . pure . pure . pure-  Arb i1 ff <*> Arb i2 fx = Arb (i1 + i2) $-    \r -> let (r1, r2) = R.split r in liftA2 (<*>) (ff r1) (fx r2)--instance Alternative Arb where-  empty = Arb 0 (\_ _ -> Nothing)-  Arb ia fa <|> Arb ib fb = Arb ((ia + ib + 1) `div` 2) $-    \r n -> let (r1, r2) = R.split r in flattenArb r1 [fa r2 n, fb r2 n]---- | Limit the depth of the generated data structure by --- dividing the given size by the number of recursive positions.-instance Unfolder Arb where-  choose ms = Arb 1 g-    where-      g _ 0 = Nothing-      g r n = let (r1, r2) = R.split r in -        flattenArb r1 $ map (\(Arb i f) -> f r2 (n `div` max i 1)) ms--flattenArb :: R.StdGen -> [Maybe a] -> Maybe a-flattenArb r ms = case catMaybes ms of-  [] -> Nothing-  ms' -> Just $ ms' !! fst (R.randomR (0, length ms' - 1) r)--arbUnit :: Arbitrary a => Arb a-arbUnit = Arb 0 (\r n -> Just $ unGen arbitrary r n)---- | Variant of 'Data.Functor.Constant' that does multiplication of the constants for @\<*>@ and addition for @\<|>@.-newtype NumConst a x = NumConst { getNumConst :: a } deriving (Eq, Show)-instance Functor (NumConst a) where-  fmap _ (NumConst a) = NumConst a-instance Num a => Applicative (NumConst a) where-  pure _ = NumConst 1-  NumConst a <*> NumConst b = NumConst $ a * b-instance Num a => Alternative (NumConst a) where-  empty = NumConst 0-  NumConst a <|> NumConst b = NumConst $ a + b--- | Unfolds to a constant numeric value. Useful for counting shapes.-instance Num a => Unfolder (NumConst a) where-  choose [] = empty-  choose as = foldr1 (<|>) as+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Unfolder
+-- Copyright   :  (c) Sjoerd Visscher 2012
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  sjoerd@w3future.com
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Unfolders provide a way to unfold data structures.
+-- They are basically 'Alternative' instances, but the 'choose' method
+-- allows the unfolder to do something special for the recursive positions
+-- of the data structure.
+-----------------------------------------------------------------------------
+{-# LANGUAGE 
+    ScopedTypeVariables
+  , GeneralizedNewtypeDeriving
+  , RankNTypes
+  #-}
+module Data.Unfolder 
+  (
+  
+  -- * Unfolder
+    Unfolder(..)
+  , chooseMonadDefault
+  
+  , boundedEnum
+  
+  -- ** Unfolder instances
+  , Random(..)
+
+  , Arb(..)
+  , arbUnit
+  
+  , NumConst(..)
+  
+  -- * UnfolderTransformer
+  , UnfolderTransformer(..)
+  , ala
+  , ala2
+  , ala3
+  
+  -- ** UnfolderTransformer instances
+  , DualA(..)
+
+  , NT(..)
+  , WithRec(..)
+  , withRec
+  , limitDepth
+  
+  , BFS(..)
+  , bfs
+  ) 
+  where 
+
+import Control.Applicative
+import Control.Monad
+import Control.Arrow (ArrowZero, ArrowPlus)
+
+import Data.Functor.Product
+import Data.Functor.Compose
+import Data.Functor.Reverse
+import Control.Applicative.Backwards
+import Control.Applicative.Lift
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.RWS
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Writer
+
+import qualified System.Random as R
+import Test.QuickCheck.Arbitrary (Arbitrary(..))
+import Test.QuickCheck.Gen (Gen(..))
+
+import Data.Monoid (Monoid(..))
+import Data.Maybe (catMaybes, listToMaybe)
+import Data.Foldable (asum)
+import Data.Traversable (traverse)
+
+-- | Unfolders provide a way to unfold data structures.
+-- The methods have default implementations in terms of 'Alternative',
+-- but you can implement 'choose' to act on recursive positions of the
+-- data structure, or simply to provide a faster implementation than 'asum'.
+class Alternative f => Unfolder f where
+  -- | Choose one of the values from the list.
+  choose :: [f x] -> f x
+  choose = asum
+  -- | Given a number 'n', return a number between '0' and 'n - 1'.
+  chooseInt :: Int -> f Int
+  chooseInt n = choose $ map pure [0 .. n - 1]
+
+-- | If an unfolder is monadic, 'choose' can be implemented in terms of 'chooseInt'.
+chooseMonadDefault :: (Monad m, Unfolder m) => [m x] -> m x
+chooseMonadDefault ms = chooseInt (length ms) >>= (ms !!)
+
+-- | If a datatype is bounded and enumerable, we can use 'chooseInt' to generate a value.
+-- This is the function to use if you want to unfold a datatype that has no type arguments (has kind *).
+boundedEnum :: forall f a. (Unfolder f, Bounded a, Enum a) => f a
+boundedEnum = (\x -> toEnum (x + lb)) <$> chooseInt (1 + ub - lb)
+  where
+    lb = fromEnum (minBound :: a)
+    ub = fromEnum (maxBound :: a)
+
+-- | Derived instance.
+instance MonadPlus m => Unfolder (WrappedMonad m)
+
+-- | Derived instance.
+instance (ArrowZero a, ArrowPlus a) => Unfolder (WrappedArrow a b)
+
+-- | Don't choose but return all items.
+instance Unfolder [] where
+  choose = concat
+  chooseInt n = [0 .. n - 1]
+
+-- | Always choose the first item.
+instance Unfolder Maybe where
+  choose [] = Nothing
+  choose ms = head ms
+  chooseInt 0 = Nothing
+  chooseInt _ = Just 0
+
+-- | Derived instance.
+instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where
+  choose ps = Pair (choose $ map fstP ps) (choose $ map sndP ps)
+    where
+      fstP (Pair p _) = p
+      sndP (Pair _ q) = q
+  chooseInt n = Pair (chooseInt n) (chooseInt n)
+
+-- | Derived instance.
+instance (Unfolder p, Applicative q) => Unfolder (Compose p q) where
+  choose = Compose . choose . map getCompose
+  chooseInt n = Compose $ pure <$> chooseInt n
+
+-- | Derived instance.
+instance Unfolder f => Unfolder (Reverse f) where
+  choose = Reverse . choose . map getReverse
+  chooseInt n = Reverse $ chooseInt n
+
+-- | Derived instance.
+instance Unfolder f => Unfolder (Backwards f) where
+  choose = Backwards . choose . map forwards
+  chooseInt n = Backwards $ chooseInt n
+
+-- | Derived instance.
+instance Unfolder f => Unfolder (Lift f)
+
+-- | Derived instance.
+instance (Functor m, Monad m, Error e) => Unfolder (ErrorT e m)
+
+-- | Derived instance.
+instance Applicative f => Unfolder (ListT f) where
+  choose ms = ListT $ concat <$> traverse runListT ms
+  chooseInt n = ListT $ pure [0 .. n - 1]
+
+-- | Derived instance.
+instance (Functor m, Monad m) => Unfolder (MaybeT m) where
+  choose ms = MaybeT $ listToMaybe . catMaybes <$> mapM runMaybeT ms
+  chooseInt 0 = MaybeT $ return Nothing
+  chooseInt _ = MaybeT $ return (Just 0)
+  
+-- | Derived instance.
+instance (Monoid w, MonadPlus m, Unfolder m) => Unfolder (RWST r w s m) where
+  choose ms = RWST $ \r s -> choose $ map (\m -> runRWST m r s) ms
+
+-- | Derived instance.
+instance (MonadPlus m, Unfolder m) => Unfolder (StateT s m) where
+  choose ms = StateT $ \s -> choose $ map (`runStateT` s) ms
+
+-- | Derived instance.
+instance Unfolder m => Unfolder (ReaderT r m) where
+  choose ms = ReaderT $ \r -> choose $ map (`runReaderT` r) ms
+  
+-- | Derived instance.
+instance (Monoid w, Unfolder m) => Unfolder (WriterT w m) where
+  choose = WriterT . choose . map runWriterT
+
+
+
+newtype Random g m a = Random { getRandom :: StateT g m a } 
+  deriving (Functor, Applicative, Monad)
+instance (Functor m, Monad m, R.RandomGen g) => Alternative (Random g m) where
+  empty = choose []
+  a <|> b = choose [a, b]
+instance (Functor m, Monad m, R.RandomGen g) => MonadPlus (Random g m) where
+  mzero = choose []
+  mplus a b = choose [a, b]
+-- | Choose randomly.
+instance (Functor m, Monad m, R.RandomGen g) => Unfolder (Random g m) where
+  choose = chooseMonadDefault
+  chooseInt 0 = Random . StateT $ const (fail "Random chooseInt 0")
+  chooseInt n = Random . StateT $ return . R.randomR (0, n - 1)
+
+
+-- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds. 
+class UnfolderTransformer t where
+  -- | Lift a computation from the argument unfolder to the constructed unfolder.
+  lift :: Unfolder f => f a -> t f a
+
+-- | Run an unfolding function with one argument using an 'UnfolderTransformer', given a way to run the transformer.
+ala :: (UnfolderTransformer t, Unfolder f) => (t f b -> f b) -> (t f a -> t f b) -> f a -> f b
+ala lower f = lower . f . lift
+
+-- | Run an unfolding function with two arguments using an 'UnfolderTransformer', given a way to run the transformer.
+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
+ala2 lower f = ala lower . f . lift
+
+-- | Run an unfolding function with three arguments using an 'UnfolderTransformer', given a way to run the transformer.
+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
+ala3 lower f = ala2 lower . f . lift
+
+
+-- | 'DualA' flips the @\<|>@ operator from `Alternative`.
+newtype DualA f a = DualA { getDualA :: f a }
+  deriving (Eq, Show, Functor, Applicative)
+
+instance Alternative f => Alternative (DualA f) where
+  empty = DualA empty
+  DualA a <|> DualA b = DualA (b <|> a)
+
+-- | Reverse the list passed to choose.
+instance Unfolder f => Unfolder (DualA f) where
+  choose = DualA . choose . reverse . map getDualA
+  chooseInt n = DualA $ (\x -> n - 1 - x) <$> chooseInt n
+
+instance UnfolderTransformer DualA where
+  lift = DualA
+
+
+-- | Natural transformations
+data NT f g = NT { getNT :: forall a. f a -> g a }
+
+newtype WithRec f a = WithRec { getWithRec :: ReaderT (Int -> NT f f) f a }
+  deriving (Functor, Applicative, Alternative)
+
+-- | Applies a certain function depending on the depth at every recursive position.
+instance Unfolder f => Unfolder (WithRec f) where
+  choose ms = WithRec . ReaderT $ \f -> 
+    getNT (f 0) $ choose (map (\(WithRec (ReaderT m)) -> m (f . succ)) ms)
+
+instance UnfolderTransformer WithRec where
+  lift = WithRec . ReaderT . const
+
+-- | Apply a certain function of type @f a -> f a@ to the result of a 'choose'.
+-- The depth is passed as 'Int', so you can apply a different function at each depth.
+-- Because of a @forall@, the function needs to be wrapped in a 'NT' constructor.
+-- See 'limitDepth' for an example how to use this function.
+withRec :: (Int -> NT f f) -> WithRec f a -> f a
+withRec f = (`runReaderT` f) . getWithRec
+
+-- | Limit the depth of an unfolding.
+limitDepth :: Unfolder f => Int -> WithRec f a -> f a
+limitDepth m = withRec (\d -> NT $ if d == m then const empty else id)
+
+
+
+-- | Return a generator of values of a given depth.
+-- Returns 'Nothing' if there are no values of that depth or deeper.
+-- The depth is the number of 'choose' calls.
+newtype BFS f x = BFS { getBFS :: Int -> Maybe [f x] }
+
+instance Functor f => Functor (BFS f) where 
+  fmap f = BFS . (fmap (map (fmap f)) .) . getBFS
+
+instance Applicative f => Applicative (BFS f) where
+  pure = packBFS . pure
+  BFS ff <*> BFS fx = BFS $ \d -> flattenBFS $
+    [ liftA2 (liftA2 (<*>)) (ff i) (fx d) | i <- [0 .. d - 1] ] ++
+    [ liftA2 (liftA2 (<*>)) (ff d) (fx i) | i <- [0 .. d] ]
+
+instance Applicative f => Alternative (BFS f) where
+  empty = BFS $ \d -> if d == 0 then Just [] else Nothing
+  BFS fa <|> BFS fb = BFS $ \d -> flattenBFS [fa d, fb d]
+  
+-- | Choose between values of a given depth only.
+instance Applicative f => Unfolder (BFS f) where
+  choose ms = BFS $ \d -> if d == 0 then Just [] else flattenBFS (map (`getBFS` (d - 1)) ms)
+
+instance UnfolderTransformer BFS where
+  lift = packBFS
+
+-- | Change the order of unfolding to be breadth-first.
+bfs :: Unfolder f => BFS f x -> f x
+bfs (BFS f) = choose (loop 0) where loop d = maybe [] (++ loop (d + 1)) (f d)
+
+packBFS :: f x -> BFS f x
+packBFS r = BFS $ \d -> if d == 0 then Just [r] else Nothing
+
+flattenBFS :: [Maybe [a]] -> Maybe [a]
+flattenBFS ms = case catMaybes ms of
+  [] -> Nothing
+  ms' -> Just (concat ms')
+
+
+-- | A variant of Test.QuickCheck.Gen, with failure 
+-- and a count of the number of recursive positions.
+data Arb a = Arb Int (R.StdGen -> Int -> Maybe a)
+
+instance Functor Arb where
+  fmap f (Arb i g) = Arb i $ fmap (fmap (fmap f)) g
+
+instance Applicative Arb where
+  pure = Arb 0 . pure . pure . pure
+  Arb i1 ff <*> Arb i2 fx = Arb (i1 + i2) $
+    \r -> let (r1, r2) = R.split r in liftA2 (<*>) (ff r1) (fx r2)
+
+instance Alternative Arb where
+  empty = Arb 0 (\_ _ -> Nothing)
+  Arb ia fa <|> Arb ib fb = Arb ((ia + ib + 1) `div` 2) $
+    \r n -> let (r1, r2) = R.split r in flattenArb r1 [fa r2 n, fb r2 n]
+
+-- | Limit the depth of the generated data structure by 
+-- dividing the given size by the number of recursive positions.
+instance Unfolder Arb where
+  choose ms = Arb 1 g
+    where
+      g _ 0 = Nothing
+      g r n = let (r1, r2) = R.split r in 
+        flattenArb r1 $ map (\(Arb i f) -> f r2 (n `div` max i 1)) ms
+
+flattenArb :: R.StdGen -> [Maybe a] -> Maybe a
+flattenArb r ms = case catMaybes ms of
+  [] -> Nothing
+  ms' -> Just $ ms' !! fst (R.randomR (0, length ms' - 1) r)
+
+arbUnit :: Arbitrary a => Arb a
+arbUnit = Arb 0 (\r n -> Just $ unGen arbitrary r n)
+
+-- | Variant of 'Data.Functor.Constant' that does multiplication of the constants for @\<*>@ and addition for @\<|>@.
+newtype NumConst a x = NumConst { getNumConst :: a } deriving (Eq, Show)
+instance Functor (NumConst a) where
+  fmap _ (NumConst a) = NumConst a
+instance Num a => Applicative (NumConst a) where
+  pure _ = NumConst 1
+  NumConst a <*> NumConst b = NumConst $ a * b
+instance Num a => Alternative (NumConst a) where
+  empty = NumConst 0
+  NumConst a <|> NumConst b = NumConst $ a + b
+-- | Unfolds to a constant numeric value. Useful for counting shapes.
+instance Num a => Unfolder (NumConst a) where
+  choose [] = empty
+  choose as = foldr1 (<|>) as

unfoldable.cabal view

@@ -1,44 +1,45 @@-Name:                 unfoldable-Version:              0.6.0-Synopsis:             Class of data structures that can be unfolded.-Description:          Just as there's a Foldable class, there should also be an Unfoldable class. -                      .-                      This package provides one. Example unfolds are:-                      .-                      * Random values-                      .-                      * Enumeration of all values (depth-first or breadth-first)-                      .-                      * Convert from a list-                      .-                      Some examples can be found in the examples directory.-Homepage:             https://github.com/sjoerdvisscher/unfoldable-Bug-reports:          https://github.com/sjoerdvisscher/unfoldable/issues-License:              BSD3-License-file:         LICENSE-Author:               Sjoerd Visscher-Maintainer:           sjoerd@w3future.com-Category:             Generics-Build-type:           Simple-Cabal-version:        >= 1.6--Extra-Source-Files:-  examples/*.hs--Library-  HS-Source-Dirs:  src-  -  Exposed-modules:-    Data.Unfolder-    Data.Unfoldable-    Data.Biunfoldable-  -  Build-depends:-      base         >= 4   && < 5 -    , transformers >= 0.3 && < 0.4-    , random       >= 1.0 && < 1.1-    , QuickCheck   >= 2.4 && < 2.5--source-repository head-  type:     git-  location: git://github.com/sjoerdvisscher/unfoldable.git+Name:                 unfoldable
+Version:              0.6.0.1
+Synopsis:             Class of data structures that can be unfolded.
+Description:          Just as there's a Foldable class, there should also be an Unfoldable class. 
+                      .
+                      This package provides one. Example unfolds are:
+                      .
+                      * Random values
+                      .
+                      * Enumeration of all values (depth-first or breadth-first)
+                      .
+                      * Convert from a list
+                      .
+                      Some examples can be found in the examples directory.
+Homepage:             https://github.com/sjoerdvisscher/unfoldable
+Bug-reports:          https://github.com/sjoerdvisscher/unfoldable/issues
+License:              BSD3
+License-file:         LICENSE
+Author:               Sjoerd Visscher
+Maintainer:           sjoerd@w3future.com
+Category:             Generics
+Build-type:           Simple
+Cabal-version:        >= 1.6
+
+Extra-Source-Files:
+  examples/*.hs
+
+Library
+  HS-Source-Dirs:  src
+  
+  Exposed-modules:
+    Data.Unfolder
+    Data.Unfoldable
+    Data.Biunfoldable
+    Data.Triunfoldable
+  
+  Build-depends:
+      base         >= 4   && < 5 
+    , transformers >= 0.3 && < 0.4
+    , random       >= 1.0 && < 1.1
+    , QuickCheck   >= 2.4 && < 2.6
+
+source-repository head
+  type:     git
+  location: git://github.com/sjoerdvisscher/unfoldable.git