Merge pull request #30 from haskell-compat/almost-all-your-base

More functions from base-4.7.0.0 and base-4.8.0.0

Author: Ryan Scott

CHANGES.markdown

@@ -1,3 +1,13 @@
+## Changes in next
+ - Backport `bitDefault`, `testBitDefault`, and `popCountDefault` in
+   `Data.Bits.Compat` to all versions of `base`
+   - Backport `toIntegralSized` to `base-4.7`
+ - Backport `nub` and `nubBy` (as well as `union` and `unionBy`, which are
+   implemented in terms of them) to fix logic error in `Data.List.Compat`
+ - Backport `byteSwap16`, `byteSwap32`, and `byteSwap64` to `Data.Word.Compat`
+ - Backport `fillBytes` in `Foreign.Marshal.Utils.Compat`
+ - Backport `showFFloatAlt` and `showGFloatAlt` to `Numeric.Compat`
+
 ## Changes in 0.8.1.1
  - Fixed Windows build
 

README.markdown

@@ -89,6 +89,8 @@ So far the following is covered.
  * `Text.Read.Compat.readMaybe`
  * `Text.Read.Compat.readEither`
  * `Data.Monoid.Compat.<>`
+ * Added `bitDefault`, `testBitDefault`, and `popCountDefault` to `Data.Bits.Compat`
+ * Added `toIntegralSized` to `Data.Bits.Compat` (if using `base-4.7`)
  * Added `bool` function to `Data.Bool.Compat`
  * Added `isLeft` and `isRight` to `Data.Either.Compat`
  * Added `withMVarMasked` function to `Control.Concurrent.MVar.Compat`
@@ -97,11 +99,15 @@ So far the following is covered.
  * `(&)` function to `Data.Function.Compat`
  * `($>)` and `void` functions to `Data.Functor.Compat`
  * `dropWhileEnd`, `isSubsequenceOf`, `sortOn`, and `uncons` functions to `Data.List.Compat`
+ * Correct versions of `nub`, `nubBy`, `union`, and `unionBy` to `Data.List.Compat`
  * `makeVersion` function to `Data.Version.Compat`
  * `traceId`, `traceShowId`, `traceM`, and `traceShowM` functions to `Debug.Trace.Compat`
+ * `byteSwap16`, `byteSwap32`, and `byteSwap64` to `Data.Word.Compat`
  * `calloc` and `callocBytes` functions to `Foreign.Marshal.Alloc.Compat`
  * `callocArray` and `callocArray0` functions to `Foreign.Marshal.Array.Compat`
+ * `fillBytes` to `Foreign.Marshal.Utils.Compat`
  * Added `Data.List.Compat.scanl'`
+ * `showFFloatAlt` and `showGFloatAlt` to `Numeric.Compat`
  * `lookupEnv`, `setEnv` and `unsetEnv` to `System.Environment.Compat`
 
 ## Supported versions of GHC/base

base-compat.cabal

@@ -49,6 +49,7 @@ library
   exposed-modules:
       Control.Concurrent.MVar.Compat
       Control.Monad.Compat
+      Data.Bits.Compat
       Data.Bool.Compat
       Data.Either.Compat
       Data.Foldable.Compat
@@ -57,11 +58,14 @@ library
       Data.List.Compat
       Data.Monoid.Compat
       Data.Version.Compat
+      Data.Word.Compat
       Debug.Trace.Compat
       Foreign.Compat
       Foreign.Marshal.Alloc.Compat
       Foreign.Marshal.Array.Compat
       Foreign.Marshal.Compat
+      Foreign.Marshal.Utils.Compat
+      Numeric.Compat
       Prelude.Compat
       System.Environment.Compat
       System.Exit.Compat

src/Data/Bits/Compat.hs

@@ -0,0 +1,126 @@
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+{-# LANGUAGE BangPatterns, PatternGuards #-}
+module Data.Bits.Compat (
+  module Base
+, bitDefault
+, testBitDefault
+, popCountDefault
+#if MIN_VERSION_base(4,7,0)
+, toIntegralSized
+#endif
+) where
+
+import Data.Bits as Base
+
+#if !(MIN_VERSION_base(4,8,0))
+import Prelude
+#endif
+
+#if !(MIN_VERSION_base(4,6,0))
+-- | Default implementation for 'bit'.
+--
+-- Note that: @bitDefault i = 1 `shiftL` i@
+--
+-- /Since: 4.6.0.0/
+bitDefault :: (Bits a, Num a) => Int -> a
+bitDefault = \i -> 1 `shiftL` i
+{-# INLINE bitDefault #-}
+
+-- | Default implementation for 'testBit'.
+--
+-- Note that: @testBitDefault x i = (x .&. bit i) /= 0@
+--
+-- /Since: 4.6.0.0/
+testBitDefault ::  (Bits a, Num a) => a -> Int -> Bool
+testBitDefault = \x i -> (x .&. bit i) /= 0
+{-# INLINE testBitDefault #-}
+
+-- | Default implementation for 'popCount'.
+--
+-- This implementation is intentionally naive. Instances are expected to provide
+-- an optimized implementation for their size.
+--
+-- /Since: 4.6.0.0/
+popCountDefault :: (Bits a, Num a) => a -> Int
+popCountDefault = go 0
+ where
+   go !c 0 = c
+   go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant
+{-# INLINABLE popCountDefault #-}
+#endif
+
+#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0))
+-- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using
+-- the size of the types as measured by 'Bits' methods.
+--
+-- A simpler version of this function is:
+--
+-- > toIntegral :: (Integral a, Integral b) => a -> Maybe b
+-- > toIntegral x
+-- >   | toInteger x == y = Just (fromInteger y)
+-- >   | otherwise        = Nothing
+-- >   where
+-- >     y = toInteger x
+--
+-- This version requires going through 'Integer', which can be inefficient.
+-- However, @toIntegralSized@ is optimized to allow GHC to statically determine
+-- the relative type sizes (as measured by 'bitSizeMaybe' and 'isSigned') and
+-- avoid going through 'Integer' for many types. (The implementation uses
+-- 'fromIntegral', which is itself optimized with rules for @base@ types but may
+-- go through 'Integer' for some type pairs.)
+--
+-- /Since: 4.8.0.0/
+
+toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b
+toIntegralSized x                 -- See Note [toIntegralSized optimization]
+  | maybe True (<= x) yMinBound
+  , maybe True (x <=) yMaxBound = Just y
+  | otherwise                   = Nothing
+  where
+    y = fromIntegral x
+
+    xWidth = bitSizeMaybe x
+    yWidth = bitSizeMaybe y
+
+    yMinBound
+      | isBitSubType x y = Nothing
+      | isSigned x, not (isSigned y) = Just 0
+      | isSigned x, isSigned y
+      , Just yW <- yWidth = Just (negate $ bit (yW-1)) -- Assumes sub-type
+      | otherwise = Nothing
+
+    yMaxBound
+      | isBitSubType x y = Nothing
+      | isSigned x, not (isSigned y)
+      , Just xW <- xWidth, Just yW <- yWidth
+      , xW <= yW+1 = Nothing -- Max bound beyond a's domain
+      | Just yW <- yWidth = if isSigned y
+                            then Just (bit (yW-1)-1)
+                            else Just (bit yW-1)
+      | otherwise = Nothing
+{-# INLINEABLE toIntegralSized #-}
+
+-- | 'True' if the size of @a@ is @<=@ the size of @b@, where size is measured
+-- by 'bitSizeMaybe' and 'isSigned'.
+isBitSubType :: (Bits a, Bits b) => a -> b -> Bool
+isBitSubType x y
+  -- Reflexive
+  | xWidth == yWidth, xSigned == ySigned = True
+
+  -- Every integer is a subset of 'Integer'
+  | ySigned, Nothing == yWidth                  = True
+  | not xSigned, not ySigned, Nothing == yWidth = True
+
+  -- Sub-type relations between fixed-with types
+  | xSigned == ySigned,   Just xW <- xWidth, Just yW <- yWidth = xW <= yW
+  | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <  yW
+
+  | otherwise = False
+  where
+    xWidth  = bitSizeMaybe x
+    xSigned = isSigned     x
+
+    yWidth  = bitSizeMaybe y
+    ySigned = isSigned     y
+{-# INLINE isBitSubType #-}
+#endif

src/Data/List/Compat.hs

@@ -21,10 +21,14 @@ module Data.List.Compat (
 , minimum
 , minimumBy
 , notElem
+, nub
+, nubBy
 , null
 , or
 , product
 , sum
+, union
+, unionBy
 , mapAccumL
 , mapAccumR
 
@@ -61,10 +65,14 @@ import Data.List as Base hiding (
   , minimum
   , minimumBy
   , notElem
+  , nub
+  , nubBy
   , null
   , or
   , product
   , sum
+  , union
+  , unionBy
   , mapAccumL
   , mapAccumR
   )
@@ -141,4 +149,54 @@ scanl' = scanlGo'
     scanlGo' f !q ls    = q : (case ls of
                             []   -> []
                             x:xs -> scanlGo' f (f q x) xs)
+
+-- | /O(n^2)/. The 'nub' function removes duplicate elements from a list.
+-- In particular, it keeps only the first occurrence of each element.
+-- (The name 'nub' means \`essence\'.)
+-- It is a special case of 'nubBy', which allows the programmer to supply
+-- their own equality test.
+nub                     :: (Eq a) => [a] -> [a]
+nub                     =  nubBy (==)
+
+
+-- | The 'nubBy' function behaves just like 'nub', except it uses a
+-- user-supplied equality predicate instead of the overloaded '=='
+-- function.
+nubBy                   :: (a -> a -> Bool) -> [a] -> [a]
+-- stolen from HBC
+nubBy eq l              = nubBy' l []
+  where
+    nubBy' [] _         = []
+    nubBy' (y:ys) xs
+       | elem_by eq y xs = nubBy' ys xs
+       | otherwise       = y : nubBy' ys (y:xs)
+
+-- Not exported:
+-- Note that we keep the call to `eq` with arguments in the
+-- same order as in the reference (prelude) implementation,
+-- and that this order is different from how `elem` calls (==).
+-- See #2528, #3280 and #7913.
+-- 'xs' is the list of things we've seen so far,
+-- 'y' is the potential new element
+elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool
+elem_by _  _ []         =  False
+elem_by eq y (x:xs)     =  x `eq` y || elem_by eq y xs
+
+-- | The 'union' function returns the list union of the two lists.
+-- For example,
+--
+-- > "dog" `union` "cow" == "dogcw"
+--
+-- Duplicates, and elements of the first list, are removed from the
+-- the second list, but if the first list contains duplicates, so will
+-- the result.
+-- It is a special case of 'unionBy', which allows the programmer to supply
+-- their own equality test.
+
+union                   :: (Eq a) => [a] -> [a] -> [a]
+union                   = unionBy (==)
+
+-- | The 'unionBy' function is the non-overloaded version of 'union'.
+unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
 #endif

src/Data/Word/Compat.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+module Data.Word.Compat (
+  module Base
+, byteSwap16
+, byteSwap32
+, byteSwap64
+) where
+
+import Data.Word as Base
+
+#if !(MIN_VERSION_base(4,7,0))
+import Data.Bits
+
+-- | Swap bytes in 'Word16'.
+--
+-- /Since: 4.7.0.0/
+byteSwap16 :: Word16 -> Word16
+byteSwap16 w = ((w `shiftR` 8) .&. 0x00ff)
+           .|. ((w .&. 0x00ff) `shiftL` 8)
+
+-- | Reverse order of bytes in 'Word32'.
+--
+-- /Since: 4.7.0.0/
+byteSwap32 :: Word32 -> Word32
+byteSwap32 w = ((w .&. 0xff000000) `shiftR` 24)
+           .|. ((w .&. 0x00ff0000) `shiftR` 8)
+           .|. ((w .&. 0x0000ff00) `shiftL` 8)
+           .|. ((w .&. 0x000000ff) `shiftL` 24)
+
+-- | Reverse order of bytes in 'Word64'.
+--
+-- /Since: 4.7.0.0/
+byteSwap64 :: Word64 -> Word64
+byteSwap64 w = ((w .&. 0xff00000000000000) `shiftR` 56)
+           .|. ((w .&. 0x00ff000000000000) `shiftR` 40)
+           .|. ((w .&. 0x0000ff0000000000) `shiftR` 24)
+           .|. ((w .&. 0x000000ff00000000) `shiftR` 8)
+           .|. ((w .&. 0x00000000ff000000) `shiftL` 8)
+           .|. ((w .&. 0x0000000000ff0000) `shiftL` 24)
+           .|. ((w .&. 0x000000000000ff00) `shiftL` 40)
+           .|. ((w .&. 0x00000000000000ff) `shiftL` 56)
+#endif

src/Foreign/Marshal/Compat.hs

@@ -3,8 +3,10 @@ module Foreign.Marshal.Compat (
   module Base
 , module Alloc
 , module Array
+, module Utils
 ) where
 import Foreign.Marshal as Base
 
 import Foreign.Marshal.Alloc.Compat as Alloc
 import Foreign.Marshal.Array.Compat as Array
+import Foreign.Marshal.Utils.Compat as Utils

src/Foreign/Marshal/Utils/Compat.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Foreign.Marshal.Utils.Compat (
+  module Base
+, fillBytes
+) where
+
+import Foreign.Marshal.Utils as Base
+
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Word (Word8)
+import Foreign.C.Types
+import Foreign.Ptr
+import Prelude
+
+-- |Fill a given number of bytes in memory area with a byte value.
+--
+-- /Since: 4.8.0.0/
+fillBytes :: Ptr a -> Word8 -> Int -> IO ()
+fillBytes dest char size = do
+  _ <- memset dest (fromIntegral char) (fromIntegral size)
+  return ()
+
+foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)
+#endif