diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,67 +1,77 @@ -## Changes in 0.8.1.1 - - Fixed Windows build - -## Changes in 0.8.1 - - Implement `setEnv` and `unsetEnv` in `System.Environment.Compat` (which were - ported from the `setenv` package). As a result, `base-compat` now depends - on `unix` on POSIX-like operating systems. - - Drop GHC 6.12 (and `base-4.2.0.0`) compatibility - -## Changes in 0.8.0.1 - - Retrospective version bump updating the changelog to reflect the changes - made in 0.8.0 - -## Changes 0.8.0 - - All orphan instances were split off into a separate package, - [`base-orphans`](https://github.com/haskell-compat/base-orphans) - - `base-compat` no longer redefines the data types `Down` and `Alt`. See - [here](https://github.com/haskell-compat/base-compat/issues/17) for - the discussion that led to this change. - - Update `Control.Monad.Compat` for `base-4.8.0.0` - - Update `Data.List.Compat` for `base-4.8.0.0` - - Update `Data.Foldable.Compat` for `base-4.8.0.0` - -## Changes in 0.7.1 - - Backported `Alt` to `Data.Monoid.Compat` - - Backported `Down` to `Data.Ord.Compat` - -## Changes in 0.7.0 - - Add functions and orphan instances introduced by changes to - `base-4.7.0.0` and `base-4.8.0.0` - -## Changes in 0.6.0 - - Update `Prelude.Compat` for `base-4.8.0.0` and AMP - -## Changes in 0.5.0 - - Remove Control.Exception.Base.Compat and GHC.Exception.Compat - - Add System.Exit.Compat.die - - Compatibility with base-4.7.1 - -## Changes in 0.4.1 - - Add `setEnv` and `unsetEnv` to `System.Environment.Compat` - -## Changes in 0.4.0 - - Major refactoring: base-compat no longer aims to replace all base, - only new code is included in module .Compat - - Removed stubbed modules - - Removed generation scripts - -## Changes in 0.3 - - Added functions from Base 4.7 (bool, isLeft, isRight) - - Added instances from Base 4.7 (Either Foldable, Traversable,...) - -## Changes in 0.2.1 - - Fix build on windows - -## Changes in 0.2.0 - - Re-export everything from base - - provides access to `VERSION_base` and `MIN_VERSION_base` CPP macros (with - `#include "base-compat.h"`) - - Do not re-export `System.IO.Error.catch` from `Prelude` for `base` < 4.6.0 - - Add `Eq`/`Ord` instance for `ErrorCall` - - Remove `GHC.IOBase`, `GHC.Handle`, `Control.Concurrent.QSem`, - `Control.Concurrent.QSemN`, `Control.Concurrent.SampleVar`, `Data.HashTable` - -## Changes in 0.1.0 - - Remove getExecutablePath, it did not work with GHC < 7.2 (patches welcome!) - - Add `<>` +## Changes in 0.8.2 + - 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 + +## Changes in 0.8.1 + - Implement `setEnv` and `unsetEnv` in `System.Environment.Compat` (which were + ported from the `setenv` package). As a result, `base-compat` now depends + on `unix` on POSIX-like operating systems. + - Drop GHC 6.12 (and `base-4.2.0.0`) compatibility + +## Changes in 0.8.0.1 + - Retrospective version bump updating the changelog to reflect the changes + made in 0.8.0 + +## Changes 0.8.0 + - All orphan instances were split off into a separate package, + [`base-orphans`](https://github.com/haskell-compat/base-orphans) + - `base-compat` no longer redefines the data types `Down` and `Alt`. See + [here](https://github.com/haskell-compat/base-compat/issues/17) for + the discussion that led to this change. + - Update `Control.Monad.Compat` for `base-4.8.0.0` + - Update `Data.List.Compat` for `base-4.8.0.0` + - Update `Data.Foldable.Compat` for `base-4.8.0.0` + +## Changes in 0.7.1 + - Backported `Alt` to `Data.Monoid.Compat` + - Backported `Down` to `Data.Ord.Compat` + +## Changes in 0.7.0 + - Add functions and orphan instances introduced by changes to + `base-4.7.0.0` and `base-4.8.0.0` + +## Changes in 0.6.0 + - Update `Prelude.Compat` for `base-4.8.0.0` and AMP + +## Changes in 0.5.0 + - Remove Control.Exception.Base.Compat and GHC.Exception.Compat + - Add System.Exit.Compat.die + - Compatibility with base-4.7.1 + +## Changes in 0.4.1 + - Add `setEnv` and `unsetEnv` to `System.Environment.Compat` + +## Changes in 0.4.0 + - Major refactoring: base-compat no longer aims to replace all base, + only new code is included in module .Compat + - Removed stubbed modules + - Removed generation scripts + +## Changes in 0.3 + - Added functions from Base 4.7 (bool, isLeft, isRight) + - Added instances from Base 4.7 (Either Foldable, Traversable,...) + +## Changes in 0.2.1 + - Fix build on windows + +## Changes in 0.2.0 + - Re-export everything from base + - provides access to `VERSION_base` and `MIN_VERSION_base` CPP macros (with + `#include "base-compat.h"`) + - Do not re-export `System.IO.Error.catch` from `Prelude` for `base` < 4.6.0 + - Add `Eq`/`Ord` instance for `ErrorCall` + - Remove `GHC.IOBase`, `GHC.Handle`, `Control.Concurrent.QSem`, + `Control.Concurrent.QSemN`, `Control.Concurrent.SampleVar`, `Data.HashTable` + +## Changes in 0.1.0 + - Remove getExecutablePath, it did not work with GHC < 7.2 (patches welcome!) + - Add `<>` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,19 +1,19 @@ -Copyright (c) 2012-2015 Simon Hengel and Ryan Scott - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. +Copyright (c) 2012-2015 Simon Hengel and Ryan Scott + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,138 +1,144 @@ -# A compatibility layer for `base` [![Hackage version](https://img.shields.io/hackage/v/base-compat.svg?style=flat)](http://hackage.haskell.org/package/base-compat) [![Build Status](https://img.shields.io/travis/haskell-compat/base-compat.svg?style=flat)](https://travis-ci.org/haskell-compat/base-compat) -## Scope - -The scope of `base-compat` is to provide functions available in later versions -of base to a wider (older) range of compilers. - -In addition, successful library proposals that have been accepted to be part of -upcoming versions of `base` are also included. This package is not intended to -replace `base`, but to complement it. - -Note that `base-compat` does not add any orphan instances. There is a separate -package [`base-orphans`](https://github.com/haskell-compat/base-orphans) for -that. - -## Basic usage - -In your cabal file, you should have something like this: - -``` - build-depends: base >= 4.3 - , base-compat >= 0.8.0 -``` - -Then, lets say you want to use the `isRight` function introduced with -`base-4.7.0.0`. Replace: - -``` -import Data.Either -``` - -with - -``` -import Data.Either.Compat -``` - -_Note (1)_: There is no need to import both unqualified. The `.Compat` modules -re-exports the original module. - -_Note (2)_: If a given module `.Compat` version is not defined, that either -means that: - -* The module has not changed in recent base versions, thus no `.Compat` is - needed. -* The module has changed, but the changes depend on newer versions of GHC, and - thus are not portable. -* The module has changed, but those changes have not yet been merged in - `base-compat`: patches are welcomed! - -## Using `Prelude.Compat` - -If you want to use `Prelude.Compat` (which provides all the -AMP/Traversable/Foldable changes from `base-4.8.0.0`), it's best to hide -`Prelude`, e.g.: - - import Prelude () - import Prelude.Compat - - main :: IO () - main = mapM_ print (Just 23) - -Alternatively, you can use the `NoImplicitPrelude` language extension: - - {-# LANGUAGE NoImplicitPrelude #-} - import Prelude.Compat - - main :: IO () - main = mapM_ print (Just 23) - -Note that we use - - mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () - -from `Data.Foldable` here, which is only exposed from `Prelude` since -`base-4.8.0.0`. - -Using this approach allows you to write code that works seamlessly with all -versions of GHC that are supported by `base-compat`. - -## What is covered -So far the following is covered. - -### For compatibility with the latest released version of `base` - - * `Prelude.Compat` incorporates the AMP/Foldable/Traversable changes and - exposes the same interface as `Prelude` from `base-4.8.0.0` - * `System.IO.Error.catch` is not re-exported from `Prelude.Compat` for older - versions of `base` - * `Text.Read.Compat.readMaybe` - * `Text.Read.Compat.readEither` - * `Data.Monoid.Compat.<>` - * Added `bool` function to `Data.Bool.Compat` - * Added `isLeft` and `isRight` to `Data.Either.Compat` - * Added `withMVarMasked` function to `Control.Concurrent.MVar.Compat` - * Added `(<$!>)` function to `Control.Monad.Compat` - * Added `($>)` and `void` functions to `Data.Functor.Compat` - * `(&)` function to `Data.Function.Compat` - * `($>)` and `void` functions to `Data.Functor.Compat` - * `dropWhileEnd`, `isSubsequenceOf`, `sortOn`, and `uncons` functions to `Data.List.Compat` - * `makeVersion` function to `Data.Version.Compat` - * `traceId`, `traceShowId`, `traceM`, and `traceShowM` functions to `Debug.Trace.Compat` - * `calloc` and `callocBytes` functions to `Foreign.Marshal.Alloc.Compat` - * `callocArray` and `callocArray0` functions to `Foreign.Marshal.Array.Compat` - * Added `Data.List.Compat.scanl'` - * `lookupEnv`, `setEnv` and `unsetEnv` to `System.Environment.Compat` - -## Supported versions of GHC/base - - * `ghc-7.10.1` / `base-4.8.0.0` - * `ghc-7.8.4` / `base-4.7.0.2` - * `ghc-7.8.3` / `base-4.7.0.1` - * `ghc-7.8.2` / `base-4.7.0.0` - * `ghc-7.8.1` / `base-4.7.0.0` - * `ghc-7.6.3` / `base-4.6.0.1` - * `ghc-7.6.2` / `base-4.6.0.1` - * `ghc-7.6.1` / `base-4.6.0.0` - * `ghc-7.4.2` / `base-4.5.1.0` - * `ghc-7.4.1` / `base-4.5.0.0` - * `ghc-7.2.2` / `base-4.4.1.0` - * `ghc-7.2.1` / `base-4.4.0.0` - * `ghc-7.0.4` / `base-4.3.1.0` - * `ghc-7.0.3` / `base-4.3.1.0` - * `ghc-7.0.2` / `base-4.3.1.0` - * `ghc-7.0.1` / `base-4.3.0.0` - -Patches are welcome; add tests for new code! - -## Development - -For `Prelude.Compat` there is an `Prelude.index` file that was generated from -the output of - - ghc --show-iface Prelude.hi - -To verify that `Prelude.Compat` matches the specification given in -`Prelude.types` run: - - ./check-Prelude.sh +# A compatibility layer for `base` [![Hackage version](https://img.shields.io/hackage/v/base-compat.svg?style=flat)](http://hackage.haskell.org/package/base-compat) [![Build Status](https://img.shields.io/travis/haskell-compat/base-compat.svg?style=flat)](https://travis-ci.org/haskell-compat/base-compat) +## Scope + +The scope of `base-compat` is to provide functions available in later versions +of base to a wider (older) range of compilers. + +In addition, successful library proposals that have been accepted to be part of +upcoming versions of `base` are also included. This package is not intended to +replace `base`, but to complement it. + +Note that `base-compat` does not add any orphan instances. There is a separate +package [`base-orphans`](https://github.com/haskell-compat/base-orphans) for +that. + +## Basic usage + +In your cabal file, you should have something like this: + +``` + build-depends: base >= 4.3 + , base-compat >= 0.8.0 +``` + +Then, lets say you want to use the `isRight` function introduced with +`base-4.7.0.0`. Replace: + +``` +import Data.Either +``` + +with + +``` +import Data.Either.Compat +``` + +_Note (1)_: There is no need to import both unqualified. The `.Compat` modules +re-exports the original module. + +_Note (2)_: If a given module `.Compat` version is not defined, that either +means that: + +* The module has not changed in recent base versions, thus no `.Compat` is + needed. +* The module has changed, but the changes depend on newer versions of GHC, and + thus are not portable. +* The module has changed, but those changes have not yet been merged in + `base-compat`: patches are welcomed! + +## Using `Prelude.Compat` + +If you want to use `Prelude.Compat` (which provides all the +AMP/Traversable/Foldable changes from `base-4.8.0.0`), it's best to hide +`Prelude`, e.g.: + + import Prelude () + import Prelude.Compat + + main :: IO () + main = mapM_ print (Just 23) + +Alternatively, you can use the `NoImplicitPrelude` language extension: + + {-# LANGUAGE NoImplicitPrelude #-} + import Prelude.Compat + + main :: IO () + main = mapM_ print (Just 23) + +Note that we use + + mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () + +from `Data.Foldable` here, which is only exposed from `Prelude` since +`base-4.8.0.0`. + +Using this approach allows you to write code that works seamlessly with all +versions of GHC that are supported by `base-compat`. + +## What is covered +So far the following is covered. + +### For compatibility with the latest released version of `base` + + * `Prelude.Compat` incorporates the AMP/Foldable/Traversable changes and + exposes the same interface as `Prelude` from `base-4.8.0.0` + * `System.IO.Error.catch` is not re-exported from `Prelude.Compat` for older + versions of `base` + * `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` + * Added `(<$!>)` function to `Control.Monad.Compat` + * Added `($>)` and `void` functions to `Data.Functor.Compat` + * `(&)` 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 + + * `ghc-7.10.1` / `base-4.8.0.0` + * `ghc-7.8.4` / `base-4.7.0.2` + * `ghc-7.8.3` / `base-4.7.0.1` + * `ghc-7.8.2` / `base-4.7.0.0` + * `ghc-7.8.1` / `base-4.7.0.0` + * `ghc-7.6.3` / `base-4.6.0.1` + * `ghc-7.6.2` / `base-4.6.0.1` + * `ghc-7.6.1` / `base-4.6.0.0` + * `ghc-7.4.2` / `base-4.5.1.0` + * `ghc-7.4.1` / `base-4.5.0.0` + * `ghc-7.2.2` / `base-4.4.1.0` + * `ghc-7.2.1` / `base-4.4.0.0` + * `ghc-7.0.4` / `base-4.3.1.0` + * `ghc-7.0.3` / `base-4.3.1.0` + * `ghc-7.0.2` / `base-4.3.1.0` + * `ghc-7.0.1` / `base-4.3.0.0` + +Patches are welcome; add tests for new code! + +## Development + +For `Prelude.Compat` there is an `Prelude.index` file that was generated from +the output of + + ghc --show-iface Prelude.hi + +To verify that `Prelude.Compat` matches the specification given in +`Prelude.types` run: + + ./check-Prelude.sh diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/base-compat.cabal b/base-compat.cabal --- a/base-compat.cabal +++ b/base-compat.cabal @@ -1,83 +1,87 @@ -name: base-compat -version: 0.8.1.1 -license: MIT -license-file: LICENSE -copyright: (c) 2012-2015 Simon Hengel, - (c) 2014 João Cristóvão, - (c) 2015 Ryan Scott -author: Simon Hengel , - João Cristóvão , - Ryan Scott -maintainer: Simon Hengel , - João Cristóvão , - Ryan Scott -build-type: Simple -cabal-version: >= 1.8 -category: Compatibility -synopsis: A compatibility layer for base -description: Provides functions available in later versions of @base@ to - a wider range of compilers, without requiring you to use CPP - pragmas in your code. See the - - for what is covered. Also see the - - for recent changes. - . - Note that @base-compat@ does not add any orphan instances. - There is a separate package - @@ - for that. -extra-source-files: CHANGES.markdown, README.markdown - -source-repository head - type: git - location: https://github.com/haskell-compat/base-compat - -library - ghc-options: - -Wall - build-depends: - base >= 4.3 && < 5 - if !os(windows) - build-depends: unix - ghc-options: - -fno-warn-duplicate-exports - - hs-source-dirs: - src - - exposed-modules: - Control.Concurrent.MVar.Compat - Control.Monad.Compat - Data.Bool.Compat - Data.Either.Compat - Data.Foldable.Compat - Data.Function.Compat - Data.Functor.Compat - Data.List.Compat - Data.Monoid.Compat - Data.Version.Compat - Debug.Trace.Compat - Foreign.Compat - Foreign.Marshal.Alloc.Compat - Foreign.Marshal.Array.Compat - Foreign.Marshal.Compat - Prelude.Compat - System.Environment.Compat - System.Exit.Compat - Text.Read.Compat - -test-suite spec - type: - exitcode-stdio-1.0 - ghc-options: - -Wall - hs-source-dirs: - test - main-is: - Spec.hs - build-depends: - base >= 4.3 && < 5 - , base-compat - , hspec >= 1.8 - , QuickCheck +name: base-compat +version: 0.8.2 +license: MIT +license-file: LICENSE +copyright: (c) 2012-2015 Simon Hengel, + (c) 2014 João Cristóvão, + (c) 2015 Ryan Scott +author: Simon Hengel , + João Cristóvão , + Ryan Scott +maintainer: Simon Hengel , + João Cristóvão , + Ryan Scott +build-type: Simple +cabal-version: >= 1.8 +category: Compatibility +synopsis: A compatibility layer for base +description: Provides functions available in later versions of @base@ to + a wider range of compilers, without requiring you to use CPP + pragmas in your code. See the + + for what is covered. Also see the + + for recent changes. + . + Note that @base-compat@ does not add any orphan instances. + There is a separate package + @@ + for that. +extra-source-files: CHANGES.markdown, README.markdown + +source-repository head + type: git + location: https://github.com/haskell-compat/base-compat + +library + ghc-options: + -Wall + build-depends: + base >= 4.3 && < 5 + if !os(windows) + build-depends: unix + ghc-options: + -fno-warn-duplicate-exports + + hs-source-dirs: + src + + exposed-modules: + Control.Concurrent.MVar.Compat + Control.Monad.Compat + Data.Bits.Compat + Data.Bool.Compat + Data.Either.Compat + Data.Foldable.Compat + Data.Function.Compat + Data.Functor.Compat + 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 + Text.Read.Compat + +test-suite spec + type: + exitcode-stdio-1.0 + ghc-options: + -Wall + hs-source-dirs: + test + main-is: + Spec.hs + build-depends: + base >= 4.3 && < 5 + , base-compat + , hspec >= 1.8 + , QuickCheck diff --git a/src/Control/Concurrent/MVar/Compat.hs b/src/Control/Concurrent/MVar/Compat.hs --- a/src/Control/Concurrent/MVar/Compat.hs +++ b/src/Control/Concurrent/MVar/Compat.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Control.Concurrent.MVar.Compat ( - module Base -, withMVarMasked -) where -import Control.Concurrent.MVar as Base - -#if !(MIN_VERSION_base(4,7,0)) -import Control.Exception (mask_, onException) -import Control.Monad (return) -import Data.Function (($)) -import System.IO (IO) - -{-| - Like 'withMVar', but the @IO@ action in the second argument is executed - with asynchronous exceptions masked. - - @since 4.7.0.0 --} -{-# INLINE withMVarMasked #-} -withMVarMasked :: MVar a -> (a -> IO b) -> IO b -withMVarMasked m io = - mask_ $ do - a <- takeMVar m - b <- io a `onException` putMVar m a - putMVar m a - return b -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Control.Concurrent.MVar.Compat ( + module Base +, withMVarMasked +) where +import Control.Concurrent.MVar as Base + +#if !(MIN_VERSION_base(4,7,0)) +import Control.Exception (mask_, onException) +import Control.Monad (return) +import Data.Function (($)) +import System.IO (IO) + +{-| + Like 'withMVar', but the @IO@ action in the second argument is executed + with asynchronous exceptions masked. + + @since 4.7.0.0 +-} +{-# INLINE withMVarMasked #-} +withMVarMasked :: MVar a -> (a -> IO b) -> IO b +withMVarMasked m io = + mask_ $ do + a <- takeMVar m + b <- io a `onException` putMVar m a + putMVar m a + return b +#endif diff --git a/src/Control/Monad/Compat.hs b/src/Control/Monad/Compat.hs --- a/src/Control/Monad/Compat.hs +++ b/src/Control/Monad/Compat.hs @@ -1,118 +1,118 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Control.Monad.Compat ( - module Base -, Monad(..) -, MonadPlus(..) -#if !(MIN_VERSION_base(4,8,0)) -, foldM -, foldM_ -, forM -, forM_ -, guard -, mapM -, mapM_ -, msum -, sequence -, sequence_ -, unless -, when - -, (<$!>) -#endif -) where - -#if MIN_VERSION_base(4,8,0) -import Control.Monad as Base -#else -import Control.Monad as Base hiding ( - foldM - , foldM_ - , forM - , forM_ - , guard - , mapM - , mapM_ - , msum - , sequence - , sequence_ - , unless - , when - ) -import Control.Applicative (Alternative(..)) -import Data.Foldable.Compat -import Data.Traversable -import Prelude.Compat -#endif - -#if !(MIN_VERSION_base(4,8,0)) --- | Conditional execution of 'Applicative' expressions. For example, --- --- > when debug (putStrLn "Debugging") --- --- will output the string @Debugging@ if the Boolean value @debug@ --- is 'True', and otherwise do nothing. -when :: (Applicative f) => Bool -> f () -> f () -{-# INLINEABLE when #-} -{-# SPECIALISE when :: Bool -> IO () -> IO () #-} -{-# SPECIALISE when :: Bool -> Maybe () -> Maybe () #-} -when p s = if p then s else pure () - --- | @'guard' b@ is @'pure' ()@ if @b@ is 'True', --- and 'empty' if @b@ is 'False'. -guard :: (Alternative f) => Bool -> f () -guard True = pure () -guard False = empty - --- | The reverse of 'when'. -unless :: (Applicative f) => Bool -> f () -> f () -{-# INLINEABLE unless #-} -{-# SPECIALISE unless :: Bool -> IO () -> IO () #-} -{-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-} -unless p s = if p then pure () else s - -{- | The 'foldM' function is analogous to 'foldl', except that its result is -encapsulated in a monad. Note that 'foldM' works from left-to-right over -the list arguments. This could be an issue where @('>>')@ and the `folded -function' are not commutative. - - -> foldM f a1 [x1, x2, ..., xm] - -== - -> do -> a2 <- f a1 x1 -> a3 <- f a2 x2 -> ... -> f am xm - -If right-to-left evaluation is required, the input list should be reversed. - -Note: 'foldM' is the same as 'foldlM' --} - -foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b -{-# INLINEABLE foldM #-} -{-# SPECIALISE foldM :: (a -> b -> IO a) -> a -> [b] -> IO a #-} -{-# SPECIALISE foldM :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a #-} -foldM = foldlM - --- | Like 'foldM', but discards the result. -foldM_ :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m () -{-# INLINEABLE foldM_ #-} -{-# SPECIALISE foldM_ :: (a -> b -> IO a) -> a -> [b] -> IO () #-} -{-# SPECIALISE foldM_ :: (a -> b -> Maybe a) -> a -> [b] -> Maybe () #-} -foldM_ f a xs = foldlM f a xs >> return () - -infixl 4 <$!> - --- | Strict version of 'Data.Functor.<$>'. --- --- /Since: 4.8.0.0/ -(<$!>) :: Monad m => (a -> b) -> m a -> m b -{-# INLINE (<$!>) #-} -f <$!> m = do - x <- m - let z = f x - z `seq` return z -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Control.Monad.Compat ( + module Base +, Monad(..) +, MonadPlus(..) +#if !(MIN_VERSION_base(4,8,0)) +, foldM +, foldM_ +, forM +, forM_ +, guard +, mapM +, mapM_ +, msum +, sequence +, sequence_ +, unless +, when + +, (<$!>) +#endif +) where + +#if MIN_VERSION_base(4,8,0) +import Control.Monad as Base +#else +import Control.Monad as Base hiding ( + foldM + , foldM_ + , forM + , forM_ + , guard + , mapM + , mapM_ + , msum + , sequence + , sequence_ + , unless + , when + ) +import Control.Applicative (Alternative(..)) +import Data.Foldable.Compat +import Data.Traversable +import Prelude.Compat +#endif + +#if !(MIN_VERSION_base(4,8,0)) +-- | Conditional execution of 'Applicative' expressions. For example, +-- +-- > when debug (putStrLn "Debugging") +-- +-- will output the string @Debugging@ if the Boolean value @debug@ +-- is 'True', and otherwise do nothing. +when :: (Applicative f) => Bool -> f () -> f () +{-# INLINEABLE when #-} +{-# SPECIALISE when :: Bool -> IO () -> IO () #-} +{-# SPECIALISE when :: Bool -> Maybe () -> Maybe () #-} +when p s = if p then s else pure () + +-- | @'guard' b@ is @'pure' ()@ if @b@ is 'True', +-- and 'empty' if @b@ is 'False'. +guard :: (Alternative f) => Bool -> f () +guard True = pure () +guard False = empty + +-- | The reverse of 'when'. +unless :: (Applicative f) => Bool -> f () -> f () +{-# INLINEABLE unless #-} +{-# SPECIALISE unless :: Bool -> IO () -> IO () #-} +{-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-} +unless p s = if p then pure () else s + +{- | The 'foldM' function is analogous to 'foldl', except that its result is +encapsulated in a monad. Note that 'foldM' works from left-to-right over +the list arguments. This could be an issue where @('>>')@ and the `folded +function' are not commutative. + + +> foldM f a1 [x1, x2, ..., xm] + +== + +> do +> a2 <- f a1 x1 +> a3 <- f a2 x2 +> ... +> f am xm + +If right-to-left evaluation is required, the input list should be reversed. + +Note: 'foldM' is the same as 'foldlM' +-} + +foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b +{-# INLINEABLE foldM #-} +{-# SPECIALISE foldM :: (a -> b -> IO a) -> a -> [b] -> IO a #-} +{-# SPECIALISE foldM :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a #-} +foldM = foldlM + +-- | Like 'foldM', but discards the result. +foldM_ :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m () +{-# INLINEABLE foldM_ #-} +{-# SPECIALISE foldM_ :: (a -> b -> IO a) -> a -> [b] -> IO () #-} +{-# SPECIALISE foldM_ :: (a -> b -> Maybe a) -> a -> [b] -> Maybe () #-} +foldM_ f a xs = foldlM f a xs >> return () + +infixl 4 <$!> + +-- | Strict version of 'Data.Functor.<$>'. +-- +-- /Since: 4.8.0.0/ +(<$!>) :: Monad m => (a -> b) -> m a -> m b +{-# INLINE (<$!>) #-} +f <$!> m = do + x <- m + let z = f x + z `seq` return z +#endif diff --git a/src/Data/Bits/Compat.hs b/src/Data/Bits/Compat.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Data/Bool/Compat.hs b/src/Data/Bool/Compat.hs --- a/src/Data/Bool/Compat.hs +++ b/src/Data/Bool/Compat.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Bool.Compat ( - module Base -, bool -) where - -import Data.Bool as Base - -#if !(MIN_VERSION_base(4,7,0)) --- | Case analysis for the 'Bool' type. --- @bool a b p@ evaluates to @a@ when @p@ is @False@, and evaluates to @b@ --- when @p@ is @True@. --- --- /Since: 4.7.0.0/ -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Bool.Compat ( + module Base +, bool +) where + +import Data.Bool as Base + +#if !(MIN_VERSION_base(4,7,0)) +-- | Case analysis for the 'Bool' type. +-- @bool a b p@ evaluates to @a@ when @p@ is @False@, and evaluates to @b@ +-- when @p@ is @True@. +-- +-- /Since: 4.7.0.0/ +bool :: a -> a -> Bool -> a +bool f _ False = f +bool _ t True = t +#endif diff --git a/src/Data/Either/Compat.hs b/src/Data/Either/Compat.hs --- a/src/Data/Either/Compat.hs +++ b/src/Data/Either/Compat.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Either.Compat ( - module Base -, isLeft -, isRight -) where -import Data.Either as Base - -#if !(MIN_VERSION_base(4,7,0)) -import Data.Bool (Bool(..)) - --- | Return `True` if the given value is a `Left`-value, `False` otherwise. --- --- /Since: 4.7.0.0/ -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft (Right _) = False - --- | Return `True` if the given value is a `Right`-value, `False` otherwise. --- --- /Since: 4.7.0.0/ -isRight :: Either a b -> Bool -isRight (Left _) = False -isRight (Right _) = True -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Either.Compat ( + module Base +, isLeft +, isRight +) where +import Data.Either as Base + +#if !(MIN_VERSION_base(4,7,0)) +import Data.Bool (Bool(..)) + +-- | Return `True` if the given value is a `Left`-value, `False` otherwise. +-- +-- /Since: 4.7.0.0/ +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft (Right _) = False + +-- | Return `True` if the given value is a `Right`-value, `False` otherwise. +-- +-- /Since: 4.7.0.0/ +isRight :: Either a b -> Bool +isRight (Left _) = False +isRight (Right _) = True +#endif diff --git a/src/Data/Foldable/Compat.hs b/src/Data/Foldable/Compat.hs --- a/src/Data/Foldable/Compat.hs +++ b/src/Data/Foldable/Compat.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Foldable.Compat ( - module Base -#if !(MIN_VERSION_base(4,8,0)) -, length -, null -#endif -) where - -import Data.Foldable as Base - -#if !(MIN_VERSION_base(4,8,0)) -import Prelude (Bool(..), Int, (+)) - --- | Test whether the structure is empty. The default implementation is --- optimized for structures that are similar to cons-lists, because there --- is no general way to do better. -null :: Foldable t => t a -> Bool -null = foldr (\_ _ -> False) True - --- | Returns the size/length of a finite structure as an 'Int'. The --- default implementation is optimized for structures that are similar to --- cons-lists, because there is no general way to do better. -length :: Foldable t => t a -> Int -length = foldl' (\c _ -> c+1) 0 -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Foldable.Compat ( + module Base +#if !(MIN_VERSION_base(4,8,0)) +, length +, null +#endif +) where + +import Data.Foldable as Base + +#if !(MIN_VERSION_base(4,8,0)) +import Prelude (Bool(..), Int, (+)) + +-- | Test whether the structure is empty. The default implementation is +-- optimized for structures that are similar to cons-lists, because there +-- is no general way to do better. +null :: Foldable t => t a -> Bool +null = foldr (\_ _ -> False) True + +-- | Returns the size/length of a finite structure as an 'Int'. The +-- default implementation is optimized for structures that are similar to +-- cons-lists, because there is no general way to do better. +length :: Foldable t => t a -> Int +length = foldl' (\c _ -> c+1) 0 +#endif diff --git a/src/Data/Function/Compat.hs b/src/Data/Function/Compat.hs --- a/src/Data/Function/Compat.hs +++ b/src/Data/Function/Compat.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Function.Compat ( - module Base -, (&) -) where -import Data.Function as Base - -#if !(MIN_VERSION_base(4,8,0)) -infixl 1 & - --- | '&' is a reverse application operator. This provides notational --- convenience. Its precedence is one higher than that of the forward --- application operator '$', which allows '&' to be nested in '$'. --- --- /Since: 4.8.0.0/ -(&) :: a -> (a -> b) -> b -x & f = f x - -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Function.Compat ( + module Base +, (&) +) where +import Data.Function as Base + +#if !(MIN_VERSION_base(4,8,0)) +infixl 1 & + +-- | '&' is a reverse application operator. This provides notational +-- convenience. Its precedence is one higher than that of the forward +-- application operator '$', which allows '&' to be nested in '$'. +-- +-- /Since: 4.8.0.0/ +(&) :: a -> (a -> b) -> b +x & f = f x + +#endif diff --git a/src/Data/Functor/Compat.hs b/src/Data/Functor/Compat.hs --- a/src/Data/Functor/Compat.hs +++ b/src/Data/Functor/Compat.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Functor.Compat ( - module Base -, Functor(..) -, ($>) -, void -) where -import Data.Functor as Base - -#if !(MIN_VERSION_base(4,7,0)) -import Control.Monad.Compat (void) -import Data.Function (flip) - -infixl 4 $> - --- | Flipped version of '$>'. --- --- /Since: 4.7.0.0/ -($>) :: Functor f => f a -> b -> f b -($>) = flip (<$) - -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Functor.Compat ( + module Base +, Functor(..) +, ($>) +, void +) where +import Data.Functor as Base + +#if !(MIN_VERSION_base(4,7,0)) +import Control.Monad.Compat (void) +import Data.Function (flip) + +infixl 4 $> + +-- | Flipped version of '$>'. +-- +-- /Since: 4.7.0.0/ +($>) :: Functor f => f a -> b -> f b +($>) = flip (<$) + +#endif diff --git a/src/Data/List/Compat.hs b/src/Data/List/Compat.hs --- a/src/Data/List/Compat.hs +++ b/src/Data/List/Compat.hs @@ -1,144 +1,202 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -module Data.List.Compat ( - module Base -#if !(MIN_VERSION_base(4,8,0)) -, all -, and -, any -, concat -, concatMap -, elem -, find -, foldl -, foldl' -, foldl1 -, foldr -, foldr1 -, length -, maximum -, maximumBy -, minimum -, minimumBy -, notElem -, null -, or -, product -, sum -, mapAccumL -, mapAccumR - -, isSubsequenceOf -, sortOn -, uncons -, scanl' -#endif - -#if !(MIN_VERSION_base(4,5,0)) -, dropWhileEnd -#endif -) where - -#if MIN_VERSION_base(4,8,0) -import Data.List as Base -#else -import Data.List as Base hiding ( - all - , and - , any - , concat - , concatMap - , elem - , find - , foldl - , foldl' - , foldl1 - , foldr - , foldr1 - , length - , maximum - , maximumBy - , minimum - , minimumBy - , notElem - , null - , or - , product - , sum - , mapAccumL - , mapAccumR - ) -import Data.Foldable.Compat -import Data.Traversable -import Prelude.Compat hiding (foldr, null) -import Data.Ord (comparing) -#endif - -#if !(MIN_VERSION_base(4,5,0)) --- | The 'dropWhileEnd' function drops the largest suffix of a list --- in which the given predicate holds for all elements. For example: --- --- > dropWhileEnd isSpace "foo\n" == "foo" --- > dropWhileEnd isSpace "foo bar" == "foo bar" --- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined --- --- /Since: 4.5.0.0/ -dropWhileEnd :: (a -> Bool) -> [a] -> [a] -dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] - -#endif - -#if !(MIN_VERSION_base(4,8,0)) --- | The 'isSubsequenceOf' function takes two lists and returns 'True' if the --- first list is a subsequence of the second list. --- --- @'isSubsequenceOf' x y@ is equivalent to @'elem' x ('subsequences' y)@. --- --- /Since: 4.8.0.0/ --- --- ==== __Examples__ --- --- >>> isSubsequenceOf "GHC" "The Glorious Haskell Compiler" --- True --- >>> isSubsequenceOf ['a','d'..'z'] ['a'..'z'] --- True --- >>> isSubsequenceOf [1..10] [10,9..0] --- False -isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool -isSubsequenceOf [] _ = True -isSubsequenceOf _ [] = False -isSubsequenceOf a@(x:a') (y:b) | x == y = isSubsequenceOf a' b - | otherwise = isSubsequenceOf a b - --- | Sort a list by comparing the results of a key function applied to each --- element. @sortOn f@ is equivalent to @sortBy . comparing f@, but has the --- performance advantage of only evaluating @f@ once for each element in the --- input list. This is called the decorate-sort-undecorate paradigm, or --- Schwartzian transform. --- --- /Since: 4.8.0.0/ -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = - map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) - --- | Decompose a list into its head and tail. If the list is empty, --- returns 'Nothing'. If the list is non-empty, returns @'Just' (x, xs)@, --- where @x@ is the head of the list and @xs@ its tail. --- --- /Since: 4.8.0.0/ -uncons :: [a] -> Maybe (a, [a]) -uncons [] = Nothing -uncons (x:xs) = Just (x, xs) - --- | A strictly accumulating version of 'scanl' -{-# NOINLINE [1] scanl' #-} -scanl' :: (b -> a -> b) -> b -> [a] -> [b] --- This peculiar form is needed to prevent scanl' from being rewritten --- in its own right hand side. -scanl' = scanlGo' - where - scanlGo' :: (b -> a -> b) -> b -> [a] -> [b] - scanlGo' f !q ls = q : (case ls of - [] -> [] - x:xs -> scanlGo' f (f q x) xs) -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +module Data.List.Compat ( + module Base +#if !(MIN_VERSION_base(4,8,0)) +, all +, and +, any +, concat +, concatMap +, elem +, find +, foldl +, foldl' +, foldl1 +, foldr +, foldr1 +, length +, maximum +, maximumBy +, minimum +, minimumBy +, notElem +, nub +, nubBy +, null +, or +, product +, sum +, union +, unionBy +, mapAccumL +, mapAccumR + +, isSubsequenceOf +, sortOn +, uncons +, scanl' +#endif + +#if !(MIN_VERSION_base(4,5,0)) +, dropWhileEnd +#endif +) where + +#if MIN_VERSION_base(4,8,0) +import Data.List as Base +#else +import Data.List as Base hiding ( + all + , and + , any + , concat + , concatMap + , elem + , find + , foldl + , foldl' + , foldl1 + , foldr + , foldr1 + , length + , maximum + , maximumBy + , minimum + , minimumBy + , notElem + , nub + , nubBy + , null + , or + , product + , sum + , union + , unionBy + , mapAccumL + , mapAccumR + ) +import Data.Foldable.Compat +import Data.Traversable +import Prelude.Compat hiding (foldr, null) +import Data.Ord (comparing) +#endif + +#if !(MIN_VERSION_base(4,5,0)) +-- | The 'dropWhileEnd' function drops the largest suffix of a list +-- in which the given predicate holds for all elements. For example: +-- +-- > dropWhileEnd isSpace "foo\n" == "foo" +-- > dropWhileEnd isSpace "foo bar" == "foo bar" +-- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined +-- +-- /Since: 4.5.0.0/ +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] + +#endif + +#if !(MIN_VERSION_base(4,8,0)) +-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if the +-- first list is a subsequence of the second list. +-- +-- @'isSubsequenceOf' x y@ is equivalent to @'elem' x ('subsequences' y)@. +-- +-- /Since: 4.8.0.0/ +-- +-- ==== __Examples__ +-- +-- >>> isSubsequenceOf "GHC" "The Glorious Haskell Compiler" +-- True +-- >>> isSubsequenceOf ['a','d'..'z'] ['a'..'z'] +-- True +-- >>> isSubsequenceOf [1..10] [10,9..0] +-- False +isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool +isSubsequenceOf [] _ = True +isSubsequenceOf _ [] = False +isSubsequenceOf a@(x:a') (y:b) | x == y = isSubsequenceOf a' b + | otherwise = isSubsequenceOf a b + +-- | Sort a list by comparing the results of a key function applied to each +-- element. @sortOn f@ is equivalent to @sortBy . comparing f@, but has the +-- performance advantage of only evaluating @f@ once for each element in the +-- input list. This is called the decorate-sort-undecorate paradigm, or +-- Schwartzian transform. +-- +-- /Since: 4.8.0.0/ +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +-- | Decompose a list into its head and tail. If the list is empty, +-- returns 'Nothing'. If the list is non-empty, returns @'Just' (x, xs)@, +-- where @x@ is the head of the list and @xs@ its tail. +-- +-- /Since: 4.8.0.0/ +uncons :: [a] -> Maybe (a, [a]) +uncons [] = Nothing +uncons (x:xs) = Just (x, xs) + +-- | A strictly accumulating version of 'scanl' +{-# NOINLINE [1] scanl' #-} +scanl' :: (b -> a -> b) -> b -> [a] -> [b] +-- This peculiar form is needed to prevent scanl' from being rewritten +-- in its own right hand side. +scanl' = scanlGo' + where + scanlGo' :: (b -> a -> b) -> b -> [a] -> [b] + 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 diff --git a/src/Data/Monoid/Compat.hs b/src/Data/Monoid/Compat.hs --- a/src/Data/Monoid/Compat.hs +++ b/src/Data/Monoid/Compat.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Monoid.Compat ( - module Base -, (<>) -) where - -import Data.Monoid as Base - -#if !(MIN_VERSION_base(4,5,0)) - -infixr 6 <> - --- | An infix synonym for 'mappend'. --- --- /Since: 4.5.0.0/ -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} - -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Monoid.Compat ( + module Base +, (<>) +) where + +import Data.Monoid as Base + +#if !(MIN_VERSION_base(4,5,0)) + +infixr 6 <> + +-- | An infix synonym for 'mappend'. +-- +-- /Since: 4.5.0.0/ +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} + +#endif diff --git a/src/Data/Version/Compat.hs b/src/Data/Version/Compat.hs --- a/src/Data/Version/Compat.hs +++ b/src/Data/Version/Compat.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Data.Version.Compat ( - module Base -, makeVersion -) where -import Data.Version as Base - -#if !(MIN_VERSION_base(4,8,0)) -import Prelude.Compat - --- | Construct tag-less 'Version' --- --- /Since: 4.8.0.0/ -makeVersion :: [Int] -> Version -makeVersion b = Version b [] -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Data.Version.Compat ( + module Base +, makeVersion +) where +import Data.Version as Base + +#if !(MIN_VERSION_base(4,8,0)) +import Prelude.Compat + +-- | Construct tag-less 'Version' +-- +-- /Since: 4.8.0.0/ +makeVersion :: [Int] -> Version +makeVersion b = Version b [] +#endif diff --git a/src/Data/Word/Compat.hs b/src/Data/Word/Compat.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Debug/Trace/Compat.hs b/src/Debug/Trace/Compat.hs --- a/src/Debug/Trace/Compat.hs +++ b/src/Debug/Trace/Compat.hs @@ -1,59 +1,59 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Debug.Trace.Compat ( - module Base -, traceId -, traceShowId -, traceM -, traceShowM -) where -import Debug.Trace as Base - -#if !(MIN_VERSION_base(4,7,0)) -import Prelude.Compat - -{-| -Like 'trace' but returns the message instead of a third value. - -/Since: 4.7.0.0/ --} -traceId :: String -> String -traceId a = trace a a - -{-| -Like 'traceShow' but returns the shown value instead of a third value. - -/Since: 4.7.0.0/ --} -traceShowId :: (Show a) => a -> a -traceShowId a = trace (show a) a - -{-| -Like 'trace' but returning unit in an arbitrary monad. Allows for convenient -use in do-notation. Note that the application of 'trace' is not an action in the -monad, as 'traceIO' is in the 'IO' monad. - -> ... = do -> x <- ... -> traceM $ "x: " ++ show x -> y <- ... -> traceM $ "y: " ++ show y - -/Since: 4.7.0.0/ --} -traceM :: (Monad m) => String -> m () -traceM string = trace string $ return () - -{-| -Like 'traceM', but uses 'show' on the argument to convert it to a 'String'. - -> ... = do -> x <- ... -> traceMShow $ x -> y <- ... -> traceMShow $ x + y - -/Since: 4.7.0.0/ --} -traceShowM :: (Show a, Monad m) => a -> m () -traceShowM = traceM . show -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Debug.Trace.Compat ( + module Base +, traceId +, traceShowId +, traceM +, traceShowM +) where +import Debug.Trace as Base + +#if !(MIN_VERSION_base(4,7,0)) +import Prelude.Compat + +{-| +Like 'trace' but returns the message instead of a third value. + +/Since: 4.7.0.0/ +-} +traceId :: String -> String +traceId a = trace a a + +{-| +Like 'traceShow' but returns the shown value instead of a third value. + +/Since: 4.7.0.0/ +-} +traceShowId :: (Show a) => a -> a +traceShowId a = trace (show a) a + +{-| +Like 'trace' but returning unit in an arbitrary monad. Allows for convenient +use in do-notation. Note that the application of 'trace' is not an action in the +monad, as 'traceIO' is in the 'IO' monad. + +> ... = do +> x <- ... +> traceM $ "x: " ++ show x +> y <- ... +> traceM $ "y: " ++ show y + +/Since: 4.7.0.0/ +-} +traceM :: (Monad m) => String -> m () +traceM string = trace string $ return () + +{-| +Like 'traceM', but uses 'show' on the argument to convert it to a 'String'. + +> ... = do +> x <- ... +> traceMShow $ x +> y <- ... +> traceMShow $ x + y + +/Since: 4.7.0.0/ +-} +traceShowM :: (Show a, Monad m) => a -> m () +traceShowM = traceM . show +#endif diff --git a/src/Foreign/Compat.hs b/src/Foreign/Compat.hs --- a/src/Foreign/Compat.hs +++ b/src/Foreign/Compat.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Foreign.Compat ( - module Base -, module Marshal -) where -import Foreign as Base - -import Foreign.Marshal.Compat as Marshal +{-# LANGUAGE NoImplicitPrelude #-} +module Foreign.Compat ( + module Base +, module Marshal +) where +import Foreign as Base + +import Foreign.Marshal.Compat as Marshal diff --git a/src/Foreign/Marshal/Alloc/Compat.hs b/src/Foreign/Marshal/Alloc/Compat.hs --- a/src/Foreign/Marshal/Alloc/Compat.hs +++ b/src/Foreign/Marshal/Alloc/Compat.hs @@ -1,43 +1,43 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module Foreign.Marshal.Alloc.Compat ( - module Base -, calloc -, callocBytes -) where -import Foreign.Marshal.Alloc as Base - -#if !(MIN_VERSION_base(4,8,0)) -import Foreign.C.Types -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (Storable(..)) -import GHC.IO.Exception -import Prelude.Compat - --- |Like 'malloc' but memory is filled with bytes of value zero. --- -{-# INLINE calloc #-} -calloc :: Storable a => IO (Ptr a) -calloc = doCalloc undefined - where - doCalloc :: Storable b => b -> IO (Ptr b) - doCalloc dummy = callocBytes (sizeOf dummy) - --- |Llike 'mallocBytes' but memory is filled with bytes of value zero. --- -callocBytes :: Int -> IO (Ptr a) -callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size) - --- asserts that the pointer returned from the action in the second argument is --- non-null --- -failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) -failWhenNULL name f = do - addr <- f - if addr == nullPtr - then ioError (IOError Nothing ResourceExhausted name - "out of memory" Nothing Nothing) - else return addr - -foreign import ccall unsafe "stdlib.h calloc" _calloc :: CSize -> CSize -> IO (Ptr a) -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Foreign.Marshal.Alloc.Compat ( + module Base +, calloc +, callocBytes +) where +import Foreign.Marshal.Alloc as Base + +#if !(MIN_VERSION_base(4,8,0)) +import Foreign.C.Types +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(..)) +import GHC.IO.Exception +import Prelude.Compat + +-- |Like 'malloc' but memory is filled with bytes of value zero. +-- +{-# INLINE calloc #-} +calloc :: Storable a => IO (Ptr a) +calloc = doCalloc undefined + where + doCalloc :: Storable b => b -> IO (Ptr b) + doCalloc dummy = callocBytes (sizeOf dummy) + +-- |Llike 'mallocBytes' but memory is filled with bytes of value zero. +-- +callocBytes :: Int -> IO (Ptr a) +callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size) + +-- asserts that the pointer returned from the action in the second argument is +-- non-null +-- +failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) +failWhenNULL name f = do + addr <- f + if addr == nullPtr + then ioError (IOError Nothing ResourceExhausted name + "out of memory" Nothing Nothing) + else return addr + +foreign import ccall unsafe "stdlib.h calloc" _calloc :: CSize -> CSize -> IO (Ptr a) +#endif diff --git a/src/Foreign/Marshal/Array/Compat.hs b/src/Foreign/Marshal/Array/Compat.hs --- a/src/Foreign/Marshal/Array/Compat.hs +++ b/src/Foreign/Marshal/Array/Compat.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Foreign.Marshal.Array.Compat ( - module Base -, callocArray -, callocArray0 -) where -import Foreign.Marshal.Array as Base - -#if !(MIN_VERSION_base(4,8,0)) -import Foreign.Marshal.Alloc.Compat -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) -import Prelude.Compat - --- |Like 'mallocArray', but allocated memory is filled with bytes of value zero. --- -callocArray :: Storable a => Int -> IO (Ptr a) -callocArray = doCalloc undefined - where - doCalloc :: Storable a' => a' -> Int -> IO (Ptr a') - doCalloc dummy size = callocBytes (size * sizeOf dummy) - --- |Like 'callocArray0', but allocated memory is filled with bytes of value --- zero. --- -callocArray0 :: Storable a => Int -> IO (Ptr a) -callocArray0 size = callocArray (size + 1) -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Foreign.Marshal.Array.Compat ( + module Base +, callocArray +, callocArray0 +) where +import Foreign.Marshal.Array as Base + +#if !(MIN_VERSION_base(4,8,0)) +import Foreign.Marshal.Alloc.Compat +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import Prelude.Compat + +-- |Like 'mallocArray', but allocated memory is filled with bytes of value zero. +-- +callocArray :: Storable a => Int -> IO (Ptr a) +callocArray = doCalloc undefined + where + doCalloc :: Storable a' => a' -> Int -> IO (Ptr a') + doCalloc dummy size = callocBytes (size * sizeOf dummy) + +-- |Like 'callocArray0', but allocated memory is filled with bytes of value +-- zero. +-- +callocArray0 :: Storable a => Int -> IO (Ptr a) +callocArray0 size = callocArray (size + 1) +#endif diff --git a/src/Foreign/Marshal/Compat.hs b/src/Foreign/Marshal/Compat.hs --- a/src/Foreign/Marshal/Compat.hs +++ b/src/Foreign/Marshal/Compat.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Foreign.Marshal.Compat ( - module Base -, module Alloc -, module Array -) where -import Foreign.Marshal as Base - -import Foreign.Marshal.Alloc.Compat as Alloc -import Foreign.Marshal.Array.Compat as Array +{-# LANGUAGE CPP, NoImplicitPrelude #-} +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 diff --git a/src/Foreign/Marshal/Utils/Compat.hs b/src/Foreign/Marshal/Utils/Compat.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Numeric/Compat.hs b/src/Numeric/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Compat.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Numeric.Compat ( + module Base +, showFFloatAlt +, showGFloatAlt +) where + +import Numeric as Base + +#if !(MIN_VERSION_base(4,7,0)) +import Data.Char (intToDigit) +import GHC.Float +import Prelude + +-- | Show a signed 'RealFloat' value +-- using standard decimal notation (e.g. @245000@, @0.0015@). +-- +-- This behaves as 'showFFloat', except that a decimal point +-- is always guaranteed, even if not needed. +-- +-- /Since: 4.7.0.0/ +showFFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS +showFFloatAlt d x = showString (formatRealFloatAlt FFFixed d True x) + +-- | Show a signed 'RealFloat' value +-- using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise. +-- +-- This behaves as 'showFFloat', except that a decimal point +-- is always guaranteed, even if not needed. +-- +-- /Since: 4.7.0.0/ +showGFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS +showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x) + +formatRealFloatAlt :: (RealFloat a) => FFFormat -> Maybe Int -> Bool -> a + -> String +formatRealFloatAlt fmt decs alt x + | isNaN x = "NaN" + | isInfinite x = if x < 0 then "-Infinity" else "Infinity" + | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x)) + | otherwise = doFmt fmt (floatToDigits (toInteger base) x) + where + base = 10 + + doFmt format (is, e) = + let ds = map intToDigit is in + case format of + FFGeneric -> + doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) + (is,e) + FFExponent -> + case decs of + Nothing -> + let show_e' = show (e-1) in + case ds of + "0" -> "0.0e0" + [d] -> d : ".0e" ++ show_e' + (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' + [] -> error "formatRealFloat/doFmt/FFExponent: []" + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0" + _ -> + let + (ei,is') = roundTo base (dec'+1) is + (d:ds') = map intToDigit (if ei > 0 then init is' else is') + in + d:'.':ds' ++ 'e':show (e-1+ei) + FFFixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> ls} + in + case decs of + Nothing + | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds + | otherwise -> + let + f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo base (dec' + e) is + (ls,rs) = splitAt (e+ei) (map intToDigit is') + in + mk0 ls ++ (if null rs && not alt then "" else '.':rs) + else + let + (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is) + d:ds' = map intToDigit (if ei > 0 then is' else 0:is') + in + d : (if null ds' && not alt then "" else '.':ds') +#endif diff --git a/src/Prelude/Compat.hs b/src/Prelude/Compat.hs --- a/src/Prelude/Compat.hs +++ b/src/Prelude/Compat.hs @@ -1,298 +1,298 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Prelude.Compat ( -#if MIN_VERSION_base(4,8,0) - module Base -#else - either -, all -, and -, any -, concat -, concatMap -, mapM_ -, notElem -, or -, sequence_ -, (<$>) -, maybe -, lines -, unlines -, unwords -, words -, curry -, fst -, snd -, uncurry -, ($!) -, (++) -, (.) -, (=<<) -, asTypeOf -, const -, flip -, id -, map -, otherwise -, until -, ioError -, userError -, (!!) -, break -, cycle -, drop -, dropWhile -, filter -, head -, init -, iterate -, last -, lookup -, repeat -, replicate -, reverse -, scanl -, scanl1 -, scanr -, scanr1 -, span -, splitAt -, tail -, take -, takeWhile -, unzip -, unzip3 -, zip -, zip3 -, zipWith -, zipWith3 -, subtract -, lex -, readParen -, (^) -, (^^) - -, even -, fromIntegral -, gcd -, lcm -, odd -, realToFrac -, showChar -, showParen -, showString -, shows -, appendFile -, getChar -, getContents -, getLine -, interact -, print -, putChar -, putStr -, putStrLn -, readFile -, readIO -, readLn -, writeFile -, read -, reads -, (&&) -, not -, (||) -, ($) -, error -, undefined -, seq - -, elem -, foldMap -, foldl -, foldl1 -, foldr -, foldr1 -, length -, maximum -, minimum -, null -, product -, sum -, mapM -, sequence -, sequenceA -, traverse -, (*>) -, (<*) -, (<*>) -, pure -, (<$) -, fmap -, (>>) -, (>>=) -, fail -, return -, mappend -, mconcat -, mempty -, maxBound -, minBound -, enumFrom -, enumFromThen -, enumFromThenTo -, enumFromTo -, fromEnum -, pred -, succ -, toEnum -, (**) -, acos -, acosh -, asin -, asinh -, atan -, atanh -, cos -, cosh -, exp -, log -, logBase -, pi -, sin -, sinh -, sqrt -, tan -, tanh -, atan2 -, decodeFloat -, encodeFloat -, exponent -, floatDigits -, floatRadix -, floatRange -, isDenormalized -, isIEEE -, isInfinite -, isNaN -, isNegativeZero -, scaleFloat -, significand -, (*) -, (+) -, (-) -, abs -, negate -, signum -, readList -, readsPrec -, (/) -, fromRational -, recip -, div -, divMod -, mod -, quot -, quotRem -, rem -, toInteger -, toRational -, ceiling -, floor -, properFraction -, round -, truncate -, show -, showList -, showsPrec -, (/=) -, (==) -, (<) -, (<=) -, (>) -, (>=) -, compare -, max -, min - --- classes -, Applicative -, Bounded -, Enum -, Eq -, Floating -, Foldable -, Fractional -, Functor -, Integral -, Monad -, Monoid -, Num (fromInteger) -, Ord -, Read -, Real -, RealFloat -, RealFrac -, Show -, Traversable - --- data types -, IO -, Char -, Double -, Float -, Int -, Integer -, Word -, Bool (True, False) -, Either(Left, Right) -, Maybe(Just, Nothing) -, Ordering (EQ, GT, LT) - --- type synonyms -, FilePath -, IOError -, Rational -, ReadS -, ShowS -, String -#endif -) where - - -#if MIN_VERSION_base(4,8,0) - -import Prelude as Base - -#else - -import Prelude hiding ( - length - , null - , foldr - , mapM - , sequence - , all - , and - , any - , concat - , concatMap - , mapM - , mapM_ - , notElem - , or - , sequence - , sequence_ - , elem - , foldl - , foldl1 - , foldr1 - , maximum - , minimum - , product - , sum - ) - -import Data.Word -import Data.Foldable.Compat -import Data.Traversable -import Data.Monoid -import Control.Applicative -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Prelude.Compat ( +#if MIN_VERSION_base(4,8,0) + module Base +#else + either +, all +, and +, any +, concat +, concatMap +, mapM_ +, notElem +, or +, sequence_ +, (<$>) +, maybe +, lines +, unlines +, unwords +, words +, curry +, fst +, snd +, uncurry +, ($!) +, (++) +, (.) +, (=<<) +, asTypeOf +, const +, flip +, id +, map +, otherwise +, until +, ioError +, userError +, (!!) +, break +, cycle +, drop +, dropWhile +, filter +, head +, init +, iterate +, last +, lookup +, repeat +, replicate +, reverse +, scanl +, scanl1 +, scanr +, scanr1 +, span +, splitAt +, tail +, take +, takeWhile +, unzip +, unzip3 +, zip +, zip3 +, zipWith +, zipWith3 +, subtract +, lex +, readParen +, (^) +, (^^) + +, even +, fromIntegral +, gcd +, lcm +, odd +, realToFrac +, showChar +, showParen +, showString +, shows +, appendFile +, getChar +, getContents +, getLine +, interact +, print +, putChar +, putStr +, putStrLn +, readFile +, readIO +, readLn +, writeFile +, read +, reads +, (&&) +, not +, (||) +, ($) +, error +, undefined +, seq + +, elem +, foldMap +, foldl +, foldl1 +, foldr +, foldr1 +, length +, maximum +, minimum +, null +, product +, sum +, mapM +, sequence +, sequenceA +, traverse +, (*>) +, (<*) +, (<*>) +, pure +, (<$) +, fmap +, (>>) +, (>>=) +, fail +, return +, mappend +, mconcat +, mempty +, maxBound +, minBound +, enumFrom +, enumFromThen +, enumFromThenTo +, enumFromTo +, fromEnum +, pred +, succ +, toEnum +, (**) +, acos +, acosh +, asin +, asinh +, atan +, atanh +, cos +, cosh +, exp +, log +, logBase +, pi +, sin +, sinh +, sqrt +, tan +, tanh +, atan2 +, decodeFloat +, encodeFloat +, exponent +, floatDigits +, floatRadix +, floatRange +, isDenormalized +, isIEEE +, isInfinite +, isNaN +, isNegativeZero +, scaleFloat +, significand +, (*) +, (+) +, (-) +, abs +, negate +, signum +, readList +, readsPrec +, (/) +, fromRational +, recip +, div +, divMod +, mod +, quot +, quotRem +, rem +, toInteger +, toRational +, ceiling +, floor +, properFraction +, round +, truncate +, show +, showList +, showsPrec +, (/=) +, (==) +, (<) +, (<=) +, (>) +, (>=) +, compare +, max +, min + +-- classes +, Applicative +, Bounded +, Enum +, Eq +, Floating +, Foldable +, Fractional +, Functor +, Integral +, Monad +, Monoid +, Num (fromInteger) +, Ord +, Read +, Real +, RealFloat +, RealFrac +, Show +, Traversable + +-- data types +, IO +, Char +, Double +, Float +, Int +, Integer +, Word +, Bool (True, False) +, Either(Left, Right) +, Maybe(Just, Nothing) +, Ordering (EQ, GT, LT) + +-- type synonyms +, FilePath +, IOError +, Rational +, ReadS +, ShowS +, String +#endif +) where + + +#if MIN_VERSION_base(4,8,0) + +import Prelude as Base + +#else + +import Prelude hiding ( + length + , null + , foldr + , mapM + , sequence + , all + , and + , any + , concat + , concatMap + , mapM + , mapM_ + , notElem + , or + , sequence + , sequence_ + , elem + , foldl + , foldl1 + , foldr1 + , maximum + , minimum + , product + , sum + ) + +import Data.Word +import Data.Foldable.Compat +import Data.Traversable +import Data.Monoid +import Control.Applicative +#endif diff --git a/src/System/Environment/Compat.hs b/src/System/Environment/Compat.hs --- a/src/System/Environment/Compat.hs +++ b/src/System/Environment/Compat.hs @@ -1,135 +1,135 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -{-# LANGUAGE ForeignFunctionInterface #-} --- | Miscellaneous information about the system environment. -module System.Environment.Compat ( - getArgs -, getProgName -, getEnv -, lookupEnv -, setEnv -, unsetEnv -, withArgs -, withProgName -, getEnvironment -) where - -import System.Environment - -#if !(MIN_VERSION_base(4,7,0)) -import Prelude.Compat - -# ifdef mingw32_HOST_OS -import Control.Monad -import Foreign.C -import Foreign.Safe -import GHC.Windows -# else -import qualified System.Posix.Env as Posix -# endif - -# ifdef mingw32_HOST_OS - -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif - -foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" - c_GetLastError:: IO DWORD - -eRROR_ENVVAR_NOT_FOUND :: DWORD -eRROR_ENVVAR_NOT_FOUND = 203 - -# endif - -# if !(MIN_VERSION_base(4,6,0)) --- | Return the value of the environment variable @var@, or @Nothing@ if --- there is no such value. --- --- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'. -lookupEnv :: String -> IO (Maybe String) -lookupEnv k = lookup k `fmap` getEnvironment -# endif - --- | @setEnv name value@ sets the specified environment variable to @value@. --- --- On Windows setting an environment variable to the /empty string/ removes --- that environment variable from the environment. For the sake of --- compatibility we adopt that behavior. In particular --- --- @ --- setEnv name \"\" --- @ --- --- has the same effect as --- --- @ --- `unsetEnv` name --- @ --- --- If you don't care about Windows support and want to set an environment --- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@ --- package instead. --- --- Throws `Control.Exception.IOException` if @name@ is the empty string or --- contains an equals sign. --- --- Note that setting Unicode values may not work correctly on versions of GHC --- prior to 7.2. -setEnv :: String -> String -> IO () -setEnv key value_ - | null value = unsetEnv key - | otherwise = setEnv_ key value - where - -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. - -- We still strip it manually so that the null check above succeds if a - -- value starts with NUL, and `unsetEnv` is called. This is important for - -- two reasons. - -- - -- * On POSIX setting an environment variable to the empty string does not - -- remove it. - -- - -- * On Windows setting an environment variable to the empty string - -- removes that environment variable. A subsequent call to - -- GetEnvironmentVariable will then return 0, but the calling thread's - -- last-error code will not be updated, and hence a call to GetLastError - -- may not return ERROR_ENVVAR_NOT_FOUND. The failed lookup will then - -- result in a random error instead of the expected - -- `isDoesNotExistError` (this is at least true for Windows XP, SP 3). - -- Explicitly calling `unsetEnv` prevents this. - value = takeWhile (/= '\NUL') value_ - -setEnv_ :: String -> String -> IO () -# ifdef mingw32_HOST_OS -setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do - success <- c_SetEnvironmentVariable k v - unless success (throwGetLastError "setEnv") - -foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" - c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool -# else -setEnv_ k v = Posix.setEnv k v True -# endif - --- | @unsetEnv name@ removes the specified environment variable from the --- environment of the current process. --- --- Throws `Control.Exception.IOException` if @name@ is the empty string or --- contains an equals sign. -unsetEnv :: String -> IO () -# ifdef mingw32_HOST_OS -unsetEnv key = withCWString key $ \k -> do - success <- c_SetEnvironmentVariable k nullPtr - unless success $ do - -- We consider unsetting an environment variable that does not exist not as - -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. - err <- c_GetLastError - unless (err == eRROR_ENVVAR_NOT_FOUND) $ do - throwGetLastError "unsetEnv" -# else -unsetEnv = Posix.unsetEnv -# endif -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE ForeignFunctionInterface #-} +-- | Miscellaneous information about the system environment. +module System.Environment.Compat ( + getArgs +, getProgName +, getEnv +, lookupEnv +, setEnv +, unsetEnv +, withArgs +, withProgName +, getEnvironment +) where + +import System.Environment + +#if !(MIN_VERSION_base(4,7,0)) +import Prelude.Compat + +# ifdef mingw32_HOST_OS +import Control.Monad +import Foreign.C +import Foreign.Safe +import GHC.Windows +# else +import qualified System.Posix.Env as Posix +# endif + +# ifdef mingw32_HOST_OS + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif + +foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" + c_GetLastError:: IO DWORD + +eRROR_ENVVAR_NOT_FOUND :: DWORD +eRROR_ENVVAR_NOT_FOUND = 203 + +# endif + +# if !(MIN_VERSION_base(4,6,0)) +-- | Return the value of the environment variable @var@, or @Nothing@ if +-- there is no such value. +-- +-- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'. +lookupEnv :: String -> IO (Maybe String) +lookupEnv k = lookup k `fmap` getEnvironment +# endif + +-- | @setEnv name value@ sets the specified environment variable to @value@. +-- +-- On Windows setting an environment variable to the /empty string/ removes +-- that environment variable from the environment. For the sake of +-- compatibility we adopt that behavior. In particular +-- +-- @ +-- setEnv name \"\" +-- @ +-- +-- has the same effect as +-- +-- @ +-- `unsetEnv` name +-- @ +-- +-- If you don't care about Windows support and want to set an environment +-- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@ +-- package instead. +-- +-- Throws `Control.Exception.IOException` if @name@ is the empty string or +-- contains an equals sign. +-- +-- Note that setting Unicode values may not work correctly on versions of GHC +-- prior to 7.2. +setEnv :: String -> String -> IO () +setEnv key value_ + | null value = unsetEnv key + | otherwise = setEnv_ key value + where + -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. + -- We still strip it manually so that the null check above succeds if a + -- value starts with NUL, and `unsetEnv` is called. This is important for + -- two reasons. + -- + -- * On POSIX setting an environment variable to the empty string does not + -- remove it. + -- + -- * On Windows setting an environment variable to the empty string + -- removes that environment variable. A subsequent call to + -- GetEnvironmentVariable will then return 0, but the calling thread's + -- last-error code will not be updated, and hence a call to GetLastError + -- may not return ERROR_ENVVAR_NOT_FOUND. The failed lookup will then + -- result in a random error instead of the expected + -- `isDoesNotExistError` (this is at least true for Windows XP, SP 3). + -- Explicitly calling `unsetEnv` prevents this. + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () +# ifdef mingw32_HOST_OS +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool +# else +setEnv_ k v = Posix.setEnv k v True +# endif + +-- | @unsetEnv name@ removes the specified environment variable from the +-- environment of the current process. +-- +-- Throws `Control.Exception.IOException` if @name@ is the empty string or +-- contains an equals sign. +unsetEnv :: String -> IO () +# ifdef mingw32_HOST_OS +unsetEnv key = withCWString key $ \k -> do + success <- c_SetEnvironmentVariable k nullPtr + unless success $ do + -- We consider unsetting an environment variable that does not exist not as + -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. + err <- c_GetLastError + unless (err == eRROR_ENVVAR_NOT_FOUND) $ do + throwGetLastError "unsetEnv" +# else +unsetEnv = Posix.unsetEnv +# endif +#endif diff --git a/src/System/Exit/Compat.hs b/src/System/Exit/Compat.hs --- a/src/System/Exit/Compat.hs +++ b/src/System/Exit/Compat.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -module System.Exit.Compat ( - module Base -, die -) where - -import System.Exit as Base - -#if !(MIN_VERSION_base(4,8,0)) - -import Prelude.Compat -import System.IO - --- | Write given error message to `stderr` and terminate with `exitFailure`. --- --- @since 4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +module System.Exit.Compat ( + module Base +, die +) where + +import System.Exit as Base + +#if !(MIN_VERSION_base(4,8,0)) + +import Prelude.Compat +import System.IO + +-- | Write given error message to `stderr` and terminate with `exitFailure`. +-- +-- @since 4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure +#endif diff --git a/src/Text/Read/Compat.hs b/src/Text/Read/Compat.hs --- a/src/Text/Read/Compat.hs +++ b/src/Text/Read/Compat.hs @@ -1,58 +1,58 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} -module Text.Read.Compat ( - -- * The 'Read' class - Read(..), - ReadS, - - -- * Haskell 2010 functions - reads, - read, - readParen, - lex, - - -- * New parsing functions - module Text.ParserCombinators.ReadPrec, - L.Lexeme(..), - lexP, - parens, - readListDefault, - readListPrecDefault, - readEither, - readMaybe - - ) where - -import Text.Read -import Text.ParserCombinators.ReadPrec -import qualified Text.Read.Lex as L - -#if !(MIN_VERSION_base(4,6,0)) -import Prelude.Compat -import qualified Text.ParserCombinators.ReadP as P - --- | Parse a string using the 'Read' instance. --- Succeeds if there is exactly one valid result. --- A 'Left' value indicates a parse error. --- --- /Since: 4.6.0.0/ -readEither :: Read a => String -> Either String a -readEither s = - case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - where - read' = - do x <- readPrec - lift P.skipSpaces - return x - --- | Parse a string using the 'Read' instance. --- Succeeds if there is exactly one valid result. --- --- /Since: 4.6.0.0/ -readMaybe :: Read a => String -> Maybe a -readMaybe s = case readEither s of - Left _ -> Nothing - Right a -> Just a -#endif +{-# LANGUAGE CPP, NoImplicitPrelude #-} +module Text.Read.Compat ( + -- * The 'Read' class + Read(..), + ReadS, + + -- * Haskell 2010 functions + reads, + read, + readParen, + lex, + + -- * New parsing functions + module Text.ParserCombinators.ReadPrec, + L.Lexeme(..), + lexP, + parens, + readListDefault, + readListPrecDefault, + readEither, + readMaybe + + ) where + +import Text.Read +import Text.ParserCombinators.ReadPrec +import qualified Text.Read.Lex as L + +#if !(MIN_VERSION_base(4,6,0)) +import Prelude.Compat +import qualified Text.ParserCombinators.ReadP as P + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- A 'Left' value indicates a parse error. +-- +-- /Since: 4.6.0.0/ +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- +-- /Since: 4.6.0.0/ +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a +#endif diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}