diff --git a/Data/Number/LogFloat.hs b/Data/Number/LogFloat.hs --- a/Data/Number/LogFloat.hs +++ b/Data/Number/LogFloat.hs @@ -1,20 +1,9 @@ --- TODO: Add QuickCheck-ness, though beware of the fuzz. --- TODO: Make sure rewrite rules really fire --- TODO: profile to make sure we don't waste too much time constructing --- dictionaries --- TODO: write strict variant to unpack into registers --- TODO: write the signed variant -- Needed by our RealToFrac contexts {-# LANGUAGE FlexibleContexts #-} --- To turn on optimizations and look at the optimization records, cf: --- http://www.haskell.org/ghc/docs/latest/html/users_guide/rewrite-rules.html --- http://www.randomhacks.net/articles/2007/02/10/map-fusion-and-haskell-performance - --- {-# OPTIONS_GHC -ddump-rules -ddump-simpl-stats #-} - -{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +-- Removed -Wall because -fno-warn-orphans was removed in GHC 6.10 +{-# OPTIONS_GHC -fwarn-tabs #-} -- Unfortunately we need -fglasgow-exts in order to actually pick -- up on the rules (see -ddump-rules). The -frewrite-rules flag @@ -24,6 +13,8 @@ {-# OPTIONS_GHC -O2 -fvia-C -optc-O3 -fexcess-precision -fglasgow-exts #-} -- Version History +-- (v0.10) Fixed bugs in Hugs for PartialOrd and Transfinite. +-- Also added maxPO, minPO, comparingPO -- (v0.9.1) Fixed some PartialOrd stuff and sanitized documentation -- (v0.9.0) s/toFractional/realToFrac/g. -- Also moved realToFrac and log to Transfinite @@ -45,7 +36,7 @@ -- ~ 2008.08.29 -- | -- Module : Data.Number.LogFloat --- Copyright : Copyright (c) 2007--2008 wren ng thornton +-- Copyright : Copyright (c) 2007--2009 wren ng thornton -- License : BSD3 -- Maintainer : wren@community.haskell.org -- Stability : stable @@ -80,8 +71,7 @@ , fromLogFloat, logFromLogFloat ) where -import Prelude hiding (log, isNaN, realToFrac) -import qualified Prelude (isNaN) +import Prelude hiding (log, realToFrac, isInfinite, isNaN) import Data.Number.Transfinite import Data.Number.PartialOrd @@ -129,16 +119,14 @@ ---------------------------------------------------------------- --- --- | Reduce the number of constant string literals we need to store. +-- | Reduce the number of constant string literals we need to store. errorOutOfRange :: String -> a errorOutOfRange fun = error $! "Data.Number.LogFloat."++fun ++ ": argument out of range" -- | We need these guards in order to ensure some invariants. - guardNonNegative :: String -> Double -> Double guardNonNegative fun x | x >= 0 = x | otherwise = errorOutOfRange fun @@ -149,10 +137,9 @@ -- and so we could ideally take advantage of @log . guardNonNegative -- fun = guardIsANumber fun . log@ to simplify things, but Hugs -- raises an error so that's non-portable. - guardIsANumber :: String -> Double -> Double -guardIsANumber fun x | Prelude.isNaN x = errorOutOfRange fun - | otherwise = x +guardIsANumber fun x | isNaN x = errorOutOfRange fun + | otherwise = x ---------------------------------------------------------------- -- @@ -192,7 +179,6 @@ -- | A constructor which does semantic conversion from normal-domain -- to log-domain. - logFloat :: (Real a, RealToFrac a Double) => a -> LogFloat {-# SPECIALIZE logFloat :: Double -> LogFloat #-} logFloat = LogFloat . log . guardNonNegative "logFloat" . realToFrac @@ -277,6 +263,14 @@ -- +\/- 4e-16. instance Num LogFloat where + -- BUG? In Hugs (Sept2006) the (>=) always returns True if + -- either isNaN. Only questionably a bug, since we try to + -- ensure that notANumber never occurs. Still... perhaps + -- we should use `ge` and other PartialOrd things in order + -- to play it safe. + -- TODO: benchmark and check core to see how much that hurts GHC. + + (*) (LogFloat x) (LogFloat y) = LogFloat (x+y) (+) (LogFloat x) (LogFloat y) @@ -320,6 +314,20 @@ -- Rationals are very buggy when it comes to transfinite values instance Real LogFloat where toRational (LogFloat x) = toRational (exp x) + + +{- -- Commented out because I'm not sure about requiring MPTCs. Of course, those are already required by "Data.Number.Transfinite" so it's pretty moot... + +-- LogFloat->LogFloat is already given via generic (a->a) +-- No LogFloat->Rational since LogFloat can have 'infinity' +-- Can't have LogFloat->a using fromLogFloat because Hugs dislikes incoherence. Adding an explicit LogFloat->LogFloat instance doesn't help like it does for GHC. + +instance RealToFrac LogFloat Double where + realToFrac = fromLogFloat + +instance RealToFrac LogFloat Float where + realToFrac = fromLogFloat +-} ---------------------------------------------------------------- ----------------------------------------------------------- fin. diff --git a/Data/Number/PartialOrd.hs b/Data/Number/PartialOrd.hs --- a/Data/Number/PartialOrd.hs +++ b/Data/Number/PartialOrd.hs @@ -6,10 +6,10 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2008.08.29 +-- ~ 2009.01.29 -- | -- Module : Data.Number.PartialOrd --- Copyright : Copyright (c) 2007--2008 wren ng thornton +-- Copyright : Copyright (c) 2007--2009 wren ng thornton -- License : BSD3 -- Maintainer : wren@community.haskell.org -- Stability : experimental @@ -21,8 +21,18 @@ -- are moreso. This module presents a class for partially ordered -- types. ---------------------------------------------------------------- -module Data.Number.PartialOrd (PartialOrd(..)) where +module Data.Number.PartialOrd + ( + -- * Partial Ordering + PartialOrd(..) + -- * Functions + , comparingPO + ) where +-- Bugfix for Hugs (September 2006), see note below. +import Prelude hiding (isNaN) +import Hugs.RealFloat (isNaN) + ---------------------------------------------------------------- -- | This class defines a partially ordered type. The method names -- were chosen so as not to conflict with 'Ord' and 'Eq'. We use @@ -33,56 +43,89 @@ -- Minimum complete definition: 'cmp' class PartialOrd a where + -- | like 'compare' cmp :: a -> a -> Maybe Ordering + -- | like ('>') gt :: a -> a -> Maybe Bool gt x y = case x `cmp` y of Just GT -> Just True Just _ -> Just False Nothing -> Nothing + -- | like ('>=') ge :: a -> a -> Maybe Bool ge x y = case x `cmp` y of Just LT -> Just False Just _ -> Just True Nothing -> Nothing + -- | like ('==') eq :: a -> a -> Maybe Bool eq x y = case x `cmp` y of Just EQ -> Just True Just _ -> Just False Nothing -> Nothing + -- | like ('/=') ne :: a -> a -> Maybe Bool ne x y = case x `cmp` y of Just EQ -> Just False Just _ -> Just True Nothing -> Nothing + -- | like ('<=') le :: a -> a -> Maybe Bool le x y = case x `cmp` y of Just GT -> Just False Just _ -> Just True Nothing -> Nothing + -- | like ('<') lt :: a -> a -> Maybe Bool lt x y = case x `cmp` y of Just LT -> Just True Just _ -> Just False Nothing -> Nothing + + -- | like 'max'. The default instance returns the left argument + -- when they're equal. + maxPO :: a -> a -> Maybe a + maxPO x y = do o <- x `cmp` y + case o of + GT -> Just x + EQ -> Just x + LT -> Just y + + -- | like 'min'. The default instance returns the left argument + -- when they're equal. + minPO :: a -> a -> Maybe a + minPO x y = do o <- x `cmp` y + case o of + GT -> Just y + EQ -> Just x + LT -> Just x -infix 4 `gt`, `ge`, `eq`, `ne`, `le`, `lt` +infix 4 `gt`, `ge`, `eq`, `ne`, `le`, `lt`, `maxPO`, `minPO` instance (Ord a) => PartialOrd a where - cmp x y = Just $! compare x y - gt x y = Just $! x > y - ge x y = Just $! x >= y - eq x y = Just $! x == y - ne x y = Just $! x /= y - le x y = Just $! x <= y - lt x y = Just $! x < y + cmp x y = Just $! x `compare` y + gt x y = Just $! x > y + ge x y = Just $! x >= y + eq x y = Just $! x == y + ne x y = Just $! x /= y + le x y = Just $! x <= y + lt x y = Just $! x < y + maxPO x y = Just $! x `max` y + minPO x y = Just $! x `min` y --- The instances inherited from Ord are wrong + +-- N.B. Hugs (Sept 2006) has a buggy definition for 'isNaN' which +-- always returns @False@. We use a fixed version, provided the CPP +-- was run with the right arguments. See "Hugs.RealFloat". If 'cmp' +-- returns @Just Eq@ for @notANumber@ then CPP was run wrongly. +-- +-- The instances inherited from Ord are wrong. So we'll fix them. instance PartialOrd Float where cmp x y | isNaN x || isNaN y = Nothing | otherwise = Just $! x `compare` y @@ -90,6 +133,16 @@ instance PartialOrd Double where cmp x y | isNaN x || isNaN y = Nothing | otherwise = Just $! x `compare` y + +---------------------------------------------------------------- +-- TODO? add maximumPO\/minimumPO via left or right fold? + +-- BUG: Haddock doesn't link the `comparing` +-- +-- | Like @Data.Ord.comparing@. Helpful in conjunction with the +-- @xxxBy@ family of functions from "Data.List" +comparingPO :: (PartialOrd b) => (a -> b) -> a -> a -> Maybe Ordering +comparingPO p x y = p x `cmp` p y ---------------------------------------------------------------- ----------------------------------------------------------- fin. diff --git a/Data/Number/Transfinite.hs b/Data/Number/Transfinite.hs --- a/Data/Number/Transfinite.hs +++ b/Data/Number/Transfinite.hs @@ -1,19 +1,20 @@ --- Needed to ensure correctness, because we can't guarantee that rules fire +-- Needed to ensure correctness, and because we can't guarantee rules fire {-# LANGUAGE MultiParamTypeClasses , OverlappingInstances + , CPP #-} -- Glasgow extensions needed to enable the # kind -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# OPTIONS_GHC -fglasgow-exts #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2008.10.16 +-- ~ 2009.01.29 -- | -- Module : Data.Number.Transfinite --- Copyright : Copyright (c) 2007--2008 wren ng thornton +-- Copyright : Copyright (c) 2007--2009 wren ng thornton -- License : BSD3 -- Maintainer : wren@community.haskell.org -- Stability : experimental @@ -49,15 +50,15 @@ , RealToFrac(..) ) where -import Prelude hiding (isInfinite, isNaN, log, realToFrac) -import qualified Prelude (isInfinite, isNaN, log, realToFrac) +import Prelude hiding (log, realToFrac, isInfinite, isNaN) +import qualified Prelude (log, realToFrac) +import qualified Hugs.RealFloat as Prelude (isInfinite, isNaN) import Data.Number.PartialOrd #ifdef __GLASGOW_HASKELL__ import GHC.Exts ( Int(..), Float(..), Double(..) --- These should all be provided indirectly from GHC.Prim... , int2Double# , int2Float# , double2Float# @@ -81,6 +82,11 @@ -- as well as an exceptional value 'notANumber'. All the natural -- laws regarding @infinity@ and @negativeInfinity@ should pertain. -- (Some of these are discussed below.) +-- +-- Hugs (September 2006) has buggy Prelude definitions for +-- 'Prelude.isNaN' and 'Prelude.isInfinite' on Float and Double. +-- This module provides correct definitions, so long as "Hugs.RealFloat" +-- is compiled correctly. class (PartialOrd a) => Transfinite a where @@ -124,9 +130,11 @@ -- -- Additionally, any mathematical operations on @notANumber@ -- must also return @notANumber@, and any equality or ordering - -- comparison on @notANumber@ must return @False@. Since it - -- returns false for equality, there may be more than one machine - -- representation of this `value'. + -- comparison on @notANumber@ must return @False@ (violating + -- the law of the excluded middle, often assumed but not required + -- for 'Eq'; thus, 'eq' and 'ne' are preferred over ('==') and + -- ('/=')). Since it returns false for equality, there may be + -- more than one machine representation of this `value'. notANumber :: a @@ -208,8 +216,10 @@ -- instances are overlapped, so you'll need to give type signatures -- if the arguments to 'realToFrac' are polymorphic. -- --- If any of these restrictions (CPP, GHC-only, OverlappingInstances) --- are onerous to you, contact the maintainer (we like patches :) +-- If any of these restrictions (CPP, GHC-only optimizations, +-- OverlappingInstances) are onerous to you, contact the maintainer +-- (we like patches). Note that this /does/ work for Hugs with +-- suitable options (e.g. @hugs -98 +o -F'cpp -P'@). class (Real a, Fractional b) => RealToFrac a b where realToFrac :: a -> b diff --git a/Hugs/RealFloat.hs b/Hugs/RealFloat.hs new file mode 100644 --- /dev/null +++ b/Hugs/RealFloat.hs @@ -0,0 +1,63 @@ + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} + +---------------------------------------------------------------- +-- ~ 2009.01.29 +-- | +-- Module : Hugs.RealFloat +-- Copyright : Copyright (c) 2007--2009 wren ng thornton +-- License : BSD3 +-- Maintainer : wren@community.haskell.org +-- Stability : stable +-- Portability : portable (with CPP) +-- +-- Hugs (September 2006) has buggy definitions for 'Prelude.isNaN' +-- and 'Prelude.isInfinite' on Float and Double. If this module is +-- run through CPP with the macro @__HUGS__@ set to a value no +-- larger than 200609, then correct definitions are used. Otherwise +-- the Prelude definitions are used (which should be correct for +-- other compilers). For example, run Hugs with +-- +-- @hugs -F'cpp -P -D__HUGS__=200609' Hugs/RealFloat.hs@ +-- +-- N.B. The corrected definitions have only been tested to work for +-- 'Float' and 'Double'. These definitions should probably not be +-- used for other 'RealFloat' types. +---------------------------------------------------------------- +module Hugs.RealFloat + ( isInfinite + , isNaN + ) where + +import Prelude hiding (isInfinite, isNaN) +import qualified Prelude +---------------------------------------------------------------- + +isInfinite :: (RealFloat a) => a -> Bool +{-# INLINE isInfinite #-} +#if defined(__HUGS__) && (__HUGS__ <= 200609) +isInfinite x = (1/0) == abs x +#else +isInfinite = Prelude.isInfinite +#endif + + +isNaN :: (RealFloat a) => a -> Bool +{-# INLINE isNaN #-} +#if defined(__HUGS__) && (__HUGS__ <= 200609) +isNaN x = compareEQ x 0 && compareEQ x 1 + +-- | In Hugs (September 2006), 'compare' always returns @EQ@ if one +-- of the arguments is not a number. Thus, if a number is @compareEQ@ +-- against multiple different numbers, then it must be @isNaN@. +compareEQ :: (Ord a) => a -> a -> Bool +compareEQ x y = case compare x y of + EQ -> True + _ -> False +#else +isNaN = Prelude.isNaN +#endif +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/logfloat.cabal b/logfloat.cabal --- a/logfloat.cabal +++ b/logfloat.cabal @@ -1,13 +1,13 @@ ---------------------------------------------------------------- --- wren ng thornton ~ 2008.10.16 +-- wren ng thornton ~ 2009.01.29 ---------------------------------------------------------------- Name: logfloat -Version: 0.9.1.3 +Version: 0.10.0 Cabal-Version: >= 1.2 Build-Type: Simple Stability: experimental -Copyright: Copyright (c) 2007--2008 wren ng thornton +Copyright: Copyright (c) 2007--2009 wren ng thornton License: BSD3 License-File: LICENSE Author: wren ng thornton @@ -34,10 +34,14 @@ Exposed-Modules: Data.Number.LogFloat , Data.Number.Transfinite , Data.Number.PartialOrd + , Hugs.RealFloat Build-Depends: base -- No longer needed since we use GHC.Exts instead -- if flag(hiddenPrim) -- Build-Depends: ghc-prim + Hugs-Options: -98 +o -F'cpp -P -D__HUGS__=200609' + if impl(ghc < 6.10) + GHC-Options: -fno-warn-orphans ---------------------------------------------------------------- ----------------------------------------------------------- fin.