Initial commit

bundled/Basement/Floating.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+module Basement.Floating
+    ( integerToDouble
+    , naturalToDouble
+    , doubleExponant
+    , integerToFloat
+    , naturalToFloat
+    , wordToFloat
+    , floatToWord
+    , wordToDouble
+    , doubleToWord
+    ) where
+
+import           GHC.Types
+import           GHC.Prim
+import           GHC.Float
+import           GHC.Word
+import           GHC.ST
+import           Basement.Compat.Base
+import           Basement.Compat.Natural
+import qualified Prelude (fromInteger, toInteger, (^^))
+
+integerToDouble :: Integer -> Double
+integerToDouble = Prelude.fromInteger
+-- this depends on integer-gmp
+--integerToDouble i = D# (doubleFromInteger i)
+
+naturalToDouble :: Natural -> Double
+naturalToDouble = integerToDouble . Prelude.toInteger
+
+doubleExponant :: Double -> Int -> Double
+doubleExponant = (Prelude.^^)
+
+integerToFloat :: Integer -> Float
+integerToFloat = Prelude.fromInteger
+
+naturalToFloat :: Natural -> Float
+naturalToFloat = integerToFloat . Prelude.toInteger
+
+wordToFloat :: Word32 -> Float
+wordToFloat (W32# x) = runST $ ST $ \s1 ->
+    case newByteArray# 4# s1             of { (# s2, mbarr #) ->
+    case writeWord32Array# mbarr 0# x s2 of { s3              ->
+    case readFloatArray# mbarr 0# s3     of { (# s4, f #)     ->
+        (# s4, F# f #) }}}
+{-# INLINE wordToFloat #-}
+
+floatToWord :: Float -> Word32
+floatToWord (F# x) = runST $ ST $ \s1 ->
+    case newByteArray# 4# s1            of { (# s2, mbarr #) ->
+    case writeFloatArray# mbarr 0# x s2 of { s3              ->
+    case readWord32Array# mbarr 0# s3   of { (# s4, w #)     ->
+        (# s4, W32# w #) }}}
+{-# INLINE floatToWord #-}
+
+wordToDouble :: Word64 -> Double
+wordToDouble (W64# x) = runST $ ST $ \s1 ->
+    case newByteArray# 8# s1             of { (# s2, mbarr #) ->
+    case writeWord64Array# mbarr 0# x s2 of { s3              ->
+    case readDoubleArray# mbarr 0# s3    of { (# s4, f #)     ->
+        (# s4, D# f #) }}}
+{-# INLINE wordToDouble #-}
+
+doubleToWord :: Double -> Word64
+doubleToWord (D# x) = runST $ ST $ \s1 ->
+    case newByteArray# 8# s1             of { (# s2, mbarr #) ->
+    case writeDoubleArray# mbarr 0# x s2 of { s3              ->
+    case readWord64Array# mbarr 0# s3    of { (# s4, w #)     ->
+        (# s4, W64# w #) }}}
+{-# INLINE doubleToWord #-}