half-0.3.1/0000755000000000000000000000000007346545000010616 5ustar0000000000000000half-0.3.1/.gitignore0000644000000000000000000000022607346545000012606 0ustar0000000000000000dist/ dist-newstyle/ .ghc.env* .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .cabal-sandbox/ cabal.sandbox.config codex.tags half-0.3.1/CHANGELOG.markdown0000644000000000000000000000242107346545000013650 0ustar00000000000000000.3.1 [2021-01-04] ------------------ * Downgraded testing claims that NaNs will round-trip, as 32-bit GHCs aren't fulfilling that promise. Now we merely claim that a NaN will return as a NaN. * Always provide `NFData Half` instance * Add `Binary Half` instance * Explicitly mark module as `Trustworthy` * Fix `isInfinite` * Add experimental support for GHCJS, add pure conversion functions. 0.3 --- * Fixed bound in `floatRange`. * Fixed `decodeFloat`. * Added a `Lift` instance for `Half` for `template-haskell` support. 0.2.2.3 ------- * Avoid the new warnings for missing pattern synonym signatures on GHC 8 0.2.2.2 ------- * Fixed an issue with `Storable` that was causing crashing for some users. 0.2.2.1 ------- * Added support for older GHCs still. `unsafeShiftR` was only added in 7.4. 0.2.2 ----- * Fixed `isInfinite`. * Added support for older GHCs. On GHC < 7.8 the pattern synonyms are disabled. 0.2.1 ----- * Removed need for `GeneralizedNewtypeDeriving` and `ScopedTypeVariables`. 0.2.0.1 ------- * Fixed source repository location 0.2 --- * Renamed `toFloat` to `fromHalf` for easier unqualified use. * Added a `Read` instance. 0.1.1 ----- * Added a `CTYPE` to the Half declaration so that it can be used with `CApiFFI` as an unsigned short. 0.1 --- * Initial release half-0.3.1/LICENSE0000644000000000000000000000235707346545000011632 0ustar0000000000000000Copyright 2014 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. 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. half-0.3.1/README.markdown0000644000000000000000000000123207346545000013315 0ustar0000000000000000half ==== [![Hackage](https://img.shields.io/hackage/v/half.svg)](https://hackage.haskell.org/package/half) [![Build Status](https://github.com/ekmett/half/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/half/actions?query=workflow%3AHaskell-CI) This package supplies half-precision floating point values w/ 1 bit of sign, 5 bits of exponent, 11 bits of mantissa trailing a leading 1 bit with proper underflow. These arise commonly in GPU applications. 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 half-0.3.1/cbits/0000755000000000000000000000000007346545000011722 5ustar0000000000000000half-0.3.1/cbits/half.c0000644000000000000000000000273607346545000013010 0ustar0000000000000000unsigned short hs_floatToHalf (float f) { union { float d; unsigned int i; } u = { f }; int s = (u.i >> 16) & 0x8000; int e = ((u.i >> 23) & 0xff) - 112; int m = u.i & 0x7fffff; if (e <= 0) { if (e < -10) return s; /* underflowed */ /* force leading 1 and round */ m |= 0x800000; int t = 14 - e; int a = (1 << (t - 1)) - 1; int b = (m >> t) & 1; return s | ((m + a + b) >> t); } if (e == 143) { if (m == 0) return s | 0x7c00; /* +/- infinity */ /* NaN, m == 0 forces us to set at least one bit and not become an infinity */ m >>= 13; return s | 0x7c00 | m | (m == 0); } /* round the normalized float */ m = m + 0xfff + ((m >> 13) & 1); /* significand overflow */ if (m & 0x800000) { m = 0; e += 1; } /* exponent overflow */ if (e > 30) return s | 0x7c00; return s | (e << 10) | (m >> 13); } int hs_halfToFloatRep (unsigned short c) { int s = (c >> 15) & 0x001; int e = (c >> 10) & 0x01f; int m = c & 0x3ff; if (e == 0) { if (m == 0) /* +/- 0 */ return s << 31; /* denormalized, renormalize it */ while (!(m & 0x400)) { m <<= 1; e -= 1; } e += 1; m &= ~0x400; } else if (e == 31) return (s << 31) | 0x7f800000 | (m << 13); /* NaN or +/- infinity */ e += 112; m <<= 13; return (s << 31) | (e << 23) | m; } float hs_halfToFloat (unsigned short c) { union { float d; unsigned int i; } u; u.i = hs_halfToFloatRep(c); return u.d; } half-0.3.1/half.cabal0000644000000000000000000000401207346545000012511 0ustar0000000000000000cabal-version: >=1.10 name: half version: 0.3.1 license: BSD3 license-file: LICENSE copyright: Copyright (C) 2014 Edward A. Kmett maintainer: Edward A. Kmett author: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/half bug-reports: http://github.com/ekmett/half/issues synopsis: Half-precision floating-point description: Half-precision floating-point. category: Numeric build-type: Simple extra-source-files: .gitignore README.markdown CHANGELOG.markdown tested-with: GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.3 source-repository head type: git location: git://github.com/ekmett/half.git library default-language: Haskell2010 exposed-modules: Numeric.Half Numeric.Half.Internal hs-source-dirs: src other-extensions: BangPatterns CPP DeriveDataTypeable DeriveGeneric ForeignFunctionInterface ghc-options: -Wall -fwarn-tabs -O2 build-depends: base >=4.5 && <5, binary >=0.5.1.0 && <0.9, deepseq >=1.3.0.0 && <1.5, template-haskell if !impl(ghcjs) c-sources: cbits/half.c if impl(ghc >= 8.0) other-extensions: DeriveLift StandaloneDeriving else other-extensions: TemplateHaskell if impl(ghc >=7.8) other-extensions: PatternSynonyms if impl(ghc <7.6) build-depends: ghc-prim if impl(ghc >=8) ghc-options: -Wno-missing-pattern-synonym-signatures test-suite spec default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test ghc-options: -Wall build-depends: base, binary, bytestring, half, QuickCheck >=2.14.1 && <2.15, test-framework, test-framework-quickcheck2 half-0.3.1/src/Numeric/0000755000000000000000000000000007346545000013007 5ustar0000000000000000half-0.3.1/src/Numeric/Half.hs0000644000000000000000000000213407346545000014215 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : PatternSynonyms -- -- Half-precision floating-point values. These arise commonly in GPU work -- and it is useful to be able to compute them and compute with them on the -- CPU as well. ---------------------------------------------------------------------------- module Numeric.Half ( Half(..) , isZero , fromHalf , toHalf -- * Patterns -- | These are available with GHC-7.8 and later. #if __GLASGOW_HASKELL__ >= 708 , pattern POS_INF , pattern NEG_INF , pattern QNaN , pattern SNaN , pattern HALF_MIN , pattern HALF_NRM_MIN , pattern HALF_MAX , pattern HALF_EPSILON , pattern HALF_DIG , pattern HALF_MIN_10_EXP , pattern HALF_MAX_10_EXP #endif ) where import Numeric.Half.Internal half-0.3.1/src/Numeric/Half/0000755000000000000000000000000007346545000013661 5ustar0000000000000000half-0.3.1/src/Numeric/Half/Internal.hs0000644000000000000000000002551007346545000015774 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ForeignFunctionInterface #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #else {-# LANGUAGE TemplateHaskell #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE PatternSynonyms #-} #endif {-# LANGUAGE Trustworthy #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : PatternSynonyms -- -- Half-precision floating-point values. These arise commonly in GPU work -- and it is useful to be able to compute them and compute with them on the -- CPU as well. ---------------------------------------------------------------------------- module Numeric.Half.Internal ( Half(..) , isZero , fromHalf , toHalf -- * Patterns -- | These are available with GHC-7.8 and later. #if __GLASGOW_HASKELL__ >= 708 , pattern POS_INF , pattern NEG_INF , pattern QNaN , pattern SNaN , pattern HALF_MIN , pattern HALF_NRM_MIN , pattern HALF_MAX , pattern HALF_EPSILON , pattern HALF_DIG , pattern HALF_MIN_10_EXP , pattern HALF_MAX_10_EXP #endif -- * Pure conversions , pure_floatToHalf , pure_halfToFloat ) where import Control.DeepSeq (NFData (..)) import Data.Bits import Data.Function (on) import Data.Int import Data.Typeable import Foreign.C.Types (CUShort (..)) import Foreign.Ptr (castPtr) import Foreign.Storable import GHC.Generics #ifdef WITH_TEMPLATE_HASKELL #endif import Text.Read (Read (..)) import Language.Haskell.TH.Syntax (Lift (..)) #if __GLASGOW_HASKELL__ < 800 import Language.Haskell.TH #endif import Data.Binary (Binary (..)) #ifdef __GHCJS__ toHalf :: Float -> Half toHalf = pure_floatToHalf fromHalf :: Half -> Float fromHalf = pure_halfToFloat #else -- | Convert a 'Float' to a 'Half' with proper rounding, while preserving NaN and dealing appropriately with infinity foreign import ccall unsafe "hs_floatToHalf" toHalf :: Float -> Half -- {-# RULES "toHalf" realToFrac = toHalf #-} -- | Convert a 'Half' to a 'Float' while preserving NaN foreign import ccall unsafe "hs_halfToFloat" fromHalf :: Half -> Float -- {-# RULES "fromHalf" realToFrac = fromHalf #-} #endif newtype #if __GLASGOW_HASKELL__ >= 706 {-# CTYPE "unsigned short" #-} #endif Half = Half { getHalf :: CUShort } deriving (Generic, Typeable) instance NFData Half where #if MIN_VERSION_deepseq(1,4,0) rnf (Half f) = rnf f #else rnf (Half f) = f `seq` () #endif instance Binary Half where put (Half (CUShort w)) = put w get = fmap (Half . CUShort) get instance Storable Half where sizeOf = sizeOf . getHalf alignment = alignment . getHalf peek p = fmap Half (peek (castPtr p)) poke p = poke (castPtr p) . getHalf instance Show Half where showsPrec d h = showsPrec d (fromHalf h) instance Read Half where readPrec = fmap toHalf readPrec instance Eq Half where (==) = (==) `on` fromHalf instance Ord Half where compare = compare `on` fromHalf (<) = (<) `on` fromHalf (<=) = (<=) `on` fromHalf (>) = (>) `on` fromHalf (>=) = (>=) `on` fromHalf instance Real Half where toRational = toRational . fromHalf instance Fractional Half where fromRational = toHalf . fromRational recip = toHalf . recip . fromHalf a / b = toHalf $ fromHalf a / fromHalf b instance RealFrac Half where properFraction a = case properFraction (fromHalf a) of (b, c) -> (b, toHalf c) truncate = truncate . fromHalf round = round . fromHalf ceiling = ceiling . fromHalf floor = floor . fromHalf instance Floating Half where pi = toHalf pi exp = toHalf . exp . fromHalf sqrt = toHalf . sqrt . fromHalf log = toHalf . log . fromHalf a ** b = toHalf $ fromHalf a ** fromHalf b logBase a b = toHalf $ logBase (fromHalf a) (fromHalf b) sin = toHalf . sin . fromHalf tan = toHalf . tan . fromHalf cos = toHalf . cos . fromHalf asin = toHalf . asin . fromHalf atan = toHalf . atan . fromHalf acos = toHalf . acos . fromHalf sinh = toHalf . sinh . fromHalf tanh = toHalf . tanh . fromHalf cosh = toHalf . cosh . fromHalf asinh = toHalf . asinh . fromHalf atanh = toHalf . atanh . fromHalf acosh = toHalf . acosh . fromHalf instance RealFloat Half where floatRadix _ = 2 floatDigits _ = 11 decodeFloat = ieee754_f16_decode isIEEE _ = isIEEE (undefined :: Float) atan2 a b = toHalf $ atan2 (fromHalf a) (fromHalf b) isInfinite (Half h) = unsafeShiftR h 10 .&. 0x1f >= 31 && h .&. 0x3ff == 0 isDenormalized (Half h) = unsafeShiftR h 10 .&. 0x1f == 0 && h .&. 0x3ff /= 0 isNaN (Half h) = unsafeShiftR h 10 .&. 0x1f == 0x1f && h .&. 0x3ff /= 0 isNegativeZero (Half h) = h == 0x8000 floatRange _ = (-13,16) encodeFloat i j = toHalf $ encodeFloat i j exponent = exponent . fromHalf significand = toHalf . significand . fromHalf scaleFloat n = toHalf . scaleFloat n . fromHalf -- | Is this 'Half' equal to 0? isZero :: Half -> Bool isZero (Half h) = h .&. 0x7fff == 0 #if __GLASGOW_HASKELL__ >= 708 -- | Positive infinity pattern POS_INF = Half 0x7c00 -- | Negative infinity pattern NEG_INF = Half 0xfc00 -- | Quiet NaN pattern QNaN = Half 0x7fff -- | Signalling NaN pattern SNaN = Half 0x7dff -- | Smallest positive half pattern HALF_MIN = Half 0x0001 -- 5.96046448e-08 -- | Smallest positive normalized half pattern HALF_NRM_MIN = Half 0x0400 -- 6.10351562e-05 -- | Largest positive half pattern HALF_MAX = Half 0x7bff -- 65504.0 -- | Smallest positive e for which half (1.0 + e) != half (1.0) pattern HALF_EPSILON = Half 0x1400 -- 0.00097656 -- | Number of base 10 digits that can be represented without change pattern HALF_DIG = 2 -- Minimum positive integer such that 10 raised to that power is a normalized half pattern HALF_MIN_10_EXP = -4 -- Maximum positive integer such that 10 raised to that power is a normalized half pattern HALF_MAX_10_EXP = 4 #endif instance Num Half where a * b = toHalf (fromHalf a * fromHalf b) a - b = toHalf (fromHalf a - fromHalf b) a + b = toHalf (fromHalf a + fromHalf b) negate (Half a) = Half (xor 0x8000 a) abs = toHalf . abs . fromHalf signum = toHalf . signum . fromHalf fromInteger a = toHalf (fromInteger a) #if __GLASGOW_HASKELL__ >= 800 instance Lift Half where lift (Half (CUShort w)) = [| Half (CUShort w) |] #if MIN_VERSION_template_haskell(2,16,0) liftTyped (Half (CUShort w)) = [|| Half (CUShort w) ||] #endif #else instance Lift Half where lift (Half (CUShort w)) = appE (conE 'Half) . appE (conE 'CUShort) . litE . integerL . fromIntegral $ w #endif -- Adapted from ghc/rts/StgPrimFloat.c -- ieee754_f16_decode :: Half -> (Integer, Int) ieee754_f16_decode (Half (CUShort i)) = let _HHIGHBIT = 0x0400 _HMSBIT = 0x8000 _HMINEXP = ((_HALF_MIN_EXP) - (_HALF_MANT_DIG) - 1) _HALF_MANT_DIG = floatDigits (undefined::Half) (_HALF_MIN_EXP, _HALF_MAX_EXP) = floatRange (undefined::Half) high1 = fromIntegral i high2 = high1 .&. (_HHIGHBIT - 1) exp1 = ((fromIntegral high1 `unsafeShiftR` 10) .&. 0x1F) + _HMINEXP exp2 = exp1 + 1 (high3, exp3) = if exp1 /= _HMINEXP then (high2 .|. _HHIGHBIT, exp1) else let go (!h, !e) = if h .&. _HHIGHBIT /= 0 then go (h `unsafeShiftL` 1, e-1) else (h, e) in go (high2, exp2) high4 = if fromIntegral i < (0 :: Int16) then -high3 else high3 in if high1 .&. complement _HMSBIT == 0 then (0,0) else (high4, exp3) -- | Naive pure-Haskell implementation of 'toHalf'. -- pure_floatToHalf :: Float -> Half pure_floatToHalf = Half . pure_floatToHalf' pure_floatToHalf' :: Float -> CUShort pure_floatToHalf' x | isInfinite x = if x < 0 then 0xfc00 else 0x7c00 pure_floatToHalf' x | isNaN x = 0xfe00 -- for some reason, comparing with 0 and then deciding sign fails with GHC-7.8 pure_floatToHalf' x | isNegativeZero x = 0x8000 pure_floatToHalf' 0 = 0 pure_floatToHalf' x = let (m, n) = decodeFloat x -- sign bit s = if signum m < 0 then 0x8000 else 0 m1 = fromIntegral $ abs m :: Int -- bit len of m1, here m1 /= 0 len = 1 + snd (foldl (\(acc, res) y -> if acc .&. y == 0 then (acc, 2*res) else (acc .&. y, 2*res + 1)) (m1, 0) [ 0xffff0000, 0xff00ff00ff00, 0xf0f0f0f0 , 0xcccccccc, 0xaaaaaaaa] ) -- scale to at least 12bit (len', m', n') = if len > 11 then (len, m1, n) else (12, shiftL m1 (11 - len), n - (11 - len)) e = n' + len' - 1 in if e > 15 then fromIntegral (s .|. 0x7c00) else if e >= -14 then let t' = len' - 11 m'' = m' + (2 ^ (t' - 1) - 1) + (shiftR m' t' .&. 1) len'' = if testBit m'' len then len' + 1 else len' t'' = len'' - 11 e'' = n' + len'' - 1 res = (shiftR m'' t'' .&. 0x3ff) .|. shiftL ((e'' + 15) .&. 0x1f) 10 .|. s in if e'' > 15 then fromIntegral (s .|. 0x7c00) else fromIntegral res -- subnormal else if e >= -25 then let t = -n' + 1 -11 - 14 m'' = m' + (2 ^ (t - 1) - 1) + (shiftR m' t .&. 1) res = shiftR m'' t .|. s in if e == -15 && testBit m'' (10 + t) then fromIntegral $ (shiftR m'' t .&. 0x3ff) .|. 0x400 .|. s else fromIntegral res else fromIntegral s -- | Naive pure-Haskell implementation of 'fromHalf'. pure_halfToFloat :: Half -> Float pure_halfToFloat = pure_halfToFloat' . getHalf pure_halfToFloat' :: CUShort -> Float pure_halfToFloat' 0xfc00 = -1/0 pure_halfToFloat' 0x7c00 = 1/0 pure_halfToFloat' 0x0000 = 0 pure_halfToFloat' 0x8000 = -0 pure_halfToFloat' x | (x .&. 0x7c00 == 0x7c00) && (x .&. 0x3ff /= 0) = 0/0 pure_halfToFloat' x = let s = if x .&. 0x8000 /= 0 then -1 else 1 e = fromIntegral (shiftR x 10) .&. 0x1f :: Int m = x .&. 0x3ff (a, b) = if e > 0 then (e - 15 - 10, m .|. 0x400) else (-15 - 10 + 1, m) in encodeFloat (s * fromIntegral b) a half-0.3.1/test/0000755000000000000000000000000007346545000011575 5ustar0000000000000000half-0.3.1/test/Spec.hs0000644000000000000000000001321607346545000013026 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE PatternSynonyms #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} import Numeric.Half import Numeric.Half.Internal import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary (..), Property, counterexample, (===), (==>), property, once) import Foreign.C.Types import Data.List (sort) import qualified Data.Binary as Binary import qualified Data.ByteString.Lazy as LBS instance Arbitrary Half where arbitrary = fmap Half arbitrary qnan :: Half qnan = Half 0x7fff snan :: Half snan = Half 0x7dff pos_inf :: Half pos_inf = Half 0x7c00 neg_inf :: Half neg_inf = Half 0xfc00 nans :: [Half] nans = [qnan, snan] -- test QNaN, SNaN patterns main :: IO () main = defaultMain [ testGroup "Half Ord instance" [ testProperty "(>=) is the opposite of (<) except for NaN" $ \x y -> ((x >= y) /= (x < y)) || isNaN x || isNaN (y :: Half) , testProperty "returns False for NaN > NaN" $ or [a > b | a <- nans, b <- nans] === False , testProperty "returns False for NaN < NaN" $ or [a < b | a <- nans, b <- nans] === False ] , testGroup "Round trip" [ testProperty "should round trip properly" $ \w -> if isNaN w then property $ isNaN $ toHalf (fromHalf w) -- nans go to nans else toHalf (fromHalf w) === w -- everything goes to itself , testProperty "idempotence 1" $ \w -> not (isNaN w) ==> fromHalf (toHalf $ fromHalf w) === fromHalf w , testProperty "idempotence 2" $ \w -> toHalf (fromHalf $ toHalf w) === toHalf w ] , testGroup "isInfinite" [ testProperty "should be equivalent to \\x -> x == POS_INF || x == NEG_INF" $ \x -> isInfinite x === (x == pos_inf || x == neg_inf) , testProperty "should return True on POS_INF" $ isInfinite pos_inf === True , testProperty "should return True on NEG_INF" $ isInfinite neg_inf === True , testProperty "should return false on QNaN" $ isInfinite qnan === False , testProperty "should return false on SNaN" $ isInfinite snan === False ] #if __GLASGOW_HASKELL__ >= 708 , testGroup "Patterns" [ testProperty "QNaN" $ case qnan of QNaN -> True _ -> False , testProperty "SNaN" $ case snan of SNaN -> True _ -> False , testProperty "POS_INF" $ case pos_inf of POS_INF -> True _ -> False , testProperty "NEG_INF" $ case neg_inf of NEG_INF -> True _ -> False ] #endif -- With GHCJS these tests are trivially true. , testGroup "Native fromHalf against C version" [ testProperty "for full CUShort range, both version of fromHalf should return same Float" $ once prop_from_half_list ] , testGroup "Native toHalf against C version" [ testProperty "for selected range of Float, both version of toHalf should return same Half" $ once prop_to_half_list ] , testGroup "Binary" [ testProperty "Binary round trip a" prop_binary_roundtrip_a , testProperty "Binary round trip b" prop_binary_roundtrip_b -- big endian , testProperty "Binary encoding example" $ Binary.encode neg_inf === LBS.pack [252, 0] ] ] ------------------------------------------------------------------------------- -- Binary ------------------------------------------------------------------------------- prop_binary_roundtrip_a :: Half -> Property prop_binary_roundtrip_a h = getHalf h === getHalf (Binary.decode (Binary.encode h)) prop_binary_roundtrip_b :: Half -> Property prop_binary_roundtrip_b h = not (isNaN h) ==> h === Binary.decode (Binary.encode h) ------------------------------------------------------------------------------- -- Pure conversions ------------------------------------------------------------------------------- -- test native haskell implementation of toHalf & fromHalf against with C version prop_from_half :: CUShort -> Bool prop_from_half i = let ref = fromHalf $ Half i imp = pure_halfToFloat $ Half i in (isNaN ref && isNaN imp) || (ref == imp) newtype U16List = U16List [CUShort] deriving (Eq, Ord, Show) instance Arbitrary U16List where arbitrary = return (U16List [0 .. 65535]) shrink (U16List (_ : [])) = [] shrink (U16List x) = let p = length x `div` 2 in [U16List $ take p x, U16List $ drop p x] prop_from_half_list :: U16List -> Bool prop_from_half_list (U16List l) = all id $ map prop_from_half l prop_to_half :: Float -> Bool prop_to_half i = let ref = getHalf $ toHalf i imp = getHalf $ pure_floatToHalf i in ref == imp -- cover all range of Half(not Float) list1 :: [Float] list1 = let r1 = filter (not . isNaN) $ map (fromHalf . Half) [0 .. 65535] r2 = sort $ filter (not . isInfinite) $ filter (>= 0) r1 r3 = r2 ++ [last r2 + 2 ** 11] r4 = zipWith (\a b -> let d = (b - a) / 4 in [a, a + d, a + d * 2, a + d * 3]) r3 (tail r3) r5 = concat r4 ++ [last r3] in r5 list2 :: [Float] list2 = map negate list1 list3 :: [Float] list3 = [1/0, -1/0, 0, -0, 0/0] newtype FloatList = FloatList [Float] deriving (Eq, Ord, Show) instance Arbitrary FloatList where arbitrary = return (FloatList $ list1 ++ list2 ++ list3) shrink (FloatList (_ : [])) = [] shrink (FloatList x) = let p = length x `div` 2 in [FloatList $ take p x, FloatList $ drop p x] prop_to_half_list :: FloatList -> Property prop_to_half_list (FloatList l) = counterexample (show [ (getHalf (toHalf f), getHalf (pure_floatToHalf f), f, isNegativeZero f) | f <- take 3 l]) $ all id $ map prop_to_half l