diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,3 @@ -.cabal-sandbox -cabal.sandbox.config dist dist-newstyle docs @@ -14,3 +12,21 @@ *.hi *~ *# +.stack-work/ +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,3 @@ +- arguments: [--cpp-ansi] + +- ignore: {name: Use camelCase} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,106 +0,0 @@ -# This file has been generated -- see https://github.com/hvr/multi-ghc-travis -language: c -sudo: false - -cache: - directories: - - $HOME/.cabsnap - - $HOME/.cabal/packages - -before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar - -matrix: - include: - - env: CABALVER=1.24 GHCVER=7.4.2 - compiler: ": #GHC 7.4.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,hlint], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=7.6.3 - compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,hlint], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=7.8.4 - compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4,hlint], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=7.10.3 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,hlint], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=8.0.2 - compiler: ": #GHC 8.0.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,hlint], sources: [hvr-ghc]}} - - env: CABALVER=2.0 GHCVER=8.2.1 - compiler: ": #GHC 8.2.1" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,hlint], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=head - compiler: ": #GHC head" - addons: {apt: {packages: [cabal-install-1.24,ghc-head,hlint], sources: [hvr-ghc]}} - - allow_failures: - - env: CABALVER=1.24 GHCVER=head - -before_install: - - unset CC - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - -install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; - then - zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > - $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; - fi - - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt - -# check whether current requested install-plan matches cached package-db snapshot - - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; - then - echo "cabal build-cache HIT"; - rm -rfv .ghc; - cp -a $HOME/.cabsnap/ghc $HOME/.ghc; - cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; - else - echo "cabal build-cache MISS"; - rm -rf $HOME/.cabsnap; - mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install -j --only-dependencies --enable-tests --enable-benchmarks; - fi - -# snapshot package-db on cache miss - - if [ ! -d $HOME/.cabsnap ]; - then - echo "snapshotting package-db to build-cache"; - mkdir $HOME/.cabsnap; - cp -a $HOME/.ghc $HOME/.cabsnap/ghc; - cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; - fi - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. -script: - - cabal configure -v2 --enable-tests --enable-benchmarks # -v2 provides useful information for debugging - - cabal build # this builds all libraries and executables (including tests/benchmarks) - - cabal test --show-details=always - - cabal sdist # tests that a source-distribution can be generated - - hlint src --cpp-define HLINT - - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313log-domain\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" - -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,5 +1,22 @@ -0.12 ----- +0.13.2 [2021.11.15] +------------------- +* Add an `Eq1 Log` instance. +* Allow building with `hashable-1.4.*`. + +0.13.1 [2021.02.17] +------------------- +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. + +0.13 [2019.11.21] +----------------- +* Replace dependency on `Precise` with standard functions available from `base` 4.9 onward. + +0.12 [2018.01.18] +----------------- +* Add `Semigroup` instance for `Log`. * Drop `safecopy` support * Removed some unused constraints. diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 --- a/HLint.hs +++ /dev/null @@ -1,1 +0,0 @@ -ignore "Use camelCase" diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ log-domain ========== -[![Hackage](https://img.shields.io/hackage/v/log-domain.svg)](https://hackage.haskell.org/package/log-domain) [![Build Status](https://secure.travis-ci.org/ekmett/log-domain.png?branch=master)](http://travis-ci.org/ekmett/log-domain) +[![Hackage](https://img.shields.io/hackage/v/log-domain.svg)](https://hackage.haskell.org/package/log-domain) [![Build Status](https://github.com/ekmett/log-domain/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/log-domain/actions?query=workflow%3AHaskell-CI) > What rolls down stairs alone or in pairs > Rolls over your neighbor's dog? diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,34 +1,7 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -import Warning () -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain +#!/usr/bin/runhaskell +> module Main (main) where -#endif +> import Distribution.Simple -\end{code} +> main :: IO () +> main = defaultMain diff --git a/Warning.hs b/Warning.hs deleted file mode 100644 --- a/Warning.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Warning - {-# WARNING ["You are configuring this package without cabal-doctest installed.", - "The doctests test-suite will not work as a result.", - "To fix this, install cabal-doctest before configuring."] #-} - () where diff --git a/log-domain.cabal b/log-domain.cabal --- a/log-domain.cabal +++ b/log-domain.cabal @@ -1,8 +1,8 @@ name: log-domain category: Numeric -version: 0.12 +version: 0.13.2 license: BSD3 -cabal-version: >= 1.8 +cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -10,82 +10,48 @@ homepage: http://github.com/ekmett/log-domain/ bug-reports: http://github.com/ekmett/log-domain/issues copyright: Copyright (C) 2013-2015 Edward A. Kmett -build-type: Custom -tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 +build-type: Simple +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.1 + , GHC == 9.2.1 synopsis: Log-domain arithmetic description: This package provides log-domain floats, doubles and complex numbers. extra-source-files: - .travis.yml .ghci .gitignore + .hlint.yaml .vim.custom - travis/cabal-apt-install - travis/config AUTHORS.markdown README.markdown CHANGELOG.markdown - HLint.hs - Warning.hs source-repository head type: git location: https://github.com/analytics/log-domain -custom-setup - setup-depends: - base >= 4 && < 5, - Cabal, - cabal-doctest >= 1 && < 1.1 - --- You can disable the doctests test suite with -f-test-doctests -flag test-doctests - default: True - manual: True - -flag ffi - default: True - manual: True - library build-depends: - base >= 4.5 && < 5, + base >= 4.9 && < 5, binary >= 0.5 && < 0.9, bytes >= 0.7 && < 1, cereal >= 0.3.5 && < 0.6, comonad >= 4 && < 6, deepseq >= 1.3 && < 1.5, distributive >= 0.3 && < 1, - hashable >= 1.2.5 && < 1.3, + hashable >= 1.2.5 && < 1.5, semigroupoids >= 4 && < 6, semigroups >= 0.8.4 && < 1, - vector >= 0.9 && < 0.13 + vector >= 0.11 && < 0.13 exposed-modules: Numeric.Log Numeric.Log.Signed - if impl(ghc < 7.6) - build-depends: ghc-prim - - if flag(ffi) && !(os(windows) && !impl(ghc >= 8.0)) - cpp-options: -D__USE_FFI__ - - ghc-options: -Wall -fwarn-tabs -O2 + ghc-options: -Wall -Wtabs -O2 hs-source-dirs: src - -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - ghc-options: -Wall -threaded - hs-source-dirs: tests - - if !flag(test-doctests) - buildable: False - else - build-depends: - base, - doctest >= 0.11.1 && < 0.14, - generic-deriving, - log-domain, - semigroups >= 0.9, - simple-reflect >= 0.3.1 + default-language: Haskell2010 diff --git a/src/Numeric/Log.hs b/src/Numeric/Log.hs --- a/src/Numeric/Log.hs +++ b/src/Numeric/Log.hs @@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} -------------------------------------------------------------------- @@ -18,53 +15,45 @@ -------------------------------------------------------------------- module Numeric.Log ( Log(..) - , Precise(..) , sum ) where import Prelude hiding (maximum, sum) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Comonad import Control.DeepSeq -import Control.Monad import Data.Binary as Binary import Data.Bytes.Serial -import Data.Complex import Data.Data import Data.Distributive import Data.Foldable as Foldable hiding (sum) import Data.Functor.Bind +import Data.Functor.Classes import Data.Functor.Extend import Data.Hashable import Data.Hashable.Lifted import Data.Int -import Data.List as List hiding (sum) +import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Serialize as Serialize -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable -#endif -import Data.Vector.Unboxed as U hiding (sum) -import Data.Vector.Generic as G hiding (sum) -import Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M import Foreign.Ptr import Foreign.Storable import GHC.Generics +import Numeric import Text.Read as T import Text.Show as T -{-# ANN module "HLint: ignore Eta reduce" #-} - -- $setup -- >>> let Exp x ~= Exp y = abs ((exp x-exp y) / exp x) < 0.01 -- | @Log@-domain @Float@ and @Double@ values. -newtype Log a = Exp { ln :: a } deriving (Eq,Ord,Data,Typeable,Generic) +newtype Log a = Exp { ln :: a } deriving (Eq,Ord,Data,Generic) instance (Floating a, Show a) => Show (Log a) where showsPrec d (Exp a) = T.showsPrec d (exp a) @@ -104,6 +93,9 @@ liftHashWithSalt hws i (Exp a) = hws i a {-# INLINE liftHashWithSalt #-} +instance Eq1 Log where + liftEq eq (Exp a) (Exp b) = eq a b + instance Storable a => Storable (Log a) where sizeOf = sizeOf . ln {-# INLINE sizeOf #-} @@ -172,7 +164,7 @@ Exp a >>= f = f a {-# INLINE (>>=) #-} -instance (RealFloat a, Precise a, Enum a) => Enum (Log a) where +instance (RealFloat a, Enum a) => Enum (Log a) where succ a = a + 1 {-# INLINE succ #-} pred a = a - 1 @@ -211,16 +203,16 @@ -- >>> 1 - 3 :: Log Float -- NaN -- --- >>> (Exp (1/0)) - (Exp (1/0)) :: Log Double +-- >>> Exp (1/0) - Exp (1/0) :: Log Double -- NaN -- -- >>> 0 - 0 :: Log Double -- 0.0 -- --- >>> 0 - (Exp (1/0)) :: Log Double +-- >>> 0 - Exp (1/0) :: Log Double -- NaN -- --- >>> (Exp (1/0)) - 0.0 :: Log Double +-- >>> Exp (1/0) - 0.0 :: Log Double -- Infinity -- -- Multiplication @@ -228,19 +220,19 @@ -- >>> (3 * 2 :: Log Double) ~= 6 -- True -- --- >>> 0 * (Exp (1/0)) :: Log Double +-- >>> 0 * Exp (1/0) :: Log Double -- NaN -- --- >>> (Exp (1/0)) * (Exp (1/0)) :: Log Double +-- >>> Exp (1/0) * Exp (1/0) :: Log Double -- Infinity -- -- >>> 0 * 0 :: Log Double -- 0.0 -- --- >>> (Exp (0/0)) * 0 :: Log Double +-- >>> Exp (0/0) * 0 :: Log Double -- NaN -- --- >>> (Exp (0/0)) * (Exp (1/0)) :: Log Double +-- >>> Exp (0/0) * Exp (1/0) :: Log Double -- NaN -- -- Addition @@ -251,10 +243,10 @@ -- >>> 0 + 0 :: Log Double -- 0.0 -- --- >>> (Exp (1/0)) + (Exp (1/0)) :: Log Double +-- >>> Exp (1/0) + Exp (1/0) :: Log Double -- Infinity -- --- >>> (Exp (1/0)) + 0 :: Log Double +-- >>> Exp (1/0) + 0 :: Log Double -- Infinity -- -- Division @@ -265,13 +257,13 @@ -- >>> 3 / 0 :: Log Double -- Infinity -- --- >>> (Exp (1/0)) / 0 :: Log Double +-- >>> Exp (1/0) / 0 :: Log Double -- Infinity -- --- >>> 0 / (Exp (1/0)) :: Log Double +-- >>> 0 / Exp (1/0) :: Log Double -- 0.0 -- --- >>> (Exp (1/0)) / (Exp (1/0)) :: Log Double +-- >>> Exp (1/0) / Exp (1/0) :: Log Double -- NaN -- -- >>> 0 / 0 :: Log Double @@ -299,7 +291,7 @@ -- >>> signum (Exp (0/0)) :: Log Double -- NaN -instance (Precise a, RealFloat a) => Num (Log a) where +instance RealFloat a => Num (Log a) where Exp a * Exp b = Exp (a + b) {-# INLINE (*) #-} Exp a + Exp b @@ -325,7 +317,7 @@ fromInteger = Exp . log . fromInteger {-# INLINE fromInteger #-} -instance (Precise a, RealFloat a) => Fractional (Log a) where +instance RealFloat a => Fractional (Log a) where -- n/0 == infinity is handled seamlessly for us, as is 0/0 and infinity/infinity NaNs, and 0/infinity == 0. Exp a / Exp b = Exp (a-b) {-# INLINE (/) #-} @@ -340,7 +332,7 @@ -- >>> (properFraction 0.5 :: (Integer, Log Double)) -- (0,0.5) -instance (Precise a, RealFloat a) => RealFrac (Log a) where +instance RealFloat a => RealFrac (Log a) where properFraction l | ln l < 0 = (0, l) | otherwise = (\(b,a) -> (b, Exp $ log a)) $ properFraction $ exp (ln l) @@ -359,26 +351,22 @@ {-# INLINE basicUnsafeRead #-} {-# INLINE basicUnsafeWrite #-} {-# INLINE basicClear #-} -#if MIN_VERSION_vector(0,11,0) {-# INLINE basicInitialize #-} -#endif {-# INLINE basicSet #-} {-# INLINE basicUnsafeCopy #-} {-# INLINE basicUnsafeGrow #-} basicLength (MV_Log v) = M.basicLength v basicUnsafeSlice i n (MV_Log v) = MV_Log $ M.basicUnsafeSlice i n v basicOverlaps (MV_Log v1) (MV_Log v2) = M.basicOverlaps v1 v2 - basicUnsafeNew n = MV_Log `liftM` M.basicUnsafeNew n - basicUnsafeReplicate n (Exp x) = MV_Log `liftM` M.basicUnsafeReplicate n x - basicUnsafeRead (MV_Log v) i = Exp `liftM` M.basicUnsafeRead v i + basicUnsafeNew n = MV_Log <$> M.basicUnsafeNew n + basicUnsafeReplicate n (Exp x) = MV_Log <$> M.basicUnsafeReplicate n x + basicUnsafeRead (MV_Log v) i = Exp <$> M.basicUnsafeRead v i basicUnsafeWrite (MV_Log v) i (Exp x) = M.basicUnsafeWrite v i x basicClear (MV_Log v) = M.basicClear v -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Log v) = M.basicInitialize v -#endif basicSet (MV_Log v) (Exp x) = M.basicSet v x basicUnsafeCopy (MV_Log v1) (MV_Log v2) = M.basicUnsafeCopy v1 v2 - basicUnsafeGrow (MV_Log v) n = MV_Log `liftM` M.basicUnsafeGrow v n + basicUnsafeGrow (MV_Log v) n = MV_Log <$> M.basicUnsafeGrow v n instance (RealFloat a, Unbox a) => G.Vector U.Vector (Log a) where {-# INLINE basicUnsafeFreeze #-} @@ -387,21 +375,21 @@ {-# INLINE basicUnsafeSlice #-} {-# INLINE basicUnsafeIndexM #-} {-# INLINE elemseq #-} - basicUnsafeFreeze (MV_Log v) = V_Log `liftM` G.basicUnsafeFreeze v - basicUnsafeThaw (V_Log v) = MV_Log `liftM` G.basicUnsafeThaw v + basicUnsafeFreeze (MV_Log v) = V_Log <$> G.basicUnsafeFreeze v + basicUnsafeThaw (V_Log v) = MV_Log <$> G.basicUnsafeThaw v basicLength (V_Log v) = G.basicLength v basicUnsafeSlice i n (V_Log v) = V_Log $ G.basicUnsafeSlice i n v - basicUnsafeIndexM (V_Log v) i = Exp `liftM` G.basicUnsafeIndexM v i + basicUnsafeIndexM (V_Log v) i = Exp <$> G.basicUnsafeIndexM v i basicUnsafeCopy (MV_Log mv) (V_Log v) = G.basicUnsafeCopy mv v - elemseq _ (Exp x) z = G.elemseq (undefined :: U.Vector a) x z + elemseq _ (Exp x) = G.elemseq (undefined :: U.Vector a) x -instance (Precise a, RealFloat a, Ord a) => Real (Log a) where +instance (RealFloat a, Ord a) => Real (Log a) where toRational (Exp a) = toRational (exp a) {-# INLINE toRational #-} data Acc1 a = Acc1 {-# UNPACK #-} !Int64 !a -instance (Precise a, RealFloat a) => Semigroup (Log a) where +instance RealFloat a => Semigroup (Log a) where (<>) = (+) {-# INLINE (<>) #-} sconcat (Exp z :| zs) = Exp $ case List.foldl' step1 (Acc1 0 z) zs of @@ -413,7 +401,7 @@ step2 a r (Exp x) = r + expm1 (x - a) {-# INLINE sconcat #-} -instance (Precise a, RealFloat a) => Monoid (Log a) where +instance RealFloat a => Monoid (Log a) where mempty = Exp negInf {-# INLINE mempty #-} #if !(MIN_VERSION_base(4,11,0)) @@ -446,7 +434,7 @@ -- True -- -- /NB:/ This does require two passes over the data. -sum :: (RealFloat a, Precise a, Foldable f) => f (Log a) -> Log a +sum :: (RealFloat a, Foldable f) => f (Log a) -> Log a sum xs = Exp $ case Foldable.foldl' step1 None xs of None -> negInf Acc nm1 a @@ -458,7 +446,7 @@ step2 a r (Exp x) = r + expm1 (x - a) {-# INLINE sum #-} -instance (RealFloat a, Precise a) => Floating (Log a) where +instance RealFloat a => Floating (Log a) where pi = Exp (log pi) {-# INLINE pi #-} exp (Exp a) = Exp (exp a) @@ -503,101 +491,3 @@ "realToFrac" realToFrac = exp . ln :: Log Float -> Float "realToFrac" realToFrac = Exp . log :: Double -> Log Double "realToFrac" realToFrac = Exp . log :: Float -> Log Float #-} - --- | This provides @log1p@ and @expm1@ for working more accurately with small numbers. -class Floating a => Precise a where - -- | Computes @log(1 + x)@ - -- - -- This is far enough from 0 that the Taylor series is defined. - -- - -- This can provide much more accurate answers for logarithms of numbers close to 1 (x near 0). - -- - -- These arise when working wth log-scale probabilities a lot. - log1p :: a -> a - - -- | The Taylor series for exp(x) is given by - -- - -- > exp(x) = 1 + x + x^2/2! + ... - -- - -- When @x@ is small, the leading 1 consumes all of the available precision. - -- - -- This computes: - -- - -- > exp(x) - 1 = x + x^2/2! + .. - -- - -- which can afford you a great deal of additional precision if you move things around - -- algebraically to provide the 1 by other means. - expm1 :: a -> a - - log1pexp :: a -> a - log1pexp a = log1p (exp a) - - log1mexp :: a -> a - log1mexp a = log1p (negate (exp a)) - -instance Precise Double where - log1p = c_log1p - {-# INLINE log1p #-} - expm1 = c_expm1 - {-# INLINE expm1 #-} - log1mexp a - | a <= log 2 = log (negate (expm1 a)) - | otherwise = log1p (negate (exp a)) - {-# INLINE log1mexp #-} - log1pexp a - | a <= 18 = log1p (exp a) - | a <= 100 = a + exp (negate a) - | otherwise = a - {-# INLINE log1pexp #-} - - -instance Precise Float where - log1p = c_log1pf - {-# INLINE log1p #-} - expm1 = c_expm1f - {-# INLINE expm1 #-} - log1mexp a | a <= log 2 = log (negate (expm1 a)) - | otherwise = log1p (negate (exp a)) - {-# INLINE log1mexp #-} - log1pexp a - | a <= 18 = log1p (exp a) - | a <= 100 = a + exp (negate a) - | otherwise = a - {-# INLINE log1pexp #-} - -instance (RealFloat a, Precise a) => Precise (Complex a) where - expm1 x@(a :+ b) - | a*a + b*b < 1, u <- expm1 a, v <- sin (b/2), w <- -2*v*v = (u*w+u+w) :+ (u+1)*sin b - | otherwise = exp x - 1 - {-# INLINE expm1 #-} - log1p x@(a :+ b) - | abs a < 0.5 && abs b < 0.5, u <- 2*a+a*a+b*b = log1p (u/(1+sqrt (u+1))) :+ atan2 (1 + a) b - | otherwise = log (1 + x) - {-# INLINE log1p #-} - -#ifdef __USE_FFI__ - -foreign import ccall unsafe "math.h log1p" c_log1p :: Double -> Double -foreign import ccall unsafe "math.h expm1" c_expm1 :: Double -> Double -foreign import ccall unsafe "math.h expm1f" c_expm1f :: Float -> Float -foreign import ccall unsafe "math.h log1pf" c_log1pf :: Float -> Float - -#else - -c_log1p :: Double -> Double -{-# INLINE c_log1p #-} -c_log1p x = log (1 + x) - -c_expm1 :: Double -> Double -{-# INLINE c_expm1 #-} -c_expm1 x = exp x - 1 - -c_expm1f :: Float -> Float -{-# INLINE c_expm1f #-} -c_expm1f x = exp x - 1 - -c_log1pf :: Float -> Float -{-# INLINE c_log1pf #-} -c_log1pf x = log (1 + x) - -#endif diff --git a/src/Numeric/Log/Signed.hs b/src/Numeric/Log/Signed.hs --- a/src/Numeric/Log/Signed.hs +++ b/src/Numeric/Log/Signed.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------- -- | @@ -18,27 +13,17 @@ -- -------------------------------------------------------------------- module Numeric.Log.Signed - ( SignedLog(..) - ) where +( SignedLog(..) +) where -import Numeric.Log (Precise(..)) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(..)) -#endif import Data.Data (Data(..)) import GHC.Generics (Generic(..)) -import Data.Typeable (Typeable) +import Numeric import Text.Read as T import Text.Show as T -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor ((<$>)) -#endif --- $setup --- >>> let SLExp sX x ~= SLExp sY y = abs ((exp x-(multSign (nxor sX sY) (exp y))) / exp x) < 0.01 - -- | @Log@-domain @Float@ and @Double@ values, with a sign bit. -data SignedLog a = SLExp { signSL :: Bool, lnSL :: a} deriving (Data, Typeable, Generic) +data SignedLog a = SLExp { signSL :: Bool, lnSL :: a} deriving (Data, Generic) negInf :: Fractional a => a negInf = (-1)/0 @@ -80,7 +65,7 @@ instance (Show a, RealFloat a, Eq a, Fractional a) => Show (SignedLog a) where showsPrec d (SLExp s a) = (if not s && a /= negInf && not (isNaN a) then T.showChar '-' else id) . T.showsPrec d (exp a) -instance (Precise a, RealFloat a, Read a) => Read (SignedLog a) where +instance (RealFloat a, Read a) => Read (SignedLog a) where readPrec = (realToFrac :: a -> SignedLog a) <$> step T.readPrec nxor :: Bool -> Bool -> Bool @@ -88,6 +73,13 @@ -- $SignedLogNumTests -- +-- Repeating internals, add testing function (~=) +-- +-- >>> let nxor = (==) +-- >>> let multSign b = if b then id else (*) (-1) +-- +-- >>> let SLExp sX x ~= SLExp sY y = abs ((exp x-(multSign (nxor sX sY) (exp y))) / exp x) < 0.01 +-- -- Subtraction -- -- >>> (3 - 1 :: SignedLog Double) ~= 2 @@ -102,16 +94,16 @@ -- >>> (1 - 3 :: SignedLog Float) ~= (-2) -- True -- --- >>> (SLExp True (1/0)) - (SLExp True (1/0)) :: SignedLog Double +-- >>> SLExp True (1/0) - SLExp True (1/0) :: SignedLog Double -- NaN -- -- >>> 0 - 0 :: SignedLog Double -- 0.0 -- --- >>> 0 - (SLExp True (1/0)) :: SignedLog Double +-- >>> 0 - SLExp True (1/0) :: SignedLog Double -- -Infinity -- --- >>> (SLExp True (1/0)) - 0.0 :: SignedLog Double +-- >>> SLExp True (1/0) - 0.0 :: SignedLog Double -- Infinity -- -- Multiplication @@ -119,19 +111,19 @@ -- >>> (3 * 2 :: SignedLog Double) ~= 6 -- True -- --- >>> 0 * (SLExp True (1/0)) :: SignedLog Double +-- >>> 0 * SLExp True (1/0) :: SignedLog Double -- NaN -- --- >>> (SLExp True (1/0)) * (SLExp True (1/0)) :: SignedLog Double +-- >>> SLExp True (1/0) * SLExp True (1/0) :: SignedLog Double -- Infinity -- -- >>> 0 * 0 :: SignedLog Double -- 0.0 -- --- >>> (SLExp True (0/0)) * 0 :: SignedLog Double +-- >>> SLExp True (0/0) * 0 :: SignedLog Double -- NaN -- --- >>> (SLExp True (0/0)) * (SLExp True (1/0)) :: SignedLog Double +-- >>> SLExp True (0/0) * SLExp True (1/0) :: SignedLog Double -- NaN -- -- Addition @@ -142,10 +134,10 @@ -- >>> 0 + 0 :: SignedLog Double -- 0.0 -- --- >>> (SLExp True (1/0)) + (SLExp True (1/0)) :: SignedLog Double +-- >>> SLExp True (1/0) + SLExp True (1/0) :: SignedLog Double -- Infinity -- --- >>> (SLExp True (1/0)) + 0 :: SignedLog Double +-- >>> SLExp True (1/0) + 0 :: SignedLog Double -- Infinity -- -- Division @@ -156,13 +148,13 @@ -- >>> 3 / 0 :: SignedLog Double -- Infinity -- --- >>> (SLExp True (1/0)) / 0 :: SignedLog Double +-- >>> SLExp True (1/0) / 0 :: SignedLog Double -- Infinity -- --- >>> 0 / (SLExp True (1/0)) :: SignedLog Double +-- >>> 0 / SLExp True (1/0) :: SignedLog Double -- 0.0 -- --- >>> (SLExp True (1/0)) / (SLExp True (1/0)) :: SignedLog Double +-- >>> SLExp True (1/0) / SLExp True (1/0) :: SignedLog Double -- NaN -- -- >>> 0 / 0 :: SignedLog Double @@ -190,10 +182,10 @@ -- >>> signum (SLExp True (0/0)) :: SignedLog Double -- NaN -instance (Precise a, RealFloat a) => Num (SignedLog a) where - (SLExp sA a) * (SLExp sB b) = SLExp (nxor sA sB) (a+b) +instance RealFloat a => Num (SignedLog a) where + SLExp sA a * SLExp sB b = SLExp (nxor sA sB) (a+b) {-# INLINE (*) #-} - (SLExp sA a) + (SLExp sB b) + SLExp sA a + SLExp sB b | a == b && isInfinite a && (a < 0 || nxor sA sB) = SLExp True a | sA == sB && a >= b = SLExp sA (a + log1pexp (b - a)) | sA == sB && otherwise = SLExp sA (b + log1pexp (a - b)) @@ -213,8 +205,8 @@ negate (SLExp sA a) = SLExp (not sA) a {-# INLINE negate #-} -instance (Precise a, RealFloat a) => Fractional (SignedLog a) where - (SLExp sA a) / (SLExp sB b) = SLExp (nxor sA sB) (a-b) +instance RealFloat a => Fractional (SignedLog a) where + SLExp sA a / SLExp sB b = SLExp (nxor sA sB) (a-b) {-# INLINE (/) #-} fromRational a = SLExp (a >= 0) $ log $ fromRational $ abs a {-# INLINE fromRational #-} @@ -224,7 +216,7 @@ -- >>> (toRational (-3.5 :: SignedLog Double)) -- (-7) % 2 -instance (Precise a, RealFloat a, Ord a) => Real (SignedLog a) where +instance (RealFloat a, Ord a) => Real (SignedLog a) where toRational (SLExp sA a) = toRational $ multSign sA $ exp a {-# INLINE toRational #-} @@ -233,7 +225,7 @@ where value = f $ multSign sA $ exp a {-# INLINE logMap #-} -instance (RealFloat a, Precise a) => Floating (SignedLog a) where +instance RealFloat a => Floating (SignedLog a) where pi = SLExp True (log pi) {-# INLINE pi #-} exp (SLExp sA a) = SLExp True (multSign sA $ exp a) @@ -241,7 +233,7 @@ log (SLExp True a) = SLExp (a >= 0) (log $ abs a) log (SLExp False _) = nan {-# INLINE log #-} - (SLExp sB b) ** (SLExp sE e) | sB || e == 0 || isInfinite e = SLExp sB (b * (multSign sE $ exp e)) + (SLExp sB b) ** (SLExp sE e) | sB || e == 0 || isInfinite e = SLExp sB (b * multSign sE (exp e)) _ ** _ = nan {-# INLINE (**) #-} sqrt (SLExp True a) = SLExp True (a / 2) @@ -284,7 +276,8 @@ -- >>> (properFraction (-0.5) :: (Integer, SignedLog Double)) -- (0,-0.5) -instance (Precise a, RealFloat a) => RealFrac (SignedLog a) where +instance RealFloat a => RealFrac (SignedLog a) where properFraction slX@(SLExp sX x) | x < 0 = (0, slX) - | otherwise = (\(b,a) -> (b, SLExp sX $ log $ abs a)) $ properFraction $ multSign sX $ exp x + | otherwise = case properFraction $ multSign sX $ exp x of + (b,a) -> (b, SLExp sX $ log $ abs a) diff --git a/tests/doctests.hs b/tests/doctests.hs deleted file mode 100644 --- a/tests/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install deleted file mode 100644 --- a/travis/cabal-apt-install +++ /dev/null @@ -1,27 +0,0 @@ -#! /bin/bash -set -eu - -APT="sudo apt-get -q -y" -CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" - -$APT update -$APT install dctrl-tools - -# Find potential system packages to satisfy cabal dependencies -deps() -{ - local M='^\([^ ]\+\)-[0-9.]\+ (.*$' - local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' - local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ - | sed -ne "s/$M/$G/p" | sort -u)" - grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u -} - -$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special -$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage - -if ! $APT install hlint ; then - $APT install $(deps hlint) - cabal install hlint -fi - diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -1,16 +0,0 @@ --- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix --- --- This is particularly useful for travis-ci to get it to stop complaining --- about a broken build when everything is still correct on our end. --- --- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead --- --- To enable this, uncomment the before_script in .travis.yml - -remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive -remote-repo-cache: ~/.cabal/packages -world-file: ~/.cabal/world -build-summary: ~/.cabal/logs/build.log -remote-build-reporting: anonymous -install-dirs user -install-dirs global