text:
-- vim:fdm=marker:foldtext=foldtext()

--------------------------------------------------------------------
-- |
-- Module    : Test.SmallCheck.Series
-- Copyright : (c) Colin Runciman et al.
-- License   : BSD3
-- Maintainer: Roman Cheplyaka <roma@ro-che.info>
--
-- You need this module if you want to generate test values of your own
-- types.
--
-- You'll typically need the following extensions:
--
-- >{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
--
-- SmallCheck itself defines data generators for all the data types used
-- by the "Prelude".
--
-- In order to generate values and functions of your own types, you need
-- to make them instances of 'Serial' (for values) and 'CoSerial' (for
-- functions). There are two main ways to do so: using Generics or writing
-- the instances by hand.
--------------------------------------------------------------------

{-# LANGUAGE CPP                   #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DefaultSignatures     #-}
#endif
{-# LANGUAGE DeriveFoldable        #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}

#if MIN_VERSION_base(4,8,0)
{-# LANGUAGE Safe                  #-}
#else
{-# LANGUAGE OverlappingInstances  #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Trustworthy           #-}
#endif
#endif

#define HASCBOOL MIN_VERSION_base(4,10,0)

module Test.SmallCheck.Series (
  -- {{{
  -- * Generic instances
  -- | The easiest way to create the necessary instances is to use GHC
  -- generics (available starting with GHC 7.2.1).
  --
  -- Here's a complete example:
  --
  -- >{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
  -- >{-# LANGUAGE DeriveGeneric #-}
  -- >
  -- >import Test.SmallCheck.Series
  -- >import GHC.Generics
  -- >
  -- >data Tree a = Null | Fork (Tree a) a (Tree a)
  -- >    deriving Generic
  -- >
  -- >instance Serial m a => Serial m (Tree a)
  --
  -- Here we enable the @DeriveGeneric@ extension which allows to derive 'Generic'
  -- instance for our data type. Then we declare that @Tree@ @a@ is an instance of
  -- 'Serial', but do not provide any definitions. This causes GHC to use the
  -- default definitions that use the 'Generic' instance.
  --
  -- One minor limitation of generic instances is that there's currently no
  -- way to distinguish newtypes and datatypes. Thus, newtype constructors
  -- will also count as one level of depth.

  -- * Data Generators
  -- | Writing 'Serial' instances for application-specific types is
  -- straightforward. You need to define a 'series' generator, typically using
  -- @consN@ family of generic combinators where N is constructor arity.
  --
  -- For example:
  --
  -- >data Tree a = Null | Fork (Tree a) a (Tree a)
  -- >
  -- >instance Serial m a => Serial m (Tree a) where
  -- >  series = cons0 Null \/ cons3 Fork
  --
  -- For newtypes use 'newtypeCons' instead of 'cons1'.
  -- The difference is that 'cons1' is counts as one level of depth, while
  -- 'newtypeCons' doesn't affect the depth.
  --
  -- >newtype Light a = Light a
  -- >
  -- >instance Serial m a => Serial m (Light a) where
  -- >  series = newtypeCons Light
  --
  -- For data types with more than 6 fields define @consN@ as
  --
  -- >consN f = decDepth $
  -- >  f <$> series
  -- >    <~> series
  -- >    <~> series
  -- >    <~> ...    {- series repeated N times in total -}

  -- ** What does @consN@ do, exactly?

  -- | @consN@ has type
  -- @(Serial t₁, ..., Serial tₙ) => (t₁ -> ... -> tₙ -> t) -> Series t@.
  --
  -- @consN@ @f@ is a series which, for a given depth \(d > 0\), produces values of the
  -- form
  --
  -- >f x₁ ... xₙ
  --
  -- where @xₖ@ ranges over all values of type @tₖ@ of depth up to \(d-1\)
  -- (as defined by the 'series' functions for @tₖ@).
  --
  -- @consN@ functions also ensure that xₖ are enumerated in the
  -- breadth-first order. Thus, combinations of smaller depth come first
  -- (assuming the same is true for @tₖ@).
  --
  -- If \(d \le 0\), no values are produced.

  cons0, cons1, cons2, cons3, cons4, cons5, cons6, newtypeCons,
  -- * Function Generators

  -- | To generate functions of an application-specific argument type,
  -- make the type an instance of 'CoSerial'.
  --
  -- Again there is a standard pattern, this time using the @altsN@
  -- combinators where again N is constructor arity.  Here are @Tree@ and
  -- @Light@ instances:
  --
  --
  -- >instance CoSerial m a => CoSerial m (Tree a) where
  -- >  coseries rs =
  -- >    alts0 rs >>- \z ->
  -- >    alts3 rs >>- \f ->
  -- >    return $ \t ->
  -- >      case t of
  -- >        Null -> z
  -- >        Fork t1 x t2 -> f t1 x t2
  --
  -- >instance CoSerial m a => CoSerial m (Light a) where
  -- >  coseries rs =
  -- >    newtypeAlts rs >>- \f ->
  -- >    return $ \l ->
  -- >      case l of
  -- >        Light x -> f x
  --
  -- For data types with more than 6 fields define @altsN@ as
  --
  -- >altsN rs = do
  -- >  rs <- fixDepth rs
  -- >  decDepthChecked
  -- >    (constM $ constM $ ... $ constM rs)
  -- >    (coseries $ coseries $ ... $ coseries rs)
  -- >    {- constM and coseries are repeated N times each -}

  -- ** What does altsN do, exactly?

  -- | @altsN@ has type
  -- @(Serial t₁, ..., Serial tₙ) => Series t -> Series (t₁ -> ... -> tₙ -> t)@.
  --
  -- @altsN@ @s@ is a series which, for a given depth \( d \), produces functions of
  -- type
  --
  -- >t₁ -> ... -> tₙ -> t
  --
  -- If \( d \le 0 \), these are constant functions, one for each value produced
  -- by @s@.
  --
  -- If \( d > 0 \), these functions inspect each of their arguments up to the depth
  -- \( d-1 \) (as defined by the 'coseries' functions for the corresponding
  -- types) and return values produced by @s@. The depth to which the
  -- values are enumerated does not depend on the depth of inspection.

  alts0, alts1, alts2, alts3, alts4, alts5, alts6, newtypeAlts,

  -- * Basic definitions
  Depth, Series, Serial(..), CoSerial(..),

#if __GLASGOW_HASKELL__ >= 702
  -- * Generic implementations
  genericSeries,
  genericCoseries,
#endif

  -- * Convenient wrappers
  Positive(..), NonNegative(..), NonZero(..), NonEmpty(..),

  -- * Other useful definitions
  (\/), (><), (<~>), (>>-),
  localDepth,
  decDepth,
  getDepth,
  generate,
  limit,
  listSeries,
  list,
  listM,
  fixDepth,
  decDepthChecked,
  constM
  -- }}}
  ) where

import Control.Monad (liftM, guard, mzero, mplus, msum)
import Control.Monad.Logic (MonadLogic, (>>-), interleave, msplit, observeAllT)
import Control.Monad.Reader (ask, local)
import Control.Applicative (empty, pure, (<$>), (<|>))
import Data.Complex (Complex(..))
import Data.Foldable (Foldable)
import Data.Functor.Compose (Compose(..))
import Data.Void (Void, absurd)
import Control.Monad.Identity (Identity(..))
import Data.Int (Int, Int8, Int16, Int32, Int64)
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NE
import Data.Ratio (Ratio, numerator, denominator, (%))
import Data.Traversable (Traversable)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import Foreign.C.Types (CFloat(..), CDouble(..), CChar(..), CSChar(..), CUChar(..), CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..), CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..), CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..), CClock(..), CTime(..))
#if __GLASGOW_HASKELL__ >= 702
import Foreign.C.Types (CUSeconds(..), CSUSeconds(..))
#endif
#if HASCBOOL
import Foreign.C.Types (CBool(..))
#endif
import Numeric.Natural (Natural)
import Test.SmallCheck.SeriesMonad
#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic, (:+:)(..), (:*:)(..), C1, K1(..), M1(..), U1(..), V1(..), Rep, to, from)
#endif

------------------------------
-- Main types and classes
------------------------------
--{{{

class Monad m => Serial m a where
  series   :: Series m a

#if __GLASGOW_HASKELL__ >= 704
  default series :: (Generic a, GSerial m (Rep a)) => Series m a
  series = genericSeries
#endif

#if __GLASGOW_HASKELL__ >= 702
genericSeries
  :: (Monad m, Generic a, GSerial m (Rep a))
  => Series m a
genericSeries = to <$> gSeries
#endif

class Monad m => CoSerial m a where
  -- | A proper 'coseries' implementation should pass the depth unchanged to
  -- its first argument. Doing otherwise will make enumeration of curried
  -- functions non-uniform in their arguments.
  coseries :: Series m b -> Series m (a->b)

#if __GLASGOW_HASKELL__ >= 704
  default coseries :: (Generic a, GCoSerial m (Rep a)) => Series m b -> Series m (a->b)
  coseries = genericCoseries
#endif

#if __GLASGOW_HASKELL__ >= 702
genericCoseries
  :: (Monad m, Generic a, GCoSerial m (Rep a))
  => Series m b -> Series m (a->b)
genericCoseries rs = (. from) <$> gCoseries rs
#endif

-- }}}

------------------------------
-- Helper functions
------------------------------
-- {{{

-- | A simple series specified by a function from depth to the list of
-- values up to that depth.
generate :: (Depth -> [a]) -> Series m a
generate f = do
  d <- getDepth
  msum $ map return $ f d

-- | Limit a 'Series' to its first @n@ elements.
limit :: forall m a . Monad m => Int -> Series m a -> Series m a
limit n0 (Series s) = Series $ go n0 s
  where
    go 0 _ = empty
    go n mb1 = do
      cons :: Maybe (b, ml b) <- msplit mb1
      case cons of
        Nothing -> empty
        Just (b, mb2) -> return b <|> go (n-1) mb2

suchThat :: Series m a -> (a -> Bool) -> Series m a
suchThat s p = s >>= \x -> if p x then pure x else empty

-- | Given a depth, return the list of values generated by a 'Serial' instance.
--
-- For example, list all integers up to depth 1:
--
-- * @listSeries 1 :: [Int]   -- returns [0,1,-1]@
listSeries :: Serial Identity a => Depth -> [a]
listSeries d = list d series

-- | Return the list of values generated by a 'Series'. Useful for
-- debugging 'Serial' instances.
--
-- Examples:
--
-- * @'list' 3 'series' :: ['Int']                  -- returns [0,1,-1,2,-2,3,-3]@
--
-- * @'list' 3 ('series' :: 'Series' 'Data.Functor.Identity' 'Int')  -- returns [0,1,-1,2,-2,3,-3]@
--
-- * @'list' 2 'series' :: [['Bool']]               -- returns [[],['True'],['False']]@
--
-- The first two are equivalent. The second has a more explicit type binding.
list :: Depth -> Series Identity a -> [a]
list d s = runIdentity $ observeAllT $ runSeries d s

-- | Monadic version of 'list'.
listM d s = observeAllT $ runSeries d s

-- | Sum (union) of series.
infixr 7 \/
(\/) :: Monad m => Series m a -> Series m a -> Series m a
(\/) = interleave

-- | Product of series
infixr 8 ><
(><) :: Monad m => Series m a -> Series m b -> Series m (a,b)
a >< b = (,) <$> a <~> b

-- | Fair version of 'Control.Applicative.ap' and '<*>'.
infixl 4 <~>
(<~>) :: Monad m => Series m (a -> b) -> Series m a -> Series m b
a <~> b = a >>- (<$> b)

uncurry3 :: (a->b->c->d) -> ((a,b,c)->d)
uncurry3 f (x,y,z) = f x y z

uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e)
uncurry4 f (w,x,y,z) = f w x y z

uncurry5 :: (a->b->c->d->e->f) -> ((a,b,c,d,e)->f)
uncurry5 f (v,w,x,y,z) = f v w x y z

uncurry6 :: (a->b->c->d->e->f->g) -> ((a,b,c,d,e,f)->g)
uncurry6 f (u,v,w,x,y,z) = f u v w x y z

-- | Query the current depth.
getDepth :: Series m Depth
getDepth = Series ask

-- | Run a series with a modified depth.
localDepth :: (Depth -> Depth) -> Series m a -> Series m a
localDepth f (Series a) = Series $ local f a

-- | Run a 'Series' with the depth decreased by 1.
--
-- If the current depth is less or equal to 0, the result is 'empty'.
decDepth :: Series m a -> Series m a
decDepth a = do
  checkDepth
  localDepth (subtract 1) a

checkDepth :: Series m ()
checkDepth = do
  d <- getDepth
  guard $ d > 0

-- | @'constM' = 'liftM' 'const'@
constM :: Monad m => m b -> m (a -> b)
constM = liftM const

-- | Fix the depth of a series at the current level. The resulting series
-- will no longer depend on the \"ambient\" depth.
fixDepth :: Series m a -> Series m (Series m a)
fixDepth s = getDepth >>= \d -> return $ localDepth (const d) s

-- | If the current depth is 0, evaluate the first argument. Otherwise,
-- evaluate the second argument with decremented depth.
decDepthChecked :: Series m a -> Series m a -> Series m a
decDepthChecked b r = do
  d <- getDepth
  if d <= 0
    then b
    else decDepth r

unwind :: MonadLogic m => m a -> m [a]
unwind a =
  msplit a >>=
  maybe (return []) (\(x,a') -> (x:) `liftM` unwind a')

-- }}}

------------------------------
-- cons* and alts* functions
------------------------------
-- {{{

cons0 :: a -> Series m a
cons0 x = decDepth $ pure x

cons1 :: Serial m a => (a->b) -> Series m b
cons1 f = decDepth $ f <$> series

-- | Same as 'cons1', but preserves the depth.
newtypeCons :: Serial m a => (a->b) -> Series m b
newtypeCons f = f <$> series

cons2 :: (Serial m a, Serial m b) => (a->b->c) -> Series m c
cons2 f = decDepth $ f <$> series <~> series

cons3 :: (Serial m a, Serial m b, Serial m c) =>
         (a->b->c->d) -> Series m d
cons3 f = decDepth $
  f <$> series
    <~> series
    <~> series

cons4 :: (Serial m a, Serial m b, Serial m c, Serial m d) =>
         (a->b->c->d->e) -> Series m e
cons4 f = decDepth $
  f <$> series
    <~> series
    <~> series
    <~> series

cons5 :: (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e) =>
         (a->b->c->d->e->f) -> Series m f
cons5 f = decDepth $
  f <$> series
    <~> series
    <~> series
    <~> series
    <~> series

cons6 :: (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e, Serial m f) =>
         (a->b->c->d->e->f->g) -> Series m g
cons6 f = decDepth $
  f <$> series
    <~> series
    <~> series
    <~> series
    <~> series
    <~> series

alts0 :: Series m a -> Series m a
alts0 s = s

alts1 :: CoSerial m a => Series m b -> Series m (a->b)
alts1 rs = do
  rs <- fixDepth rs
  decDepthChecked (constM rs) (coseries rs)

alts2
  :: (CoSerial m a, CoSerial m b)
  => Series m c -> Series m (a->b->c)
alts2 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM rs)
    (coseries $ coseries rs)

alts3 ::  (CoSerial m a, CoSerial m b, CoSerial m c) =>
            Series m d -> Series m (a->b->c->d)
alts3 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM rs)
    (coseries $ coseries $ coseries rs)

alts4 ::  (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d) =>
            Series m e -> Series m (a->b->c->d->e)
alts4 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM $ constM rs)
    (coseries $ coseries $ coseries $ coseries rs)

alts5 ::  (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e) =>
            Series m f -> Series m (a->b->c->d->e->f)
alts5 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM $ constM $ constM rs)
    (coseries $ coseries $ coseries $ coseries $ coseries rs)

alts6 ::  (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e, CoSerial m f) =>
            Series m g -> Series m (a->b->c->d->e->f->g)
alts6 rs = do
  rs <- fixDepth rs
  decDepthChecked
    (constM $ constM $ constM $ constM $ constM $ constM rs)
    (coseries $ coseries $ coseries $ coseries $ coseries $ coseries rs)

-- | Same as 'alts1', but preserves the depth.
newtypeAlts :: CoSerial m a => Series m b -> Series m (a->b)
newtypeAlts = coseries

-- }}}

------------------------------
-- Generic instances
------------------------------
-- {{{

class GSerial m f where
  gSeries :: Series m (f a)
class GCoSerial m f where
  gCoseries :: Series m b -> Series m (f a -> b)

#if __GLASGOW_HASKELL__ >= 702
instance {-# OVERLAPPABLE #-} GSerial m f => GSerial m (M1 i c f) where
  gSeries = M1 <$> gSeries
  {-# INLINE gSeries #-}
instance GCoSerial m f => GCoSerial m (M1 i c f) where
  gCoseries rs = (. unM1) <$> gCoseries rs
  {-# INLINE gCoseries #-}

instance Serial m c => GSerial m (K1 i c) where
  gSeries = K1 <$> series
  {-# INLINE gSeries #-}
instance CoSerial m c => GCoSerial m (K1 i c) where
  gCoseries rs = (. unK1) <$> coseries rs
  {-# INLINE gCoseries #-}

instance GSerial m U1 where
  gSeries = pure U1
  {-# INLINE gSeries #-}
instance GCoSerial m U1 where
  gCoseries rs = constM rs
  {-# INLINE gCoseries #-}

instance GSerial m V1 where
  gSeries = mzero
  {-# INLINE gSeries #-}
instance GCoSerial m V1 where
  gCoseries = const $ return (\a -> a `seq` let x = x in x)
  {-# INLINE gCoseries #-}

instance (Monad m, GSerial m a, GSerial m b) => GSerial m (a :*: b) where
  gSeries = (:*:) <$> gSeries <~> gSeries
  {-# INLINE gSeries #-}
instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :*: b) where
  gCoseries rs = uncur <$> gCoseries (gCoseries rs)
      where
        uncur f (x :*: y) = f x y
  {-# INLINE gCoseries #-}

instance (Monad m, GSerial m a, GSerial m b) => GSerial m (a :+: b) where
  gSeries = (L1 <$> gSeries) `interleave` (R1 <$> gSeries)
  {-# INLINE gSeries #-}
instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :+: b) where
  gCoseries rs =
    gCoseries rs >>- \f ->
    gCoseries rs >>- \g ->
    return $
    \e -> case e of
      L1 x -> f x
      R1 y -> g y
  {-# INLINE gCoseries #-}

instance {-# OVERLAPPING #-} GSerial m f => GSerial m (C1 c f) where
  gSeries = M1 <$> decDepth gSeries
  {-# INLINE gSeries #-}
#endif

-- }}}

------------------------------
-- Instances for basic types
------------------------------
-- {{{
instance Monad m => Serial m () where
  series = return ()
instance Monad m => CoSerial m () where
  coseries rs = constM rs

instance Monad m => Serial m Integer where series = unM <$> series
instance Monad m => CoSerial m Integer where coseries = fmap (. M) . coseries
instance Monad m => Serial m Natural where series = unN <$> series
instance Monad m => CoSerial m Natural where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int where series = unM <$> series
instance Monad m => CoSerial m Int where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word where series = unN <$> series
instance Monad m => CoSerial m Word where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int8 where series = unM <$> series
instance Monad m => CoSerial m Int8 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word8 where series = unN <$> series
instance Monad m => CoSerial m Word8 where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int16 where series = unM <$> series
instance Monad m => CoSerial m Int16 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word16 where series = unN <$> series
instance Monad m => CoSerial m Word16 where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int32 where series = unM <$> series
instance Monad m => CoSerial m Int32 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word32 where series = unN <$> series
instance Monad m => CoSerial m Word32 where coseries = fmap (. N) . coseries
instance Monad m => Serial m Int64 where series = unM <$> series
instance Monad m => CoSerial m Int64 where coseries = fmap (. M) . coseries
instance Monad m => Serial m Word64 where series = unN <$> series
instance Monad m => CoSerial m Word64 where coseries = fmap (. N) . coseries

-- | 'N' is a wrapper for 'Integral' types that causes only non-negative values
-- to be generated. Generated functions of type @N a -> b@ do not distinguish
-- different negative values of @a@.
newtype N a = N { unN :: a } deriving (Eq, Ord, Show)

instance Real a => Real (N a) where
  toRational (N x) = toRational x

instance Enum a => Enum (N a) where
  toEnum x = N (toEnum x)
  fromEnum (N x) = fromEnum x

instance Num a => Num (N a) where
  N x + N y = N (x + y)
  N x * N y = N (x * y)
  negate (N x) = N (negate x)
  abs (N x) = N (abs x)
  signum (N x) = N (signum x)
  fromInteger x = N (fromInteger x)

instance Integral a => Integral (N a) where
  quotRem (N x) (N y) = (N q, N r)
    where
      (q, r) = x `quotRem` y
  toInteger (N x) = toInteger x

instance (Num a, Enum a, Serial m a) => Serial m (N a) where
  series = generate $ \d -> take (d+1) [0..]

instance (Integral a, Monad m) => CoSerial m (N a) where
  coseries rs =
    -- This is a recursive function, because @alts1 rs@ typically calls
    -- back to 'coseries' (but with lower depth).
    --
    -- The recursion stops when depth == 0. Then alts1 produces a constant
    -- function, and doesn't call back to 'coseries'.
    alts0 rs >>- \z ->
    alts1 rs >>- \f ->
    return $ \(N i) ->
      if i > 0
        then f (N $ i-1)
        else z

-- | 'M' is a helper type to generate values of a signed type of increasing magnitude.
newtype M a = M { unM :: a } deriving (Eq, Ord, Show)

instance Real a => Real (M a) where
  toRational (M x) = toRational x

instance Enum a => Enum (M a) where
  toEnum x = M (toEnum x)
  fromEnum (M x) = fromEnum x

instance Num a => Num (M a) where
  M x + M y = M (x + y)
  M x * M y = M (x * y)
  negate (M x) = M (negate x)
  abs (M x) = M (abs x)
  signum (M x) = M (signum x)
  fromInteger x = M (fromInteger x)

instance Integral a => Integral (M a) where
  quotRem (M x) (M y) = (M q, M r)
    where
      (q, r) = x `quotRem` y
  toInteger (M x) = toInteger x

instance (Num a, Enum a, Monad m) => Serial m (M a) where
  series = others `interleave` positives
    where positives = generate $ \d -> take d [1..]
          others = generate $ \d -> take (d+1) [0,-1..]

instance (Ord a, Num a, Monad m) => CoSerial m (M a) where
  coseries rs =
    alts0 rs >>- \z ->
    alts1 rs >>- \f ->
    alts1 rs >>- \g ->
    pure $ \ i -> case compare i 0 of
        GT -> f (M (i - 1))
        LT -> g (M (abs i - 1))
        EQ -> z

instance Monad m => Serial m Float where
  series =
    series >>- \(sig, exp) ->
    guard (odd sig || sig==0 && exp==0) >>
    return (encodeFloat sig exp)
instance Monad m => CoSerial m Float where
  coseries rs =
    coseries rs >>- \f ->
      return $ f . decodeFloat

instance Monad m => Serial m Double where
  series = (realToFrac :: Float -> Double) <$> series
instance Monad m => CoSerial m Double where
  coseries rs =
    (. (realToFrac :: Double -> Float)) <$> coseries rs

instance (Integral i, Serial m i) => Serial m (Ratio i) where
  series = pairToRatio <$> series
    where
      pairToRatio (n, Positive d) = n % d
instance (Integral i, CoSerial m i) => CoSerial m (Ratio i) where
  coseries rs = (. ratioToPair) <$> coseries rs
    where
      ratioToPair r = (numerator r, denominator r)

instance Monad m => Serial m Char where
  series = generate $ \d -> take (d+1) ['a'..'z']
instance Monad m => CoSerial m Char where
  coseries rs =
    coseries rs >>- \f ->
    return $ \c -> f (N (fromEnum c - fromEnum 'a'))

instance (Serial m a, Serial m b) => Serial m (a,b) where
  series = cons2 (,)
instance (CoSerial m a, CoSerial m b) => CoSerial m (a,b) where
  coseries rs = uncurry <$> alts2 rs

instance (Serial m a, Serial m b, Serial m c) => Serial m (a,b,c) where
  series = cons3 (,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c) => CoSerial m (a,b,c) where
  coseries rs = uncurry3 <$> alts3 rs

instance (Serial m a, Serial m b, Serial m c, Serial m d) => Serial m (a,b,c,d) where
  series = cons4 (,,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d) => CoSerial m (a,b,c,d) where
  coseries rs = uncurry4 <$> alts4 rs

instance (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e) => Serial m (a,b,c,d,e) where
  series = cons5 (,,,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e) => CoSerial m (a,b,c,d,e) where
  coseries rs = uncurry5 <$> alts5 rs

instance (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e, Serial m f) => Serial m (a,b,c,d,e,f) where
  series = cons6 (,,,,,)
instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e, CoSerial m f) => CoSerial m (a,b,c,d,e,f) where
  coseries rs = uncurry6 <$> alts6 rs

instance Monad m => Serial m Bool where
  series = cons0 True \/ cons0 False
instance Monad m => CoSerial m Bool where
  coseries rs =
    rs >>- \r1 ->
    rs >>- \r2 ->
    return $ \x -> if x then r1 else r2

instance Monad m => Serial m Ordering where
  series = cons0 LT \/ cons0 EQ \/ cons0 GT
instance Monad m => CoSerial m Ordering where
  coseries rs =
    rs >>- \r1 ->
    rs >>- \r2 ->
    rs >>- \r3 ->
    pure $ \x -> case x of
        LT -> r1
        EQ -> r2
        GT -> r3

instance (Serial m a) => Serial m (Maybe a) where
  series = cons0 Nothing \/ cons1 Just
instance (CoSerial m a) => CoSerial m (Maybe a) where
  coseries rs =
    maybe <$> alts0 rs <~> alts1 rs

instance (Serial m a, Serial m b) => Serial m (Either a b) where
  series = cons1 Left \/ cons1 Right
instance (CoSerial m a, CoSerial m b) => CoSerial m (Either a b) where
  coseries rs =
    either <$> alts1 rs <~> alts1 rs

instance Serial m a => Serial m [a] where
  series = cons0 [] \/ cons2 (:)
instance CoSerial m a => CoSerial m [a] where
  coseries rs =
    alts0 rs >>- \y ->
    alts2 rs >>- \f ->
    return $ \xs -> case xs of [] -> y; x:xs' -> f x xs'

instance Serial m a => Serial m (NE.NonEmpty a) where
  series = cons2 (NE.:|)

instance CoSerial m a => CoSerial m (NE.NonEmpty a) where
  coseries rs =
    alts2 rs >>- \f ->
    return $ \(x NE.:| xs') -> f x xs'

#if MIN_VERSION_base(4,4,0)
instance Serial m a => Serial m (Complex a) where
#else
instance (RealFloat a, Serial m a) => Serial m (Complex a) where
#endif
  series = cons2 (:+)

#if MIN_VERSION_base(4,4,0)
instance CoSerial m a => CoSerial m (Complex a) where
#else
instance (RealFloat a, CoSerial m a) => CoSerial m (Complex a) where
#endif
  coseries rs =
    alts2 rs >>- \f ->
    return $ \(x :+ xs') -> f x xs'

instance Monad m => Serial m Void where
  series = mzero

instance Monad m => CoSerial m Void where
  coseries = const $ return absurd

instance (CoSerial m a, Serial m b) => Serial m (a->b) where
  series = coseries series
-- Thanks to Ralf Hinze for the definition of coseries
-- using the nest auxiliary.
instance (Serial m a, CoSerial m a, Serial m b, CoSerial m b) => CoSerial m (a->b) where
  coseries r = do
    args <- unwind series

    g <- nest r args
    return $ \f -> g $ map f args

    where

    nest :: forall a b m c . (Serial m b, CoSerial m b) => Series m c -> [a] -> Series m ([b] -> c)
    nest rs args = do
      case args of
        [] -> const `liftM` rs
        _:rest -> do
          let sf = coseries $ nest rs rest
          f <- sf
          return $ \(b:bs) -> f b bs

-- show the extension of a function (in part, bounded both by
-- the number and depth of arguments)
instance (Serial Identity a, Show a, Show b) => Show (a -> b) where
  show f =
    if maxarheight == 1
    && sumarwidth + length ars * length "->;" < widthLimit then
      "{"++
      intercalate ";" [a++"->"++r | (a,r) <- ars]
      ++"}"
    else
      concat $ [a++"->\n"++indent r | (a,r) <- ars]
    where
    ars = take lengthLimit [ (show x, show (f x))
                           | x <- list depthLimit series ]
    maxarheight = maximum  [ max (height a) (height r)
                           | (a,r) <- ars ]
    sumarwidth = sum       [ length a + length r
                           | (a,r) <- ars]
    indent = unlines . map ("  "++) . lines
    height = length . lines
    (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Depth)

instance (Monad m, Serial m (f (g a))) => Serial m (Compose f g a) where
  series = Compose <$> series
instance (Monad m, CoSerial m (f (g a))) => CoSerial m (Compose f g a) where
  coseries = fmap (. getCompose) . coseries

-- }}}

------------------------------
-- Convenient wrappers
------------------------------
-- {{{

--------------------------------------------------------------------------
-- | 'Positive' @x@ guarantees that \( x > 0 \).
newtype Positive a = Positive { getPositive :: a }
 deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Real a => Real (Positive a) where
  toRational (Positive x) = toRational x

instance (Num a, Bounded a) => Bounded (Positive a) where
  minBound = Positive 1
  maxBound = Positive (maxBound :: a)

instance Enum a => Enum (Positive a) where
  toEnum x = Positive (toEnum x)
  fromEnum (Positive x) = fromEnum x

instance Num a => Num (Positive a) where
  Positive x + Positive y = Positive (x + y)
  Positive x * Positive y = Positive (x * y)
  negate (Positive x) = Positive (negate x)
  abs (Positive x) = Positive (abs x)
  signum (Positive x) = Positive (signum x)
  fromInteger x = Positive (fromInteger x)

instance Integral a => Integral (Positive a) where
  quotRem (Positive x) (Positive y) = (Positive q, Positive r)
    where
      (q, r) = x `quotRem` y
  toInteger (Positive x) = toInteger x

instance (Num a, Ord a, Serial m a) => Serial m (Positive a) where
  series = Positive <$> series `suchThat` (> 0)

instance Show a => Show (Positive a) where
  showsPrec n (Positive x) = showsPrec n x

-- | 'NonNegative' @x@ guarantees that \( x \ge 0 \).
newtype NonNegative a = NonNegative { getNonNegative :: a }
 deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Real a => Real (NonNegative a) where
  toRational (NonNegative x) = toRational x

instance (Num a, Bounded a) => Bounded (NonNegative a) where
  minBound = NonNegative 0
  maxBound = NonNegative (maxBound :: a)

instance Enum a => Enum (NonNegative a) where
  toEnum x = NonNegative (toEnum x)
  fromEnum (NonNegative x) = fromEnum x

instance Num a => Num (NonNegative a) where
  NonNegative x + NonNegative y = NonNegative (x + y)
  NonNegative x * NonNegative y = NonNegative (x * y)
  negate (NonNegative x) = NonNegative (negate x)
  abs (NonNegative x) = NonNegative (abs x)
  signum (NonNegative x) = NonNegative (signum x)
  fromInteger x = NonNegative (fromInteger x)

instance Integral a => Integral (NonNegative a) where
  quotRem (NonNegative x) (NonNegative y) = (NonNegative q, NonNegative r)
    where
      (q, r) = x `quotRem` y
  toInteger (NonNegative x) = toInteger x

instance (Num a, Ord a, Serial m a) => Serial m (NonNegative a) where
  series = NonNegative <$> series `suchThat` (>= 0)

instance Show a => Show (NonNegative a) where
  showsPrec n (NonNegative x) = showsPrec n x

-- | 'NonZero' @x@ guarantees that \( x \ne 0 \).
newtype NonZero a = NonZero { getNonZero :: a }
 deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Real a => Real (NonZero a) where
  toRational (NonZero x) = toRational x

instance (Eq a, Num a, Bounded a) => Bounded (NonZero a) where
  minBound = let x = minBound in NonZero (if x == 0 then  1 else x)
  maxBound = let x = maxBound in NonZero (if x == 0 then -1 else x)

instance Enum a => Enum (NonZero a) where
  toEnum x = NonZero (toEnum x)
  fromEnum (NonZero x) = fromEnum x

instance Num a => Num (NonZero a) where
  NonZero x + NonZero y = NonZero (x + y)
  NonZero x * NonZero y = NonZero (x * y)
  negate (NonZero x) = NonZero (negate x)
  abs (NonZero x) = NonZero (abs x)
  signum (NonZero x) = NonZero (signum x)
  fromInteger x = NonZero (fromInteger x)

instance Integral a => Integral (NonZero a) where
  quotRem (NonZero x) (NonZero y) = (NonZero q, NonZero r)
    where
      (q, r) = x `quotRem` y
  toInteger (NonZero x) = toInteger x

instance (Num a, Ord a, Serial m a) => Serial m (NonZero a) where
  series = NonZero <$> series `suchThat` (/= 0)

instance Show a => Show (NonZero a) where
  showsPrec n (NonZero x) = showsPrec n x

-- | 'NonEmpty' @xs@ guarantees that @xs@ is not null.
newtype NonEmpty a = NonEmpty { getNonEmpty :: [a] }

instance (Serial m a) => Serial m (NonEmpty a) where
  series = NonEmpty <$> cons2 (:)

instance Show a => Show (NonEmpty a) where
  showsPrec n (NonEmpty x) = showsPrec n x

-- }}}

------------------------------
-- Foreign.C.Types
------------------------------
-- {{{

#if MIN_VERSION_base(4,5,0)
instance Monad m => Serial m CFloat where
  series = newtypeCons CFloat
instance Monad m => CoSerial m CFloat where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CFloat x -> f x

instance Monad m => Serial m CDouble where
  series = newtypeCons CDouble
instance Monad m => CoSerial m CDouble where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CDouble x -> f x

#if HASCBOOL
instance Monad m => Serial m CBool where
  series = newtypeCons CBool
instance Monad m => CoSerial m CBool where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CBool x -> f x
#endif

instance Monad m => Serial m CChar where
  series = newtypeCons CChar
instance Monad m => CoSerial m CChar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CChar x -> f x

instance Monad m => Serial m CSChar where
  series = newtypeCons CSChar
instance Monad m => CoSerial m CSChar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSChar x -> f x

instance Monad m => Serial m CUChar where
  series = newtypeCons CUChar
instance Monad m => CoSerial m CUChar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUChar x -> f x

instance Monad m => Serial m CShort where
  series = newtypeCons CShort
instance Monad m => CoSerial m CShort where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CShort x -> f x

instance Monad m => Serial m CUShort where
  series = newtypeCons CUShort
instance Monad m => CoSerial m CUShort where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUShort x -> f x

instance Monad m => Serial m CInt where
  series = newtypeCons CInt
instance Monad m => CoSerial m CInt where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CInt x -> f x

instance Monad m => Serial m CUInt where
  series = newtypeCons CUInt
instance Monad m => CoSerial m CUInt where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUInt x -> f x

instance Monad m => Serial m CLong where
  series = newtypeCons CLong
instance Monad m => CoSerial m CLong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CLong x -> f x

instance Monad m => Serial m CULong where
  series = newtypeCons CULong
instance Monad m => CoSerial m CULong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CULong x -> f x

instance Monad m => Serial m CPtrdiff where
  series = newtypeCons CPtrdiff
instance Monad m => CoSerial m CPtrdiff where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CPtrdiff x -> f x

instance Monad m => Serial m CSize where
  series = newtypeCons CSize
instance Monad m => CoSerial m CSize where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSize x -> f x

instance Monad m => Serial m CWchar where
  series = newtypeCons CWchar
instance Monad m => CoSerial m CWchar where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CWchar x -> f x

instance Monad m => Serial m CSigAtomic where
  series = newtypeCons CSigAtomic
instance Monad m => CoSerial m CSigAtomic where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSigAtomic x -> f x

instance Monad m => Serial m CLLong where
  series = newtypeCons CLLong
instance Monad m => CoSerial m CLLong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CLLong x -> f x

instance Monad m => Serial m CULLong where
  series = newtypeCons CULLong
instance Monad m => CoSerial m CULLong where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CULLong x -> f x

instance Monad m => Serial m CIntPtr where
  series = newtypeCons CIntPtr
instance Monad m => CoSerial m CIntPtr where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CIntPtr x -> f x

instance Monad m => Serial m CUIntPtr where
  series = newtypeCons CUIntPtr
instance Monad m => CoSerial m CUIntPtr where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUIntPtr x -> f x

instance Monad m => Serial m CIntMax where
  series = newtypeCons CIntMax
instance Monad m => CoSerial m CIntMax where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CIntMax x -> f x

instance Monad m => Serial m CUIntMax where
  series = newtypeCons CUIntMax
instance Monad m => CoSerial m CUIntMax where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUIntMax x -> f x

instance Monad m => Serial m CClock where
  series = newtypeCons CClock
instance Monad m => CoSerial m CClock where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CClock x -> f x

instance Monad m => Serial m CTime where
  series = newtypeCons CTime
instance Monad m => CoSerial m CTime where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CTime x -> f x

instance Monad m => Serial m CUSeconds where
  series = newtypeCons CUSeconds
instance Monad m => CoSerial m CUSeconds where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUSeconds x -> f x

instance Monad m => Serial m CSUSeconds where
  series = newtypeCons CSUSeconds
instance Monad m => CoSerial m CSUSeconds where
  coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSUSeconds x -> f x
#endif

-- }}}

max_issues_repo_name: feuerbach/smallcheck


text:
{- |
This module provides normalized versions of the transforms in @fftw@.

All of the transforms are normalized so that

 - Each transform is unitary, i.e., preserves the inner product and the sum-of-squares norm of its input.

 - Each backwards transform is the inverse of the corresponding forwards transform.

(Both conditions only hold approximately, due to floating point precision.)

For more information on the underlying transforms, see
<http://www.fftw.org/fftw3_doc/What-FFTW-Really-Computes.html>.
--
-- @since 0.2
-}

module Numeric.FFT.Vector.Unitary.Multi
  (
        -- * Creating and executing 'Plan's
        run,
        plan,
        execute,
        -- * Complex-to-complex transforms
        dft,
        idft,
        -- * Real-to-complex transforms
        dftR2C,
        dftC2R,
  ) where

import Control.Exception (assert)
import Control.Monad (forM_)
import Numeric.FFT.Vector.Base
import qualified Numeric.FFT.Vector.Unnormalized.Multi as U
import Data.Complex
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as MS
import Control.Monad.Primitive(RealWorld)

-- | A discrete Fourier transform. The output and input sizes are the same (@n@).
--
-- @y_k = (1\/sqrt n) sum_(j=0)^(n-1) x_j e^(-2pi i j k\/n)@
dft :: TransformND (Complex Double) (Complex Double)
dft = U.dft {normalizationND = \ns -> constMultOutput $ 1 / sqrt (toEnum (VS.product ns))}

-- | An inverse discrete Fourier transform.  The output and input sizes are the same (@n@).
--
-- @y_k = (1\/sqrt n) sum_(j=0)^(n-1) x_j e^(2pi i j k\/n)@
idft :: TransformND (Complex Double) (Complex Double)
idft = U.idft {normalizationND = \ns -> constMultOutput $ 1 / sqrt (toEnum (VS.product ns))}

-- | A forward discrete Fourier transform with real data.  If the input size is @n@,
-- the output size will be @n \`div\` 2 + 1@.
dftR2C :: TransformND Double (Complex Double)
dftR2C = U.dftR2C {normalizationND = \ns -> modifyOutput $
                    complexR2CScaling (sqrt 2) ns (outputSizeND U.dftR2C $ VS.last ns)
        }

-- | A normalized backward discrete Fourier transform which is the left inverse of
-- 'U.dftR2C'.  (Specifically, @run dftC2R . run dftR2C == id@.)
--
-- This 'Transform' behaves differently than the others:
--
--  - Calling @plan dftC2R n@ creates a 'Plan' whose /output/ size is @n@, and whose
--    /input/ size is @n \`div\` 2 + 1@.
--
--  - If @length v == n@, then @length (run dftC2R v) == 2*(n-1)@.
--
dftC2R :: TransformND (Complex Double) Double
dftC2R = U.dftC2R {normalizationND = \ns -> modifyInput $
                    complexR2CScaling (sqrt 0.5) ns (inputSizeND U.dftC2R $ VS.last ns)
        }

complexR2CScaling :: Double -> VS.Vector Int -> Int -> MS.MVector RealWorld (Complex Double) -> IO ()
complexR2CScaling !t !ns !len !a = assert (MS.length a == VS.product (VS.init ns) * len) $ do
    let !s1 = sqrt (1/toEnum (VS.product ns))
    let !s2 = t * s1
    -- Justification for the use of unsafeModify:
    -- The output size is 2n+1; so if n>0 then the output size is >=1;
    -- and if n even then the output size is >=3.
    forM_ [0.. VS.product (VS.init ns) - 1] $ \idx -> do
      unsafeModify a (idx * len) $ scaleByD s1
      if odd (VS.last ns)
        then multC s2 (MS.unsafeSlice (idx * len + 1) (len-1) a)
        else do
            unsafeModify a (idx * len + len - 1) $ scaleByD s1
            multC s2 (MS.unsafeSlice (idx * len + 1) (len-2) a)

ext: hs

max_stars_repo_name: TravisWhitaker/vector-fftw

max_issues_repo_name: TravisWhitaker/vector-fftw

max_forks_repo_name: TravisWhitaker/vector-fftw


text:
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Sam where

import Statistics.Distribution
import Statistics.Distribution.Normal (normalDistr)
import Statistics.Distribution.Beta (betaDistr)
import Statistics.Distribution.Gamma (gammaDistr)
import qualified Statistics.Distribution.Poisson as Poisson
import Data.List
import Data.Map (empty,lookup,insert,size,keys)
import Data.IORef
import Control.Monad
import Control.Monad.Extra
import System.IO.Unsafe
import Control.Monad.State.Lazy (State, state , put, get, runState, MonadTrans (lift))
import Debug.Trace
import Control.Monad.Trans.Writer
import Numeric.Log
import System.Random hiding (uniform)
import Data.Monoid (Product (Product))

{--
    This file defines
    * Two monads: Prob (for probabilities) and Meas (for unnormalized probabilities)
    * Two inference methods: lwis and mh
--}

-- A "Tree" is a lazy, infinitely wide and infinitely deep tree, labelled by Doubles
-- Our source of randomness will be a Tree, populated by uniform [0,1] choices for each label.
-- Often people would just use a list or stream instead of a tree.
-- But a tree allows us to be lazy about how far we are going all the time.
data Tree = Tree Double [Tree]

-- A probability distribution over a is a state transformer over trees
-- ie a function Tree -> (a , Tree)
-- The idea is that it uses up bits of the tree as it runs
newtype Prob a = Prob (State Tree a)

-- Two key things to do with trees:
-- Split tree splits a tree in two (bijectively)
-- Get the label at the head of the tree and discard the rest
splitTree :: Tree -> (Tree , Tree)
splitTree (Tree r (t : ts)) = (t , Tree r ts)

uniform :: Prob Double
uniform = Prob $
      do ~(Tree r (t:ts)) <- get
         put t
         return r

-- Probabilities for a monad.
-- Sequencing is done by splitting the tree
-- and using different bits for different computations.
instance Monad Prob where
  return a = Prob $ return a
  (Prob m) >>= f = Prob $
                        do g <- get
                           let (g1,g2) = splitTree g
                           put g1
                           x <- m
                           put g2
                           let (Prob m') = f x
                           m'
instance Functor Prob where fmap = liftM
instance Applicative Prob where {pure = return ; (<*>) = ap}

{-- An unnormalized measure is represented by a probability distribution over pairs of a weight and a result --}
newtype Meas a = Meas (WriterT (Product (Log Double)) Prob a)
  deriving(Functor, Applicative, Monad)

{-- The two key methods for Meas are sample (from a probability) and score (aka factor, weight) --}
score :: Double -> Meas ()
score r = Meas $ tell $ Product $ (Exp . log) $ (if r==0 then exp(-300) else r)

scorelog :: Double -> Meas ()
scorelog r = Meas $ tell $ Product $ Exp $ (if r==0 then exp(-300) else r)

sample :: Prob a -> Meas a
sample p = Meas $ lift p

{-- Preliminaries for the simulation methods. Generate a tree with uniform random labels
    This uses SPLIT to split a random seed --}
randomTree :: RandomGen g => g -> Tree
randomTree g = let (a,g') = random g in Tree a (randomTrees g')
randomTrees :: RandomGen g => g -> [Tree]
randomTrees g = let (g1,g2) = split g in (randomTree g1) : (randomTrees g2)

{-- Run prob runs a probability deterministically, given a source of randomness --}
runProb :: Prob a -> Tree -> a
runProb (Prob a) rs = fst $ runState a rs

normal :: Double -> Double -> Prob Double
normal m s = do quantile (normalDistr m s) <$> uniform

normalPdf :: Double -> Double -> Double -> Double
normalPdf m s = density $ normalDistr m s

exponential :: Double -> Prob Double
exponential rate =
  do x <- uniform
     return $ - (log x / rate)

expPdf :: Double -> Double -> Double
expPdf rate x = exp (-rate*x) * rate

gamma :: Double -> Double -> Prob Double
gamma a b = do
  quantile (gammaDistr a b) <$> uniform

beta :: Double -> Double -> Prob Double
beta a b = do
  quantile (betaDistr a b) <$> uniform

poisson :: Double -> Prob Integer
poisson lambda = do
  x <- uniform
  let cmf = scanl1 (+) $ map (probability $ Poisson.poisson lambda) [0,1..]
  let (Just n) = findIndex (> x) cmf
  return $ fromIntegral n

poissonPdf :: Double -> Integer -> Double
poissonPdf rate n = probability (Poisson.poisson rate) (fromIntegral n)

dirichlet :: [Double] -> Prob[Double]
dirichlet as = do
  xs <- mapM exponential as
  let s = Prelude.sum xs
  let ys = map (/ s) xs
  return ys

uniformbounded :: Double -> Double -> Prob Double
uniformbounded lower upper = do
  x <- uniform
  return $ (upper - lower) * x + lower

bernoulli :: Double -> Prob Bool
bernoulli r = do
  x <- uniform
  return $ x < r

{-
 uniform distribution on [0, ..., n-1]
-}
uniformdiscrete :: Int -> Prob Int
uniformdiscrete n =
  do
    let upper = fromIntegral n
    r <- uniformbounded 0 upper
    return $ floor r

{-- Categorical distribution: takes a list of k numbers that sum to 1,
    and returns a number between 0 and (k-1) --}
categorical :: [Double] -> Prob Int
categorical xs = do
  r <- uniform
  let (Just i) = findIndex (>r) $ tail $ scanl (+) 0 xs
  return i

{-- Stochastic memoization.
    We use unsafePerformIO to maintain
    a table of calls that have already been made.
    If a is finite, we could just sample all values of a in advance
    and avoid unsafePerformIO.
    If it is countably infinite, there probably also are implementation tricks.
--}
memoize :: Ord a => (a -> Prob b) -> Prob (a -> b)
memoize f =  Prob $ do g <- get
                       let ( Tree _ gs, g2) = splitTree g
                       put g2
                       return $ unsafePerformIO $ do
                                ref <- newIORef Data.Map.empty
                                return $ \x -> unsafePerformIO $ do
                                          m <- fmap (Data.Map.lookup x) (readIORef ref)
                                          case m of
                                              Just y -> return y
                                              Nothing -> do
                                                            let (Prob k) = f x
                                                            n <- readIORef ref
                                                            let (y,_) = runState k (gs !! (1 + size n))
                                                            modifyIORef' ref (Data.Map.insert x y)
                                                            return y

{-- Stochastic memoization for recursive functions.
    Applying 'memoize' to a recursively defined function only memoizes at the
    top-level: recursive calls are calls to the non-memoized function.
    'memrec' is an alternative implementation which resolves recursion and
    memoization at the same time, so that recursive calls are also memoized.
--}
memrec :: Ord a => Show a => ((a -> b) -> (a -> Prob b)) -> Prob (a -> b)
memrec f =
   Prob $ do
    g <- get
    let ( Tree _ gs, g2) = splitTree g
    put g2
    return $ unsafePerformIO $ do
                  ref <- newIORef Data.Map.empty
                  let memoized_fixpoint = \x -> unsafePerformIO $ do
                                m <- fmap (Data.Map.lookup x) (readIORef ref)
                                case m of
                                      Just y -> return y
                                      Nothing -> do
                                                  n <- readIORef ref
                                                  let fix = f memoized_fixpoint
                                                  let Prob k = fix x
                                                  let (y, _) = runState k (gs !! (1 + size n))
                                                  modifyIORef' ref (Data.Map.insert x y)
                                                  return y
                  return memoized_fixpoint

max_stars_repo_name: kai-pischke/ppl

max_issues_repo_name: kai-pischke/ppl

max_forks_repo_name: kai-pischke/ppl


text:
-- |
-- Module      : BenchShow.Report
-- Copyright   : (c) 2018 Composewell Technologies
--
-- License     : BSD3
-- Maintainer  : harendra.kumar@gmail.com
-- Stability   : experimental
-- Portability : GHC
--

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module BenchShow.Report
    (
      report
    ) where

import Control.Applicative (ZipList(..))
import Control.Monad (forM_)
import Data.Maybe (fromMaybe)
import Statistics.Types (Estimate(..))
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
import Text.Printf (printf)

import BenchShow.Common
import BenchShow.Analysis

multiplesToPercentDiff :: Double -> Double
multiplesToPercentDiff x = (if x > 0 then x - 1 else x + 1) * 100

colorCode :: Word -> Double -> Doc -> Doc
colorCode thresh x =
    if x > fromIntegral thresh
    then dullred
    else if x < (-1) * fromIntegral thresh
         then dullgreen
         else id

-- XXX in comparative reports render lower than baseline in green and higher
-- than baseline in red
genGroupReport :: RawReport -> Config -> IO ()
genGroupReport RawReport{..} cfg@Config{..} = do
    let diffStr =
            if length reportColumns > 1
            then diffString presentation diffStrategy
            else Nothing
    case mkTitle of
        Just _ -> putStrLn $ maybe "" (\f -> f reportIdentifier) mkTitle
        Nothing -> putStrLn $ makeTitle reportIdentifier diffStr cfg

    let benchcol  = "Benchmark" : reportRowIds
        groupcols =
            let firstCol : tailCols = reportColumns
                colorCol ReportColumn{..} =
                    let f x = case presentation of
                                Groups Diff ->
                                    if x > 0 then dullred else dullgreen
                                Groups PercentDiff -> colorCode threshold x
                                Groups Multiples ->
                                    let y = multiplesToPercentDiff x
                                    in colorCode threshold y
                                _ -> id
                    in map f colValues
                renderTailCols estimators col analyzed =
                    let regular = renderGroupCol $ showCol col Nothing analyzed
                        colored = zipWith ($) (id : id : colorCol col)
                                    $ renderGroupCol
                                    $ showCol col estimators analyzed
                    in case presentation of
                        Groups Diff        -> colored
                        Groups PercentDiff -> colored
                        Groups Multiples   -> colored
                        _ -> regular
            in renderGroupCol (showFirstCol firstCol)
             : case reportEstimators of
                Just ests -> getZipList $
                            renderTailCols
                        <$> ZipList (map Just $ tail ests)
                        <*> ZipList tailCols
                        <*> ZipList (tail reportAnalyzed)
                Nothing ->  getZipList $
                            renderTailCols
                        <$> pure Nothing
                        <*> ZipList tailCols
                        <*> ZipList (tail reportAnalyzed)
        rows = foldl (zipWith (<+>)) (renderCol benchcol) groupcols
    putDoc $ vcat rows
    putStrLn "\n"

    where

    renderCol [] = error "Bug: header row missing"
    renderCol col@(h : rows) =
        let maxlen = maximum (map length col)
        in map (fill maxlen . text) (h : replicate maxlen '-' : rows)

    renderGroupCol [] = error
        "Bug: There has to be at least one column in raw report"
    renderGroupCol col@(h : rows) =
        let maxlen = maximum (map length col)
        in map (\x -> indent (maxlen - length x) $ text x)
               (h : replicate maxlen '-' : rows)

    showEstimator est =
        case est of
            Mean       -> "(mean)"
            Median     -> "(medi)"
            Regression -> "(regr)"

    showEstVal estvals est =
        case est of
            Mean ->
                let sd = analyzedStdDev estvals
                    val = analyzedMean estvals
                in
                   if val /= 0
                   then printf "(%.2f)" $ sd / abs val
                   else ""
            Median ->
                let x = ovFraction $ analyzedOutlierVar estvals
                in printf "(%.2f)" x
            Regression ->
                case analyzedRegRSq estvals of
                    Just rsq -> printf "(%.2f)" (estPoint rsq)
                    Nothing -> ""

    showFirstCol ReportColumn{..} =
        let showVal = printf "%.2f"
            withEstimator val estvals =
                showVal val ++
                    if verbose
                    then showEstVal estvals estimator
                    else ""
            withEstVal =
                zipWith withEstimator colValues (head reportAnalyzed)
        in colName : withEstVal

    showCol ReportColumn{..} estimators analyzed = colName :
        let showVal val =
                let showDiff =
                        if val > 0
                        then printf "+%.2f" val
                        else printf "%.2f" val
                in case presentation of
                        Groups Diff        -> showDiff
                        Groups PercentDiff -> showDiff
                        Groups Multiples ->
                            if val > 0
                            then printf "%.2f" val
                            else printf "1/%.2f" (negate val)
                        _ -> printf "%.2f" val

            showEstAnnot est =
                case presentation of
                    Groups Diff        -> showEstimator est
                    Groups PercentDiff -> showEstimator est
                    Groups Multiples   -> showEstimator est
                    _ -> ""

        in case estimators of
            Just ests ->
                let withAnnot val estvals est =
                           showVal val
                        ++ if verbose
                           then showEstVal estvals est
                                ++ showEstAnnot est
                           else ""
                in getZipList $
                        withAnnot
                    <$> ZipList colValues
                    <*> ZipList analyzed
                    <*> ZipList ests

            Nothing ->
                let withEstVal val estvals est =
                           showVal val
                        ++ if verbose then showEstVal estvals est else ""
                in getZipList $
                        withEstVal
                    <$> ZipList colValues
                    <*> ZipList analyzed
                    <*> pure estimator

-- | Presents the benchmark results in a CSV input file as text reports
-- according to the provided configuration.  The first parameter is the input
-- file name. The second parameter, when specified using 'Just', is the name
-- prefix for the output SVG image file(s). One or more output files may be
-- generated with the given prefix depending on the 'Presentation' setting.
-- When the second parameter is 'Nothing' the reports are printed on the
-- console. The last parameter is the configuration to customize the report,
-- you can start with 'defaultConfig' as the base and override any of the
-- fields that you may want to change.
--
-- For example:
--
-- @
-- report "bench-results.csv" Nothing 'defaultConfig'
-- @
--
-- @since 0.2.0
report :: FilePath -> Maybe FilePath -> Config -> IO ()
report inputFile outputFile cfg@Config{..} = do
    let dir = fromMaybe "." outputDir
    (csvlines, fields) <- prepareToReport inputFile cfg
    (runs, matrices) <- prepareGroupMatrices cfg inputFile csvlines fields
    case presentation of
        Groups style ->
            forM_ fields $
                reportComparingGroups style dir outputFile TextReport runs
                               cfg genGroupReport matrices
        Fields -> do
            forM_ matrices $
                reportPerGroup dir outputFile TextReport cfg genGroupReport
        Solo ->
            let funcs = map
                    (\mx -> reportComparingGroups Absolute dir
                        (fmap (++ "-" ++ groupName mx) outputFile)
                        TextReport runs cfg genGroupReport [mx])
                    matrices
             in sequence_ $ funcs <*> fields

max_stars_repo_name: pranaysashank/bench-show

max_issues_repo_name: pranaysashank/bench-show

max_forks_repo_name: pranaysashank/bench-show


text:
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings,
    RecordWildCards, ScopedTypeVariables #-}

-- |
-- Module      : Criterion.Report
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Reporting functions.

module Criterion.Report
    (
      formatReport
    , report
    , tidyTails
    -- * Rendering helper functions
    , TemplateException(..)
    , loadTemplate
    , includeFile
    , getTemplateDir
    , vector
    , vector2
    ) where

import Control.Exception (Exception, IOException, throwIO)
import Control.Monad (mplus)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Reader (ask)
import Criterion.Monad (Criterion)
import Criterion.Types
import Data.Aeson.Encode (encodeToTextBuilder)
import Data.Aeson.Types (toJSON)
import Data.Data (Data, Typeable)
import Data.Foldable (forM_)
import GHC.Generics (Generic)
import Paths_criterion (getDataFileName)
import Statistics.Function (minMax)
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>), isPathSeparator)
import Text.Hastache (MuType(..))
import Text.Hastache.Context (mkGenericContext, mkStrContext, mkStrContextM)
import qualified Control.Exception as E
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Language.Javascript.Flot as Flot
import qualified Language.Javascript.JQuery as JQuery
import qualified Text.Hastache as H

-- | Trim long flat tails from a KDE plot.
tidyTails :: KDE -> KDE
tidyTails KDE{..} = KDE { kdeType   = kdeType
                        , kdeValues = G.slice front winSize kdeValues
                        , kdePDF    = G.slice front winSize kdePDF
                        }
  where tiny     = uncurry subtract (minMax kdePDF) * 0.005
        omitTiny = G.length . G.takeWhile ((<= tiny) . abs)
        front    = omitTiny kdePDF
        back     = omitTiny . G.reverse $ kdePDF
        winSize  = G.length kdePDF - front - back

-- | Return the path to the template and other files used for
-- generating reports.
getTemplateDir :: IO FilePath
getTemplateDir = getDataFileName "templates"

-- | Write out a series of 'Report' values to a single file, if
-- configured to do so.
report :: [Report] -> Criterion ()
report reports = do
  Config{..} <- ask
  forM_ reportFile $ \name -> liftIO $ do
    td <- getTemplateDir
    tpl <- loadTemplate [td,"."] template
    TL.writeFile name =<< formatReport reports tpl

-- | Format a series of 'Report' values using the given Hastache
-- template.
formatReport :: [Report]
             -> T.Text    -- ^ Hastache template.
             -> IO TL.Text
formatReport reports template = do
  templates <- getTemplateDir
  let context "report"    = return $ MuList $ map inner reports
      context "json"      = return $ MuVariable (encode reports)
      context "include"   = return $ MuLambdaM $ includeFile [templates]
      context "js-jquery" = fmap MuVariable $ TL.readFile =<< JQuery.file
      context "js-flot"   = fmap MuVariable $ TL.readFile =<< Flot.file Flot.Flot
      context _           = return $ MuNothing
      encode v = TL.toLazyText . encodeToTextBuilder . toJSON $ v
      inner r@Report{..} = mkStrContextM $ \nym ->
                         case nym of
                           "name"     -> return . MuVariable . H.htmlEscape .
                                         TL.pack $ reportName
                           "json"     -> return $ MuVariable (encode r)
                           "number"   -> return $ MuVariable reportNumber
                           "iters"    -> return $ vector "x" iters
                           "times"    -> return $ vector "x" times
                           "cycles"   -> return $ vector "x" cycles
                           "kdetimes" -> return $ vector "x" kdeValues
                           "kdepdf"   -> return $ vector "x" kdePDF
                           "kde"      -> return $ vector2 "time" "pdf" kdeValues kdePDF
                           ('a':'n':_)-> mkGenericContext reportAnalysis $
                                         H.encodeStr nym
                           _          -> mkGenericContext reportOutliers $
                                         H.encodeStr nym
          where [KDE{..}]   = reportKDEs
                iters       = measure measIters reportMeasured
                times       = measure measTime reportMeasured
                cycles      = measure measCycles reportMeasured
      config = H.defaultConfig {
                 H.muEscapeFunc = H.emptyEscape
               , H.muTemplateFileDir = Just templates
               , H.muTemplateFileExt = Just ".tpl"
               }
  H.hastacheStr config template context

-- | Render the elements of a vector.
--
-- For example, given this piece of Haskell:
--
-- @'mkStrContext' $ \\name ->
-- case name of
--   \"foo\" -> 'vector' \"x\" foo@
--
-- It will substitute each value in the vector for @x@ in the
-- following Hastache template:
--
-- > {{#foo}}
-- >  {{x}}
-- > {{/foo}}
vector :: (Monad m, G.Vector v a, H.MuVar a) =>
          String                -- ^ Name to use when substituting.
       -> v a
       -> MuType m
{-# SPECIALIZE vector :: String -> U.Vector Double -> MuType IO #-}
vector name v = MuList . map val . G.toList $ v
    where val i = mkStrContext $ \nym ->
                  if nym == name
                  then MuVariable i
                  else MuNothing

-- | Render the elements of two vectors.
vector2 :: (Monad m, G.Vector v a, G.Vector v b, H.MuVar a, H.MuVar b) =>
           String               -- ^ Name for elements from the first vector.
        -> String               -- ^ Name for elements from the second vector.
        -> v a                  -- ^ First vector.
        -> v b                  -- ^ Second vector.
        -> MuType m
{-# SPECIALIZE vector2 :: String -> String -> U.Vector Double -> U.Vector Double
                       -> MuType IO #-}
vector2 name1 name2 v1 v2 = MuList $ zipWith val (G.toList v1) (G.toList v2)
    where val i j = mkStrContext $ \nym ->
                    case undefined of
                      _| nym == name1 -> MuVariable i
                       | nym == name2 -> MuVariable j
                       | otherwise    -> MuNothing

-- | Attempt to include the contents of a file based on a search path.
-- Returns 'B.empty' if the search fails or the file could not be read.
--
-- Intended for use with Hastache's 'MuLambdaM', for example:
--
-- @context \"include\" = 'MuLambdaM' $ 'includeFile' ['templateDir']@
--
-- Hastache template expansion is /not/ performed within the included
-- file.  No attempt is made to ensure that the included file path is
-- safe, i.e. that it does not refer to an unexpected file such as
-- \"@/etc/passwd@\".
includeFile :: (MonadIO m) =>
               [FilePath]       -- ^ Directories to search.
            -> T.Text          -- ^ Name of the file to search for.
            -> m T.Text
{-# SPECIALIZE includeFile :: [FilePath] -> T.Text -> IO T.Text #-}
includeFile searchPath name = liftIO $ foldr go (return T.empty) searchPath
    where go dir next = do
            let path = dir </> H.decodeStr name
            T.readFile path `E.catch` \(_::IOException) -> next

-- | A problem arose with a template.
data TemplateException =
    TemplateNotFound FilePath   -- ^ The template could not be found.
    deriving (Eq, Read, Show, Typeable, Data, Generic)

instance Exception TemplateException

-- | Load a Hastache template file.
--
-- If the name is an absolute or relative path, the search path is
-- /not/ used, and the name is treated as a literal path.
--
-- This function throws a 'TemplateException' if the template could
-- not be found, or an 'IOException' if no template could be loaded.
loadTemplate :: [FilePath]      -- ^ Search path.
             -> FilePath        -- ^ Name of template file.
             -> IO T.Text
loadTemplate paths name
    | any isPathSeparator name = T.readFile name
    | otherwise                = go Nothing paths
  where go me (p:ps) = do
          let cur = p </> name <.> "tpl"
          x <- doesFileExist cur
          if x
            then T.readFile cur `E.catch` \e -> go (me `mplus` Just e) ps
            else go me ps
        go (Just e) _ = throwIO (e::IOException)
        go _        _ = throwIO . TemplateNotFound $ name

max_stars_repo_name: phadej/criterion

max_issues_repo_name: phadej/criterion

max_forks_repo_name: phadej/criterion


text:
{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-}

-- |
-- Module:  Control.DeepSeq
-- Copyright:   (c) 2012, Maxime Henrion
-- License:     BSD-style (see the LICENSE file)
--
-- Maintainer:  Maxime Henrion <mhenrion@gmail.com>
-- Stability:   stable
-- Portability: portable
--
-- This module provides a 'deepseq' function for fully evaluating data
-- structures (that is, evaluating to \"Normal Form\", and not just up to
-- \"Head Normal Form\" like 'seq' does).
--
-- It uses the "GHC.Generics" framework so that you can generate instances
-- for your datatypes without having to provide an implementation.
--
module Control.DeepSeq
  ( DeepSeq(..)
  , deepseq
  , ($!!)
  , force
  ) where

import Data.Int
import Data.Word
import Data.Complex
import Data.Ratio
import GHC.Generics

class DeepSeq a where
  -- | Evaluate its argument to normal form, and then return '()'.
  rnf :: a -> ()
  default rnf :: (Generic a, GDeepSeq (Rep a)) => a -> ()
  rnf = grnf . from

-- Instances for primitive types.
instance DeepSeq Bool     where rnf x = x `seq` ()
instance DeepSeq Char     where rnf x = x `seq` ()
instance DeepSeq Double   where rnf x = x `seq` ()
instance DeepSeq Float    where rnf x = x `seq` ()
instance DeepSeq Int      where rnf x = x `seq` ()
instance DeepSeq Word     where rnf x = x `seq` ()
instance DeepSeq Integer  where rnf x = x `seq` ()
instance DeepSeq Ordering where rnf x = x `seq` ()
instance DeepSeq ()       where rnf x = x `seq` ()

instance DeepSeq Int8     where rnf x = x `seq` ()
instance DeepSeq Int16    where rnf x = x `seq` ()
instance DeepSeq Int32    where rnf x = x `seq` ()
instance DeepSeq Int64    where rnf x = x `seq` ()

instance DeepSeq Word8    where rnf x = x `seq` ()
instance DeepSeq Word16   where rnf x = x `seq` ()
instance DeepSeq Word32   where rnf x = x `seq` ()
instance DeepSeq Word64   where rnf x = x `seq` ()

instance DeepSeq (a -> b) where rnf x = x `seq` ()

instance (DeepSeq a, DeepSeq b) => DeepSeq (a,b)
instance (DeepSeq a, DeepSeq b, DeepSeq c) => DeepSeq (a,b,c)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d) => DeepSeq (a,b,c,d)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e) =>
          DeepSeq (a,b,c,d,e)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e, DeepSeq f) =>
          DeepSeq (a,b,c,d,e,f)
instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e, DeepSeq f,
          DeepSeq g) => DeepSeq (a,b,c,d,e,f,g)

instance DeepSeq a => DeepSeq [a]
instance DeepSeq a => DeepSeq (Maybe a)
instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b)

-- We cannot derive an instance for Ratio automatically, because it is an
-- abstract datatype (it doesn't export its constructors), and doesn't provide
-- a Generic instance either.
instance (Integral a, DeepSeq a) => DeepSeq (Ratio a) where
  rnf x = rnf (denominator x) `seq` rnf (numerator x)

-- We should be able to derive an instance for Complex a automatically, but it
-- turns out GHC 7.4.1 panics if we do that, so we provide an explicit instance
-- for now.
instance DeepSeq a => DeepSeq (Complex a) where
  rnf (x :+ y) = rnf x `seq` rnf y

class GDeepSeq f where
  grnf :: f a -> ()

instance GDeepSeq V1 where
  grnf _  = undefined

instance GDeepSeq U1 where
  -- It is important to pattern match on the U1 constructor here. If we didn't
  -- and used an underscore pattern, the following equality wouldn't hold:
  --   x `deepseq` () = x `seq` () = _|_
  --     where x = undefined :: T
  -- with T being some unit-shaped type with a DeepSeq instance.
  grnf U1 = ()

instance DeepSeq a => GDeepSeq (K1 i a) where
  grnf = rnf . unK1

instance GDeepSeq a => GDeepSeq (M1 i c a) where
  grnf = grnf . unM1

instance (GDeepSeq a, GDeepSeq b) => GDeepSeq (a :*: b) where
  grnf (x :*: y) = grnf x `seq` grnf y

instance (GDeepSeq a, GDeepSeq b) => GDeepSeq (a :+: b) where
  grnf (L1 x) = grnf x
  grnf (R1 x) = grnf x

infixr 0 $!!

-- | The deep analogue of '$!'.
($!!) :: DeepSeq a => (a -> b) -> a -> b
f $!! x = x `deepseq` f x

-- | Evaluates its first argument to normal form, and then returns its
-- second argument as the result.
deepseq :: DeepSeq a => a -> b -> b
deepseq x y = rnf x `seq` y

-- | Evaluates its argument to normal form, and then return it.
force :: DeepSeq a => a -> a
force x = x `deepseq` x

max_stars_repo_name: mux/generic-deepseq

max_issues_repo_name: mux/generic-deepseq

max_forks_repo_name: mux/generic-deepseq