diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,17 @@ Changelog ========= +Version 0.1.3.0 +--------------- + +*Nov 20, 2021* + + + +* Fixed builds for *random-1.2* +* Fixed warnings for *base-4.11* +* Added support for new *System.Random.Stateful* instances for *random* library + Version 0.1.2.1 --------------- diff --git a/one-liner-instances.cabal b/one-liner-instances.cabal --- a/one-liner-instances.cabal +++ b/one-liner-instances.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.21.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 6acb459b36dc35bbc749809acb02ea8b942833b8ae0a465908c8ddfc21ac7dca name: one-liner-instances -version: 0.1.2.1 +version: 0.1.3.0 synopsis: Generics-based implementations for common typeclasses description: Provides generics-based implementations for common typeclasses using Generics. @@ -20,11 +20,11 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 - +tested-with: + GHC >= 8.0 extra-source-files: - CHANGELOG.md README.md + CHANGELOG.md source-repository head type: git @@ -37,13 +37,15 @@ Data.Ord.OneLiner Numeric.OneLiner System.Random.OneLiner + System.Random.Stateful.OneLiner other-modules: Paths_one_liner_instances + System.Random.OneLiner.Internal hs-source-dirs: src ghc-options: -Wall build-depends: base >=4.7 && <5 , one-liner >=0.9 - , random + , random >=1.2 default-language: Haskell2010 diff --git a/src/Data/Bounded/OneLiner.hs b/src/Data/Bounded/OneLiner.hs --- a/src/Data/Bounded/OneLiner.hs +++ b/src/Data/Bounded/OneLiner.hs @@ -11,7 +11,7 @@ -- | -- Module : Data.Bounded.OneLiner -- Description : Derived methods for Semigroup. --- Copyright : (c) Justin Le 2018 +-- Copyright : (c) Justin Le 2021 -- License : BSD-3 -- Maintainer : justin@jle.im -- Stability : unstable @@ -67,7 +67,6 @@ gMinBound = case create @Bounded [minBound] of [] -> error "minBound: uninhabited" x:_ -> x -{-# INLINE gMinBound #-} -- | 'maxBound' implemented by using 'maxBound' for all of the components -- for the last constructor @@ -77,4 +76,3 @@ gMaxBound = case reverse (create @Bounded [maxBound]) of [] -> error "maxBound: uninhabited" x:_ -> x -{-# INLINE gMaxBound #-} diff --git a/src/Data/Monoid/OneLiner.hs b/src/Data/Monoid/OneLiner.hs --- a/src/Data/Monoid/OneLiner.hs +++ b/src/Data/Monoid/OneLiner.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -11,7 +12,7 @@ -- | -- Module : Data.Monoid.OneLiner -- Description : Derived methods for Semigroup and Monoid. --- Copyright : (c) Justin Le 2018 +-- Copyright : (c) Justin Le 2021 -- License : BSD-3 -- Maintainer : justin@jle.im -- Stability : unstable @@ -42,9 +43,12 @@ import Data.Coerce import Data.Data -import Data.Semigroup import GHC.Generics import Generics.OneLiner + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif -- | If @a@ is a data type with a single constructor whose fields are all -- instances of 'Semigroup', then @'GMonoid' a@ has a 'Semigroup' instance. diff --git a/src/Data/Ord/OneLiner.hs b/src/Data/Ord/OneLiner.hs --- a/src/Data/Ord/OneLiner.hs +++ b/src/Data/Ord/OneLiner.hs @@ -11,7 +11,7 @@ -- | -- Module : Data.Ord.OneLiner -- Description : Derived methods for Semigroup. --- Copyright : (c) Justin Le 2018 +-- Copyright : (c) Justin Le 2021 -- License : BSD-3 -- Maintainer : justin@jle.im -- Stability : unstable diff --git a/src/Numeric/OneLiner.hs b/src/Numeric/OneLiner.hs --- a/src/Numeric/OneLiner.hs +++ b/src/Numeric/OneLiner.hs @@ -11,7 +11,7 @@ -- | -- Module : Numeric.OneLiner -- Description : Derived methods for numeric typeclasses --- Copyright : (c) Justin Le 2018 +-- Copyright : (c) Justin Le 2021 -- License : BSD-3 -- Maintainer : justin@jle.im -- Stability : unstable diff --git a/src/System/Random/OneLiner.hs b/src/System/Random/OneLiner.hs --- a/src/System/Random/OneLiner.hs +++ b/src/System/Random/OneLiner.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -14,7 +15,7 @@ -- | -- Module : System.Random.OneLiner -- Description : Derived methods for Random. --- Copyright : (c) Justin Le 2018 +-- Copyright : (c) Justin Le 2021 -- License : BSD-3 -- Maintainer : justin@jle.im -- Stability : unstable @@ -30,6 +31,7 @@ -- instant 'Random' instances, which can one day be used with /DerivingVia/ -- syntax to derive instances automatically. -- +-- @since 0.1.2.1 module System.Random.OneLiner ( -- * Single constructor @@ -64,6 +66,7 @@ import GHC.Generics import Generics.OneLiner import System.Random +import System.Random.OneLiner.Internal (Pair(..), dePair, State(..)) import qualified Data.List.NonEmpty as NE -- | If @a@ is a data type with a single constructor whose fields are all @@ -74,6 +77,8 @@ -- -- Only works with data types with single constructors. If you need it to -- work with types of multiple constructors, consider 'GRandomSum'. +-- +-- @since 0.1.2.1 newtype GRandom a = GRandom { getGRandom :: a } deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) @@ -93,16 +98,12 @@ randoms :: forall g. RandomGen g => g -> [GRandom a] randoms = coerce (gRandoms @a @g) {-# INLINE randoms #-} - randomRIO :: (GRandom a, GRandom a) -> IO (GRandom a) - randomRIO = coerce (gRandomRIO @a) - {-# INLINE randomRIO #-} - randomIO :: IO (GRandom a) - randomIO = coerce (gRandomIO @a) - {-# INLINE randomIO #-} -- | 'randomR' implemented by sequencing 'randomR' between all components -- -- Requires the type to have only a single constructor. +-- +-- @since 0.1.2.1 gRandomR :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) => (a, a) -> g -> (a, g) @@ -115,6 +116,8 @@ -- | 'random' implemented by sequencing 'random' for all components. -- -- Requires the type to have only a single constructor. +-- +-- @since 0.1.2.1 gRandom :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) => g -> (a, g) @@ -122,6 +125,8 @@ {-# INLINE gRandom #-} -- | 'randomRs' implemented by repeatedly calling 'gRandomR'. +-- +-- @since 0.1.2.1 gRandomRs :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) => (a, a) -> g -> [a] @@ -129,6 +134,8 @@ {-# INLINE gRandomRs #-} -- | 'randoms' implemented by repeatedly calling 'gRandom'. +-- +-- @since 0.1.2.1 gRandoms :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) => g -> [a] @@ -136,6 +143,8 @@ {-# INLINE gRandoms #-} -- | 'randomRIO' implemented by calling 'gRandomR' on the global seed. +-- +-- @since 0.1.2.1 gRandomRIO :: forall a. (ADTRecord a, Constraints a Random) => (a, a) -> IO a @@ -143,6 +152,8 @@ {-# INLINE gRandomRIO #-} -- | 'randomIO' implemented by calling 'gRandom' on the global seed. +-- +-- @since 0.1.2.1 gRandomIO :: forall a. (ADTRecord a, Constraints a Random) => IO a @@ -161,6 +172,8 @@ -- -- Note that the "ranged" variants are partial: if given a range of items -- made with different constructors, will be 'error'! +-- +-- @since 0.1.2.1 newtype GRandomSum a = GRandomSum { getGRandomSum :: a } deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) @@ -180,17 +193,13 @@ randoms :: forall g. RandomGen g => g -> [GRandomSum a] randoms = coerce (gRandomSums @a @g) {-# INLINE randoms #-} - randomRIO :: (GRandomSum a, GRandomSum a) -> IO (GRandomSum a) - randomRIO = coerce (gRandomRIOSum @a) - {-# INLINE randomRIO #-} - randomIO :: IO (GRandomSum a) - randomIO = coerce (gRandomIOSum @a) - {-# INLINE randomIO #-} -- | 'randomR' implemented by sequencing 'randomR' between all components. -- -- If given a range of items made with different constructors, will be -- 'error'! +-- +-- @since 0.1.2.1 gRandomRSum :: forall a g. (ADT a, Constraints a Random, RandomGen g) => (a, a) -> g -> (a, g) @@ -203,6 +212,8 @@ -- | 'random' implemented by selecting a random constructor and sequencing -- 'random' for all components. +-- +-- @since 0.1.2.1 gRandomSum :: forall a g. (ADT a, Constraints a Random, RandomGen g) => g -> (a, g) @@ -218,6 +229,8 @@ -- -- If given a range of items made with different constructors, will be -- 'error'! +-- +-- @since 0.1.2.1 gRandomRSums :: forall a g. (ADT a, Constraints a Random, RandomGen g) => (a, a) -> g -> [a] @@ -225,6 +238,8 @@ {-# INLINE gRandomRSums #-} -- | 'randoms' implemented by repeatedly calling 'gRandomSum'. +-- +-- @since 0.1.2.1 gRandomSums :: forall a g. (ADT a, Constraints a Random, RandomGen g) => g -> [a] @@ -235,6 +250,8 @@ -- -- If given a range of items made with different constructors, will be -- 'error'! +-- +-- @since 0.1.2.1 gRandomRIOSum :: forall a. (ADT a, Constraints a Random) => (a, a) -> IO a @@ -248,33 +265,6 @@ gRandomIOSum = getStdRandom gRandomSum {-# INLINE gRandomIOSum #-} - -data Pair a = Pair !a !a - deriving Functor - -dePair :: Pair a -> (a, a) -dePair (Pair x y) = (x, y) -{-# INLINE dePair #-} - -newtype State s a = State { runState :: s -> (a, s) } - deriving Functor - -instance Applicative (State s) where - pure x = State (x,) - {-# INLINE pure #-} - sf <*> sx = State $ \s0 -> - let (f, !s1) = runState sf s0 - (x, !s2) = runState sx s1 - in (f x, s2) - {-# INLINE (<*>) #-} - -instance Monad (State s) where - return x = State (x,) - {-# INLINE return #-} - sx >>= f = State $ \s0 -> - let (x, !s1) = runState sx s0 - in runState (f x) s1 - {-# INLINE (>>=) #-} buildRandoms :: RandomGen g => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion diff --git a/src/System/Random/OneLiner/Internal.hs b/src/System/Random/OneLiner/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/OneLiner/Internal.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module System.Random.OneLiner.Internal ( + Pair(..) + , dePair + , State(..) + ) where + +data Pair a = Pair !a !a + deriving Functor + +dePair :: Pair a -> (a, a) +dePair (Pair x y) = (x, y) +{-# INLINE dePair #-} + +newtype State s a = State { runState :: s -> (a, s) } + deriving Functor + +instance Applicative (State s) where + pure x = State (x,) + {-# INLINE pure #-} + sf <*> sx = State $ \s0 -> + let (f, !s1) = runState sf s0 + (x, !s2) = runState sx s1 + in (f x, s2) + {-# INLINE (<*>) #-} + +instance Monad (State s) where + return x = State (x,) + {-# INLINE return #-} + sx >>= f = State $ \s0 -> + let (x, !s1) = runState sx s0 + in runState (f x) s1 + {-# INLINE (>>=) #-} + diff --git a/src/System/Random/Stateful/OneLiner.hs b/src/System/Random/Stateful/OneLiner.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/Stateful/OneLiner.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : System.Random.Stateful.OneLiner +-- Description : Derived methods for Random. +-- Copyright : (c) Justin Le 2021 +-- License : BSD-3 +-- Maintainer : justin@jle.im +-- Stability : unstable +-- Portability : portable +-- +-- Derived methods for 'Uniform', using "Generics.OneLiner" and +-- "GHC.Generics". +-- +-- Can be used for any types (deriving 'Generic') made with a single +-- constructor, where every field is an instance of 'Uniform'. +-- +-- Also includes a newtype wrapper that imbues any such data type with +-- instant 'Uniform' instances, which can one day be used with /DerivingVia/ +-- syntax to derive instances automatically. +-- +-- @since 0.1.3.0 +module System.Random.Stateful.OneLiner ( + -- * Single constructor + -- ** Newtype wrapper + GUniform(..) + -- ** Generics-derived methods + , gUniformM + , gUniformRM + , gUniformListM + , gRandomM + , gRandomRM + -- * Multiple constructor + -- ** Newtype wrapper + , GUniformSum(..) + -- ** Generics-derived methods + , gUniformSumM + , gUniformRSumM + , gUniformSumListM + , gRandomSumM + , gRandomRSumM + ) where + +import Control.Monad +import Data.Data +import Data.Functor.Compose +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import GHC.Generics +import Generics.OneLiner +import System.Random +import System.Random.OneLiner +import System.Random.OneLiner.Internal (Pair(..), dePair) +import System.Random.Stateful +import qualified Data.List.NonEmpty as NE + +-- | If @a@ is a data type with a single constructor whose fields are all +-- instances of 'Uniform', then @'GUniform' a@ has a 'Uniform' instance. +-- +-- Will one day be able to be used with /DerivingVia/ syntax, to derive +-- instances automatically. +-- +-- Only works with data types with single constructors. If you need it to +-- work with types of multiple constructors, consider 'GUniformSum'. +newtype GUniform a = GUniform { getGUniform :: a } + deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) + +instance ( ADTRecord a + , Constraints a Uniform + ) + => Uniform (GUniform a) where + uniformM :: forall g m. StatefulGen g m => g -> m (GUniform a) + uniformM g = GUniform <$> gUniformM g + {-# INLINE uniformM #-} + +instance ( ADTRecord a + , Constraints a UniformRange + ) + => UniformRange (GUniform a) where + uniformRM :: forall g m. StatefulGen g m => (GUniform a, GUniform a) -> g -> m (GUniform a) + uniformRM (GUniform l, GUniform r) g = GUniform <$> gUniformRM (l, r) g + {-# INLINE uniformRM #-} + +gUniformM + :: forall a g m. (ADTRecord a, Constraints a Uniform, StatefulGen g m) + => g + -> m a +gUniformM g = createA' @Uniform (uniformM g) +{-# INLINE gUniformM #-} + +gUniformRM + :: forall a g m. (ADTRecord a, Constraints a UniformRange, StatefulGen g m) + => (a, a) -> g -> m a +gUniformRM (l, u) g = dialgebra @UniformRange + ((`uniformRM` g) . dePair) + (Pair l u) +{-# INLINE gUniformRM #-} + +-- | Uses the 'Random' instance instead of the 'Uniform' instance. +gRandomM + :: forall a g m r. (ADTRecord a, Constraints a Random, RandomGenM g r m) + => g -> m a +gRandomM = applyRandomGenM gRandom + +-- | Uses the 'Random' instance instead of the 'Uniform' instance. +gRandomRM + :: forall a g m r. (ADTRecord a, Constraints a Random, RandomGenM g r m) + => (a, a) -> g -> m a +gRandomRM r = applyRandomGenM (gRandomR r) + +gUniformListM + :: forall a g m. (ADTRecord a, Constraints a Uniform, StatefulGen g m) + => Int + -> g + -> m [a] +gUniformListM n g = replicateM n (gUniformM g) + +-- | If @a@ is a data type whose fields are all instances of 'Uniform', then +-- @'GUniform' a@ has a 'Uniform' instance. +-- +-- Will one day be able to be used with /DerivingVia/ syntax, to derive +-- instances automatically. +-- +-- A version of 'GUniform' that works for data types with multiple +-- constructors. If your type has only one constructor, it might be more +-- performant to use 'GUniform'. +-- +-- Note that the "ranged" variants are partial: if given a range of items +-- made with different constructors, will be 'error'! +newtype GUniformSum a = GUniformSum { getGUniformSum :: a } + deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) + +instance ( ADT a + , Constraints a Uniform + ) + => Uniform (GUniformSum a) where + uniformM :: forall g m. StatefulGen g m => g -> m (GUniformSum a) + uniformM g = GUniformSum <$> gUniformSumM g + {-# INLINE uniformM #-} + +-- | Note that this is partial: the range limits must have the same +-- constructors. +instance ( ADT a + , Constraints a UniformRange + ) + => UniformRange (GUniformSum a) where + uniformRM :: forall g m. StatefulGen g m => (GUniformSum a, GUniformSum a) -> g -> m (GUniformSum a) + uniformRM (GUniformSum l, GUniformSum u) g = GUniformSum <$> gUniformRSumM (l, u) g + {-# INLINE uniformRM #-} + +-- | 'randomR' implemented by sequencing 'randomR' between all components. +-- +-- If given a range of items made with different constructors, will be +-- 'error'! +gUniformRSumM + :: forall a g m. (ADT a, Constraints a UniformRange, StatefulGen g m) + => (a, a) -> g -> m a +gUniformRSumM (l, u) g = fromMaybe (error badbad) . getCompose $ + zipWithA @UniformRange + (\l' u' -> Compose (Just (uniformRM (l', u') g))) + l u + where + badbad = "gUniformRSum: Constructors in range do not match." +{-# INLINE gUniformRSumM #-} + +-- | 'random' implemented by selecting a random constructor and sequencing +-- 'random' for all components. +gUniformSumM + :: forall a g m. (ADT a, Constraints a Uniform, StatefulGen g m) + => g -> m a +gUniformSumM g = case options of + Nothing -> pure (error "gUniformSumM: Uninhabited type") + Just opts -> join $ reservoir opts g + where + options = NE.nonEmpty . getCompose $ createA @Uniform @a $ + Compose [uniformM g] +{-# INLINE gUniformSumM #-} + +-- | Uses the 'Random' instance instead of the 'Uniform' instance. +gRandomSumM + :: forall a g m r. (ADT a, Constraints a Random, RandomGenM g r m) + => g -> m a +gRandomSumM = applyRandomGenM gRandomSum + +-- | Uses the 'Random' instance instead of the 'Uniform' instance. +gRandomRSumM + :: forall a g m r. (ADT a, Constraints a Random, RandomGenM g r m) + => (a, a) -> g -> m a +gRandomRSumM r = applyRandomGenM (gRandomRSum r) + +gUniformSumListM + :: forall a g m. (ADT a, Constraints a Uniform, StatefulGen g m) + => Int + -> g + -> m [a] +gUniformSumListM n g = replicateM n (gUniformSumM g) + +-- | Select a random item from a non-empty list in constant memory, using +-- only a single traversal, using reservoir sampling. +reservoir :: StatefulGen g m => NE.NonEmpty a -> g -> m a +reservoir (x :| xs) g = go 1 x xs + where + go _ y [] = pure y + go !i y (z:zs) = do + j <- uniformWord64R i g + if j <= 0 + then go (i + 1) z zs + else go (i + 1) y zs +{-# INLINE reservoir #-} +