unfoldable 0.4.0 → 0.5.0

raw patch · 6 files changed

+167/−87 lines, 6 filesdep +QuickCheck

Dependencies added: QuickCheck

Files

• examples/btree.hs +1/−1
• examples/tree.hs +1/−1
• src/Data/Unfoldable.hs +20/−12
• src/Data/Unfolder.hs +143/−32
• src/Data/Unfolder/Arbitrary.hs +0/−39
• unfoldable.cabal +2/−2

@@ -21,4 +21,4 @@ btreeShapes = take 5 unfold_  randomBTree :: IO (TB Bool)-randomBTree = getStdRandom randomValue+randomBTree = getStdRandom randomDefault

@@ -22,4 +22,4 @@ treeShapes = take 10 unfoldBF_  randomTree :: IO (Tree Bool)-randomTree = getStdRandom randomValue+randomTree = getStdRandom randomDefault

@@ -26,7 +26,8 @@   , rightMost   , allDepthFirst   , allBreadthFirst-  , randomValue+  , randomDefault+  , arbitraryDefault      )    where@@ -40,6 +41,8 @@ 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.@@ -94,12 +97,12 @@     uncons (a:as) = Just (a, as)  -- | Always choose the first constructor.-leftMost :: Unfoldable t => t ()-leftMost = runIdentity $ getL unfold_+leftMost :: Unfoldable t => Maybe (t ())+leftMost = unfold_  -- | Always choose the last constructor.-rightMost :: Unfoldable t => t ()-rightMost = runIdentity $ getR unfold_+rightMost :: Unfoldable t => Maybe (t ())+rightMost = getDualA unfold_  -- | Generate all the values depth first. allDepthFirst :: Unfoldable t => [t ()]@@ -109,10 +112,15 @@ allBreadthFirst :: Unfoldable t => [t ()] allBreadthFirst = unfoldBF_ --- | Generate a random value, can be used as default instance for Random.-randomValue :: (R.Random a, R.RandomGen g, Unfoldable t) => g -> (t a, g)-randomValue = runState . getRandom . unfold . Random . state $ R.random+-- | 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 f = choose      [ pure []@@ -135,16 +143,16 @@   unfold f = (,) <$> boundedEnum <*> f  instance Unfoldable Identity where-  unfold f = Identity <$> f+  unfold = fmap Identity  instance (Bounded a, Enum a) => Unfoldable (Constant a) where-  unfold _ = Constant <$> boundedEnum+  unfold = fmap Constant . const boundedEnum    instance (Unfoldable p, Unfoldable q) => Unfoldable (Product p q) where   unfold f = Pair <$> unfold f <*> unfold f  instance (Unfoldable p, Unfoldable q) => Unfoldable (Compose p q) where-  unfold f = Compose <$> unfold (unfold f)+  unfold = fmap Compose . unfold . unfold  instance Unfoldable f => Unfoldable (Reverse f) where-  unfold f = Reverse <$> getReverse (unfold (Reverse f))+  unfold = fmap Reverse . getDualA . unfold . DualA

@@ -9,8 +9,9 @@ -- Portability :  non-portable -- -- Unfolders provide a way to unfold data structures.--- They are applicative functors that can perform a choice.--- (Which is basically @Alternative@ without @empty@.)+-- 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@@ -21,46 +22,62 @@      -- * Unfolder     Unfolder(..)-  , chooseAltDefault   , chooseMonadDefault      , boundedEnum      -- ** Unfolder instances-  , Left(..)-  , Right(..)+  , DualA(..)   , Random(..)    , BFS(..)   , runBFS   , packBFS   +  , Arb(..)+  , arbUnit+     )    where   import Control.Applicative-import Data.Functor.Identity+import Control.Monad+import Control.Arrow (ArrowZero, ArrowPlus)+ import Data.Functor.Product import Data.Functor.Compose import Data.Functor.Reverse-import Control.Monad.Trans.Cont+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 Data.Maybe (catMaybes)+import Test.QuickCheck.Arbitrary (Arbitrary(..))+import Test.QuickCheck.Gen (Gen(..)) --- | Unfolders provide a way to unfold data structures. The minimal implementation is 'choose'.-class Applicative f => Unfolder f where+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 an instance of 'Alternative', 'choose' can be implemented in terms of '<|>'.-chooseAltDefault :: (Alternative f, Unfolder f) => [f x] -> f x-chooseAltDefault = foldr (<|>) empty- -- | 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 !!)@@ -72,59 +89,114 @@     lb = fromEnum (minBound :: a)     ub = fromEnum (maxBound :: a) -newtype Left x = L { getL :: Identity x } deriving (Functor, Applicative, Monad)--- | Always choose the first item.-instance Unfolder Left where-  choose = head-  chooseInt _ = pure 0+-- | Derived instance.+instance MonadPlus m => Unfolder (WrappedMonad m) -newtype Right x = R { getR :: Identity x } deriving (Functor, Applicative, Monad)--- | Always choose the last item.-instance Unfolder Right where-  choose = last-  chooseInt n = pure (n - 1)+-- | 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++-- | 'DualA' flips the '(<|>)' operator.+newtype DualA f a = DualA { getDualA :: f a }+  deriving (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+ fstP :: Product p q a -> p a fstP (Pair p _) = p  sndP :: Product p q a -> q a sndP (Pair _ q) = q +-- | Derived instance. instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where   choose ps = Pair (choose $ map fstP ps) (choose $ map sndP ps)   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 -instance Unfolder m => Unfolder (Reverse m) where-  choose = Reverse . choose . reverse . map getReverse-  chooseInt n = Reverse $ (\x -> n - 1 - x) <$> 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 $ fmap (listToMaybe . catMaybes) (mapM runMaybeT ms)+  chooseInt 0 = MaybeT $ return Nothing+  chooseInt _ = MaybeT $ return (Just 0)   -instance (Monad m, Unfolder m) => Unfolder (StateT s m) where-  choose ms = StateT $ \as -> choose $ map (`runStateT` as) ms+-- | 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 -instance Unfolder m => Unfolder (ContT r m) where-  choose ms = ContT $ \k -> choose $ map (`runContT` k) 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) + -- | Return a generator of values of a given depth.---   Returns 'Nothing' if there are no values of that depth or deeper.+-- 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 @@ -136,6 +208,10 @@     [ 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)@@ -150,3 +226,38 @@ 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)

@@ -1,39 +0,0 @@-{-# LANGUAGE -    ScopedTypeVariables-  , GeneralizedNewtypeDeriving-  #-}-module Data.Unfolder.Arbitrary where-  -import Control.Applicative-import Data.Unfoldable-import Data.Unfolder-import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Gen--import Control.Monad.Trans.Reader-import Data.Functor.Constant-import Data.Monoid (Sum(..))---- This is somewhat of a hack. It assumes that choose always chooses from a list of Gen (t a),--- which is true at the top-level, but might not be when recursing.--newtype CountPos a = CountPos { getCountPos :: Constant (Sum Int, Sum Int, [(Int, Int)]) a }-  deriving (Functor, Applicative)-instance Unfolder CountPos where-  choose ms = CountPos . Constant $ -    (Sum 0, Sum 1, map (\(CountPos (Constant (Sum c, Sum r, _))) -> (c, r)) ms)--newtype Arb a = Arb { getArb :: ReaderT [(Int, Int)] Gen a }-  deriving (Functor, Applicative)-instance Unfolder Arb where-  choose ms = Arb (ReaderT f)-    where -      f poss = sized (\n -> oneof . map (resz n) . filter ((<= n) . fst . fst) . zip poss $ ms)-        where-          resz n ((c, r), Arb (ReaderT g)) = resize ((n - c) `div` max r 1) (g poss)--arbitraryDefault :: forall t a. (Unfoldable t, Arbitrary a) => Gen (t a)-arbitraryDefault = flip runReaderT poss . getArb $ unfold (Arb . ReaderT $ const arbitrary)-  where-    CountPos (Constant (_, _, poss)) = -      unfold (CountPos $ Constant (Sum 1, Sum 0, [])) :: CountPos (t ())

@@ -1,5 +1,5 @@ Name:                 unfoldable-Version:              0.4.0+Version:              0.5.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.                        .@@ -24,7 +24,6 @@  Extra-Source-Files:   examples/*.hs-  src/Data/Unfolder/Arbitrary.hs  Library   HS-Source-Dirs:  src@@ -37,6 +36,7 @@       base         >= 4   && < 5      , transformers >= 0.3 && < 0.4     , random       >= 1.0 && < 1.1+    , QuickCheck   >= 2.4 && < 2.5  source-repository head   type:     git