diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ Changelog ========= +Version 0.1.2.0 +--------------- + +*Apr 20, 2018* + + + +* Generic instances for `Random` from the *random* package. + Version 0.1.1.0 --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,11 +3,12 @@ This package uses machinery from *[one-liner][]* in order to provide default implementations for methods from `Num`, `Fractional`, `Floating`, `Semigroup`, -`Monoid`, `Bounded`, `Eq`, and `Ord`. These will work for any types (deriving -`Generic`) whose fields are all instances of that typeclass. +`Monoid`, `Bounded`, `Eq`, `Ord`, and `Random`. These will work for any types +(deriving `Generic`) whose fields are all instances of that typeclass. For `Num`, `Fractional`, `Floating`, `Semigroup`, and `Monoid`, the types also -must have only a single constructor. +must have only a single constructor. `Random` methods offer variants with +single constructors (for performance) and with multiple constructors. [one-liner]: https://hackage.haskell.org/package/one-liner diff --git a/one-liner-instances.cabal b/one-liner-instances.cabal --- a/one-liner-instances.cabal +++ b/one-liner-instances.cabal @@ -1,15 +1,14 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack -- --- hash: 95c2f55c56790e15fd9320018faf309e137158787294ce8fa8024dde4348a9fa +-- hash: a1781911abc3fd4d6382fa43927d49aba4d1e07d876833a215fc311dec1da55b name: one-liner-instances -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Generics-based implementations for common typeclasses description: Provides generics-based implementations for common typeclasses using - Generics. For now, has implementations for Numeric typeclasses (Num, - Fractional, and Floating) and Semigroup and Monoid. + Generics. . Please see the README on Github at category: Web @@ -38,12 +37,13 @@ build-depends: base >=4.7 && <5 , one-liner >=0.9 + , random exposed-modules: Data.Bounded.OneLiner Data.Monoid.OneLiner Data.Ord.OneLiner Numeric.OneLiner other-modules: - Generics.OneLiner.Instances.Internal + System.Random.OneLiner Paths_one_liner_instances 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 @@ -36,10 +36,10 @@ , gMaxBound ) where +import Data.Coerce import Data.Data import GHC.Generics import Generics.OneLiner -import Generics.OneLiner.Instances.Internal -- | If @a@ is a data type whose fields are all instances of 'Bounded', -- then @'GBounded' a@ has a 'Bounded' instance. @@ -54,9 +54,9 @@ , Constraints a Bounded ) => Bounded (GBounded a) where - minBound = c0 (gMinBound @a) + minBound = coerce (gMinBound @a) {-# INLINE minBound #-} - maxBound = c0 (gMaxBound @a) + maxBound = coerce (gMaxBound @a) {-# INLINE maxBound #-} -- | 'minBound' implemented by using 'minBound' for all of the components 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 @@ -40,11 +40,11 @@ , gMempty ) where +import Data.Coerce import Data.Data import Data.Semigroup import GHC.Generics import Generics.OneLiner -import Generics.OneLiner.Instances.Internal -- | If @a@ is a data type with a single constructor whose fields are all -- instances of 'Semigroup', then @'GMonoid' a@ has a 'Semigroup' instance. @@ -62,7 +62,7 @@ , Constraints a Semigroup ) => Semigroup (GMonoid a) where - (<>) = c2 (gSemigroup @a) + (<>) = coerce (gSemigroup @a) {-# INLINE (<>) #-} instance ( ADTRecord a @@ -70,9 +70,9 @@ , Constraints a Monoid ) => Monoid (GMonoid a) where - mappend = c2 (gMappend @a) + mappend = coerce (gMappend @a) {-# INLINE mappend #-} - mempty = c0 (gMempty @a) + mempty = coerce (gMempty @a) {-# INLINE mempty #-} 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 @@ -45,11 +45,11 @@ , gMin ) where +import Data.Coerce import Data.Data import Data.Monoid import GHC.Generics import Generics.OneLiner -import Generics.OneLiner.Instances.Internal -- | If @a@ is a data type whose fields are all instances of 'Eq', then -- @'GOrd' a@ has a 'Eq' instance. @@ -67,9 +67,9 @@ , Constraints a Eq ) => Eq (GOrd a) where - (==) = c2' (gEquals @a) + (==) = coerce (gEquals @a) {-# INLINE (==) #-} - (/=) = c2' (gNotEquals @a) + (/=) = coerce (gNotEquals @a) {-# INLINE (/=) #-} instance ( ADT a @@ -77,19 +77,19 @@ , Constraints a Ord ) => Ord (GOrd a) where - compare = c2' (gCompare @a) + compare = coerce (gCompare @a) {-# INLINE compare #-} - (<=) = c2' (gLTE @a) + (<=) = coerce (gLTE @a) {-# INLINE (<=) #-} - (<) = c2' (gLT @a) + (<) = coerce (gLT @a) {-# INLINE (<) #-} - (>=) = c2' (gGTE @a) + (>=) = coerce (gGTE @a) {-# INLINE (>=) #-} - (>) = c2' (gGT @a) + (>) = coerce (gGT @a) {-# INLINE (>) #-} - max = c2 (gMax @a) + max = coerce (gMax @a) {-# INLINE max #-} - min = c2 (gMin @a) + min = coerce (gMin @a) {-# INLINE min #-} -- | '==' implemented by using '==' between all of the diff --git a/src/Generics/OneLiner/Instances/Internal.hs b/src/Generics/OneLiner/Instances/Internal.hs deleted file mode 100644 --- a/src/Generics/OneLiner/Instances/Internal.hs +++ /dev/null @@ -1,22 +0,0 @@ - -module Generics.OneLiner.Instances.Internal ( - c0 - , c1 - , c2 - , c2' - ) where - -import Data.Coerce - -c0 :: Coercible a b => b -> a -c0 = coerce - -c1 :: Coercible a b => (b -> b) -> a -> a -c1 f = coerce . f . coerce - -c2 :: Coercible a b => (b -> b -> b) -> a -> a -> a -c2 f x y = coerce (f (coerce x) (coerce y)) - -c2' :: Coercible a b => (b -> b -> c) -> a -> a -> c -c2' f x y = f (coerce x) (coerce y) - diff --git a/src/Numeric/OneLiner.hs b/src/Numeric/OneLiner.hs --- a/src/Numeric/OneLiner.hs +++ b/src/Numeric/OneLiner.hs @@ -67,10 +67,10 @@ , gAtanh ) where +import Data.Coerce import Data.Data import GHC.Generics import Generics.OneLiner -import Generics.OneLiner.Instances.Internal -- | If @a@ is a data type with a single constructor whose fields are all -- instances of 'Num', then @'GNum' a@ has a 'Num' instance. @@ -89,19 +89,19 @@ instance (ADTRecord a, Constraints a Num) => Num (GNum a) where - (+) = c2 (gPlus @a) + (+) = coerce (gPlus @a) {-# INLINE (+) #-} - (-) = c2 (gMinus @a) + (-) = coerce (gMinus @a) {-# INLINE (-) #-} - (*) = c2 (gTimes @a) + (*) = coerce (gTimes @a) {-# INLINE (*) #-} - negate = c1 (gNegate @a) + negate = coerce (gNegate @a) {-# INLINE negate #-} - abs = c1 (gAbs @a) + abs = coerce (gAbs @a) {-# INLINE abs #-} - signum = c1 (gSignum @a) + signum = coerce (gSignum @a) {-# INLINE signum #-} - fromInteger = c0 (gFromInteger @a) + fromInteger = coerce (gFromInteger @a) {-# INLINE fromInteger #-} instance ( ADTRecord a @@ -109,11 +109,11 @@ , Constraints a Fractional ) => Fractional (GNum a) where - (/) = c2 (gDivide @a) + (/) = coerce (gDivide @a) {-# INLINE (/) #-} - recip = c1 (gRecip @a) + recip = coerce (gRecip @a) {-# INLINE recip #-} - fromRational = c0 (gFromRational @a) + fromRational = coerce (gFromRational @a) {-# INLINE fromRational #-} instance ( ADTRecord a @@ -122,41 +122,41 @@ , Constraints a Floating ) => Floating (GNum a) where - pi = c0 (gPi @a) + pi = coerce (gPi @a) {-# INLINE pi #-} - exp = c1 (gExp @a) + exp = coerce (gExp @a) {-# INLINE exp #-} - log = c1 (gLog @a) + log = coerce (gLog @a) {-# INLINE log #-} - sqrt = c1 (gSqrt @a) + sqrt = coerce (gSqrt @a) {-# INLINE sqrt #-} - (**) = c2 (gPower @a) + (**) = coerce (gPower @a) {-# INLINE (**) #-} - logBase = c2 (gLogBase @a) + logBase = coerce (gLogBase @a) {-# INLINE logBase #-} - sin = c1 (gSin @a) + sin = coerce (gSin @a) {-# INLINE sin #-} - cos = c1 (gCos @a) + cos = coerce (gCos @a) {-# INLINE cos #-} - tan = c1 (gTan @a) + tan = coerce (gTan @a) {-# INLINE tan #-} - asin = c1 (gAsin @a) + asin = coerce (gAsin @a) {-# INLINE asin #-} - acos = c1 (gAcos @a) + acos = coerce (gAcos @a) {-# INLINE acos #-} - atan = c1 (gAtan @a) + atan = coerce (gAtan @a) {-# INLINE atan #-} - sinh = c1 (gSinh @a) + sinh = coerce (gSinh @a) {-# INLINE sinh #-} - cosh = c1 (gCosh @a) + cosh = coerce (gCosh @a) {-# INLINE cosh #-} - tanh = c1 (gTanh @a) + tanh = coerce (gTanh @a) {-# INLINE tanh #-} - asinh = c1 (gAsinh @a) + asinh = coerce (gAsinh @a) {-# INLINE asinh #-} - acosh = c1 (gAcosh @a) + acosh = coerce (gAcosh @a) {-# INLINE acosh #-} - atanh = c1 (gAtanh @a) + atanh = coerce (gAtanh @a) {-# INLINE atanh #-} -- $num diff --git a/src/System/Random/OneLiner.hs b/src/System/Random/OneLiner.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/OneLiner.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE BangPatterns #-} +{-# 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 +-- Description : Derived methods for Random. +-- Copyright : (c) Justin Le 2018 +-- License : BSD-3 +-- Maintainer : justin@jle.im +-- Stability : unstable +-- Portability : portable +-- +-- Derived methods for 'Random', 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 'Random'. +-- +-- Also includes a newtype wrapper that imbues any such data type with +-- instant 'Random' instances, which can one day be used with /DerivingVia/ +-- syntax to derive instances automatically. +-- + +module System.Random.OneLiner ( + -- * Single constructor + -- ** Newtype wrapper + GRandom(..) + -- ** Generics-derived methods + , gRandomR + , gRandom + , gRandomRs + , gRandoms + , gRandomRIO + , gRandomIO + -- * Multiple constructor + -- ** Newtype wrapper + , GRandomSum(..) + -- ** Generics-derived methods + , gRandomRSum + , gRandomSum + , gRandomRSums + , gRandomSums + , gRandomRIOSum + , gRandomIOSum + ) where + +import Control.Monad +import Data.Coerce +import Data.Data +import Data.Functor.Compose +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import GHC.Exts (build) +import GHC.Generics +import Generics.OneLiner +import System.Random +import qualified Data.List.NonEmpty as NE + +-- | If @a@ is a data type with a single constructor whose fields are all +-- instances of 'Random', then @'GRandom' a@ has a 'Random' 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 'GRandomSum'. +newtype GRandom a = GRandom { getGRandom :: a } + deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) + +instance ( ADTRecord a + , Constraints a Random + ) + => Random (GRandom a) where + randomR :: forall g. RandomGen g => (GRandom a, GRandom a) -> g -> (GRandom a, g) + randomR = coerce (gRandomR @a @g) + {-# INLINE randomR #-} + random :: forall g. RandomGen g => g -> (GRandom a, g) + random = coerce (gRandom @a @g) + {-# INLINE random #-} + randomRs :: forall g. RandomGen g => (GRandom a, GRandom a) -> g -> [GRandom a] + randomRs = coerce (gRandomRs @a @g) + {-# INLINE randomRs #-} + 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. +gRandomR + :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) + => (a, a) -> g -> (a, g) +gRandomR (l, u) = runState $ + dialgebra @Random + (State . randomR . dePair) + (Pair l u) +{-# INLINE gRandomR #-} + +-- | 'random' implemented by sequencing 'random' for all components. +-- +-- Requires the type to have only a single constructor. +gRandom + :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) + => g -> (a, g) +gRandom = runState $ createA' @Random (State random) +{-# INLINE gRandom #-} + +-- | 'randomRs' implemented by repeatedly calling 'gRandomR'. +gRandomRs + :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) + => (a, a) -> g -> [a] +gRandomRs ival g = build (\cons _nil -> buildRandoms cons (gRandomR ival) g) +{-# INLINE gRandomRs #-} + +-- | 'randoms' implemented by repeatedly calling 'gRandom'. +gRandoms + :: forall a g. (ADTRecord a, Constraints a Random, RandomGen g) + => g -> [a] +gRandoms g = build (\cons _nil -> buildRandoms cons gRandom g) +{-# INLINE gRandoms #-} + +-- | 'randomRIO' implemented by calling 'gRandomR' on the global seed. +gRandomRIO + :: forall a. (ADTRecord a, Constraints a Random) + => (a, a) -> IO a +gRandomRIO range = getStdRandom (gRandomR range) +{-# INLINE gRandomRIO #-} + +-- | 'randomIO' implemented by calling 'gRandom' on the global seed. +gRandomIO + :: forall a. (ADTRecord a, Constraints a Random) + => IO a +gRandomIO = getStdRandom gRandom +{-# INLINE gRandomIO #-} + +-- | If @a@ is a data type whose fields are all instances of 'Random', then +-- @'GRandom' a@ has a 'Random' instance. +-- +-- Will one day be able to be used with /DerivingVia/ syntax, to derive +-- instances automatically. +-- +-- A version of 'GRandom' that works for data types with multiple +-- constructors. If your type has only one constructor, it might be more +-- performant to use 'GRandom'. +-- +-- Note that the "ranged" variants are partial: if given a range of items +-- made with different constructors, will be 'error'! +newtype GRandomSum a = GRandomSum { getGRandomSum :: a } + deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) + +instance ( ADT a + , Constraints a Random + ) + => Random (GRandomSum a) where + randomR :: forall g. RandomGen g => (GRandomSum a, GRandomSum a) -> g -> (GRandomSum a, g) + randomR = coerce (gRandomRSum @a @g) + {-# INLINE randomR #-} + random :: forall g. RandomGen g => g -> (GRandomSum a, g) + random = coerce (gRandomSum @a @g) + {-# INLINE random #-} + randomRs :: forall g. RandomGen g => (GRandomSum a, GRandomSum a) -> g -> [GRandomSum a] + randomRs = coerce (gRandomRSums @a @g) + {-# INLINE randomRs #-} + 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'! +gRandomRSum + :: forall a g. (ADT a, Constraints a Random, RandomGen g) + => (a, a) -> g -> (a, g) +gRandomRSum (l, u) = runState . fromMaybe (error badbad) . getCompose $ + zipWithA @Random (\l' u' -> Compose (Just (State (randomR (l', u'))))) + l u + where + badbad = "gRandomRSum: Constructors in range do not match." +{-# INLINE gRandomRSum #-} + +-- | 'random' implemented by selecting a random constructor and sequencing +-- 'random' for all components. +gRandomSum + :: forall a g. (ADT a, Constraints a Random, RandomGen g) + => g -> (a, g) +gRandomSum = case options of + Nothing -> (error "gRandomSum: Uninhabited type",) + Just opts -> runState (join (reservoir opts)) + where + options = NE.nonEmpty . getCompose $ createA @Random @a $ + Compose [State random] +{-# INLINE gRandomSum #-} + +-- | 'randomRs' implemented by repeatedly calling 'gRandomRSum'. +-- +-- If given a range of items made with different constructors, will be +-- 'error'! +gRandomRSums + :: forall a g. (ADT a, Constraints a Random, RandomGen g) + => (a, a) -> g -> [a] +gRandomRSums ival g = build (\cons _nil -> buildRandoms cons (gRandomRSum ival) g) +{-# INLINE gRandomRSums #-} + +-- | 'randoms' implemented by repeatedly calling 'gRandomSum'. +gRandomSums + :: forall a g. (ADT a, Constraints a Random, RandomGen g) + => g -> [a] +gRandomSums g = build (\cons _nil -> buildRandoms cons gRandomSum g) +{-# INLINE gRandomSums #-} + +-- | 'randomRIO' implemented by calling 'gRandomRSum' on the global seed. +-- +-- If given a range of items made with different constructors, will be +-- 'error'! +gRandomRIOSum + :: forall a. (ADT a, Constraints a Random) + => (a, a) -> IO a +gRandomRIOSum range = getStdRandom (gRandomRSum range) +{-# INLINE gRandomRIOSum #-} + +-- | 'randomIO' implemented by calling 'gRandom' on the global seed. +gRandomIOSum + :: forall a. (ADT a, Constraints a Random) + => IO a +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 + -> (g -> (a,g)) -- ^ E.g. 'random' + -> g -- ^ A 'RandomGen' instance + -> as +buildRandoms cons rand = go + where + -- The seq fixes part of #4218 and also makes fused Core simpler. + go g = x `seq` (x `cons` go g') where (x,g') = rand g +{-# INLINE buildRandoms #-} + +-- | Select a random item from a non-empty list in constant memory, using +-- only a single traversal, using reservoir sampling. +reservoir :: RandomGen g => NE.NonEmpty a -> State g a +reservoir (x :| xs) = go 2 x xs + where + go _ y [] = pure y + go !i y (z:zs) = do + j <- State $ randomR @Int (1, i) + if j <= 1 + then go (i + 1) z zs + else go (i + 1) y zs +{-# INLINE reservoir #-}