{-# language FlexibleContexts #-}
{-# language CPP #-}

module Test.SmallCheck.Series.Instances.Internal where

import Test.SmallCheck.Series
import Data.Functor.Identity
#if !MIN_VERSION_base(4,8,0)
import Data.Word (Word)
#endif

sets :: (Ord a, Serial m a, Serial Identity a) => Series m [a]
sets :: Series m [a]
sets = do
  Depth
depth <- Series m Depth
forall (m :: * -> *). Series m Depth
getDepth
  let xs :: [a]
xs = Depth -> Series Identity a -> [a]
forall a. Depth -> Series Identity a -> [a]
list Depth
depth Series Identity a
forall (m :: * -> *) a. Serial m a => Series m a
series  -- We are going to generate all subsets of this enumeration.
  Word
i <- (Depth -> Depth) -> Series m Word -> Series m Word
forall (m :: * -> *) a.
(Depth -> Depth) -> Series m a -> Series m a
localDepth (Depth -> Depth -> Depth
forall a b. a -> b -> a
const (Depth
2Depth -> Depth -> Depth
forall a b. (Num a, Integral b) => a -> b -> a
^Depth -> Depth -> Depth
forall a. Ord a => a -> a -> a
min Depth
depth ([a] -> Depth
forall (t :: * -> *) a. Foldable t => t a -> Depth
length [a]
xs) Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
- Depth
1)) Series m Word
forall (m :: * -> *) a. Serial m a => Series m a
series
    -- This complicated expression ensures that a number is chosen from just a
    -- large enough subset of `Word`.
    -- - For finite types, the enumeration `xs` can inherently be no longer than
    --     their cardinality.
    -- - For infinite types, we make sure that `i` has at most `depth` binary
    --     digits.
    -- For the depth of −1 the series for `Word` is empty, and for depth n > 0
    -- it equals {0… n}. So, we adjust depth by −1 to make sure there are
    -- exactly `depth` elements: |{0… n−1}| = n.

  let pattern :: [Bool]
pattern = Word -> [Bool]
binaryExpansion Word
i
      ys :: [a]
ys = ([Bool], [a]) -> [a]
forall a b. (a, b) -> b
snd (([Bool], [a]) -> [a]) -> ([a] -> ([Bool], [a])) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Bool, a)] -> ([Bool], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Bool, a)] -> ([Bool], [a]))
-> ([a] -> [(Bool, a)]) -> [a] -> ([Bool], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, a) -> Bool) -> [(Bool, a)] -> [(Bool, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, a) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, a)] -> [(Bool, a)])
-> ([a] -> [(Bool, a)]) -> [a] -> [(Bool, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [a] -> [(Bool, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
pattern ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
xs
  [a] -> Series m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ys

binaryExpansion :: Word -> [Bool]
binaryExpansion :: Word -> [Bool]
binaryExpansion Word
0 = [ ]
binaryExpansion Word
i = ((Word
i Word -> Word -> Word
forall a. Integral a => a -> a -> a
`mod` Word
2) Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
1)Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Word -> [Bool]
binaryExpansion (Word
i Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` Word
2)