approximate (empty) → 0.1
raw patch · 15 files changed
+844/−0 lines, 15 filesdep +basedep +binarydep +bytesbuild-type:Customsetup-changed
Dependencies added: base, binary, bytes, cereal, comonad, data-default, deepseq, directory, distributive, doctest, filepath, generic-deriving, ghc-prim, hashable, hashable-extras, lens, log-domain, pointed, safecopy, semigroupoids, semigroups, simple-reflect, vector
Files
- .ghci +1/−0
- .gitignore +13/−0
- .travis.yml +26/−0
- .vim.custom +31/−0
- AUTHORS.markdown +7/−0
- CHANGELOG.markdown +3/−0
- LICENSE +30/−0
- README.markdown +15/−0
- Setup.lhs +55/−0
- approximate.cabal +93/−0
- src/Data/Approximate/Mass.hs +238/−0
- src/Data/Approximate/Type.hs +215/−0
- tests/doctests.hsc +74/−0
- travis/cabal-apt-install +27/−0
- travis/config +16/−0
+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes
+ .gitignore view
@@ -0,0 +1,13 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#
+ .travis.yml view
@@ -0,0 +1,26 @@+language: haskell+before_install:+ # Uncomment whenever hackage is down.+ # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update+ - cabal update++ # Try installing some of the build-deps with apt-get for speed.+ - travis/cabal-apt-install $mode++install:+ - cabal configure -flib-Werror $mode+ - cabal build++script:+ - $script && hlint src --cpp-define HLINT++notifications:+ irc:+ channels:+ - "irc.freenode.org#haskell-lens"+ skip_join: true+ template:+ - "\x0313approximate\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++env:+ - mode="--enable-tests" script="cabal test --show-details=always"
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+" so .vim.custom+" endif++function StripTrailingWhitespace()+ let myline=line(".")+ let mycolumn = col(".")+ silent %s/ *$//+ call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ AUTHORS.markdown view
@@ -0,0 +1,7 @@+`approximate` was inspired by the use of approximate booleans and approximate numbers in twitter's algebird library.++A variant of those ideas was introduced into the [analytics](http://github.com/analytics) project.++This package is an attempt to open that version up to more users.++- [Edward Kmett](mailto:ekmett@gmail.com) [@ekmett](https://github.com/ekmett)
+ CHANGELOG.markdown view
@@ -0,0 +1,3 @@+0.1+---+* Ported from [analytics](http://github.com/analytics)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2011 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,15 @@+approximate+===========++[](http://travis-ci.org/ekmett/approximate)++This package provides approximate numbers and discrete values with lower bounds on their probability of correctness.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
+ Setup.lhs view
@@ -0,0 +1,55 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ , postHaddock = \args flags pkg lbi -> do+ copyFiles normal (haddockOutputDir flags pkg) []+ postHaddock simpleUserHooks args flags pkg lbi+ }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+ baseDir = case haddockDistPref flags of+ NoFlag -> "."+ Flag x -> x+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ withLibLBI pkg lbi $ \_ libcfg -> do+ withTestLBI pkg lbi $ \suite suitecfg -> do+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+ [ "module Build_" ++ testName suite ++ " where"+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
+ approximate.cabal view
@@ -0,0 +1,93 @@+name: approximate+category: Numeric+version: 0.1+license: BSD3+cabal-version: >= 1.8+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/analytics/approximate/+bug-reports: http://github.com/analytics/approximate/issues+copyright: Copyright (C) 2013 Edward A. Kmett+build-type: Custom+tested-with: GHC == 7.4.1, GHC == 7.6.1+synopsis: Approximate discrete values and numbers+description: This package provides approximate discrete values and numbers.++extra-source-files:+ .travis.yml+ .ghci+ .gitignore+ .vim.custom+ travis/cabal-apt-install+ travis/config+ AUTHORS.markdown+ README.markdown+ CHANGELOG.markdown++source-repository head+ type: git+ location: git://github.com/analytics/approximate.git++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+ default: True+ manual: True++flag lib-Werror+ default: False+ manual: True++library+ build-depends:+ base >= 4.3 && < 5,+ binary >= 0.5 && < 0.8,+ bytes >= 0.7 && < 1,+ cereal >= 0.3.5 && < 0.4,+ comonad >= 3 && < 4,+ data-default >= 0.5 && < 0.6,+ deepseq >= 1.3 && < 1.5,+ distributive >= 0.3 && < 1,+ generic-deriving >= 1.4 && < 1.6,+ ghc-prim,+ hashable >= 1.1.2.3 && < 1.3,+ hashable-extras >= 0.1 && < 1,+ lens >= 3.9 && < 4,+ log-domain,+ pointed >= 3 && < 4,+ semigroupoids >= 3.0.2 && < 4,+ semigroups >= 0.8.4 && < 1,+ safecopy >= 0.8.1 && < 0.9,+ vector >= 0.9 && < 0.11++ exposed-modules:+ Data.Approximate.Type+ Data.Approximate.Mass++ if flag(lib-Werror)+ ghc-options: -Werror++ ghc-options: -Wall -fwarn-tabs -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,+ directory >= 1.0,+ doctest >= 0.9.1,+ filepath,+ generic-deriving,+ semigroups >= 0.9,+ simple-reflect >= 0.3.1++ if impl(ghc<7.6.1)+ ghc-options: -Werror
+ src/Data/Approximate/Mass.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+--------------------------------------------------------------------+-- |+-- Copyright : (c) Edward Kmett 2013+-- License : BSD3+-- Maintainer: Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability: non-portable+--+--------------------------------------------------------------------+module Data.Approximate.Mass+ ( Mass(..)+ , (|?), (&?), (^?)+ ) where++import Control.Applicative+import Control.Comonad+import Control.DeepSeq+import Control.Monad+import Data.Binary as Binary+import Data.Bytes.Serial as Bytes+import Data.Copointed+import Data.Data+import Data.Default+import Data.Foldable+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Hashable+import Data.Hashable.Extras+import Data.Pointed+import Data.SafeCopy+import Data.Semigroup+import Data.Serialize as Serialize+import Data.Traversable+import Data.Vector.Generic as G+import Data.Vector.Generic.Mutable as M+import Data.Vector.Unboxed as U+import Generics.Deriving+import Numeric.Log++-- | A quantity with a lower-bound on its probability mass. This represents+-- a 'probable value' as a 'Monad' that you can use to calculate progressively+-- less likely consequences.+--+-- /NB:/ These probabilities are all stored in the log domain. This enables us+-- to retain accuracy despite very long multiplication chains. We never add+-- these probabilities so the additional overhead of working in the log domain+-- is never incurred, except on transitioning in and out.+--+-- This is most useful for discrete types, such as+-- small 'Integral' instances or a 'Bounded' 'Enum' like+-- 'Bool'.+--+-- Also note that @('&?')@ and @('|?')@ are able to use knowledge about the+-- function to get better precision on their results than naively using+-- @'liftA2' ('&&')@+data Mass a = Mass {-# UNPACK #-} !(Log Double) a+ deriving (Eq,Ord,Show,Read,Typeable,Data,Generic)++instance Binary a => Binary (Mass a) where+ put (Mass p a) = Binary.put p >> Binary.put a+ get = Mass <$> Binary.get <*> Binary.get++instance Serialize a => Serialize (Mass a) where+ put (Mass p a) = Serialize.put p >> Serialize.put a+ get = Mass <$> Serialize.get <*> Serialize.get++instance Serialize a => SafeCopy (Mass a)++instance Hashable a => Hashable (Mass a)+instance Hashable1 Mass++instance Serial1 Mass where+ serializeWith f (Mass p a) = serialize p >> f a+ deserializeWith m = Mass <$> deserialize <*> m++instance Serial a => Serial (Mass a) where+ serialize (Mass p a) = serialize p >> serialize a+ deserialize = Mass <$> deserialize <*> deserialize++instance Functor Mass where+ fmap f (Mass p a) = Mass p (f a)+ {-# INLINE fmap #-}++instance Foldable Mass where+ foldMap f (Mass _ a) = f a+ {-# INLINE foldMap #-}++newtype instance U.MVector s (Mass a) = MV_Mass (U.MVector s (Log Double,a))+newtype instance U.Vector (Mass a) = V_Mass (U.Vector (Log Double,a))++instance Unbox a => M.MVector U.MVector (Mass a) where+ basicLength (MV_Mass v) = M.basicLength v+ {-# INLINE basicLength #-}+ basicUnsafeSlice i n (MV_Mass v) = MV_Mass $ M.basicUnsafeSlice i n v+ {-# INLINE basicUnsafeSlice #-}+ basicOverlaps (MV_Mass v1) (MV_Mass v2) = M.basicOverlaps v1 v2+ {-# INLINE basicOverlaps #-}+ basicUnsafeNew n = MV_Mass `liftM` M.basicUnsafeNew n+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeReplicate n (Mass p a) = MV_Mass `liftM` M.basicUnsafeReplicate n (p,a)+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeRead (MV_Mass v) i = uncurry Mass `liftM` M.basicUnsafeRead v i+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeWrite (MV_Mass v) i (Mass p a) = M.basicUnsafeWrite v i (p,a)+ {-# INLINE basicUnsafeWrite #-}+ basicClear (MV_Mass v) = M.basicClear v+ {-# INLINE basicClear #-}+ basicSet (MV_Mass v) (Mass p a) = M.basicSet v (p,a)+ {-# INLINE basicSet #-}+ basicUnsafeCopy (MV_Mass v1) (MV_Mass v2) = M.basicUnsafeCopy v1 v2+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeMove (MV_Mass v1) (MV_Mass v2) = M.basicUnsafeMove v1 v2+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeGrow (MV_Mass v) n = MV_Mass `liftM` M.basicUnsafeGrow v n+ {-# INLINE basicUnsafeGrow #-}++instance Unbox a => G.Vector U.Vector (Mass a) where+ basicUnsafeFreeze (MV_Mass v) = V_Mass `liftM` G.basicUnsafeFreeze v+ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeThaw (V_Mass v) = MV_Mass `liftM` G.basicUnsafeThaw v+ {-# INLINE basicUnsafeThaw #-}+ basicLength (V_Mass v) = G.basicLength v+ {-# INLINE basicLength #-}+ basicUnsafeSlice i n (V_Mass v) = V_Mass $ G.basicUnsafeSlice i n v+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeIndexM (V_Mass v) i+ = uncurry Mass `liftM` G.basicUnsafeIndexM v i+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeCopy (MV_Mass mv) (V_Mass v) = G.basicUnsafeCopy mv v+ {-# INLINE basicUnsafeCopy #-}+ elemseq _ (Mass p a) z+ = G.elemseq (undefined :: U.Vector (Log Double)) p+ $ G.elemseq (undefined :: U.Vector a) a z+ {-# INLINE elemseq #-}++instance NFData a => NFData (Mass a) where+ rnf (Mass _ a) = rnf a `seq` ()+ {-# INLINE rnf #-}++instance Traversable Mass where+ traverse f (Mass p a) = Mass p <$> f a+ {-# INLINE traverse #-}++instance Apply Mass where+ (<.>) = (<*>)+ {-# INLINE (<.>) #-}++instance Pointed Mass where+ point = Mass 1+ {-# INLINE point #-}++instance Copointed Mass where+ copoint (Mass _ a) = a+ {-# INLINE copoint #-}++instance Default a => Default (Mass a) where+ def = Mass 1 def+ {-# INLINE def #-}++instance Applicative Mass where+ pure = Mass 1+ {-# INLINE pure #-}+ Mass p f <*> Mass q a = Mass (p * q) (f a)+ {-# INLINE (<*>) #-}++instance Monoid a => Monoid (Mass a) where+ mempty = Mass 1 mempty+ {-# INLINE mempty #-}+ mappend (Mass p a) (Mass q b) = Mass (p * q) (mappend a b)+ {-# INLINE mappend #-}++instance Semigroup a => Semigroup (Mass a) where+ Mass p a <> Mass q b = Mass (p * q) (a <> b)+ {-# INLINE (<>) #-}++instance Bind Mass where+ Mass p a >>- f = case f a of+ Mass q b -> Mass (p * q) b+ {-# INLINE (>>-) #-}++instance Monad Mass where+ return = Mass 1+ {-# INLINE return #-}+ Mass p a >>= f = case f a of+ Mass q b -> Mass (p * q) b+ {-# INLINE (>>=) #-}++instance Extend Mass where+ duplicated (Mass n a) = Mass n (Mass n a)+ {-# INLINE duplicated #-}+ extended f w@(Mass n _) = Mass n (f w)+ {-# INLINE extended #-}++instance Comonad Mass where+ extract (Mass _ a) = a+ {-# INLINE extract #-}+ duplicate (Mass n a) = Mass n (Mass n a)+ {-# INLINE duplicate #-}+ extend f w@(Mass n _) = Mass n (f w)+ {-# INLINE extend #-}++instance ComonadApply Mass where+ (<@>) = (<*>)+ {-# INLINE (<@>) #-}++infixl 6 ^?+infixr 3 &?+infixr 2 |?++-- | Calculate the logical @and@ of two booleans with confidence lower bounds.+(&?) :: Mass Bool -> Mass Bool -> Mass Bool+Mass p False &? Mass q False = Mass (max p q) False+Mass p False &? Mass _ True = Mass p False+Mass _ True &? Mass q False = Mass q False+Mass p True &? Mass q True = Mass (p * q) True+{-# INLINE (&?) #-}++-- | Calculate the logical @or@ of two booleans with confidence lower bounds.+(|?) :: Mass Bool -> Mass Bool -> Mass Bool+Mass p False |? Mass q False = Mass (p * q) False+Mass _ False |? Mass q True = Mass q True+Mass p True |? Mass _ False = Mass p True+Mass p True |? Mass q True = Mass (max p q) True+{-# INLINE (|?) #-}++-- | Calculate the exclusive @or@ of two booleans with confidence lower bounds.+(^?) :: Mass Bool -> Mass Bool -> Mass Bool+Mass p a ^? Mass q b = Mass (p * q) (xor a b) where+ xor True True = False+ xor False True = True+ xor True False = True+ xor False False = False+ {-# INLINE xor #-}+{-# INLINE (^?) #-}
+ src/Data/Approximate/Type.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+--------------------------------------------------------------------+-- |+-- Copyright : (c) Edward Kmett 2013+-- License : BSD3+-- Maintainer: Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability: non-portable+--+--------------------------------------------------------------------+module Data.Approximate.Type+ ( Approximate(Approximate)+ , HasApproximate(..)+ , exact+ , zero+ , one+ , withMin, withMax+ ) where++import Control.Applicative+import Control.DeepSeq+import Control.Lens+import Control.Monad+import Data.Binary as Binary+import Data.Bytes.Serial as Bytes+import Data.Copointed+import Data.Data+import Data.Foldable+import Data.Functor.Apply+import Data.Hashable+import Data.Hashable.Extras+import Data.Monoid+import Data.Pointed+import Data.SafeCopy+import Data.Serialize as Serialize+import Data.Vector.Generic as G+import Data.Vector.Generic.Mutable as M+import Data.Vector.Unboxed as U+import GHC.Generics+import Numeric.Log++-- | An approximate number, with a likely interval, an expected value and a lower bound on the @log@ of probability that the answer falls in the interval.+--+-- /NB:/ The probabilities associated with confidence are stored in the @log@ domain.+data Approximate a = Approximate+ { _confidence :: {-# UNPACK #-} !(Log Double)+ , _lo, _estimate, _hi :: a+ } deriving (Eq,Show,Read,Typeable,Data,Generic)++makeClassy ''Approximate++instance Binary a => Binary (Approximate a) where+ put (Approximate p l m h) = Binary.put p >> Binary.put l >> Binary.put m >> Binary.put h+ get = Approximate <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get++instance Serialize a => Serialize (Approximate a) where+ put (Approximate p l m h) = Serialize.put p >> Serialize.put l >> Serialize.put m >> Serialize.put h+ get = Approximate <$> Serialize.get <*> Serialize.get <*> Serialize.get <*> Serialize.get++instance Serialize a => SafeCopy (Approximate a)++instance Hashable a => Hashable (Approximate a)+instance Hashable1 Approximate++instance Serial a => Serial (Approximate a)++instance Serial1 Approximate where+ serializeWith f (Approximate p l m h) = serialize p >> f l >> f m >> f h+ deserializeWith m = Approximate <$> deserialize <*> m <*> m <*> m++-- instance Storable a => Storable (Approximate a) where+-- sizeOf _ = sizeOf (undefined :: Double) + sizeOf (undefined :: a) * 3 --?++instance Unbox a => Unbox (Approximate a)++newtype instance U.MVector s (Approximate a) = MV_Approximate (U.MVector s (Log Double,a,a,a))+newtype instance U.Vector (Approximate a) = V_Approximate (U.Vector (Log Double,a,a,a))++instance Unbox a => M.MVector U.MVector (Approximate a) where+ basicLength (MV_Approximate v) = M.basicLength v+ {-# INLINE basicLength #-}+ basicUnsafeSlice i n (MV_Approximate v) = MV_Approximate $ M.basicUnsafeSlice i n v+ {-# INLINE basicUnsafeSlice #-}+ basicOverlaps (MV_Approximate v1) (MV_Approximate v2) = M.basicOverlaps v1 v2+ {-# INLINE basicOverlaps #-}+ basicUnsafeNew n = MV_Approximate `liftM` M.basicUnsafeNew n+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeReplicate n (Approximate p l m h) = MV_Approximate `liftM` M.basicUnsafeReplicate n (p,l,m,h)+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeRead (MV_Approximate v) i = (\(p,l,m,h) -> Approximate p l m h) `liftM` M.basicUnsafeRead v i+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeWrite (MV_Approximate v) i (Approximate p l m h) = M.basicUnsafeWrite v i (p,l,m,h)+ {-# INLINE basicUnsafeWrite #-}+ basicClear (MV_Approximate v) = M.basicClear v+ {-# INLINE basicClear #-}+ basicSet (MV_Approximate v) (Approximate p l m h) = M.basicSet v (p,l,m,h)+ {-# INLINE basicSet #-}+ basicUnsafeCopy (MV_Approximate v1) (MV_Approximate v2) = M.basicUnsafeCopy v1 v2+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeMove (MV_Approximate v1) (MV_Approximate v2) = M.basicUnsafeMove v1 v2+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeGrow (MV_Approximate v) n = MV_Approximate `liftM` M.basicUnsafeGrow v n+ {-# INLINE basicUnsafeGrow #-}++instance Unbox a => G.Vector U.Vector (Approximate a) where+ basicUnsafeFreeze (MV_Approximate v) = V_Approximate `liftM` G.basicUnsafeFreeze v+ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeThaw (V_Approximate v) = MV_Approximate `liftM` G.basicUnsafeThaw v+ {-# INLINE basicUnsafeThaw #-}+ basicLength (V_Approximate v) = G.basicLength v+ {-# INLINE basicLength #-}+ basicUnsafeSlice i n (V_Approximate v) = V_Approximate $ G.basicUnsafeSlice i n v+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeIndexM (V_Approximate v) i+ = (\(p,l,m,h) -> Approximate p l m h) `liftM` G.basicUnsafeIndexM v i+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeCopy (MV_Approximate mv) (V_Approximate v) = G.basicUnsafeCopy mv v+ {-# INLINE basicUnsafeCopy #-}+ elemseq _ (Approximate p l m h) z+ = G.elemseq (undefined :: U.Vector (Log Double)) p+ $ G.elemseq (undefined :: U.Vector a) l+ $ G.elemseq (undefined :: U.Vector a) m+ $ G.elemseq (undefined :: U.Vector a) h z+ {-# INLINE elemseq #-}++instance NFData a => NFData (Approximate a) where+ rnf (Approximate _ l m h) = rnf l `seq` rnf m `seq` rnf h `seq` ()++instance Functor Approximate where+ fmap f (Approximate p l m h) = Approximate p (f l) (f m) (f h)+ {-# INLINE fmap #-}++instance Foldable Approximate where+ foldMap f (Approximate _ l m h) = f l `mappend` f m `mappend` f h+ {-# INLINE foldMap #-}++instance Traversable Approximate where+ traverse f (Approximate p l m h) = Approximate p <$> f l <*> f m <*> f h+ {-# INLINE traverse #-}++instance Copointed Approximate where+ copoint (Approximate _ _ a _) = a+ {-# INLINE copoint #-}++instance Pointed Approximate where+ point a = Approximate 1 a a a+ {-# INLINE point #-}++instance Apply Approximate where+ Approximate p lf mf hf <.> Approximate q la ma ha = Approximate (p * q) (lf la) (mf ma) (hf ha)+ {-# INLINE (<.>) #-}++instance Applicative Approximate where+ pure a = Approximate 1 a a a+ {-# INLINE pure #-}+ Approximate p lf mf hf <*> Approximate q la ma ha = Approximate (p * q) (lf la) (mf ma) (hf ha)+ {-# INLINE (<*>) #-}++withMin :: Ord a => a -> Approximate a -> Approximate a+withMin b r@(Approximate p l m h)+ | b <= l = r+ | otherwise = Approximate p b (max b m) (max b h)+{-# INLINE withMin #-}++withMax :: Ord a => a -> Approximate a -> Approximate a+withMax b r@(Approximate p l m h)+ | h <= b = r+ | otherwise = Approximate p (min l b) (min m b) b+{-# INLINE withMax #-}++instance (Ord a, Num a) => Num (Approximate a) where+ (+) = liftA2 (+)+ {-# INLINE (+) #-}+ m * n+ | is zero n || is one m = m+ | is zero m || is one n = n+ | otherwise = Approximate (m^.confidence * n^.confidence) (Prelude.minimum extrema) (m^.estimate * n^.estimate) (Prelude.maximum extrema) where+ extrema = (*) <$> [m^.lo,m^.hi] <*> [n^.lo,n^.hi]+ {-# INLINE (*) #-}+ negate (Approximate p l m h) = Approximate p (-h) (-m) (-l)+ {-# INLINE negate #-}+ Approximate p la ma ha - Approximate q lb mb hb = Approximate (p * q) (la - hb) (ma - mb) (ha - lb)+ {-# INLINE (-) #-}+ abs (Approximate p la ma ha) = Approximate p (min lb hb) (abs ma) (max lb hb) where+ lb = abs la+ hb = abs ha+ {-# INLINE abs #-}+ signum = fmap signum+ {-# INLINE signum #-}+ fromInteger = pure . fromInteger+ {-# INLINE fromInteger #-}++exact :: Eq a => Prism' (Approximate a) a+exact = prism pure $ \ s -> case s of+ Approximate (Exp lp) a b c | lp == 0 && a == c -> Right b+ _ -> Left s+{-# INLINE exact #-}++zero :: (Num a, Eq a) => Prism' (Approximate a) ()+zero = exact.only 0+{-# INLINE zero #-}++one :: (Num a, Eq a) => Prism' (Approximate a) ()+one = exact.only 1+{-# INLINE one #-}++is :: Getting Any s a -> s -> Bool+is = has+{-# INLINE is #-}
+ tests/doctests.hsc view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-13 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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 (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+ cp <- c_GetConsoleCP+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : "-hide-all-packages"+ : "-Iincludes"+ : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ travis/cabal-apt-install view
@@ -0,0 +1,27 @@+#! /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+
+ travis/config view
@@ -0,0 +1,16 @@+-- 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