diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,8 +1,6 @@ (The following is the 3-clause BSD license.) -Copyright (c) 2000-2017, Koen Claessen -Copyright (c) 2006-2008, Björn Bringert -Copyright (c) 2009-2017, Nick Smallbone +Copyright (c) 2017 Daniel Cartwright Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,3 @@ # `savage` -`savage` is a re-export of the random generators from QuickCheck. +`savage` is a re-export of the random generators from Hedgehog. diff --git a/dist/build/autogen/Paths_savage.hs b/dist/build/autogen/Paths_savage.hs new file mode 100644 --- /dev/null +++ b/dist/build/autogen/Paths_savage.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -fno-warn-implicit-prelude #-} +module Paths_savage ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,1] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/usr/local/bin" +libdir = "/usr/local/lib/x86_64-linux-ghc-8.0.2/savage-1.0.1-7mk4JPYthPZDBUwhx5ufuF" +dynlibdir = "/usr/local/lib/x86_64-linux-ghc-8.0.2" +datadir = "/usr/local/share/x86_64-linux-ghc-8.0.2/savage-1.0.1" +libexecdir = "/usr/local/libexec/x86_64-linux-ghc-8.0.2/savage-1.0.1" +sysconfdir = "/usr/local/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "savage_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "savage_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "savage_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "savage_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "savage_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "savage_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/dist/build/autogen/cabal_macros.h b/dist/build/autogen/cabal_macros.h new file mode 100644 --- /dev/null +++ b/dist/build/autogen/cabal_macros.h @@ -0,0 +1,407 @@ +/* DO NOT EDIT: This file is automatically generated by Cabal */ + +/* package savage-1.0.1 */ +#ifndef VERSION_savage +#define VERSION_savage "1.0.1" +#endif /* VERSION_savage */ +#ifndef MIN_VERSION_savage +#define MIN_VERSION_savage(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 0 || \ + (major1) == 1 && (major2) == 0 && (minor) <= 1) +#endif /* MIN_VERSION_savage */ + +/* package base-4.9.1.0 */ +#ifndef VERSION_base +#define VERSION_base "4.9.1.0" +#endif /* VERSION_base */ +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(major1,major2,minor) (\ + (major1) < 4 || \ + (major1) == 4 && (major2) < 9 || \ + (major1) == 4 && (major2) == 9 && (minor) <= 1) +#endif /* MIN_VERSION_base */ + +/* package ansi-terminal-0.6.3.1 */ +#ifndef VERSION_ansi_terminal +#define VERSION_ansi_terminal "0.6.3.1" +#endif /* VERSION_ansi_terminal */ +#ifndef MIN_VERSION_ansi_terminal +#define MIN_VERSION_ansi_terminal(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 6 || \ + (major1) == 0 && (major2) == 6 && (minor) <= 3) +#endif /* MIN_VERSION_ansi_terminal */ + +/* package async-2.1.1.1 */ +#ifndef VERSION_async +#define VERSION_async "2.1.1.1" +#endif /* VERSION_async */ +#ifndef MIN_VERSION_async +#define MIN_VERSION_async(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 1 || \ + (major1) == 2 && (major2) == 1 && (minor) <= 1) +#endif /* MIN_VERSION_async */ + +/* package bytestring-0.10.8.1 */ +#ifndef VERSION_bytestring +#define VERSION_bytestring "0.10.8.1" +#endif /* VERSION_bytestring */ +#ifndef MIN_VERSION_bytestring +#define MIN_VERSION_bytestring(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 10 || \ + (major1) == 0 && (major2) == 10 && (minor) <= 8) +#endif /* MIN_VERSION_bytestring */ + +/* package concurrent-output-1.9.2 */ +#ifndef VERSION_concurrent_output +#define VERSION_concurrent_output "1.9.2" +#endif /* VERSION_concurrent_output */ +#ifndef MIN_VERSION_concurrent_output +#define MIN_VERSION_concurrent_output(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 9 || \ + (major1) == 1 && (major2) == 9 && (minor) <= 2) +#endif /* MIN_VERSION_concurrent_output */ + +/* package containers-0.5.7.1 */ +#ifndef VERSION_containers +#define VERSION_containers "0.5.7.1" +#endif /* VERSION_containers */ +#ifndef MIN_VERSION_containers +#define MIN_VERSION_containers(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 5 || \ + (major1) == 0 && (major2) == 5 && (minor) <= 7) +#endif /* MIN_VERSION_containers */ + +/* package directory-1.3.0.0 */ +#ifndef VERSION_directory +#define VERSION_directory "1.3.0.0" +#endif /* VERSION_directory */ +#ifndef MIN_VERSION_directory +#define MIN_VERSION_directory(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 3 || \ + (major1) == 1 && (major2) == 3 && (minor) <= 0) +#endif /* MIN_VERSION_directory */ + +/* package exceptions-0.8.3 */ +#ifndef VERSION_exceptions +#define VERSION_exceptions "0.8.3" +#endif /* VERSION_exceptions */ +#ifndef MIN_VERSION_exceptions +#define MIN_VERSION_exceptions(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 8 || \ + (major1) == 0 && (major2) == 8 && (minor) <= 3) +#endif /* MIN_VERSION_exceptions */ + +/* package lifted-async-0.9.3 */ +#ifndef VERSION_lifted_async +#define VERSION_lifted_async "0.9.3" +#endif /* VERSION_lifted_async */ +#ifndef MIN_VERSION_lifted_async +#define MIN_VERSION_lifted_async(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 9 || \ + (major1) == 0 && (major2) == 9 && (minor) <= 3) +#endif /* MIN_VERSION_lifted_async */ + +/* package mmorph-1.0.9 */ +#ifndef VERSION_mmorph +#define VERSION_mmorph "1.0.9" +#endif /* VERSION_mmorph */ +#ifndef MIN_VERSION_mmorph +#define MIN_VERSION_mmorph(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 0 || \ + (major1) == 1 && (major2) == 0 && (minor) <= 9) +#endif /* MIN_VERSION_mmorph */ + +/* package monad-control-1.0.2.2 */ +#ifndef VERSION_monad_control +#define VERSION_monad_control "1.0.2.2" +#endif /* VERSION_monad_control */ +#ifndef MIN_VERSION_monad_control +#define MIN_VERSION_monad_control(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 0 || \ + (major1) == 1 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_VERSION_monad_control */ + +/* package mtl-2.2.1 */ +#ifndef VERSION_mtl +#define VERSION_mtl "2.2.1" +#endif /* VERSION_mtl */ +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 2 || \ + (major1) == 2 && (major2) == 2 && (minor) <= 1) +#endif /* MIN_VERSION_mtl */ + +/* package pretty-show-1.6.13 */ +#ifndef VERSION_pretty_show +#define VERSION_pretty_show "1.6.13" +#endif /* VERSION_pretty_show */ +#ifndef MIN_VERSION_pretty_show +#define MIN_VERSION_pretty_show(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 6 || \ + (major1) == 1 && (major2) == 6 && (minor) <= 13) +#endif /* MIN_VERSION_pretty_show */ + +/* package primitive-0.6.2.0 */ +#ifndef VERSION_primitive +#define VERSION_primitive "0.6.2.0" +#endif /* VERSION_primitive */ +#ifndef MIN_VERSION_primitive +#define MIN_VERSION_primitive(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 6 || \ + (major1) == 0 && (major2) == 6 && (minor) <= 2) +#endif /* MIN_VERSION_primitive */ + +/* package random-1.1 */ +#ifndef VERSION_random +#define VERSION_random "1.1" +#endif /* VERSION_random */ +#ifndef MIN_VERSION_random +#define MIN_VERSION_random(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 1 || \ + (major1) == 1 && (major2) == 1 && (minor) <= 0) +#endif /* MIN_VERSION_random */ + +/* package resourcet-1.1.9 */ +#ifndef VERSION_resourcet +#define VERSION_resourcet "1.1.9" +#endif /* VERSION_resourcet */ +#ifndef MIN_VERSION_resourcet +#define MIN_VERSION_resourcet(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 1 || \ + (major1) == 1 && (major2) == 1 && (minor) <= 9) +#endif /* MIN_VERSION_resourcet */ + +/* package stm-2.4.4.1 */ +#ifndef VERSION_stm +#define VERSION_stm "2.4.4.1" +#endif /* VERSION_stm */ +#ifndef MIN_VERSION_stm +#define MIN_VERSION_stm(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 4 || \ + (major1) == 2 && (major2) == 4 && (minor) <= 4) +#endif /* MIN_VERSION_stm */ + +/* package template-haskell-2.11.1.0 */ +#ifndef VERSION_template_haskell +#define VERSION_template_haskell "2.11.1.0" +#endif /* VERSION_template_haskell */ +#ifndef MIN_VERSION_template_haskell +#define MIN_VERSION_template_haskell(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 11 || \ + (major1) == 2 && (major2) == 11 && (minor) <= 1) +#endif /* MIN_VERSION_template_haskell */ + +/* package text-1.2.2.2 */ +#ifndef VERSION_text +#define VERSION_text "1.2.2.2" +#endif /* VERSION_text */ +#ifndef MIN_VERSION_text +#define MIN_VERSION_text(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 2 || \ + (major1) == 1 && (major2) == 2 && (minor) <= 2) +#endif /* MIN_VERSION_text */ + +/* package th-lift-0.7.7 */ +#ifndef VERSION_th_lift +#define VERSION_th_lift "0.7.7" +#endif /* VERSION_th_lift */ +#ifndef MIN_VERSION_th_lift +#define MIN_VERSION_th_lift(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 7 || \ + (major1) == 0 && (major2) == 7 && (minor) <= 7) +#endif /* MIN_VERSION_th_lift */ + +/* package time-1.6.0.1 */ +#ifndef VERSION_time +#define VERSION_time "1.6.0.1" +#endif /* VERSION_time */ +#ifndef MIN_VERSION_time +#define MIN_VERSION_time(major1,major2,minor) (\ + (major1) < 1 || \ + (major1) == 1 && (major2) < 6 || \ + (major1) == 1 && (major2) == 6 && (minor) <= 0) +#endif /* MIN_VERSION_time */ + +/* package transformers-0.5.2.0 */ +#ifndef VERSION_transformers +#define VERSION_transformers "0.5.2.0" +#endif /* VERSION_transformers */ +#ifndef MIN_VERSION_transformers +#define MIN_VERSION_transformers(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 5 || \ + (major1) == 0 && (major2) == 5 && (minor) <= 2) +#endif /* MIN_VERSION_transformers */ + +/* package transformers-base-0.4.4 */ +#ifndef VERSION_transformers_base +#define VERSION_transformers_base "0.4.4" +#endif /* VERSION_transformers_base */ +#ifndef MIN_VERSION_transformers_base +#define MIN_VERSION_transformers_base(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 4 || \ + (major1) == 0 && (major2) == 4 && (minor) <= 4) +#endif /* MIN_VERSION_transformers_base */ + +/* package wl-pprint-annotated-0.1.0.0 */ +#ifndef VERSION_wl_pprint_annotated +#define VERSION_wl_pprint_annotated "0.1.0.0" +#endif /* VERSION_wl_pprint_annotated */ +#ifndef MIN_VERSION_wl_pprint_annotated +#define MIN_VERSION_wl_pprint_annotated(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 1 || \ + (major1) == 0 && (major2) == 1 && (minor) <= 0) +#endif /* MIN_VERSION_wl_pprint_annotated */ + +/* package unix-2.7.2.1 */ +#ifndef VERSION_unix +#define VERSION_unix "2.7.2.1" +#endif /* VERSION_unix */ +#ifndef MIN_VERSION_unix +#define MIN_VERSION_unix(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 7 || \ + (major1) == 2 && (major2) == 7 && (minor) <= 2) +#endif /* MIN_VERSION_unix */ + +/* tool gcc-6.4.0 */ +#ifndef TOOL_VERSION_gcc +#define TOOL_VERSION_gcc "6.4.0" +#endif /* TOOL_VERSION_gcc */ +#ifndef MIN_TOOL_VERSION_gcc +#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ + (major1) < 6 || \ + (major1) == 6 && (major2) < 4 || \ + (major1) == 6 && (major2) == 4 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_gcc */ + +/* tool ghc-8.0.2 */ +#ifndef TOOL_VERSION_ghc +#define TOOL_VERSION_ghc "8.0.2" +#endif /* TOOL_VERSION_ghc */ +#ifndef MIN_TOOL_VERSION_ghc +#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_ghc */ + +/* tool ghc-pkg-8.0.2 */ +#ifndef TOOL_VERSION_ghc_pkg +#define TOOL_VERSION_ghc_pkg "8.0.2" +#endif /* TOOL_VERSION_ghc_pkg */ +#ifndef MIN_TOOL_VERSION_ghc_pkg +#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_ghc_pkg */ + +/* tool ghcjs-0.2.0 */ +#ifndef TOOL_VERSION_ghcjs +#define TOOL_VERSION_ghcjs "0.2.0" +#endif /* TOOL_VERSION_ghcjs */ +#ifndef MIN_TOOL_VERSION_ghcjs +#define MIN_TOOL_VERSION_ghcjs(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 2 || \ + (major1) == 0 && (major2) == 2 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_ghcjs */ + +/* tool ghcjs-pkg-7.10.3 */ +#ifndef TOOL_VERSION_ghcjs_pkg +#define TOOL_VERSION_ghcjs_pkg "7.10.3" +#endif /* TOOL_VERSION_ghcjs_pkg */ +#ifndef MIN_TOOL_VERSION_ghcjs_pkg +#define MIN_TOOL_VERSION_ghcjs_pkg(major1,major2,minor) (\ + (major1) < 7 || \ + (major1) == 7 && (major2) < 10 || \ + (major1) == 7 && (major2) == 10 && (minor) <= 3) +#endif /* MIN_TOOL_VERSION_ghcjs_pkg */ + +/* tool haddock-2.17.3 */ +#ifndef TOOL_VERSION_haddock +#define TOOL_VERSION_haddock "2.17.3" +#endif /* TOOL_VERSION_haddock */ +#ifndef MIN_TOOL_VERSION_haddock +#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 17 || \ + (major1) == 2 && (major2) == 17 && (minor) <= 3) +#endif /* MIN_TOOL_VERSION_haddock */ + +/* tool hpc-0.67 */ +#ifndef TOOL_VERSION_hpc +#define TOOL_VERSION_hpc "0.67" +#endif /* TOOL_VERSION_hpc */ +#ifndef MIN_TOOL_VERSION_hpc +#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 67 || \ + (major1) == 0 && (major2) == 67 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_hpc */ + +/* tool hsc2hs-0.68.1 */ +#ifndef TOOL_VERSION_hsc2hs +#define TOOL_VERSION_hsc2hs "0.68.1" +#endif /* TOOL_VERSION_hsc2hs */ +#ifndef MIN_TOOL_VERSION_hsc2hs +#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\ + (major1) < 0 || \ + (major1) == 0 && (major2) < 68 || \ + (major1) == 0 && (major2) == 68 && (minor) <= 1) +#endif /* MIN_TOOL_VERSION_hsc2hs */ + +/* tool runghc-8.0.2 */ +#ifndef TOOL_VERSION_runghc +#define TOOL_VERSION_runghc "8.0.2" +#endif /* TOOL_VERSION_runghc */ +#ifndef MIN_TOOL_VERSION_runghc +#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\ + (major1) < 8 || \ + (major1) == 8 && (major2) < 0 || \ + (major1) == 8 && (major2) == 0 && (minor) <= 2) +#endif /* MIN_TOOL_VERSION_runghc */ + +/* tool strip-2.28 */ +#ifndef TOOL_VERSION_strip +#define TOOL_VERSION_strip "2.28" +#endif /* TOOL_VERSION_strip */ +#ifndef MIN_TOOL_VERSION_strip +#define MIN_TOOL_VERSION_strip(major1,major2,minor) (\ + (major1) < 2 || \ + (major1) == 2 && (major2) < 28 || \ + (major1) == 2 && (major2) == 28 && (minor) <= 0) +#endif /* MIN_TOOL_VERSION_strip */ + +#ifndef CURRENT_PACKAGE_KEY +#define CURRENT_PACKAGE_KEY "savage-1.0.1-7mk4JPYthPZDBUwhx5ufuF" +#endif /* CURRENT_PACKAGE_KEY */ +#ifndef CURRENT_COMPONENT_ID +#define CURRENT_COMPONENT_ID "savage-1.0.1-7mk4JPYthPZDBUwhx5ufuF" +#endif /* CURRENT_COMPONENT_ID */ +#ifndef CURRENT_PACKAGE_VERSION +#define CURRENT_PACKAGE_VERSION "1.0.1" +#endif /* CURRENT_PACKAGE_VERSION */ diff --git a/dist/package.conf.inplace/package.cache b/dist/package.conf.inplace/package.cache new file mode 100644 Binary files /dev/null and b/dist/package.conf.inplace/package.cache differ diff --git a/dist/setup-config b/dist/setup-config new file mode 100644 Binary files /dev/null and b/dist/setup-config differ diff --git a/release.nix b/release.nix new file mode 100644 --- /dev/null +++ b/release.nix @@ -0,0 +1,63 @@ +let + # Disable tests for these packages + dontCheckPackages = [ + ]; + + # Jailbreak these packages + doJailbreakPackages = [ + ]; + + # Disable haddocks for these packages + dontHaddockPackages = [ + ]; + + config = { + packageOverrides = pkgs: rec { + haskellPackages = + let + generatedOverrides = haskellPackagesNew: haskellPackagesOld: + let + toPackage = file: _: { + name = builtins.replaceStrings [ ".nix" ] [ "" ] file; + + value = haskellPackagesNew.callPackage (./. + "/nix/${file}") { }; + }; + + in + pkgs.lib.mapAttrs' toPackage (builtins.readDir ./nix); + + makeOverrides = + function: names: haskellPackagesNew: haskellPackagesOld: + let + toPackage = name: { + inherit name; + + value = function haskellPackagesOld.${name}; + }; + + in + builtins.listToAttrs (map toPackage names); + + composeExtensionsList = + pkgs.lib.fold pkgs.lib.composeExtensions (_: _: {}); + + # More exotic overrides go here + manualOverrides = haskellPackagesNew: haskellPackagesOld: { + }; + in + pkgs.haskellPackages.override { + overrides = composeExtensionsList [ + generatedOverrides + (makeOverrides pkgs.haskell.lib.dontCheck dontCheckPackages ) + (makeOverrides pkgs.haskell.lib.doJailbreak doJailbreakPackages) + (makeOverrides pkgs.haskell.lib.dontHaddock dontHaddockPackages) + manualOverrides + ]; + }; + }; + }; + + pkgs = import { inherit config; }; + +in + { savage = pkgs.haskellPackages.callCabal2nix "savage" ./. {}; } diff --git a/repl.sh b/repl.sh new file mode 100644 --- /dev/null +++ b/repl.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +# dist can cause problems with nix-build (called by nix-shell) +# so delete this in between builds +rm -rf dist + +#this is a workaround while cabal-repl is broken (https://github.com/haskell/cabal/issues/4602) +nix-shell -A savage.env release.nix --run "runhaskell Setup.hs configure; runhaskell Setup.hs repl lib:savage" + +# dist can cause problems with nix-build (called by nix-shell) +# so delete this in between builds +rm -rf dist diff --git a/savage-1.0.1.tar.gz b/savage-1.0.1.tar.gz new file mode 100644 Binary files /dev/null and b/savage-1.0.1.tar.gz differ diff --git a/savage.cabal b/savage.cabal --- a/savage.cabal +++ b/savage.cabal @@ -1,40 +1,92 @@ ---------------------------------------------------------------------- - -name: savage -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.10 -category: Data -author: Daniel Cartwright -maintainer: dcartwright@layer3com.com -license: BSD3 -license-file: LICENSE -homepage: https://github.com/chessai/savage -bug-reports: https://github.com/chessai/savage/issues -synopsis: Re-exported random generators from QuickCheck. -description: Re-exported random generators from QuickCheck. -extra-source-files: README.md -tested-with: GHC == 8.2.1 +version: 1.0.1 ---------------------------------------------------------------------- +name: + savage +author: + Daniel Cartwright +maintainer: + Daniel Cartwright +homepage: + https://github.com/chessai/savage +bug-reports: + https://github.com/chessai/savage/issues +synopsis: + re-export of the random generators from Hedgehog +description: + re-export of the random generators from Hedgehog: + +category: + Testing +license: + BSD3 +license-file: + LICENSE +cabal-version: + >= 1.8 +build-type: + Simple +tested-with: + GHC == 7.10.2 + , GHC == 7.10.3 + , GHC == 8.0.1 + , GHC == 8.0.2 +extra-source-files: + README.md + CHANGELOG.md source-repository head - type: git - branch: master - location: https://github.com/chessai/savage.git - ---------------------------------------------------------------------- + type: git + location: git://github.com/chessai/savage.git library - hs-source-dirs: src - build-depends: base >= 4.8 && < 5.0 - , random - , tf-random - exposed-modules: Savage - , Savage.Gen - , Savage.Randy - default-language: Haskell2010 - other-extensions: CPP - ---------------------------------------------------------------------- + build-depends: + base >= 3 && < 5 + , ansi-terminal >= 0.6 && < 0.8 + , async >= 2.0 && < 2.2 + , bytestring >= 0.10 && < 0.11 + , concurrent-output >= 1.7 && < 1.11 + , containers >= 0.4 && < 0.6 + , directory >= 1.2 && < 1.4 + , exceptions >= 0.7 && < 0.9 + , lifted-async >= 0.7 && < 0.10 + , mmorph >= 1.0 && < 1.2 + , monad-control >= 1.0 && < 1.1 + , mtl >= 2.1 && < 2.3 + , pretty-show >= 1.6 && < 1.7 + , primitive >= 0.6 && < 0.7 + , random >= 1.1 && < 1.2 + , resourcet >= 1.1 && < 1.2 + , stm >= 2.4 && < 2.5 + , template-haskell >= 2.10 && < 2.13 + , text >= 1.1 && < 1.3 + , th-lift >= 0.7 && < 0.8 + , time >= 1.4 && < 1.9 + , transformers >= 0.5 && < 0.6 + , transformers-base >= 0.4 && < 0.5 + , wl-pprint-annotated >= 0.0 && < 0.2 + if impl(ghc < 8.0) + build-depends: + semigroups >= 0.16 && < 0.19 + + if !os(windows) + build-depends: + unix >= 2.6 && < 2.8 + + ghc-options: + -Wall + + hs-source-dirs: + src + + exposed-modules: + Savage + Savage.Randy + Savage.Range + + Savage.Internal.Distributive + Savage.Internal.Gen + Savage.Internal.Range + Savage.Internal.Seed + Savage.Internal.Shrink + Savage.Internal.Tree diff --git a/src/Savage.hs b/src/Savage.hs --- a/src/Savage.hs +++ b/src/Savage.hs @@ -1,8 +1,21 @@ -module Savage - ( module Savage.Gen - , module Savage.Randy - ) where +-- This module is designed to be used alongside "Savage.Randy" and "Savage.Range", +-- which should be imported qualified. +-- +-- > import Savage +-- > import qualified Savage.Randy as Gen +-- > import qualified Savage.Range as Range -import Savage.Gen -import Savage.Randy +module Savage ( + Gen + , GenT + , MonadGen(..) + , Range + , Size(..) + , Seed(..) + , Distributive(..) + ) where +import Savage.Internal.Distributive (Distributive(..)) +import Savage.Internal.Gen (Gen, GenT, MonadGen(..)) +import Savage.Internal.Range (Range, Size(..)) +import Savage.Internal.Seed (Seed(..)) diff --git a/src/Savage/Gen.hs b/src/Savage/Gen.hs deleted file mode 100644 --- a/src/Savage/Gen.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifndef NO_ST_MONAD -{-# LANGUAGE Rank2Types #-} -#endif --- | Test case generation. -module Savage.Gen where - --------------------------------------------------------------------------- --- imports - -import System.Random - ( Random - , random - , randomR - , split - ) - -import Control.Monad - ( ap - , replicateM - , filterM - ) - -import Control.Applicative - ( Applicative(..) ) - -import Savage.Randy -import Data.List -import Data.Ord -import Data.Maybe - --------------------------------------------------------------------------- --- ** Generator type - --- | A generator for values of type @a@. --- --- The third-party package --- --- provides a monad transformer version of @GenT@. -newtype Gen a = MkGen{ - unGen :: SVGen -> Int -> a -- ^ Run the generator on a particular seed. - -- If you just want to get a random value out, consider using 'generate'. - } - -instance Functor Gen where - fmap f (MkGen h) = - MkGen (\r n -> f (h r n)) - -instance Applicative Gen where - pure = return - (<*>) = ap - -instance Monad Gen where - return x = - MkGen (\_ _ -> x) - - MkGen m >>= k = - MkGen (\r n -> - case split r of - (r1, r2) -> - let MkGen m' = k (m r1 n) - in m' r2 n - ) - --------------------------------------------------------------------------- --- ** Primitive generator combinators - --- | Modifies a generator using an integer seed. -variant :: Integral n => n -> Gen a -> Gen a -variant k (MkGen g) = MkGen (\r n -> g (variantSVGen k r) n) - --- | Used to construct generators that depend on the size parameter. --- --- For example, 'listOf', which uses the size parameter as an upper bound on --- length of lists it generates, can be defined like this: --- --- > listOf :: Gen a -> Gen [a] --- > listOf gen = sized $ \n -> --- > do k <- choose (0,n) --- > vectorOf k gen --- --- You can also do this using 'getSize'. -sized :: (Int -> Gen a) -> Gen a -sized f = MkGen (\r n -> let MkGen m = f n in m r n) - --- | Generates the size parameter. Used to construct generators that depend on --- the size parameter. --- --- For example, 'listOf', which uses the size parameter as an upper bound on --- length of lists it generates, can be defined like this: --- --- > listOf :: Gen a -> Gen [a] --- > listOf gen = do --- > n <- getSize --- > k <- choose (0,n) --- > vectorOf k gen --- --- You can also do this using 'sized'. -getSize :: Gen Int -getSize = sized pure - --- | Overrides the size parameter. Returns a generator which uses --- the given size instead of the runtime-size parameter. -resize :: Int -> Gen a -> Gen a -resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" -resize n (MkGen g) = MkGen (\r _ -> g r n) - --- | Adjust the size parameter, by transforming it with the given --- function. -scale :: (Int -> Int) -> Gen a -> Gen a -scale f g = sized (\n -> resize (f n) g) - --- | Generates a random element in the given inclusive range. -choose :: Random a => (a,a) -> Gen a -choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) - --- | Generates a random element over the natural range of `a`. -chooseAny :: Random a => Gen a -chooseAny = MkGen (\r _ -> let (x,_) = random r in x) - --- | Run a generator. The size passed to the generator is always 30; --- if you want another size then you should explicitly use 'resize'. -generate :: Gen a -> IO a -generate (MkGen g) = - do r <- newSVGen - return (g r 30) - --- | Generates some example values. -sample' :: Gen a -> IO [a] -sample' g = - generate (sequence [ resize n g | n <- [0,2..20] ]) - --- | Generates some example values and prints them to 'stdout'. -sample :: Show a => Gen a -> IO () -sample g = - do cases <- sample' g - mapM_ print cases - --------------------------------------------------------------------------- --- ** Common generator combinators - --- | Generates a value that satisfies a predicate. -suchThat :: Gen a -> (a -> Bool) -> Gen a -gen `suchThat` p = - do mx <- gen `suchThatMaybe` p - case mx of - Just x -> return x - Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) - --- | Generates a value for which the given function returns a 'Just', and then --- applies the function. -suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b -gen `suchThatMap` f = - fmap fromJust $ fmap f gen `suchThat` isJust - --- | Tries to generate a value that satisfies a predicate. --- If it fails to do so after enough attempts, returns @Nothing@. -suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) -gen `suchThatMaybe` p = sized (try 0 . max 1) - where - try _ 0 = return Nothing - try k n = do x <- resize (2*k+n) gen - if p x then return (Just x) else try (k+1) (n-1) - --- | Randomly uses one of the given generators. The input list --- must be non-empty. -oneof :: [Gen a] -> Gen a -oneof [] = error "QuickCheck.oneof used with empty list" -oneof gs = choose (0,length gs - 1) >>= (gs !!) - --- | Chooses one of the given generators, with a weighted random distribution. --- The input list must be non-empty. -frequency :: [(Int, Gen a)] -> Gen a -frequency [] = error "QuickCheck.frequency used with empty list" -frequency xs0 = choose (1, tot) >>= (`pick` xs0) - where - tot = sum (map fst xs0) - - pick n ((k,x):xs) - | n <= k = x - | otherwise = pick (n-k) xs - pick _ _ = error "QuickCheck.pick used with empty list" - --- | Generates one of the given values. The input list must be non-empty. -elements :: [a] -> Gen a -elements [] = error "QuickCheck.elements used with empty list" -elements xs = (xs !!) `fmap` choose (0, length xs - 1) - --- | Generates a random subsequence of the given list. -sublistOf :: [a] -> Gen [a] -sublistOf xs = filterM (\_ -> choose (False, True)) xs - --- | Generates a random permutation of the given list. -shuffle :: [a] -> Gen [a] -shuffle xs = do - ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) - return (map snd (sortBy (comparing fst) (zip ns xs))) - --- | Takes a list of elements of increasing size, and chooses --- among an initial segment of the list. The size of this initial --- segment increases with the size parameter. --- The input list must be non-empty. -growingElements :: [a] -> Gen a -growingElements [] = error "QuickCheck.growingElements used with empty list" -growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) - where - k = length xs - mx = 100 - log' = round . log . toDouble - size n = (log' n + 1) * k `div` log' mx - toDouble = fromIntegral :: Int -> Double - -{- WAS: -growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) - where - k = length xs --} - --- | Generates a list of random length. The maximum length depends on the --- size parameter. -listOf :: Gen a -> Gen [a] -listOf gen = sized $ \n -> - do k <- choose (0,n) - vectorOf k gen - --- | Generates a non-empty list of random length. The maximum length --- depends on the size parameter. -listOf1 :: Gen a -> Gen [a] -listOf1 gen = sized $ \n -> - do k <- choose (1,1 `max` n) - vectorOf k gen - --- | Generates a list of the given length. -vectorOf :: Int -> Gen a -> Gen [a] -vectorOf = replicateM - --- | Generates an infinite list. -infiniteListOf :: Gen a -> Gen [a] -infiniteListOf gen = sequence (repeat gen) - --------------------------------------------------------------------------- --- the end. diff --git a/src/Savage/Internal/Distributive.hs b/src/Savage/Internal/Distributive.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Internal/Distributive.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module Savage.Internal.Distributive ( + Distributive(..) + ) where + +import Control.Monad (join) +import Control.Monad.Morph (MFunctor(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.Writer (WriterT(..)) + +import GHC.Exts (Constraint) + + +class Distributive g where + type Transformer + (f :: (* -> *) -> * -> *) + (g :: (* -> *) -> * -> *) + (m :: * -> *) :: Constraint + + type Transformer f g m = ( + Monad m + , Monad (f m) + , Monad (g m) + , Monad (f (g m)) + , MonadTrans f + , MFunctor f + ) + + -- | Distribute one monad transformer over another. + -- + distribute :: Transformer f g m => g (f m) a -> f (g m) a + +instance Distributive MaybeT where + distribute x = + lift . MaybeT . pure =<< hoist lift (runMaybeT x) + +instance Distributive (ExceptT x) where + distribute x = + lift . ExceptT . pure =<< hoist lift (runExceptT x) + +instance Monoid w => Distributive (WriterT w) where + distribute x = + lift . WriterT . pure =<< hoist lift (runWriterT x) + +instance Distributive (ReaderT r) where + distribute x = + join . lift . ReaderT $ \r -> + pure . hoist lift $ runReaderT x r diff --git a/src/Savage/Internal/Gen.hs b/src/Savage/Internal/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Internal/Gen.hs @@ -0,0 +1,1622 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- MonadBase +module Savage.Internal.Gen ( + -- * Transformer + Gen + , GenT(..) + , MonadGen(..) + + -- * Combinators + , lift + + -- ** Shrinking + , shrink + , prune + + -- ** Size + , small + , scale + , resize + , sized + + -- ** Integral + , integral + , integral_ + + , int + , int8 + , int16 + , int32 + , int64 + + , word + , word8 + , word16 + , word32 + , word64 + + -- ** Floating-point + , realFloat + , realFrac_ + , float + , double + + -- ** Enumeration + , enum + , enumBounded + , bool + , bool_ + + -- ** Characters + , binit + , octit + , digit + , hexit + , lower + , upper + , alpha + , alphaNum + , ascii + , latin1 + , unicode + , unicodeAll + + -- ** Strings + , string + , text + , utf8 + , bytes + + -- ** Choice + , constant + , element + , choice + , frequency + , recursive + + -- ** Conditional + , discard + , ensure + , filter + , just + + -- ** Collections + , maybe + , list + , seq + , nonEmpty + , set + , map + + -- ** Subterms + , freeze + , subterm + , subtermM + , subterm2 + , subtermM2 + , subterm3 + , subtermM3 + + -- ** Combinations & Permutations + , subsequence + , shuffle + + -- * Sampling Generators + , sample + , print + , printTree + , printWith + , printTreeWith + + -- * Internal + -- $internal + + -- ** Transfomer + , runGenT + , mapGenT + , generate + , liftTree + , runDiscardEffect + + -- ** Size + , golden + + -- ** Shrinking + , atLeast + + -- ** Characters + , isSurrogate + + -- ** Subterms + , Vec(..) + , Nat(..) + , subtermMVec + + -- ** Sampling + , renderNodes + ) where + +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..), filterM, replicateM, ap, join) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Morph (MFunctor(..), MMonad(..), generalize) +import Control.Monad.Primitive (PrimMonad(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans) +import qualified Control.Monad.Trans.Class as Trans +import Control.Monad.Trans.Except (ExceptT(..), mapExceptT) +import Control.Monad.Trans.Identity (IdentityT(..), mapIdentityT) +import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT) +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT) +import Control.Monad.Trans.Resource (MonadResource(..)) +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Control.Monad.Writer.Class (MonadWriter(..)) + +import Data.Bifunctor (first, second) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.Char as Char +import Data.Foldable (for_, toList) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word (Word8, Word16, Word32, Word64) + +import Savage.Internal.Distributive (Distributive(..)) +import Savage.Internal.Seed (Seed) +import qualified Savage.Internal.Seed as Seed +import qualified Savage.Internal.Shrink as Shrink +import Savage.Internal.Tree (Tree(..), Node(..)) +import qualified Savage.Internal.Tree as Tree +import Savage.Range (Size, Range) +import qualified Savage.Range as Range + +import Prelude hiding (filter, print, maybe, map, seq) + + +------------------------------------------------------------------------ +-- Generator transformer + +-- | Generator for random values of @a@. +-- +type Gen = + GenT Identity + +-- | Monad transformer which can generate random values of @a@. +-- +newtype GenT m a = + GenT { + unGen :: Size -> Seed -> Tree (MaybeT m) a + } + +-- | Runs a generator, producing its shrink tree. +-- +runGenT :: Size -> Seed -> GenT m a -> Tree (MaybeT m) a +runGenT size seed (GenT m) = + m size seed + +-- | Map over a generator's shrink tree. +-- +mapGenT :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> GenT m a -> GenT n b +mapGenT f gen = + GenT $ \size seed -> + f (runGenT size seed gen) + +-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the +-- size. +-- +liftTree :: Tree (MaybeT m) a -> GenT m a +liftTree x = + GenT (\_ _ -> x) + +-- | Run the discard effects through the tree and reify them as 'Maybe' values +-- at the nodes. 'Nothing' means discarded, 'Just' means we have a value. +-- +runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a) +runDiscardEffect = + runMaybeT . distribute + +------------------------------------------------------------------------ +-- MonadGen + +-- | Class of monads which can generate input data for tests. +-- +-- /The functions on this class can, and should, be used without their @Gen@/ +-- /suffix by importing "Hedgehog.Gen" qualified./ +-- +class Monad m => MonadGen m where + -- | See @Gen.@'Hedgehog.Gen.lift' + -- + liftGen :: Gen a -> m a + + -- | See @Gen.@'Hedgehog.Gen.shrink' + -- + shrinkGen :: (a -> [a]) -> m a -> m a + + -- | See @Gen.@'Hedgehog.Gen.prune' + -- + pruneGen :: m a -> m a + + -- | See @Gen.@'Hedgehog.Gen.scale' + -- + scaleGen :: (Size -> Size) -> m a -> m a + + -- | See @Gen.@'Hedgehog.Gen.freeze' + -- + freezeGen :: m a -> m (a, m a) + +instance Monad m => MonadGen (GenT m) where + liftGen gen = + hoist generalize gen + + shrinkGen = + mapGenT . Tree.expand + + pruneGen = + mapGenT Tree.prune + + scaleGen f gen = + GenT $ \size0 seed -> + let + size = + f size0 + in + if size < 0 then + error "Hedgehog.Gen.scale: negative size" + else + runGenT size seed gen + + freezeGen gen = + GenT $ \size seed -> do + mx <- Trans.lift . Trans.lift . runMaybeT . runTree $ runGenT size seed gen + case mx of + Nothing -> + mzero + Just (Node x xs) -> + pure (x, liftTree . Tree.fromNode $ Node x xs) + +instance MonadGen m => MonadGen (IdentityT m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapIdentityT (shrink f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapIdentityT $ + fmap (second Trans.lift) . freeze + +shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a] +shrinkMaybe f = \case + Nothing -> + pure Nothing + Just x -> + fmap Just (f x) + +shrinkEither :: (a -> [a]) -> Either x a -> [Either x a] +shrinkEither f = \case + Left x -> + pure $ Left x + Right x -> + fmap Right (f x) + +shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)] +shrink2 f (x, y) = + fmap (, y) (f x) + +shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)] +shrink3 f (x, y, z) = + fmap (, y, z) (f x) + +instance MonadGen m => MonadGen (MaybeT m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapMaybeT $ + shrink (shrinkMaybe f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapMaybeT $ \m0 -> do + (mx, m) <- freeze m0 + pure $ fmap (, MaybeT m) mx + +instance MonadGen m => MonadGen (ExceptT x m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapExceptT $ + shrink (shrinkEither f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapExceptT $ \m0 -> do + (mx, m) <- freeze m0 + pure $ fmap (, ExceptT m) mx + +instance MonadGen m => MonadGen (ReaderT r m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + mapReaderT (shrink f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen = + mapReaderT $ + fmap (second Trans.lift) . freeze + +instance MonadGen m => MonadGen (Lazy.StateT s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Lazy.mapStateT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Lazy.StateT $ \s0 -> do + ((x, s), m) <- freeze (Lazy.runStateT m0 s0) + pure ((x, Lazy.StateT (const m)), s) + +instance MonadGen m => MonadGen (Strict.StateT s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Strict.mapStateT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Strict.StateT $ \s0 -> do + ((x, s), m) <- freeze (Strict.runStateT m0 s0) + pure ((x, Strict.StateT (const m)), s) + +instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Lazy.mapWriterT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Lazy.WriterT $ do + ((x, w), m) <- freeze (Lazy.runWriterT m0) + pure ((x, Lazy.WriterT m), w) + +instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Strict.mapWriterT $ + shrink (shrink2 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Strict.WriterT $ do + ((x, w), m) <- freeze (Strict.runWriterT m0) + pure ((x, Strict.WriterT m), w) + +instance (MonadGen m, Monoid w) => MonadGen (Lazy.RWST r w s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Lazy.mapRWST $ + shrink (shrink3 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Lazy.RWST $ \r s0 -> do + ((x, s, w), m) <- freeze (Lazy.runRWST m0 r s0) + pure ((x, Lazy.RWST (\_ _ -> m)), s, w) + +instance (MonadGen m, Monoid w) => MonadGen (Strict.RWST r w s m) where + liftGen = + Trans.lift . liftGen + + shrinkGen f = + Strict.mapRWST $ + shrink (shrink3 f) + + pruneGen = + hoist prune + + scaleGen f = + hoist (scale f) + + freezeGen m0 = + Strict.RWST $ \r s0 -> do + ((x, s, w), m) <- freeze (Strict.runRWST m0 r s0) + pure ((x, Strict.RWST (\_ _ -> m)), s, w) + +------------------------------------------------------------------------ +-- GenT instances + +instance Functor m => Functor (GenT m) where + fmap f gen = + GenT $ \seed size -> + fmap f (runGenT seed size gen) + +instance Monad m => Applicative (GenT m) where + pure = + return + (<*>) = + ap + +instance Monad m => Monad (GenT m) where + return = + liftTree . pure + + (>>=) m k = + GenT $ \size seed -> + case Seed.split seed of + (sk, sm) -> + runGenT size sk . k =<< + runGenT size sm m + +instance Monad m => Alternative (GenT m) where + empty = + mzero + (<|>) = + mplus + +instance Monad m => MonadPlus (GenT m) where + mzero = + liftTree mzero + + mplus x y = + GenT $ \size seed -> + case Seed.split seed of + (sx, sy) -> + runGenT size sx x `mplus` + runGenT size sy y + +instance MonadTrans GenT where + lift = + liftTree . Trans.lift . Trans.lift + +instance MFunctor GenT where + hoist f = + mapGenT (hoist (hoist f)) + +embedMaybe :: + MonadTrans t + => Monad n + => Monad (t (MaybeT n)) + => (forall a. m a -> t (MaybeT n) a) + -> MaybeT m b + -> t (MaybeT n) b +embedMaybe f m = + Trans.lift . MaybeT . pure =<< f (runMaybeT m) + +embedTree :: Monad n => (forall a. m a -> Tree (MaybeT n) a) -> Tree (MaybeT m) b -> Tree (MaybeT n) b +embedTree f tree = + embed (embedMaybe f) tree + +embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b +embedGen f gen = + GenT $ \size seed -> + case Seed.split seed of + (sf, sg) -> + (runGenT size sf . f) `embedTree` + (runGenT size sg gen) + +instance MMonad GenT where + embed = + embedGen + +distributeGen :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a +distributeGen x = + join . Trans.lift . GenT $ \size seed -> + pure . hoist liftTree . distribute . hoist distribute $ runGenT size seed x + +instance Distributive GenT where + type Transformer t GenT m = ( + Monad (t (GenT m)) + , Transformer t MaybeT m + , Transformer t Tree (MaybeT m) + ) + + distribute = + distributeGen + +instance PrimMonad m => PrimMonad (GenT m) where + type PrimState (GenT m) = + PrimState m + primitive = + Trans.lift . primitive + +instance MonadIO m => MonadIO (GenT m) where + liftIO = + Trans.lift . liftIO + +instance MonadBase b m => MonadBase b (GenT m) where + liftBase = + Trans.lift . liftBase + +instance MonadThrow m => MonadThrow (GenT m) where + throwM = + Trans.lift . throwM + +instance MonadCatch m => MonadCatch (GenT m) where + catch m onErr = + GenT $ \size seed -> + case Seed.split seed of + (sm, se) -> + (runGenT size sm m) `catch` + (runGenT size se . onErr) + +instance MonadReader r m => MonadReader r (GenT m) where + ask = + Trans.lift ask + local f m = + mapGenT (local f) m + +instance MonadState s m => MonadState s (GenT m) where + get = + Trans.lift get + put = + Trans.lift . put + state = + Trans.lift . state + +instance MonadWriter w m => MonadWriter w (GenT m) where + writer = + Trans.lift . writer + tell = + Trans.lift . tell + listen = + mapGenT listen + pass = + mapGenT pass + +instance MonadError e m => MonadError e (GenT m) where + throwError = + Trans.lift . throwError + catchError m onErr = + GenT $ \size seed -> + case Seed.split seed of + (sm, se) -> + (runGenT size sm m) `catchError` + (runGenT size se . onErr) + +instance MonadResource m => MonadResource (GenT m) where + liftResourceT = + Trans.lift . liftResourceT + +------------------------------------------------------------------------ +-- Combinators + +-- | Lift a vanilla 'Gen' in to a 'MonadGen'. +-- +lift :: MonadGen m => Gen a -> m a +lift = + liftGen + +-- | Generate a value with no shrinks from a 'Size' and a 'Seed'. +-- +generate :: MonadGen m => (Size -> Seed -> a) -> m a +generate f = + liftGen . GenT $ \size seed -> + pure (f size seed) + +------------------------------------------------------------------------ +-- Combinators - Shrinking + +-- | Apply a shrinking function to a generator. +-- +-- This will give the generator additional shrinking options, while keeping +-- the existing shrinks intact. +-- +shrink :: MonadGen m => (a -> [a]) -> m a -> m a +shrink = + shrinkGen + +-- | Throw away a generator's shrink tree. +-- +prune :: MonadGen m => m a -> m a +prune = + pruneGen + +------------------------------------------------------------------------ +-- Combinators - Size + +-- | Construct a generator that depends on the size parameter. +-- +sized :: MonadGen m => (Size -> m a) -> m a +sized f = do + f =<< generate (\size _ -> size) + +-- | Override the size parameter. Returns a generator which uses the given size +-- instead of the runtime-size parameter. +-- +resize :: MonadGen m => Size -> m a -> m a +resize size gen = + scale (const size) gen + +-- | Adjust the size parameter by transforming it with the given function. +-- +scale :: MonadGen m => (Size -> Size) -> m a -> m a +scale = + scaleGen + +-- | Make a generator smaller by scaling its size parameter. +-- +small :: MonadGen m => m a -> m a +small = + scale golden + +-- | Scale a size using the golden ratio. +-- +-- > golden x = x / φ +-- > golden x = x / 1.61803.. +-- +golden :: Size -> Size +golden x = + round (fromIntegral x * 0.61803398875 :: Double) + +------------------------------------------------------------------------ +-- Combinators - Integral + +-- | Generates a random integral number in the given @[inclusive,inclusive]@ range. +-- +-- When the generator tries to shrink, it will shrink towards the +-- 'Range.origin' of the specified 'Range'. +-- +-- For example, the following generator will produce a number between @1970@ +-- and @2100@, but will shrink towards @2000@: +-- +-- @ +-- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int' +-- @ +-- +-- Some sample outputs from this generator might look like: +-- +-- > === Outcome === +-- > 1973 +-- > === Shrinks === +-- > 2000 +-- > 1987 +-- > 1980 +-- > 1976 +-- > 1974 +-- +-- > === Outcome === +-- > 2061 +-- > === Shrinks === +-- > 2000 +-- > 2031 +-- > 2046 +-- > 2054 +-- > 2058 +-- > 2060 +-- +integral :: (MonadGen m, Integral a) => Range a -> m a +integral range = + shrink (Shrink.towards $ Range.origin range) (integral_ range) + +-- | Generates a random integral number in the [inclusive,inclusive] range. +-- +-- /This generator does not shrink./ +-- +integral_ :: (MonadGen m, Integral a) => Range a -> m a +integral_ range = + generate $ \size seed -> + let + (x, y) = + Range.bounds size range + in + fromInteger . fst $ + Seed.nextInteger (toInteger x) (toInteger y) seed + +-- | Generates a random machine integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int :: MonadGen m => Range Int -> m Int +int = + integral + +-- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int8 :: MonadGen m => Range Int8 -> m Int8 +int8 = + integral + +-- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int16 :: MonadGen m => Range Int16 -> m Int16 +int16 = + integral + +-- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int32 :: MonadGen m => Range Int32 -> m Int32 +int32 = + integral + +-- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +int64 :: MonadGen m => Range Int64 -> m Int64 +int64 = + integral + +-- | Generates a random machine word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word :: MonadGen m => Range Word -> m Word +word = + integral + +-- | Generates a random byte in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word8 :: MonadGen m => Range Word8 -> m Word8 +word8 = + integral + +-- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word16 :: MonadGen m => Range Word16 -> m Word16 +word16 = + integral + +-- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word32 :: MonadGen m => Range Word32 -> m Word32 +word32 = + integral + +-- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range. +-- +-- /This is a specialization of 'integral', offered for convenience./ +-- +word64 :: MonadGen m => Range Word64 -> m Word64 +word64 = + integral + +------------------------------------------------------------------------ +-- Combinators - Fractional / Floating-Point + +-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. +-- +-- This generator works the same as 'integral', but for floating point numbers. +-- +realFloat :: (MonadGen m, RealFloat a) => Range a -> m a +realFloat range = + shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range) + +-- | Generates a random fractional number in the [inclusive,exclusive) range. +-- +-- /This generator does not shrink./ +-- +realFrac_ :: (MonadGen m, RealFrac a) => Range a -> m a +realFrac_ range = + generate $ \size seed -> + let + (x, y) = + Range.bounds size range + in + realToFrac . fst $ + Seed.nextDouble (realToFrac x) (realToFrac y) seed + +-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. +-- +-- /This is a specialization of 'realFloat', offered for convenience./ +-- +float :: MonadGen m => Range Float -> m Float +float = + realFloat + +-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. +-- +-- /This is a specialization of 'realFloat', offered for convenience./ +-- +double :: MonadGen m => Range Double -> m Double +double = + realFloat + +------------------------------------------------------------------------ +-- Combinators - Enumeration + +-- | Generates an element from an enumeration. +-- +-- This generator shrinks towards the first argument. +-- +-- For example: +-- +-- @ +-- enum \'a' \'z' :: 'Gen' 'Char' +-- @ +-- +enum :: (MonadGen m, Enum a) => a -> a -> m a +enum lo hi = + fmap toEnum . integral $ + Range.constant (fromEnum lo) (fromEnum hi) + +-- | Generates a random value from a bounded enumeration. +-- +-- This generator shrinks towards 'minBound'. +-- +-- For example: +-- +-- @ +-- enumBounded :: 'Gen' 'Bool' +-- @ +-- +enumBounded :: (MonadGen m, Enum a, Bounded a) => m a +enumBounded = + enum minBound maxBound + +-- | Generates a random boolean. +-- +-- This generator shrinks to 'False'. +-- +-- /This is a specialization of 'enumBounded', offered for convenience./ +-- +bool :: MonadGen m => m Bool +bool = + enumBounded + +-- | Generates a random boolean. +-- +-- /This generator does not shrink./ +-- +bool_ :: MonadGen m => m Bool +bool_ = + generate $ \_ seed -> + (/= 0) . fst $ Seed.nextInteger 0 1 seed + +------------------------------------------------------------------------ +-- Combinators - Characters + +-- | Generates an ASCII binit: @'0'..'1'@ +-- +binit :: MonadGen m => m Char +binit = + enum '0' '1' + +-- | Generates an ASCII octit: @'0'..'7'@ +-- +octit :: MonadGen m => m Char +octit = + enum '0' '7' + +-- | Generates an ASCII digit: @'0'..'9'@ +-- +digit :: MonadGen m => m Char +digit = + enum '0' '9' + +-- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@ +-- +hexit :: MonadGen m => m Char +hexit = + -- FIXME optimize lookup, use a SmallArray or something. + element "0123456789aAbBcCdDeEfF" + +-- | Generates an ASCII lowercase letter: @\'a\'..\'z\'@ +-- +lower :: MonadGen m => m Char +lower = + enum 'a' 'z' + +-- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@ +-- +upper :: MonadGen m => m Char +upper = + enum 'A' 'Z' + +-- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@ +-- +alpha :: MonadGen m => m Char +alpha = + -- FIXME optimize lookup, use a SmallArray or something. + element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + +-- | Generates an ASCII letter or digit: @\'a\'..\'z\', \'A\'..\'Z\', \'0\'..\'9\'@ +-- +alphaNum :: MonadGen m => m Char +alphaNum = + -- FIXME optimize lookup, use a SmallArray or something. + element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + +-- | Generates an ASCII character: @'\0'..'\127'@ +-- +ascii :: MonadGen m => m Char +ascii = + enum '\0' '\127' + +-- | Generates a Latin-1 character: @'\0'..'\255'@ +-- +latin1 :: MonadGen m => m Char +latin1 = + enum '\0' '\255' + +-- | Generates a Unicode character, excluding invalid standalone surrogates: +-- @'\0'..'\1114111' (excluding '\55296'..'\57343')@ +-- +unicode :: MonadGen m => m Char +unicode = + filter (not . isSurrogate) unicodeAll + +-- | Generates a Unicode character, including invalid standalone surrogates: +-- @'\0'..'\1114111'@ +-- +unicodeAll :: MonadGen m => m Char +unicodeAll = + enumBounded + +-- | Check if a character is in the surrogate category. +-- +isSurrogate :: Char -> Bool +isSurrogate x = + x >= '\55296' && x <= '\57343' + +------------------------------------------------------------------------ +-- Combinators - Strings + +-- | Generates a string using 'Range' to determine the length. +-- +-- /This is a specialization of 'list', offered for convenience./ +-- +string :: MonadGen m => Range Int -> m Char -> m String +string = + list + +-- | Generates a string using 'Range' to determine the length. +-- +text :: MonadGen m => Range Int -> m Char -> m Text +text range = + fmap Text.pack . string range + +-- | Generates a UTF-8 encoded string, using 'Range' to determine the length. +-- +utf8 :: MonadGen m => Range Int -> m Char -> m ByteString +utf8 range = + fmap Text.encodeUtf8 . text range + +-- | Generates a random 'ByteString', using 'Range' to determine the +-- length. +-- +bytes :: MonadGen m => Range Int -> m ByteString +bytes range = + fmap ByteString.pack $ + choice [ + list range . word8 $ + Range.constant + (fromIntegral $ Char.ord 'a') + (fromIntegral $ Char.ord 'z') + + , list range . word8 $ + Range.constant minBound maxBound + ] + +------------------------------------------------------------------------ +-- Combinators - Choice + +-- | Trivial generator that always produces the same element. +-- +-- /This is another name for 'pure' \/ 'return'./ +constant :: MonadGen m => a -> m a +constant = + pure + +-- | Randomly selects one of the elements in the list. +-- +-- This generator shrinks towards the first element in the list. +-- +-- /The input list must be non-empty./ +-- +element :: MonadGen m => [a] -> m a +element = \case + [] -> + error "Hedgehog.Gen.element: used with empty list" + xs -> do + n <- integral $ Range.constant 0 (length xs - 1) + pure $ xs !! n + +-- | Randomly selects one of the generators in the list. +-- +-- This generator shrinks towards the first generator in the list. +-- +-- /The input list must be non-empty./ +-- +choice :: MonadGen m => [m a] -> m a +choice = \case + [] -> + error "Hedgehog.Gen.choice: used with empty list" + xs -> do + n <- integral $ Range.constant 0 (length xs - 1) + xs !! n + +-- | Uses a weighted distribution to randomly select one of the generators in +-- the list. +-- +-- This generator shrinks towards the first generator in the list. +-- +-- /The input list must be non-empty./ +-- +frequency :: MonadGen m => [(Int, m a)] -> m a +frequency = \case + [] -> + error "Hedgehog.Gen.frequency: used with empty list" + xs0 -> do + let + pick n = \case + [] -> + error "Hedgehog.Gen.frequency/pick: used with empty list" + (k, x) : xs -> + if n <= k then + x + else + pick (n - k) xs + + total = + sum (fmap fst xs0) + + n <- integral $ Range.constant 1 total + pick n xs0 + +-- | Modifies combinators which choose from a list of generators, like 'choice' +-- or 'frequency', so that they can be used in recursive scenarios. +-- +-- This combinator modifies its target to select one of the generators in +-- either the non-recursive or the recursive list. When a selection is made +-- from the recursive list, the 'Size' is halved. When the 'Size' gets to one +-- or less, selections are no longer made from the recursive list, this +-- ensures termination. +-- +-- A good example of where this might be useful is abstract syntax trees: +-- +-- @ +-- data Expr = +-- Var String +-- | Lam String Expr +-- | App Expr Expr +-- +-- -- Assuming we have a name generator +-- genName :: 'MonadGen' m => m String +-- +-- -- We can write a generator for expressions +-- genExpr :: 'MonadGen' m => m Expr +-- genExpr = +-- Gen.'recursive' Gen.'choice' [ +-- -- non-recursive generators +-- Var '<$>' genName +-- ] [ +-- -- recursive generators +-- Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x) +-- , Gen.'subterm2' genExpr genExpr App +-- ] +-- @ +-- +-- If we wrote the above example using only 'choice', it is likely that it +-- would fail to terminate. This is because for every call to @genExpr@, +-- there is a 2 in 3 chance that we will recurse again. +-- +recursive :: MonadGen m => ([m a] -> m a) -> [m a] -> [m a] -> m a +recursive f nonrec rec = + sized $ \n -> + if n <= 1 then + f nonrec + else + f $ nonrec ++ fmap small rec + +------------------------------------------------------------------------ +-- Combinators - Conditional + +-- | Discards the whole generator. +-- +discard :: MonadGen m => m a +discard = + liftGen mzero + +-- | Discards the generator if the generated value does not satisfy the +-- predicate. +-- +ensure :: MonadGen m => (a -> Bool) -> m a -> m a +ensure p gen = do + x <- gen + if p x then + pure x + else + discard + +-- | Generates a value that satisfies a predicate. +-- +-- This is essentially: +-- +-- @ +-- filter p gen = 'mfilter' p gen '<|>' filter p gen +-- @ +-- +-- It differs from the above in that we keep some state to avoid looping +-- forever. If we trigger these limits then the whole generator is discarded. +-- +filter :: MonadGen m => (a -> Bool) -> m a -> m a +filter p gen = + let + try k = + if k > 100 then + discard + else do + x <- scale (2 * k +) gen + if p x then + pure x + else + try (k + 1) + in + try 0 + +-- | Runs a 'Maybe' generator until it produces a 'Just'. +-- +-- This is implemented using 'filter' and has the same caveats. +-- +just :: MonadGen m => m (Maybe a) -> m a +just g = do + mx <- filter Maybe.isJust g + case mx of + Just x -> + pure x + Nothing -> + error "Hedgehog.Gen.just: internal error, unexpected Nothing" + +------------------------------------------------------------------------ +-- Combinators - Collections + +-- | Generates a 'Nothing' some of the time. +-- +maybe :: MonadGen m => m a -> m (Maybe a) +maybe gen = + sized $ \n -> + frequency [ + (2, pure Nothing) + , (1 + fromIntegral n, Just <$> gen) + ] + +-- | Generates a list using a 'Range' to determine the length. +-- +list :: MonadGen m => Range Int -> m a -> m [a] +list range gen = + sized $ \size -> + (traverse snd =<<) . + ensure (atLeast $ Range.lowerBound size range) . + shrink Shrink.list $ do + k <- integral_ range + replicateM k (freeze gen) + +-- | Generates a seq using a 'Range' to determine the length. +-- +seq :: MonadGen m => Range Int -> m a -> m (Seq a) +seq range gen = + Seq.fromList <$> list range gen + +-- | Generates a non-empty list using a 'Range' to determine the length. +-- +nonEmpty :: MonadGen m => Range Int -> m a -> m (NonEmpty a) +nonEmpty range gen = do + xs <- list (fmap (max 1) range) gen + case xs of + [] -> + error "Hedgehog.Gen.nonEmpty: internal error, generated empty list" + _ -> + pure $ NonEmpty.fromList xs + +-- | Generates a set using a 'Range' to determine the length. +-- +-- /This may fail to generate anything if the element generator/ +-- /cannot produce a large enough number of unique items to satify/ +-- /the required set size./ +-- +set :: (MonadGen m, Ord a) => Range Int -> m a -> m (Set a) +set range gen = + fmap Map.keysSet . map range $ fmap (, ()) gen + +-- | Generates a map using a 'Range' to determine the length. +-- +-- /This may fail to generate anything if the keys produced by the/ +-- /generator do not account for a large enough number of unique/ +-- /items to satify the required map size./ +-- +map :: (MonadGen m, Ord k) => Range Int -> m (k, v) -> m (Map k v) +map range gen = + sized $ \size -> + ensure ((>= Range.lowerBound size range) . Map.size) . + fmap Map.fromList . + (sequence =<<) . + shrink Shrink.list $ do + k <- integral_ range + uniqueByKey k gen + +-- | Generate exactly 'n' unique generators. +-- +uniqueByKey :: (MonadGen m, Ord k) => Int -> m (k, v) -> m [m (k, v)] +uniqueByKey n gen = + let + try k xs0 = + if k > 100 then + discard + else + replicateM n (freeze gen) >>= \kvs -> + case uniqueInsert n xs0 (fmap (first fst) kvs) of + Left xs -> + pure $ Map.elems xs + Right xs -> + try (k + 1) xs + in + try (0 :: Int) Map.empty + +uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v) +uniqueInsert n xs kvs0 = + if Map.size xs >= n then + Left xs + else + case kvs0 of + [] -> + Right xs + (k, v) : kvs -> + uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs + +-- | Check that list contains at least a certain number of elements. +-- +atLeast :: Int -> [a] -> Bool +atLeast n = + if n == 0 then + const True + else + not . null . drop (n - 1) + +------------------------------------------------------------------------ +-- Combinators - Subterms + +data Subterms n a = + One a + | All (Vec n a) + deriving (Functor, Foldable, Traversable) + +data Nat = + Z + | S Nat + +data Vec n a where + Nil :: Vec 'Z a + (:.) :: a -> Vec n a -> Vec ('S n) a + +infixr 5 :. + +deriving instance Functor (Vec n) +deriving instance Foldable (Vec n) +deriving instance Traversable (Vec n) + +-- | Freeze the size and seed used by a generator, so we can inspect the value +-- which it will produce. +-- +-- This is used for implementing `list` and `subtermMVec`. It allows us to +-- shrink the list itself before trying to shrink the values inside the list. +-- +freeze :: MonadGen m => m a -> m (a, m a) +freeze = + freezeGen + +shrinkSubterms :: Subterms n a -> [Subterms n a] +shrinkSubterms = \case + One _ -> + [] + All xs -> + fmap One $ toList xs + +genSubterms :: MonadGen m => Vec n (m a) -> m (Subterms n a) +genSubterms = + (sequence =<<) . + shrink shrinkSubterms . + fmap All . + mapM (fmap snd . freeze) + +fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a +fromSubterms f = \case + One x -> + pure x + All xs -> + f xs + +-- | Constructs a generator from a number of sub-term generators. +-- +-- /Shrinks to one of the sub-terms if possible./ +-- +subtermMVec :: MonadGen m => Vec n (m a) -> (Vec n a -> m a) -> m a +subtermMVec gs f = + fromSubterms f =<< genSubterms gs + +-- | Constructs a generator from a sub-term generator. +-- +-- /Shrinks to the sub-term if possible./ +-- +subtermM :: MonadGen m => m a -> (a -> m a) -> m a +subtermM gx f = + subtermMVec (gx :. Nil) $ \(x :. Nil) -> + f x + +-- | Constructs a generator from a sub-term generator. +-- +-- /Shrinks to the sub-term if possible./ +-- +subterm :: MonadGen m => m a -> (a -> a) -> m a +subterm gx f = + subtermM gx $ \x -> + pure (f x) + +-- | Constructs a generator from two sub-term generators. +-- +-- /Shrinks to one of the sub-terms if possible./ +-- +subtermM2 :: MonadGen m => m a -> m a -> (a -> a -> m a) -> m a +subtermM2 gx gy f = + subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) -> + f x y + +-- | Constructs a generator from two sub-term generators. +-- +-- /Shrinks to one of the sub-terms if possible./ +-- +subterm2 :: MonadGen m => m a -> m a -> (a -> a -> a) -> m a +subterm2 gx gy f = + subtermM2 gx gy $ \x y -> + pure (f x y) + +-- | Constructs a generator from three sub-term generators. +-- +-- /Shrinks to one of the sub-terms if possible./ +-- +subtermM3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> m a) -> m a +subtermM3 gx gy gz f = + subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) -> + f x y z + +-- | Constructs a generator from three sub-term generators. +-- +-- /Shrinks to one of the sub-terms if possible./ +-- +subterm3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> a) -> m a +subterm3 gx gy gz f = + subtermM3 gx gy gz $ \x y z -> + pure (f x y z) + +------------------------------------------------------------------------ +-- Combinators - Combinations & Permutations + +-- | Generates a random subsequence of a list. +-- +subsequence :: MonadGen m => [a] -> m [a] +subsequence xs = + shrink Shrink.list $ filterM (const bool_) xs + +-- | Generates a random permutation of a list. +-- +-- This shrinks towards the order of the list being identical to the input +-- list. +-- +shuffle :: MonadGen m => [a] -> m [a] +shuffle = \case + [] -> + pure [] + xs0 -> do + n <- integral $ Range.constant 0 (length xs0 - 1) + case splitAt n xs0 of + (xs, y : ys) -> + (y :) <$> shuffle (xs ++ ys) + (_, []) -> + error "Hedgehog.Gen.shuffle: internal error, split generated empty list" + +------------------------------------------------------------------------ +-- Sampling + +-- | Generate a sample from a generator. +-- +sample :: MonadIO m => Gen a -> m a +sample gen = + liftIO $ + let + loop n = + if n <= 0 then + error "Hedgehog.Gen.sample: too many discards, could not generate a sample" + else do + seed <- Seed.random + case runIdentity . runMaybeT . runTree $ runGenT 30 seed gen of + Nothing -> + loop (n - 1) + Just x -> + pure $ nodeValue x + in + loop (100 :: Int) + +-- | Print the value produced by a generator, and the first level of shrinks, +-- for the given size and seed. +-- +-- Use 'print' to generate a value from a random seed. +-- +printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () +printWith size seed gen = + liftIO $ do + let + Node x ss = + runIdentity . runTree $ renderNodes size seed gen + + putStrLn "=== Outcome ===" + putStrLn x + putStrLn "=== Shrinks ===" + + for_ ss $ \s -> + let + Node y _ = + runIdentity $ runTree s + in + putStrLn y + +-- | Print the shrink tree produced by a generator, for the given size and +-- seed. +-- +-- Use 'printTree' to generate a value from a random seed. +-- +printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () +printTreeWith size seed gen = do + liftIO . putStr . runIdentity . Tree.render $ renderNodes size seed gen + +-- | Run a generator with a random seed and print the outcome, and the first +-- level of shrinks. +-- +-- @ +-- Gen.print (Gen.'enum' \'a\' \'f\') +-- @ +-- +-- > === Outcome === +-- > 'd' +-- > === Shrinks === +-- > 'a' +-- > 'b' +-- > 'c' +-- +print :: (MonadIO m, Show a) => Gen a -> m () +print gen = do + seed <- liftIO Seed.random + printWith 30 seed gen + +-- | Run a generator with a random seed and print the resulting shrink tree. +-- +-- @ +-- Gen.printTree (Gen.'enum' \'a\' \'f\') +-- @ +-- +-- > 'd' +-- > ├╼'a' +-- > ├╼'b' +-- > │ └╼'a' +-- > └╼'c' +-- > ├╼'a' +-- > └╼'b' +-- > └╼'a' +-- +-- /This may not terminate when the tree is very large./ +-- +printTree :: (MonadIO m, Show a) => Gen a -> m () +printTree gen = do + seed <- liftIO Seed.random + printTreeWith 30 seed gen + +-- | Render a generator as a tree of strings. +-- +renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String +renderNodes size seed = + fmap (Maybe.maybe "" show) . runDiscardEffect . runGenT size seed . lift + +------------------------------------------------------------------------ +-- Internal + +-- $internal +-- +-- These functions are exported in case you need them in a pinch, but are not +-- part of the public API and may change at any time, even as part of a minor +-- update. diff --git a/src/Savage/Internal/Range.hs b/src/Savage/Internal/Range.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Internal/Range.hs @@ -0,0 +1,462 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Savage.Internal.Range ( + -- * Size + Size(..) + + -- * Range + , Range(..) + , origin + , bounds + , lowerBound + , upperBound + + -- * Constant + , singleton + , constant + , constantFrom + , constantBounded + + -- * Linear + , linear + , linearFrom + , linearFrac + , linearFracFrom + , linearBounded + + -- * Exponential + , exponential + , exponentialFrom + , exponentialBounded + , exponentialFloat + , exponentialFloatFrom + + -- * Internal + -- $internal + , clamp + , scaleLinear + , scaleLinearFrac + , scaleExponential + , scaleExponentialFloat + ) where + +import Data.Bifunctor (bimap) + +import Prelude hiding (minimum, maximum) + +-- $setup +-- >>> import Data.Int (Int8) +-- >>> let x = 3 + +-- | Tests are parameterized by the size of the randomly-generated data, the +-- meaning of which depends on the particular generator used. +-- +newtype Size = + Size { + unSize :: Int + } deriving (Eq, Ord, Num, Real, Enum, Integral) + +instance Show Size where + showsPrec p (Size x) = + showParen (p > 10) $ + showString "Size " . + showsPrec 11 x + +instance Read Size where + readsPrec p = + readParen (p > 10) $ \r0 -> do + ("Size", r1) <- lex r0 + (s, r2) <- readsPrec 11 r1 + pure (Size s, r2) + +-- | A range describes the bounds of a number to generate, which may or may not +-- be dependent on a 'Size'. +-- +data Range a = + Range !a (Size -> (a, a)) + +instance Functor Range where + fmap f (Range z g) = + Range (f z) $ \sz -> + bimap f f (g sz) + +-- | Get the origin of a range. This might be the mid-point or the lower bound, +-- depending on what the range represents. +-- +-- The 'bounds' of a range are scaled around this value when using the +-- 'linear' family of combinators. +-- +-- When using a 'Range' to generate numbers, the shrinking function will +-- shrink towards the origin. +-- +origin :: Range a -> a +origin (Range z _) = + z + +-- | Get the extents of a range, for a given size. +-- +bounds :: Size -> Range a -> (a, a) +bounds sz (Range _ f) = + f sz + +-- | Get the lower bound of a range for the given size. +-- +lowerBound :: Ord a => Size -> Range a -> a +lowerBound sz range = + let + (x, y) = + bounds sz range + in + min x y + +-- | Get the upper bound of a range for the given size. +-- +upperBound :: Ord a => Size -> Range a -> a +upperBound sz range = + let + (x, y) = + bounds sz range + in + max x y + +-- | Construct a range which represents a constant single value. +-- +-- >>> bounds x $ singleton 5 +-- (5,5) +-- +-- >>> origin $ singleton 5 +-- 5 +-- +singleton :: a -> Range a +singleton x = + Range x $ \_ -> (x, x) + +-- | Construct a range which is unaffected by the size parameter. +-- +-- A range from @0@ to @10@, with the origin at @0@: +-- +-- >>> bounds x $ constant 0 10 +-- (0,10) +-- +-- >>> origin $ constant 0 10 +-- 0 +-- +constant :: a -> a -> Range a +constant x y = + constantFrom x x y + +-- | Construct a range which is unaffected by the size parameter with a origin +-- point which may differ from the bounds. +-- +-- A range from @-10@ to @10@, with the origin at @0@: +-- +-- >>> bounds x $ constantFrom 0 (-10) 10 +-- (-10,10) +-- +-- >>> origin $ constantFrom 0 (-10) 10 +-- 0 +-- +-- A range from @1970@ to @2100@, with the origin at @2000@: +-- +-- >>> bounds x $ constantFrom 2000 1970 2100 +-- (1970,2100) +-- +-- >>> origin $ constantFrom 2000 1970 2100 +-- 2000 +-- +constantFrom :: a -> a -> a -> Range a +constantFrom z x y = + Range z $ \_ -> (x, y) + +-- | Construct a range which is unaffected by the size parameter using the full +-- range of a data type. +-- +-- A range from @-128@ to @127@, with the origin at @0@: +-- +-- >>> bounds x (constantBounded :: Range Int8) +-- (-128,127) +-- +-- >>> origin (constantBounded :: Range Int8) +-- 0 +-- +constantBounded :: (Bounded a, Num a) => Range a +constantBounded = + constantFrom 0 minBound maxBound + +-- | Construct a range which scales the second bound relative to the size +-- parameter. +-- +-- >>> bounds 0 $ linear 0 10 +-- (0,0) +-- +-- >>> bounds 50 $ linear 0 10 +-- (0,5) +-- +-- >>> bounds 99 $ linear 0 10 +-- (0,10) +-- +linear :: Integral a => a -> a -> Range a +linear x y = + linearFrom x x y + +-- | Construct a range which scales the bounds relative to the size parameter. +-- +-- >>> bounds 0 $ linearFrom 0 (-10) 10 +-- (0,0) +-- +-- >>> bounds 50 $ linearFrom 0 (-10) 20 +-- (-5,10) +-- +-- >>> bounds 99 $ linearFrom 0 (-10) 20 +-- (-10,20) +-- +linearFrom :: Integral a => a -> a -> a -> Range a +linearFrom z x y = + Range z $ \sz -> + let + x_sized = + clamp x y $ scaleLinear sz z x + + y_sized = + clamp x y $ scaleLinear sz z y + in + (x_sized, y_sized) + +-- | Construct a range which is scaled relative to the size parameter and uses +-- the full range of a data type. +-- +-- >>> bounds 0 (linearBounded :: Range Int8) +-- (0,0) +-- +-- >>> bounds 50 (linearBounded :: Range Int8) +-- (-64,64) +-- +-- >>> bounds 99 (linearBounded :: Range Int8) +-- (-128,127) +-- +linearBounded :: (Bounded a, Integral a) => Range a +linearBounded = + linearFrom 0 minBound maxBound + +-- | Construct a range which scales the second bound relative to the size +-- parameter. +-- +-- This works the same as 'linear', but for fractional values. +-- +linearFrac :: (Fractional a, Ord a) => a -> a -> Range a +linearFrac x y = + linearFracFrom x x y + +-- | Construct a range which scales the bounds relative to the size parameter. +-- +-- This works the same as 'linearFrom', but for fractional values. +-- +linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a +linearFracFrom z x y = + Range z $ \sz -> + let + x_sized = + clamp x y $ scaleLinearFrac sz z x + + y_sized = + clamp x y $ scaleLinearFrac sz z y + in + (x_sized, y_sized) + +-- | Truncate a value so it stays within some range. +-- +-- >>> clamp 5 10 15 +-- 10 +-- +-- >>> clamp 5 10 0 +-- 5 +-- +clamp :: Ord a => a -> a -> a -> a +clamp x y n = + if x > y then + min x (max y n) + else + min y (max x n) + +-- | Scale an integral linearly with the size parameter. +-- +scaleLinear :: Integral a => Size -> a -> a -> a +scaleLinear sz0 z0 n0 = + let + sz = + max 0 (min 99 sz0) + + z = + toInteger z0 + + n = + toInteger n0 + + diff = + ((n - z) * fromIntegral sz) `quot` 99 + in + fromInteger $ z + diff + +-- | Scale a fractional number linearly with the size parameter. +-- +scaleLinearFrac :: Fractional a => Size -> a -> a -> a +scaleLinearFrac sz0 z n = + let + sz = + max 0 (min 99 sz0) + + diff = + (n - z) * (fromIntegral sz / 99) + in + z + diff + +-- | Construct a range which scales the second bound exponentially relative to +-- the size parameter. +-- +-- >>> bounds 0 $ exponential 1 512 +-- (1,1) +-- +-- >>> bounds 11 $ exponential 1 512 +-- (1,2) +-- +-- >>> bounds 22 $ exponential 1 512 +-- (1,4) +-- +-- >>> bounds 77 $ exponential 1 512 +-- (1,128) +-- +-- >>> bounds 88 $ exponential 1 512 +-- (1,256) +-- +-- >>> bounds 99 $ exponential 1 512 +-- (1,512) +-- +exponential :: Integral a => a -> a -> Range a +exponential x y = + exponentialFrom x x y + +-- | Construct a range which scales the bounds exponentially relative to the +-- size parameter. +-- +-- >>> bounds 0 $ exponentialFrom 0 (-128) 512 +-- (0,0) +-- +-- >>> bounds 25 $ exponentialFrom 0 (-128) 512 +-- (-2,4) +-- +-- >>> bounds 50 $ exponentialFrom 0 (-128) 512 +-- (-11,22) +-- +-- >>> bounds 75 $ exponentialFrom 0 (-128) 512 +-- (-39,112) +-- +-- >>> bounds 99 $ exponentialFrom x (-128) 512 +-- (-128,512) +-- +exponentialFrom :: Integral a => a -> a -> a -> Range a +exponentialFrom z x y = + Range z $ \sz -> + let + sized_x = + clamp x y $ scaleExponential sz z x + + sized_y = + clamp x y $ scaleExponential sz z y + in + (sized_x, sized_y) + +-- | Construct a range which is scaled exponentially relative to the size +-- parameter and uses the full range of a data type. +-- +-- >>> bounds 0 (exponentialBounded :: Range Int8) +-- (0,0) +-- +-- >>> bounds 50 (exponentialBounded :: Range Int8) +-- (-11,11) +-- +-- >>> bounds 99 (exponentialBounded :: Range Int8) +-- (-128,127) +-- +exponentialBounded :: (Bounded a, Integral a) => Range a +exponentialBounded = + exponentialFrom 0 minBound maxBound + +-- | Construct a range which scales the second bound exponentially relative to +-- the size parameter. +-- +-- This works the same as 'exponential', but for floating-point values. +-- +-- >>> bounds 0 $ exponentialFloat 0 10 +-- (0.0,0.0) +-- +-- >>> bounds 50 $ exponentialFloat 0 10 +-- (0.0,2.357035250656098) +-- +-- >>> bounds 99 $ exponentialFloat 0 10 +-- (0.0,10.0) +-- +exponentialFloat :: (Floating a, Ord a) => a -> a -> Range a +exponentialFloat x y = + exponentialFloatFrom x x y + +-- | Construct a range which scales the bounds exponentially relative to the +-- size parameter. +-- +-- This works the same as 'exponentialFrom', but for floating-point values. +-- +-- >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20 +-- (0.0,0.0) +-- +-- >>> bounds 50 $ exponentialFloatFrom 0 (-10) 20 +-- (-2.357035250656098,3.6535836249197002) +-- +-- >>> bounds 99 $ exponentialFloatFrom x (-10) 20 +-- (-10.0,20.0) +-- +exponentialFloatFrom :: (Floating a, Ord a) => a -> a -> a -> Range a +exponentialFloatFrom z x y = + Range z $ \sz -> + let + sized_x = + clamp x y $ scaleExponentialFloat sz z x + + sized_y = + clamp x y $ scaleExponentialFloat sz z y + in + (sized_x, sized_y) + +-- | Scale an integral exponentially with the size parameter. +-- +scaleExponential :: Integral a => Size -> a -> a -> a +scaleExponential sz z0 n0 = + let + z = + fromIntegral z0 + + n = + fromIntegral n0 + in + round (scaleExponentialFloat sz z n :: Double) + +-- | Scale a floating-point number exponentially with the size parameter. +-- +scaleExponentialFloat :: Floating a => Size -> a -> a -> a +scaleExponentialFloat sz0 z n = + let + sz = + clamp 0 99 sz0 + + diff = + (((abs (n - z) + 1) ** (realToFrac sz / 99)) - 1) * signum (n - z) + in + z + diff + + +------------------------------------------------------------------------ +-- Internal + +-- $internal +-- +-- These functions are exported in case you need them in a pinch, but are not +-- part of the public API and may change at any time, even as part of a minor +-- update. diff --git a/src/Savage/Internal/Seed.hs b/src/Savage/Internal/Seed.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Internal/Seed.hs @@ -0,0 +1,230 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +-- | +-- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele +-- et. al. [1]. +-- +-- The paper's algorithm provides decent randomness for most purposes but +-- sacrifices cryptographic-quality randomness in favor of speed. The original +-- implementation is tested with DieHarder and BigCrush; see the paper for +-- details. +-- +-- This implementation, originally from [2], is a port from the paper. +-- +-- It also takes in to account the SplittableRandom.java source code in OpenJDK +-- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library +-- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3. +-- +-- Other than the choice of initial seed for 'from' this port should be +-- faithful. Currently, we have not rerun the DieHarder, or BigCrush tests on +-- this implementation. +-- +-- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood +-- Fast splittable pseudorandom number generators +-- Comm ACM, 49(10), Oct 2014, pp453-472. +-- +-- 2. Nikos Baxevanis +-- https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs +-- +module Savage.Internal.Seed ( + Seed(..) + , random + , from + , split + , nextInteger + , nextDouble + + -- * Internal + -- $internal + , goldenGamma + , nextInt64 + , nextInt32 + , mix64 + , mix64variant13 + , mix32 + , mixGamma + ) where + +import Control.Monad.IO.Class (MonadIO(..)) + +import Data.Bifunctor (first) +import Data.Bits ((.|.), xor, shiftR, popCount) +import Data.Int (Int32, Int64) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.IORef (IORef) +import qualified Data.IORef as IORef + +import System.IO.Unsafe (unsafePerformIO) +import System.Random (RandomGen) +import qualified System.Random as Random + +-- | A splittable random number generator. +-- +data Seed = + Seed { + seedValue :: !Int64 + , seedGamma :: !Int64 -- ^ must be an odd number + } deriving (Eq, Ord) + +instance Show Seed where + showsPrec p (Seed v g) = + showParen (p > 10) $ + showString "Seed " . + showsPrec 11 v . + showChar ' ' . + showsPrec 11 g + +instance Read Seed where + readsPrec p = + readParen (p > 10) $ \r0 -> do + ("Seed", r1) <- lex r0 + (v, r2) <- readsPrec 11 r1 + (g, r3) <- readsPrec 11 r2 + pure (Seed v g, r3) + +global :: IORef Seed +global = + unsafePerformIO $ do + -- FIXME use /dev/urandom on posix + seconds <- getPOSIXTime + IORef.newIORef $ from (round (seconds * 1000)) +{-# NOINLINE global #-} + +-- | Create a random 'Seed' using an effectful source of randomness. +-- +random :: MonadIO m => m Seed +random = + liftIO $ IORef.atomicModifyIORef' global split + +-- | Create a 'Seed' using an 'Int64'. +-- +from :: Int64 -> Seed +from x = + Seed x goldenGamma + +-- | A predefined gamma value's needed for initializing the "root" instances of +-- 'Seed'. That is, instances not produced by splitting an already existing +-- instance. +-- +-- We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is +-- the golden ratio. +-- +goldenGamma :: Int64 +goldenGamma = + -7046029254386353131 + +-- | Get the next value in the SplitMix sequence. +-- +next :: Seed -> (Int64, Seed) +next (Seed v0 g) = + let + v = v0 + g + in + (v, Seed v g) + +-- | Splits a random number generator in to two. +-- +split :: Seed -> (Seed, Seed) +split s0 = + let + (v0, s1) = next s0 + (g0, s2) = next s1 + in + (s2, Seed (mix64 v0) (mixGamma g0)) + +-- | Generate a random 'Int64'. +-- +nextInt64 :: Seed -> (Int64, Seed) +nextInt64 s0 = + let + (v0, s1) = next s0 + in + (mix64 v0, s1) + +-- | Generate a random 'Int32'. +-- +nextInt32 :: Seed -> (Int32, Seed) +nextInt32 s0 = + let + (v0, s1) = next s0 + in + (mix32 v0, s1) + +-- | Generate a random 'Integer' in the [inclusive,inclusive] range. +-- +nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed) +nextInteger lo hi = + Random.randomR (lo, hi) + +-- | Generate a random 'Double' in the [inclusive,exclusive) range. +-- +nextDouble :: Double -> Double -> Seed -> (Double, Seed) +nextDouble lo hi = + Random.randomR (lo, hi) + +mix64 :: Int64 -> Int64 +mix64 x = + let + y = (x `xor` (x `shiftR` 33)) * (-49064778989728563) + z = (y `xor` (y `shiftR` 33)) * (-4265267296055464877) + in + z `xor` (z `shiftR` 33) + +mix32 :: Int64 -> Int32 +mix32 x = + let + y = (x `xor` (x `shiftR` 33)) * (-49064778989728563) + z = (y `xor` (y `shiftR` 33)) * (-4265267296055464877) + in + fromIntegral (z `shiftR` 32) + +mix64variant13 :: Int64 -> Int64 +mix64variant13 x = + let + y = (x `xor` (x `shiftR` 30)) * (-4658895280553007687) + z = (y `xor` (y `shiftR` 27)) * (-7723592293110705685) + in + z `xor` (z `shiftR` 31) + +mixGamma :: Int64 -> Int64 +mixGamma x = + let + y = mix64variant13 x .|. 1 + n = popCount $ y `xor` (y `shiftR` 1) + in + if n < 24 then + y `xor` (-6148914691236517206) + else + y + +------------------------------------------------------------------------ +-- RandomGen instances + +#include "MachDeps.h" + +#if (SIZEOF_HSINT == 8) +instance RandomGen Seed where + next = + first fromIntegral . nextInt64 + genRange _ = + (fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64)) + split = + split +#else +instance RandomGen Seed where + next = + first fromIntegral . nextInt32 + genRange _ = + (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32)) + split = + split +#endif + +------------------------------------------------------------------------ +-- Internal + +-- $internal +-- +-- These functions are exported in case you need them in a pinch, but are not +-- part of the public API and may change at any time, even as part of a minor +-- update. diff --git a/src/Savage/Internal/Shrink.hs b/src/Savage/Internal/Shrink.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Internal/Shrink.hs @@ -0,0 +1,129 @@ +{-# OPTIONS_HADDOCK not-home #-} +module Savage.Internal.Shrink ( + towards + , towardsFloat + , list + + , halves + , removes + , consNub + ) where + + +-- | Shrink an integral number by edging towards a destination. +-- +-- >>> towards 0 100 +-- [0,50,75,88,94,97,99] +-- +-- >>> towards 500 1000 +-- [500,750,875,938,969,985,993,997,999] +-- +-- >>> towards (-50) (-26) +-- [-50,-38,-32,-29,-27] +-- +-- /Note we always try the destination first, as that is the optimal shrink./ +-- +towards :: Integral a => a -> a -> [a] +towards destination x = + if destination == x then + [] + else + let + -- Halve the operands before subtracting them so they don't overflow. + -- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'. + diff = + (x `quot` 2) - (destination `quot` 2) + in + destination `consNub` fmap (x -) (halves diff) + +-- | Shrink a floating-point number by edging towards a destination. +-- +-- >>> take 7 (towardsFloat 0.0 100) +-- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375] +-- +-- >>> take 7 (towardsFloat 1.0 0.5) +-- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125] +-- +-- /Note we always try the destination first, as that is the optimal shrink./ +-- +towardsFloat :: RealFloat a => a -> a -> [a] +towardsFloat destination x = + if destination == x then + [] + else + let + diff = + x - destination + + ok y = + y /= x && not (isNaN y) && not (isInfinite y) + in + takeWhile ok . + fmap (x -) $ + iterate (/ 2) diff + +-- | Shrink a list by edging towards the empty list. +-- +-- >>> list [1,2,3] +-- [[],[2,3],[1,3],[1,2]] +-- +-- >>> list "abcd" +-- ["","cd","ab","bcd","acd","abd","abc"] +-- +-- /Note we always try the empty list first, as that is the optimal shrink./ +-- +list :: [a] -> [[a]] +list xs = + concatMap + (\k -> removes k xs) + (halves $ length xs) + +-- | Produce all permutations of removing 'k' elements from a list. +-- +-- >>> removes 2 "abcdef" +-- ["cdef","abef","abcd"] +-- +removes :: Int -> [a] -> [[a]] +removes k0 xs0 = + let + loop k n xs = + let + (hd, tl) = + splitAt k xs + in + if k > n then + [] + else if null tl then + [[]] + else + tl : fmap (hd ++) (loop k (n - k) tl) + in + loop k0 (length xs0) xs0 + +-- | Produce a list containing the progressive halving of an integral. +-- +-- >>> halves 15 +-- [15,7,3,1] +-- +-- >>> halves 100 +-- [100,50,25,12,6,3,1] +-- +-- >>> halves (-26) +-- [-26,-13,-6,-3,-1] +-- +halves :: Integral a => a -> [a] +halves = + takeWhile (/= 0) . iterate (`quot` 2) + +-- | Cons an element on to the front of a list unless it is already there. +-- +consNub :: Eq a => a -> [a] -> [a] +consNub x ys0 = + case ys0 of + [] -> + x : [] + y : ys -> + if x == y then + y : ys + else + x : y : ys diff --git a/src/Savage/Internal/Tree.hs b/src/Savage/Internal/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Internal/Tree.hs @@ -0,0 +1,390 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- MonadBase +module Savage.Internal.Tree ( + Tree(..) + , Node(..) + + , fromNode + + , unfold + , unfoldForest + + , expand + , prune + + , render + ) where + +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus(..), ap, join) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Morph (MFunctor(..), MMonad(..)) +import Control.Monad.Primitive (PrimMonad(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Resource (MonadResource(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) + +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Classes (Show1(..), showsPrec1) +import Data.Functor.Classes (showsUnaryWith, showsBinaryWith) +#endif + +import Savage.Internal.Distributive + +------------------------------------------------------------------------ + +-- | An effectful tree, each node in the tree can have an effect before it is +-- produced. +-- +newtype Tree m a = + Tree { + runTree :: m (Node m a) + } + +-- | A node in an effectful tree, as well as its unevaluated children. +-- +data Node m a = + Node { + nodeValue :: a + , nodeChildren :: [Tree m a] + } + +-- | Create a 'Tree' from a 'Node' +-- +fromNode :: Applicative m => Node m a -> Tree m a +fromNode = + Tree . pure + +-- | Create a tree from a value and an unfolding function. +-- +unfold :: Monad m => (a -> [a]) -> a -> Tree m a +unfold f x = + Tree . pure $ + Node x (unfoldForest f x) + +-- | Create a forest from a value and an unfolding function. +-- +unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree m a] +unfoldForest f = + fmap (unfold f) . f + +-- | Expand a tree using an unfolding function. +-- +expand :: Monad m => (a -> [a]) -> Tree m a -> Tree m a +expand f m = + Tree $ do + Node x xs <- runTree m + pure . Node x $ + fmap (expand f) xs ++ unfoldForest f x + +-- | Throw away a tree's children. +-- +prune :: Monad m => Tree m a -> Tree m a +prune m = + Tree $ do + Node x _ <- runTree m + pure $ Node x [] + +------------------------------------------------------------------------ +-- Node/Tree instances + +instance Functor m => Functor (Node m) where + fmap f (Node x xs) = + Node (f x) (fmap (fmap f) xs) + +instance Functor m => Functor (Tree m) where + fmap f = + Tree . fmap (fmap f) . runTree + +instance Monad m => Applicative (Node m) where + pure = + return + (<*>) = + ap + +instance Monad m => Applicative (Tree m) where + pure = + return + (<*>) = + ap + +instance Monad m => Monad (Node m) where + return x = + Node x [] + + (>>=) (Node x xs) k = + case k x of + Node y ys -> + Node y $ + fmap (Tree . fmap (>>= k) . runTree) xs ++ ys + +instance Monad m => Monad (Tree m) where + return x = + Tree . pure $ Node x [] + + (>>=) m k = + Tree $ do + Node x xs <- runTree m + Node y ys <- runTree (k x) + pure . Node y $ + fmap (>>= k) xs ++ ys + +instance MonadPlus m => Alternative (Tree m) where + empty = + mzero + (<|>) = + mplus + +instance MonadPlus m => MonadPlus (Tree m) where + mzero = + Tree mzero + mplus x y = + Tree (runTree x `mplus` runTree y) + +instance MonadTrans Tree where + lift m = + Tree $ do + x <- m + pure (Node x []) + +instance MFunctor Node where + hoist f (Node x xs) = + Node x (fmap (hoist f) xs) + +instance MFunctor Tree where + hoist f (Tree m) = + Tree . f $ fmap (hoist f) m + +embedNode :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Node t b -> Node m b +embedNode f (Node x xs) = + Node x (fmap (embedTree f) xs) + +embedTree :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Tree t b -> Tree m b +embedTree f (Tree m) = + Tree . pure . embedNode f =<< f m + +instance MMonad Tree where + embed f m = + embedTree f m + +distributeNode :: Transformer t Tree m => Node (t m) a -> t (Tree m) a +distributeNode (Node x xs) = + join . lift . fromNode . Node (pure x) $ + fmap (pure . distributeTree) xs + +distributeTree :: Transformer t Tree m => Tree (t m) a -> t (Tree m) a +distributeTree x = + distributeNode =<< hoist lift (runTree x) + +instance Distributive Tree where + distribute = + distributeTree + +instance PrimMonad m => PrimMonad (Tree m) where + type PrimState (Tree m) = + PrimState m + primitive = + lift . primitive + +instance MonadIO m => MonadIO (Tree m) where + liftIO = + lift . liftIO + +instance MonadBase b m => MonadBase b (Tree m) where + liftBase = + lift . liftBase + +instance MonadThrow m => MonadThrow (Tree m) where + throwM = + lift . throwM + +handleNode :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Node m a -> Node m a +handleNode onErr (Node x xs) = + Node x $ + fmap (handleTree onErr) xs + +handleTree :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Tree m a -> Tree m a +handleTree onErr m = + Tree . fmap (handleNode onErr) $ + catch (runTree m) (runTree . onErr) + +instance MonadCatch m => MonadCatch (Tree m) where + catch = + flip handleTree + +localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a +localNode f (Node x xs) = + Node x $ + fmap (localTree f) xs + +localTree :: MonadReader r m => (r -> r) -> Tree m a -> Tree m a +localTree f (Tree m) = + Tree $ + pure . localNode f =<< local f m + +instance MonadReader r m => MonadReader r (Tree m) where + ask = + lift ask + local = + localTree + +instance MonadState s m => MonadState s (Tree m) where + get = + lift get + put = + lift . put + state = + lift . state + +listenNode :: MonadWriter w m => w -> Node m a -> Node m (a, w) +listenNode w (Node x xs) = + Node (x, w) $ + fmap (listenTree w) xs + +listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w) +listenTree w0 (Tree m) = + Tree $ do + (x, w) <- listen m + pure $ listenNode (mappend w0 w) x + +-- FIXME This just throws away the writer modification function. +passNode :: MonadWriter w m => Node m (a, w -> w) -> Node m a +passNode (Node (x, _) xs) = + Node x $ + fmap passTree xs + +passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a +passTree (Tree m) = + Tree $ + pure . passNode =<< m + +instance MonadWriter w m => MonadWriter w (Tree m) where + writer = + lift . writer + tell = + lift . tell + listen = + listenTree mempty + pass = + passTree + +handleErrorNode :: MonadError e m => (e -> Tree m a) -> Node m a -> Node m a +handleErrorNode onErr (Node x xs) = + Node x $ + fmap (handleErrorTree onErr) xs + +handleErrorTree :: MonadError e m => (e -> Tree m a) -> Tree m a -> Tree m a +handleErrorTree onErr m = + Tree . fmap (handleErrorNode onErr) $ + catchError (runTree m) (runTree . onErr) + +instance MonadError e m => MonadError e (Tree m) where + throwError = + lift . throwError + catchError = + flip handleErrorTree + +instance MonadResource m => MonadResource (Tree m) where + liftResourceT = + lift . liftResourceT + +------------------------------------------------------------------------ +-- Show/Show1 instances + +#if MIN_VERSION_base(4,9,0) +instance (Show1 m, Show a) => Show (Node m a) where + showsPrec = + showsPrec1 + +instance (Show1 m, Show a) => Show (Tree m a) where + showsPrec = + showsPrec1 + +instance Show1 m => Show1 (Node m) where + liftShowsPrec sp sl d (Node x xs) = + let + sp1 = + liftShowsPrec sp sl + + sl1 = + liftShowList sp sl + + sp2 = + liftShowsPrec sp1 sl1 + in + showsBinaryWith sp sp2 "Node" d x xs + +instance Show1 m => Show1 (Tree m) where + liftShowsPrec sp sl d (Tree m) = + let + sp1 = + liftShowsPrec sp sl + + sl1 = + liftShowList sp sl + + sp2 = + liftShowsPrec sp1 sl1 + in + showsUnaryWith sp2 "Tree" d m +#endif + +------------------------------------------------------------------------ +-- Pretty Printing + +-- +-- Rendering implementation based on the one from containers/Data.Tree +-- + +renderTreeLines :: Monad m => Tree m String -> m [String] +renderTreeLines (Tree m) = do + Node x xs0 <- m + xs <- renderForestLines xs0 + pure $ + lines (renderNode x) ++ xs + +renderNode :: String -> String +renderNode xs = + case xs of + [_] -> + ' ' : xs + _ -> + xs + +renderForestLines :: Monad m => [Tree m String] -> m [String] +renderForestLines xs0 = + let + shift hd other = + zipWith (++) (hd : repeat other) + in + case xs0 of + [] -> + pure [] + + [x] -> do + s <- renderTreeLines x + pure $ + shift " └╼" " " s + + x : xs -> do + s <- renderTreeLines x + ss <- renderForestLines xs + pure $ + shift " ├╼" " │ " s ++ ss + +-- | Render a tree of strings, note that this forces all the delayed effects in +-- the tree. +render :: Monad m => Tree m String -> m String +render = + fmap unlines . renderTreeLines diff --git a/src/Savage/Randy.hs b/src/Savage/Randy.hs --- a/src/Savage/Randy.hs +++ b/src/Savage/Randy.hs @@ -1,83 +1,106 @@ -{-# LANGUAGE CPP #-} - -module Savage.Randy where - -import System.Random -import System.Random.TF -import System.Random.TF.Gen (splitn) -import Data.Word -import Data.Bits +module Savage.Randy ( + -- * Combinators + lift -#define TheGen TFGen + -- ** Shrinking + , shrink + , prune -newTheGen :: IO TFGen -newTheGen = newTFGen + -- ** Size + , small + , scale + , resize + , sized -bits, mask, doneBit :: Integral a => a -bits = 14 -mask = 0x3fff -doneBit = 0x4000 + -- ** Integral + , integral + , integral_ -chip :: Bool -> Word32 -> TFGen -> TFGen -chip done n g = splitn g (bits+1) (if done then m .|. doneBit else m) - where - m = n .&. mask + , int + , int8 + , int16 + , int32 + , int64 -chop :: Integer -> Integer -chop n = n `shiftR` bits + , word + , word8 + , word16 + , word32 + , word64 -stop :: Integral a => a -> Bool -stop n = n <= mask + -- ** Floating-point + , realFloat + , realFrac_ + , float + , double -mkTheGen :: Int -> TFGen -mkTheGen = mkTFGen + -- ** Enumeration + , enum + , enumBounded + , bool + , bool_ --- | The "standard" QuickCheck random number generator. --- A wrapper around either 'TFGen' on GHC, or 'StdGen' --- on other Haskell systems. -newtype SVGen = SVGen TheGen + -- ** Characters + , binit + , octit + , digit + , hexit + , lower + , upper + , alpha + , alphaNum + , ascii + , latin1 + , unicode + , unicodeAll -instance Show SVGen where - showsPrec n (SVGen g) s = showsPrec n g "" ++ s -instance Read SVGen where - readsPrec n xs = [(SVGen g, ys) | (g, ys) <- readsPrec n xs] + -- ** Strings + , string + , text + , utf8 + , bytes -instance RandomGen SVGen where - split (SVGen g) = - case split g of - (g1, g2) -> (SVGen g1, SVGen g2) - genRange (SVGen g) = genRange g - next (SVGen g) = - case next g of - (x, g') -> (x, SVGen g') + -- ** Choice + , constant + , element + , choice + , frequency + , recursive -newSVGen :: IO SVGen -newSVGen = fmap SVGen newTheGen + -- ** Conditional + , discard + , filter + , just -mkSVGen :: Int -> SVGen -mkSVGen n = SVGen (mkTheGen n) + -- ** Collections + , maybe + , list + , seq + , nonEmpty + , set + , map -bigNatVariant :: Integer -> TheGen -> TheGen -bigNatVariant n g - | g `seq` stop n = chip True (fromInteger n) g - | otherwise = (bigNatVariant $! chop n) $! chip False (fromInteger n) g + -- ** Subterms + , freeze + , subterm + , subtermM + , subterm2 + , subtermM2 + , subterm3 + , subtermM3 -{-# INLINE natVariant #-} -natVariant :: Integral a => a -> TheGen -> TheGen -natVariant n g - | g `seq` stop n = chip True (fromIntegral n) g - | otherwise = bigNatVariant (toInteger n) g + -- ** Combinations & Permutations + , subsequence + , shuffle -{-# INLINE variantTheGen #-} -variantTheGen :: Integral a => a -> TheGen -> TheGen -variantTheGen n g - | n >= 1 = natVariant (n-1) (boolVariant False g) - | n == 0 = natVariant (0 `asTypeOf` n) (boolVariant True g) - | otherwise = bigNatVariant (negate (toInteger n)) (boolVariant True g) + -- * Sampling Generators + , sample + , print + , printTree + , printWith + , printTreeWith + ) where -boolVariant :: Bool -> TheGen -> TheGen -boolVariant False = fst . split -boolVariant True = snd . split +import Savage.Internal.Gen -variantSVGen :: Integral a => a -> SVGen -> SVGen -variantSVGen n (SVGen g) = SVGen (variantTheGen n g) +import Prelude hiding (filter, print, maybe, map, seq) diff --git a/src/Savage/Range.hs b/src/Savage/Range.hs new file mode 100644 --- /dev/null +++ b/src/Savage/Range.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Savage.Range ( + -- * Size + Size(..) + + -- * Range + , Range + , origin + , bounds + , lowerBound + , upperBound + + -- * Constant + , singleton + , constant + , constantFrom + , constantBounded + + -- * Linear + , linear + , linearFrom + , linearFrac + , linearFracFrom + , linearBounded + + -- * Exponential + , exponential + , exponentialFrom + , exponentialBounded + , exponentialFloat + , exponentialFloatFrom + ) where + +import Savage.Internal.Range