diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,51 @@ +Change log +========== + +0.1.0 +===== + +* [#7](https://github.com/kowainik/relude/issues/7): + Remove `Container.Class.Container`. Export `Foldable`. +* [#2](https://github.com/kowainik/relude/issues/2): + Remove `microlens` from dependencies. +* [#10](https://github.com/kowainik/relude/issues/10): + Remove `VarArg` module. +* [#9](https://github.com/kowainik/relude/issues/9): + Remove `safe-exceptions` from dependencies. Reexport `Exception` and + `SomeException` from `Control.Exception` instead. +* [#11](https://github.com/kowainik/relude/issues/11): + Remove `TypeOps` module and `type-operators` dependency. +* [#13](https://github.com/kowainik/relude/issues/13): + Remove `list`, `getContents`, `interact`, `getArgs`, `note` functions. + Remove `Lifted.ST` module. + Rename `Lifted.Env` to `Lifted.Exit`. +* [#16](https://github.com/kowainik/relude/issues/16): + Rename `whenLeft`, `whenRight`, `whenLeftM`, `whenRightM` to + `whenLeft_` and `whenRight_`, `whenLeftM_` and `whenRightM_`. + Add `whenLeft`, `whenRight`, `whenLeftM`, `whenRightM` which return + the value. +* [#18](https://github.com/kowainik/relude/issues/18): + Add `LazyStrict` type class for conversions. +* `map` is not `fmap` anymore. Reexport `map` from `Data.List` +* [#12](https://github.com/kowainik/relude/issues/12): + Remove `liquid-haskell` support. +* [#20](https://github.com/kowainik/relude/issues/20): + Add `viaNonEmpty` function. +* [#21](https://github.com/kowainik/relude/issues/21): + Add `MonadFail` instance for `Either`. +* [#17](https://github.com/kowainik/relude/issues/17): + Add `foldMapA` and `foldMapM` functions. +* [#4](https://github.com/kowainik/relude/issues/4): + Rename package to `Relude`. +* [#14](https://github.com/kowainik/relude/issues/14): + Add `Relude.Extra.*` modules which are not exported by default but have useful + functions. +* [#8](https://github.com/kowainik/relude/issues/8): + Introduce `StaticMap` and `DynamicMap` type classes as universal interface for + Map-like structures. + +`relude` uses [PVP Versioning][1]. +The change log is available [on GitHub][2]. + +[1]: https://pvp.haskell.org +[2]: https://github.com/kowainik/relude/releases diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,50 @@ +# Contributing to `relude` + +## :wave: Greetings Traveler! + +We're glad you're reading this, we really appreciate the effort you're +putting in. Thank you for your help in making this library awesome! :sparkles: + +### How to contribute + +#### Report bugs or feature request + +If you have found any bugs or have proposals on how to make this project better, +don't hesitate to create issues +[here](https://github.com/kowainik/relude/issues/new) in free format. + +#### Create a PR + +We love receiving pull requests from everyone. But, please, don't create a PR +without a corresponding issue. It's always better to discuss your future +work first. Even if such an issue exists it's still better to express your willing +to do that issue under comment section. Thus you will show that you're doing +that issue, and nobody else will accidentally do it in parallel with you. Furthermore you +also can discuss the best way to implement that issue! + +To get started with this you should first fork, then clone the repo: + + git clone git@github.com:your-username/relude.git + +Make your changes and consider the following check list to go through before submitting your pull request. + +#### :white_check_mark: Check list + +- [ ] Project compiles +- [ ] New/fixed features work as expected +- [ ] Old features do not break after the change +- [ ] `stylish-haskell` with config in this repo root was used to format code +- [ ] _Recommended:_ Commit messages are in the proper format. If the commit + addresses an issue start the first line of the commit with the issue number in + square parentheses. + + **_Example:_** `[#42] Short commit description` + +If you fix bugs or add new features, please add tests. + +After everything above is done, commit and push to your fork. +Now you are ready to [submit a pull request][pr]! + +---------- +Thanks for spending time on reading this contributing guide! :sparkling_heart: + +[pr]: https://github.com/kowainik/relude/compare/ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) +Copyright (c) 2016-2017, Stephen Diehl, 2017, Serokell, 2018, Kowainik + +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.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,311 @@ +Relude +========= + +[![Build Status](https://travis-ci.org/kowainik/relude.svg?branch=master)](https://travis-ci.org/kowainik/relude) +[![Hackage](https://img.shields.io/hackage/v/relude.svg)](https://hackage.haskell.org/package/relude) +[![Stackage LTS](http://stackage.org/package/relude/badge/lts)](http://stackage.org/lts/package/relude) +[![Stackage Nightly](http://stackage.org/package/relude/badge/nightly)](http://stackage.org/nightly/package/relude) +[![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) + +`relude` is a custom prelude based on `universum`. `relude` tries to achieve the following goals: + +1. **Avoid all** [**partial functions**](https://www.reddit.com/r/haskell/comments/5n51u3/why_are_partial_functions_as_in_head_tail_bad/) + (like `head :: [a] -> a`). The types of partial functions lie about their + behavior and usage of such functions can lead to the unexpected bugs. Though + you can still use some unsafe functions from `Relude.Unsafe` module, but they + are not exported by default. +2. **Type-safety**. We like to make invalid states unrepresantable. And if it's + possible to express this concept through the types then we will do it. + + _Example:_ + ```haskell + whenNotNull :: Applicative f => [a] -> (NonEmpty a -> f ()) -> f () + ``` + instead of + ```haskell + whenNotNull :: Applicative f => [a] -> ([a] -> f ()) -> f () + ``` +3. **Performance.** Prefer `Text` over [`String`](https://www.reddit.com/r/haskell/comments/29jw0s/whats_wrong_with_string/), + use spaceleak-free functions (like our custom `sum` and `product`), introduce + `{-# INLINE #-}` and `{-# SPECIALIZE #-}` pragmas where appropriate. +4. **Minimalism** (low number of dependencies). We don't force users of `relude` to + stick to some specific lens or text formatting or logging library. +5. **Convenience** (like lifted to `MonadIO` functions, more reexports). But we + want to bring common types and functions (like `containers` and `bytestrng`) + into scope because they are used in almost every application anyways. +6. **Provide excellent documentation.** + * Tutorial + * Migration guide from `Prelude` + * Haddock with examples for (almost) every function + (all examples are tested with [`doctest`](http://hackage.haskell.org/package/doctest)) + * Documentation regarding [internal module structure]((http://hackage.haskell.org/package/relude/docs/Relude.html)) + * `relude`-specific [HLint](http://hackage.haskell.org/package/hlint) rules: + [`.hlint.yaml`](.hlint.yaml) +7. **User-friendliness.** Ability to quickly migrate to `relude` if you're familiar + with the common libraries like `text` and `containers`. +8. **Exploration.** Experiment with new ideas and proposals without introducing + breaking changes. + +This README contains introduction to `Relude` and a tutorial on how to use it. + +Structure of this tutorial +-------------------------- + +This tutorial has several parts: + +1. [Motivation.](#motivation-) +2. [Get started.](#get-started-) +3. [Difference from `Prelude`.](#difference-from-prelude-) +4. [Reexports.](#reexports-) +5. [What's new?](#whats-new-) +6. [Migration guide.](#migration-guide-) + +This is neither a tutorial on _Haskell_ nor tutorial on each function contained +in `Relude`. For detailed documentation of every function together with examples +and usage, see [_Haddock documentation_](http://hackage.haskell.org/package/relude). + +Motivation [↑](#structure-of-this-tutorial) +------------------------------------------ + +We decided to base `relude` on `universum` due to the following reasons: + +1. `universum` helps to achieve our goals more than any other custom prelude. +2. We worked on `universum` a lot (just check contributors statistics) and we + know its internal structure. + +The motivation to create another alternative prelude instead of modifying +existing one is that it's hard to change preludes in any way. `relude` +uses approach with `Extra.*` modules which are not exported by default so it's +quite easy to bring something new (that satisfies `relude` goals) and let users +decide to use it or not. + +Unlike `universum`, we are: + +1. Not trying to replace `Foldable` with custom `Container` type class. We only + forbid `elem` and `notElem` functions for sets due to performance reasons. +2. Have less dependencies: no `vector`, no `microlens`, no `safe-exceptions`, no `type-operators`. +3. Have a lot of other different improvements. + +Get started [↑](#structure-of-this-tutorial) +-------------------------------------------- + +If you want to start using `relude` in your project and explore it with the help +of compiler, set everything up according to the instructions below. + +### `base-noprelude` + +This is the recommended way to use custom prelude. It requires you to perform +the following steps: + +1. Replace `base` dependency with corresponding version of `base-noprelude` in + your `.cabal` file. +2. Add the following `Prelude` module to your project (both to filesystem and to `exposed-modules`): + ```haskell + module Prelude + ( module Relude + ) where + + import Relude + ``` +3. Optionally modify your `Prelude` to include more or less functions. Probably + you want to hide something from `Relude` module. Or maybe you want to add + something from `Relude.Extra.*` modules! + +This is a very convenient way to add a custom prelude to your project because +you don't need to import module manually inside each file and enable the +`NoImplicitPrelude` extension. + +### Per-file configuration + +Disable the built-in prelude at the top of your file: + +```haskell +{-# LANGUAGE NoImplicitPrelude #-} +``` + +Or directly in your project `.cabal` file, if you want to use in every module by default: + +```haskell +default-extensions: NoImplicitPrelude +``` + +Then add the following import to your modules: + +```haskell +import Relude +``` + +Difference from Prelude [↑](#structure-of-this-tutorial) +-------------------------------------------------------- + +* `head`, `tail`, `last`, `init` work with `NonEmpty a` instead of `[a]`. +* `undefined` triggers a compiler warning, because you probably don't want to + leave `undefined` in your code. Either use `throwIO`, `Except`, `error` or + `bug`. +* Multiple sorting functions are available without imports: + + `sortBy :: (a -> a -> Ordering) -> [a] -> [a]`: sorts list using given custom comparator. + + `sortWith :: Ord b => (a -> b) -> [a] -> [a]`: sorts a list based on some property of its elements. + + `sortOn :: Ord b => (a -> b) -> [a] -> [a]`: just like `sortWith`, but more + time-efficient if function is calculated slowly (though less + space-efficient). So you should write `sortOn length` (would sort elements + by length) but `sortWith fst` (would sort list of pairs by first element). +* Functions `sum` and `product` are strict now, which makes them more efficient. +* If you try to do something like `putStrLn "hi"`, you'll get an error message if + `OverloadedStrings` is enabled – it happens because the compiler doesn't know what + type to infer for the string. Use `putTextLn` in this case. +* Since `show` doesn't come from `Show` anymore, you need to export `Show` from + `Text.Show` module if you want to implement `Show` instance manually. +* You can't call `elem` and `notElem` functions over `Set` and `HashSet`. These + functions are forbidden for these two types because of the performance reasons. +* `error` takes `Text`. +* `lookup` doesn't work on list of pairs. + +Reexports [↑](#structure-of-this-tutorial) +------------------------------------------ + +### Commonly used libraries + +First of all, we reexport some generally useful modules: `Control.Applicative`, +`Data.Traversable`, `Data.Monoid`, `Control.DeepSeq`, `Data.List`, and lots of +others. Just remove unneeded imports after importing `Relude` (you can use +`.hlint.yaml` file for this). + +Then, some commonly used types: `Map/HashMap/IntMap`, `Set/HashSet/IntSet`, +`Seq`, `Text` and `ByteString` (as well as synonyms `LText` and `LByteString` +for lazy versions). + +`liftIO` and `MonadIO` are exported by default. A lot of `IO` functions are +generalized to `MonadIO`. + +`deepseq` is exported. For instance, if you want to force deep evaluation of +some value (in IO), you can write `evaluateNF a`. WHNF evaluation is possible +with `evaluateWHNF a`. + +We also reexport big chunks of these libraries: `mtl`, `stm`. + +[`Bifunctor`](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Bifunctor.html) +type class with useful instances is exported. + +* `first` and `second` functions apply a function to first/second part of a tuple (for tuples). +* `bimap` takes two functions and applies them to first and second parts respectively. + +### Text + +We export `Text` and `LText`, and some functions work with `Text` instead of `String` – +specifically, IO functions (`readFile`, `putStrLn`, etc) and `show`. In fact, `show` +is polymorphic and can produce strict or lazy `Text`, `String`, or `ByteString`. +Also, `toText/toLText/toString` can convert `Text|LText|String` types to +`Text/LText/String`. If you want to convert to and from `ByteString` use +`encodeUtf8/decodeUtf8` functions. + +### Debugging and `undefined`s + +`trace`, `traceM`, `traceShow`, etc. are available by default. GHC will warn you +if you accidentally leave them in code, however (same for `undefined`). + +We also have `data Undefined = Undefined` (which, too, comes with warnings). + +### Exceptions + +TODO: write about reexports, `Bug` and `Exc` pattern. + +What's new? [↑](#structure-of-this-tutorial) +-------------------------------------------- + +Finally, we can move to part describing the new cool features we bring with `relude`. + +* Safe analogue for `head` function: `safeHead :: [a] -> Maybe a` or you can + use our `viaNonEmpty` function to get `Maybe a`: `viaNonEmpty head :: [a] -> Maybe a`. +* `uncons` splits a list at the first element. +* `ordNub` and `sortNub` are _O(n log n)_ versions of `nub` (which is quadratic) + and `hashNub` and `unstableNub` are almost _O(n)_ versions of `nub`. +* `(&)` – reverse application. `x & f & g` instead of `g $ f $ x` is useful sometimes. +* `whenM`, `unlessM`, `ifM`, `guardM` are available and do what you expect + them to do (e.g. `whenM (doesFileExist "foo")`). +* General fold functions: + ```haskell + foldMapA :: (Monoid b, Applicative m, Foldable f) => (a -> m b) -> f a -> m b + foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b + ``` +* `readMaybe` and `readEither` are like `read` but total and give either + `Maybe` or `Either` with parse error. +* `when(Just|Nothing|Left|Right|NotEmpty)[M][_]` + let you conditionally execute something. Before: + + ```haskell + case mbX of + Nothing -> return () + Just x -> f x + ``` + + After: + + ```haskell + whenJust mbX $ \x -> + f x + ``` + +* `for_` for loops. There's also `forM_` but `for_` looks a bit nicer. + + ```haskell + for_ [1..10] $ \i -> do + ... + ``` + +* `andM`, `allM`, `anyM`, `orM` are monadic version of corresponding functions from `base`. + +* Conversions between `Either` and `Maybe` like `rightToMaybe` and `maybeToLeft` + with clear semantic. +* `using(Reader|State)[T]` functions as aliases for `flip run(Reader|State)[T]`. +* [`One` type class](src/Relude/Container/One.hs) + for creating singleton containers. Even monomorhpic ones like `Text`. +* [`StaticMap` and `DynamicMap`type classes](src/Relude/Extra/Map.hs) as a + general interface for `Map`-like data structures. +* `evaluateWHNF` and `evaluateNF` functions as clearer and lifted aliases for + `evaluate` and `evaluate . force`. +* `MonadFail` instance for `Either`. + +Migration guide [↑](#structure-of-this-tutorial) +------------------------------------------------ + +In order to replace default `Prelude` with `relude` you should start with instructions given in +[_get started_](#get-started-) section. + +This section describes what you need to change to make your code compile with `relude`. + +1. Enable `-XOverloadedStrings` extension by default for your project. +2. Since `head`, `tail`, `last` and `init` work for `NonEmpty` you should + refactor your code in one of the multiple ways described below: + 1. Change `[a]` to `NonEmpty a` where it makes sense. + 2. Use functions which return `Maybe`. There is the `viaNonEmpty` function for this. + And you can use it like `viaNonEmpty last l`. + + `viaNonEmpty head l` is `safeHead l` + + `tail` is `drop 1`. It's almost never a good idea to use `tail` from `Prelude`. + 3. Add `import qualified Relude.Unsafe as Unsafe` and replace function with qualified usage. +3. If you use `fromJust` or `!!` you should use them from `import qualified Relude.Unsafe as Unsafe`. +4. If you use `foldr` or `forM_` or similar for something like `Maybe a` or + `Either a b` it's recommended to replace usages of such function with + monomorhpic alternatives: + * `Maybe` + + `(?:) :: Maybe a -> a -> a` + + `fromMaybe :: a -> Maybe a -> a` + + `maybeToList :: Maybe a -> [a]` + + `maybeToMonoid :: Monoid m => Maybe m -> m` + + `maybe :: b -> (a -> b) -> Maybe a -> b` + + `whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()` + + `whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m ()` + + * `Either` + + `fromLeft :: a -> Either a b -> a` + + `fromRight :: b -> Either a b -> b` + + `either :: (a -> c) -> (b -> c) -> Either a b -> c` + + `whenRight_ :: Applicative f => Either l r -> (r -> f ()) -> f ()` + + `whenRightM_ :: Monad m => m (Either l r) -> (r -> m ()) -> m ()` + +5. Forget about `String` type. + + Replace `putStr` and `putStrLn` with `putText` and `putTextLn`. + + Replace `(++)` with `(<>)` for `String`-like types. + + Try to use [`fmt`](http://hackage.haskell.org/package/fmt) library if you need to construct messages. + + Use `toText/toLText/toString` functions to convert to `Text/LazyText/String` types. + + Use `encodeUtf8/decodeUtf8` to convert to/from `ByteString`. +6. Run `hlint` using `.hlint.yaml` file from `relude` package to cleanup code and imports. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,94 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +module Main where + +import Relude hiding (show) + +import Data.List (nub) +import Gauge (Benchmark, bench, bgroup, nf) +import Gauge.Main (defaultMain) +import Prelude (show) + +import qualified Data.HashSet as HashSet (insert) +import qualified Data.List.NonEmpty as NonEmpty (group, head) +import qualified Relude.Unsafe as Unsafe + +main :: IO () +main = defaultMain + [ bgroupList listOfSmall "small" + , bgroupList listOfBig "big" + , bgroupList (nStrings 'z') "small str" + , bgroupList (nStrings 'c') "big str" + , bgroupFold + ] + +bgroupList :: forall a . (Ord a, Hashable a, NFData a) + => (Int -> [a]) + -> String + -> Benchmark +bgroupList f name = bgroup name $ map ($ f) + [ bgroupNubAll 100 + , bgroupNubAll 500 + , bgroupNubAll 1000 + , bgroupNubHugeList 5000 + , bgroupNubHugeList 500000 + , bgroupNubHugeList 1000000 + ] + where + bgroupNubAll :: Int -> (Int -> [a]) -> Benchmark + bgroupNubAll = bgroupNub True + + bgroupNubHugeList :: Int -> (Int -> [a]) -> Benchmark + bgroupNubHugeList = bgroupNub False + + bgroupNub :: Bool -> Int -> (Int -> [a]) -> Benchmark + bgroupNub isNub n listOf = bgroup (show n) nubBenchs + where + listN :: [a] + listN = listOf n + + nubBenchs :: [Benchmark] + nubBenchs = + (if isNub + then (:) (bench "nub" $ nf nub listN) + else id) + [ bench "ordNub" $ nf ordNub (listN :: [a]) + , bench "hashNub" $ nf hashNub (listN :: [a]) + , bench "sortNub" $ nf sortNub (listN :: [a]) + , bench "hashSet" $ nf unstableNub (listN :: [a]) + , bench "groupSort" $ nf groupSort (listN :: [a]) + , bench "safeSort" $ nf safeSort (listN :: [a]) + ] + + groupSort :: [a] -> [a] + groupSort = map Unsafe.head . group . sort + + safeSort :: [a] -> [a] + safeSort = map NonEmpty.head . NonEmpty.group . sort + +listOfSmall :: Int -> [Int] +listOfSmall n = let part = n `div` 100 in concat $ replicate part [1..100] + +listOfBig :: Int -> [Int] +listOfBig n = let part = n `div` 2 in [1..part] ++ [1..part] + +allStrings :: Char -> [String] +allStrings ch = [ c : s | s <- "" : allStrings ch, c <- ['a'..ch] ] + +nStrings :: Char -> Int -> [Text] +nStrings ch n = take n $ map toText $ allStrings ch + +-- | Checks that 'foldl'' is implemented efficiently for 'Relude.List' +bgroupFold :: Benchmark +bgroupFold = do + let testList = [1..100000] :: [Int] + let flipFoldl' = flipfoldl' HashSet.insert mempty + let ghcFoldl' = foldl' (\hashSet element -> HashSet.insert element hashSet) mempty + bgroup "foldl'" [ bench "flipped" $ nf flipFoldl' testList + , bench "base" $ nf ghcFoldl' testList + ] diff --git a/relude.cabal b/relude.cabal new file mode 100644 --- /dev/null +++ b/relude.cabal @@ -0,0 +1,184 @@ +name: relude +version: 0.1.0 +synopsis: Custom prelude from Kowainik +description: + == Goals + . + * __Avoid all [partial functions](https://www.reddit.com/r/haskell/comments/5n51u3/why_are_partial_functions_as_in_head_tail_bad/)__ + (like @head :: [a] -> a@). The types of partial functions lie about their + behavior and usage of such functions can lead to the unexpected bugs. Though + you can still use some unsafe functions from @Relude.Unsafe@ module, but they + are not exported by default. + . + * __Type-safety__. We like to make invalid states unrepresantable. And if it's + possible to express this concept through the types then we will do it. + /Example:/ @ whenNotNull :: Applicative f => [a] -> (NonEmpty a -> f ()) -> f () @ + . + * __Performance.__ Prefer @Text@ over @[String](https://www.reddit.com/r/haskell/comments/29jw0s/whats_wrong_with_string/)@, + use spaceleak-free functions (like our custom @sum@ and @product@). + . + * __Minimalism__ (low number of dependencies). We don't force users of @relude@ to + stick to some specific lens or text formatting or logging library. + . + * __Convenience__ (like lifted to @MonadIO@ functions, more reexports). But we + want to bring common types and functions (like @containers@ and @bytestrng@) + into scope because they are used in almost every application anyways. + . + * __Provide excellent documentation.__ + . + 1. Tutorial + . + 2. Migration guide from @Prelude@ + . + 3. Haddock with examples for (almost) every function + (all examples are tested with [`doctest`](http://hackage.haskell.org/package/doctest)) + . + 4. Documentation regarding [internal module structure]((http://hackage.haskell.org/package/relude/docs/Relude.html)) + . + 5. @relude@-specific [HLint](http://hackage.haskell.org/package/hlint) rules: @[.hlint.yaml](https://github.com/kowainik/relude/blob/master/.hlint.yaml)@ + . + * __User-friendliness.__ Ability to quickly migrate to @relude@ if you're familiar + with the common libraries like @text@ and @containers@. + . + * __Exploration.__ Experiment with new ideas and proposals without introducing + breaking changes. + +homepage: https://github.com/kowainik/relude +bug-reports: https://github.com/kowainik/relude/issues +license: MIT +license-file: LICENSE +author: Stephen Diehl, @serokell, Kowainik +maintainer: Kowainik +copyright: 2016 Stephen Diehl, 2016-2018 Serokell, 2018 Kowainik +category: Prelude +stability: stable +build-type: Simple +cabal-version: 1.24 +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.3 +extra-doc-files: CHANGELOG.md + , CONTRIBUTING.md + , README.md + +source-repository head + type: git + location: git@github.com:kowainik/relude.git + +library + hs-source-dirs: src + exposed-modules: + Relude + Relude.Applicative + Relude.Base + Relude.Bool + Relude.Bool.Guard + Relude.Bool.Reexport + Relude.Container + Relude.Container.One + Relude.Container.Reexport + Relude.Debug + Relude.DeepSeq + Relude.Exception + Relude.Foldable + Relude.Foldable.Fold + Relude.Foldable.Reexport + Relude.Function + Relude.Functor + Relude.Functor.Fmap + Relude.Functor.Reexport + Relude.Lifted + Relude.Lifted.Concurrent + Relude.Lifted.Exit + Relude.Lifted.File + Relude.Lifted.IORef + Relude.List + Relude.List.Reexport + Relude.List.Safe + Relude.Monad + Relude.Monad.Either + Relude.Monad.Maybe + Relude.Monad.Reexport + Relude.Monad.Trans + Relude.Monoid + Relude.Nub + Relude.Print + Relude.String + Relude.String.Conversion + Relude.String.Reexport + + -- not exported by default + Relude.Extra.Bifunctor + Relude.Extra.Enum + Relude.Extra.Group + Relude.Extra.Map + Relude.Unsafe + + + ghc-options: -Wall -fwarn-implicit-prelude + + build-depends: base >= 4.8 && < 5 + , bytestring + , containers + , deepseq + , ghc-prim >= 0.4.0.0 + , hashable + , mtl + , stm + , text + , transformers + , unordered-containers + , utf8-string + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + OverloadedStrings + +test-suite relude-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + + other-modules: Test.Relude.Property + + build-depends: base >= 4.8 && < 5 + , relude + , bytestring + , text + , utf8-string + , hedgehog + , tasty + , tasty-hedgehog + + ghc-options: -Wall -threaded + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + +test-suite relude-doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctest.hs + + build-depends: base >= 4.8 && < 5 + , doctest + , Glob + + ghc-options: -threaded + default-language: Haskell2010 + +benchmark relude-benchmark + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: benchmark + main-is: Main.hs + build-depends: base < 5 + , relude + , containers + , gauge + , unordered-containers + if impl(ghc == 7.10.3) + build-depends: semigroups >= 0.18 + + default-extensions: NoImplicitPrelude + ScopedTypeVariables diff --git a/src/Relude.hs b/src/Relude.hs new file mode 100644 --- /dev/null +++ b/src/Relude.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE Trustworthy #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +{- | Main module that reexports all functionality allowed to use +without importing any other modules. Just add next lines to your +module to replace default 'Prelude' with better one. + +@ +\{\-\# LANGUAGE NoImplicitPrelude \#\-\} + +__import__ "Relude" +@ + +This documentation section contains description of internal module structure to +help navigate between modules, search for interesting functionalities and +understand where you need to put your new changes. + +Functions and types are distributed across multiple modules and grouped by +meaning or __theme__. Name of the module should give you hints regarding what +this module contains. Some /themes/ contain a great amount of both reexported +functions and functions of our own. To make it easier to understand these huge +chunks of functions, all reexported stuff is moved into separate module with +name @Relude.SomeTheme.Reexport@ and our own functions and types are in +@Relude.SomeTheme.SomeName@. For example, see modules +"Relude.Container.Class" and "Relude.Container.Reexport". + +Below is a short description of what you can find under different modules: + +* __"Relude.Applicative"__: reexports from "Control.Applicative" and some + general-purpose applicative combinators. +* __"Relude.Base"__: different general types and type classes from @base@ + package ('Int', 'Num', 'Generic', etc.) not exported by other modules. +* __"Relude.Bool"__: 'Bool' data type with different predicates and combinators. +* __"Relude.Debug"__: @trace@-like debugging functions with compile-time + warnings (so you don't forget to remove them) +* __"Relude.DeepSeq"__: reexports from "Control.DeepSeq" module and + functions to evaluate expressions to weak-head normal form or normal form. +* __"Relude.Exception"__: reexports "Control.Exception.Safe" from + @safe-exceptions@ package, 'bug' as better 'error', 'Exc' pattern synonym for + convenient pattern-matching on exceptions. +* __"Relude.Foldable"__: reexports functions for 'Foldable' and 'Traversable'. +* __"Relude.Function"__: almost everything from "Data.Function" module. +* __"Relude.Functor"__: reexports from "Data.Functor", "Data.Bifunctor", + other useful 'Functor' combinators. +* __"Relude.Lifted"__: lifted to 'MonadIO' functions to work with console, + files, 'IORef's, 'MVar's, etc. +* __"Relude.List"__: big chunk of "Data.List", 'NonEmpty' type and + functions for this type ('head', 'tail', 'last', 'init'). +* __"Relude.Monad"__: monad transormers, combinators for 'Maybe' and 'Either'. +* __"Relude.Monoid"__: reexports from "Data.Monoid" and "Data.Semigroup". +* __"Relude.Nub"__: better versions of @nub@ function for list. +* __"Relude.Print"__: polymorphic 'putStrLn' function and functions to print 'Text'. +* __"Relude.String"__: reexports from @text@ and @bytestring@ packages with + conversion functions between different textual types. +* __"Relude.Unsafe"__: unsafe functions (produce 'error'). + Not exported by "Relude" module by default. +-} + +module Relude + ( -- * Reexports from base and from modules in this repo + module Relude.Applicative + , module Relude.Base + , module Relude.Bool + , module Relude.Container + , module Relude.Debug + , module Relude.DeepSeq + , module Relude.Exception + , module Relude.Foldable + , module Relude.Function + , module Relude.Functor + , module Relude.Lifted + , module Relude.List + , module Relude.Monad + , module Relude.Monoid + , module Relude.Nub + , module Relude.Print + , module Relude.String + ) where + +import Relude.Applicative +import Relude.Base +import Relude.Bool +import Relude.Container +import Relude.Debug +import Relude.DeepSeq +import Relude.Exception +import Relude.Foldable +import Relude.Function +import Relude.Functor +import Relude.Lifted +import Relude.List +import Relude.Monad +import Relude.Monoid +import Relude.Nub +import Relude.Print +import Relude.String diff --git a/src/Relude/Applicative.hs b/src/Relude/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Applicative.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Convenient utils to work with 'Applicative'. There were more functions in this module +-- (see ) +-- but only convenient ans most used are left. + +module Relude.Applicative + ( module Control.Applicative + , pass + ) where + +import Control.Applicative (Alternative (..), Applicative (..), Const (..), ZipList (..), liftA2, + liftA3, optional, (<**>)) + +-- $setup +-- >>> import Relude.Monad (Maybe) + +-- | Shorter alias for @pure ()@. +-- +-- >>> pass :: Maybe () +-- Just () +pass :: Applicative f => f () +pass = pure () + +{- +orAlt :: (Alternative f, Monoid a) => f a -> f a +orAlt f = f <|> pure mempty + +orEmpty :: Alternative f => Bool -> a -> f a +orEmpty b a = if b then pure a else empty + +eitherA :: Alternative f => f a -> f b -> f (Either a b) +eitherA a b = (Left <$> a) <|> (Right <$> b) + +purer :: (Applicative f, Applicative g) => a -> f (g a) +purer = pure . pure + +liftAA2 :: (Applicative f, Applicative g) => (a -> b -> c) -> f (g a) -> f (g b) -> f (g c) +liftAA2 = liftA2 . liftA2 + +(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) +(<<*>>) = liftA2 (<*>) +-} diff --git a/src/Relude/Base.hs b/src/Relude/Base.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Base.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Reexports from @GHC.*@ modules of +-- package. + +module Relude.Base + ( -- * Base types + module Data.Bits + , module Data.Char + , module Data.Int + , module Data.Word + , Natural + + -- * Base type classes + , module Data.Eq + , module Data.Ord + + -- * System IO + , module System.IO + + -- * Types for type-level computation + , module Data.Coerce + , module Data.Kind + , module Data.Proxy + , module Data.Typeable + , module Data.Void + + , module GHC.Base + , module GHC.Enum + , module GHC.Float + , module GHC.Generics + , module GHC.Num + , module GHC.Real + , module GHC.Show + +#if MIN_VERSION_base(4,10,0) + , module GHC.TypeNats +#else + , module GHC.TypeLits +#endif + + , module GHC.OverloadedLabels + , module GHC.ExecutionStack + , module GHC.Stack + + , ($!) + ) where + +-- Base types +import Data.Bits (xor) +import Data.Char (Char, chr) +import Data.Int (Int, Int16, Int32, Int64, Int8) +import Data.Word (Word, Word16, Word32, Word64, Word8, byteSwap16, byteSwap32, byteSwap64) +import Numeric.Natural (Natural) + +-- IO +import System.IO (FilePath, Handle, IO, IOMode (..), stderr, stdin, stdout, withFile) + +-- Base typeclasses +import Data.Eq (Eq (..)) +import Data.Ord (Down (..), Ord (..), Ordering (..), comparing) + +-- Types for type-level computation +import Data.Coerce (Coercible, coerce) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Data.Void (Void, absurd, vacuous) + +import GHC.Base (String, asTypeOf, maxInt, minInt, ord, seq) +import GHC.Enum (Bounded (..), Enum (..), boundedEnumFrom, boundedEnumFromThen) +import GHC.Float (Double (..), Float (..), Floating (acos, acosh, asin, asinh, atan, atanh, cos, cosh, exp, logBase, pi, sin, sinh, sqrt, tan, tanh, (**))) +import GHC.Generics (Generic) +import GHC.Num (Integer, Num (..), subtract) +import GHC.Real hiding (showSigned, (%)) +import GHC.Show (Show) + +#if MIN_VERSION_base(4,10,0) +import GHC.TypeNats (CmpNat, KnownNat, Nat, SomeNat (..), natVal, someNatVal) +#else +import GHC.TypeLits (CmpNat, KnownNat, Nat, SomeNat (..), natVal, someNatVal) +#endif + +import GHC.ExecutionStack (getStackTrace, showStackTrace) +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.Stack (CallStack, HasCallStack, callStack, currentCallStack, getCallStack, + prettyCallStack, prettySrcLoc, withFrozenCallStack) + +-- $setup +-- >>> import Relude.Function (const, ($)) + +-- | Stricter version of 'Data.Function.$' operator. +-- Default Prelude defines this at the toplevel module, so we do as well. +-- +-- >>> const 3 $ Prelude.undefined +-- 3 +-- >>> const 3 $! Prelude.undefined +-- *** Exception: Prelude.undefined +-- CallStack (from HasCallStack): +-- error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err +-- ... +($!) :: (a -> b) -> a -> b +f $! x = let !vx = x in f vx +infixr 0 $! diff --git a/src/Relude/Bool.hs b/src/Relude/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Bool.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Safe #-} + +-- | Convenient commonly used and very helpful functions to work with +-- 'Bool' and also with monads. + +module Relude.Bool + ( module Relude.Bool.Guard + , module Relude.Bool.Reexport + ) where + +import Relude.Bool.Guard +import Relude.Bool.Reexport diff --git a/src/Relude/Bool/Guard.hs b/src/Relude/Bool/Guard.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Bool/Guard.hs @@ -0,0 +1,74 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module contains monadic predicates. + +module Relude.Bool.Guard + ( guardM + , ifM + , unlessM + , whenM + ) where + +import Relude.Bool.Reexport (Bool, guard, unless, when) +import Relude.Function (flip) +import Relude.Monad (Monad, MonadPlus, (>>=)) + +-- $setup +-- >>> import Relude.Applicative (pure) +-- >>> import Relude.Bool.Reexport (Bool (..)) +-- >>> import Relude.Function (($)) +-- >>> import Relude.Monad (Maybe (..)) +-- >>> import Relude.Print (putTextLn) + +-- | Monadic version of 'when'. +-- +-- >>> whenM (pure False) $ putTextLn "No text :(" +-- >>> whenM (pure True) $ putTextLn "Yes text :)" +-- Yes text :) +-- >>> whenM (Just True) (pure ()) +-- Just () +-- >>> whenM (Just False) (pure ()) +-- Just () +-- >>> whenM Nothing (pure ()) +-- Nothing +whenM :: Monad m => m Bool -> m () -> m () +whenM p m = p >>= flip when m +{-# INLINE whenM #-} + +-- | Monadic version of 'unless'. +-- +-- >>> unlessM (pure False) $ putTextLn "No text :(" +-- No text :( +-- >>> unlessM (pure True) $ putTextLn "Yes text :)" +unlessM :: Monad m => m Bool -> m () -> m () +unlessM p m = p >>= flip unless m +{-# INLINE unlessM #-} + +-- | Monadic version of @if-then-else@. +-- +-- >>> ifM (pure True) (putTextLn "True text") (putTextLn "False text") +-- True text +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM p x y = p >>= \b -> if b then x else y +{-# INLINE ifM #-} + +-- | Monadic version of 'guard'. Occasionally useful. +-- Here some complex but real-life example: +-- +-- @ +-- findSomePath :: IO (Maybe FilePath) +-- +-- somePath :: MaybeT IO FilePath +-- somePath = do +-- path <- MaybeT findSomePath +-- guardM $ liftIO $ doesDirectoryExist path +-- return path +-- @ +guardM :: MonadPlus m => m Bool -> m () +guardM f = f >>= guard +{-# INLINE guardM #-} diff --git a/src/Relude/Bool/Reexport.hs b/src/Relude/Bool/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Bool/Reexport.hs @@ -0,0 +1,16 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports functions to work with 'Bool' type. + +module Relude.Bool.Reexport + ( module Control.Monad + , module Data.Bool + ) where + +import Control.Monad (guard, unless, when) +import Data.Bool (Bool (..), bool, not, otherwise, (&&), (||)) diff --git a/src/Relude/Container.hs b/src/Relude/Container.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Container.hs @@ -0,0 +1,16 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module exports all container-related stuff. + +module Relude.Container + ( module Relude.Container.One + , module Relude.Container.Reexport + ) where + +import Relude.Container.One +import Relude.Container.Reexport diff --git a/src/Relude/Container/One.hs b/src/Relude/Container/One.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Container/One.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +{- | Typeclass for creating structures from singleton element. +-} + +module Relude.Container.One + ( One (..) + ) where + +import Relude.Base (Char, Int, Word8) +import Relude.Container.Reexport (HashMap, HashSet, Hashable, IntMap, IntSet, Map, Set, uncurry) + +import qualified Data.List.NonEmpty as NE + +import qualified Data.Sequence as SEQ + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HashSet +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import qualified Data.Set as Set + +-- $setup +-- >>> import Relude.Base (Int, String) +-- >>> import Relude.Bool (Bool (..)) +-- >>> import Relude.String (Text) +-- >>> import qualified Data.HashMap.Strict as HashMap + +{- | Type class for types that can be created from one element. @singleton@ +is lone name for this function. Constructions of different type differ: +@:[]@ for lists, two arguments for Maps. Also some data types are monomorphic. + +>>> one True :: [Bool] +[True] +>>> one 'a' :: Text +"a" +>>> one (3, "hello") :: HashMap Int String +fromList [(3,"hello")] +-} +class One x where + type OneItem x + -- | Create a list, map, 'Text', etc from a single element. + one :: OneItem x -> x + +-- Lists + +instance One [a] where + type OneItem [a] = a + one = (:[]) + {-# INLINE one #-} + +instance One (NE.NonEmpty a) where + type OneItem (NE.NonEmpty a) = a + one = (NE.:|[]) + {-# INLINE one #-} + +instance One (SEQ.Seq a) where + type OneItem (SEQ.Seq a) = a + one = (SEQ.empty SEQ.|>) + {-# INLINE one #-} + +-- Monomorphic sequences + +instance One T.Text where + type OneItem T.Text = Char + one = T.singleton + {-# INLINE one #-} + +instance One TL.Text where + type OneItem TL.Text = Char + one = TL.singleton + {-# INLINE one #-} + +instance One BS.ByteString where + type OneItem BS.ByteString = Word8 + one = BS.singleton + {-# INLINE one #-} + +instance One BSL.ByteString where + type OneItem BSL.ByteString = Word8 + one = BSL.singleton + {-# INLINE one #-} + +-- Maps + +instance One (Map k v) where + type OneItem (Map k v) = (k, v) + one = uncurry M.singleton + {-# INLINE one #-} + +instance Hashable k => One (HashMap k v) where + type OneItem (HashMap k v) = (k, v) + one = uncurry HM.singleton + {-# INLINE one #-} + +instance One (IntMap v) where + type OneItem (IntMap v) = (Int, v) + one = uncurry IM.singleton + {-# INLINE one #-} + +-- Sets + +instance One (Set v) where + type OneItem (Set v) = v + one = Set.singleton + {-# INLINE one #-} + +instance Hashable v => One (HashSet v) where + type OneItem (HashSet v) = v + one = HashSet.singleton + {-# INLINE one #-} + +instance One IntSet where + type OneItem IntSet = Int + one = IS.singleton + {-# INLINE one #-} diff --git a/src/Relude/Container/Reexport.hs b/src/Relude/Container/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Container/Reexport.hs @@ -0,0 +1,32 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports all container related stuff from 'Prelude'. + +module Relude.Container.Reexport + ( module Data.Hashable + , module Data.HashMap.Strict + , module Data.HashSet + , module Data.IntMap.Strict + , module Data.IntSet + , module Data.Map.Strict + , module Data.Sequence + , module Data.Set + , module Data.Tuple + , module GHC.Exts + ) where + +import Data.Hashable (Hashable (hashWithSalt)) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.IntMap.Strict (IntMap) +import Data.IntSet (IntSet) +import Data.Map.Strict (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Tuple (curry, fst, snd, swap, uncurry) +import GHC.Exts (IsList (fromList, fromListN)) diff --git a/src/Relude/Debug.hs b/src/Relude/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Debug.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +#if ( __GLASGOW_HASKELL__ >= 804 ) +{-# LANGUAGE TypeInType #-} +#endif + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Functions for debugging. If you left these functions in your code +-- then warning is generated to remind you about left usages. Also some +-- functions (and data types) are convenient for prototyping. + +module Relude.Debug + ( Undefined (..) + , error + , trace + , traceM + , traceId + , traceShow + , traceShowId + , traceShowM + , undefined + ) where + +import Control.Monad (Monad, return) +import Data.Data (Data) +import Data.Text (Text, unpack) +import Data.Typeable (Typeable) +import GHC.Exts (RuntimeRep, TYPE) +import GHC.Generics (Generic) +import System.IO.Unsafe (unsafePerformIO) + +import Relude.Base (HasCallStack) + +import Relude.Applicative (pass) +import Relude.Print (Print, putStrLn) + +import qualified Prelude as P + +-- | Generalized over string version of 'Debug.Trace.trace' that leaves warnings. +{-# WARNING trace "'trace' remains in code" #-} +trace :: Print b => b -> a -> a +trace string expr = unsafePerformIO (do + putStrLn string + return expr) + +-- | 'P.error' that takes 'Text' as an argument. +error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack + => Text -> a +error s = P.error (unpack s) + +-- | Version of 'Debug.Trace.traceShow' that leaves warning. +{-# WARNING traceShow "'traceShow' remains in code" #-} +traceShow :: P.Show a => a -> b -> b +traceShow a b = trace (P.show a) b + +-- | Version of 'Debug.Trace.traceShow' that leaves warning. +{-# WARNING traceShowId "'traceShowId' remains in code" #-} +traceShowId :: P.Show a => a -> a +traceShowId a = trace (P.show a) a + +-- | Version of 'Debug.Trace.traceShowM' that leaves warning. +{-# WARNING traceShowM "'traceShowM' remains in code" #-} +traceShowM :: (P.Show a, Monad m) => a -> m () +traceShowM a = trace (P.show a) pass + +-- | Version of 'Debug.Trace.traceM' that leaves warning and takes 'Text'. +{-# WARNING traceM "'traceM' remains in code" #-} +traceM :: (Monad m) => Text -> m () +traceM s = trace (unpack s) pass + +-- | Version of 'Debug.Trace.traceId' that leaves warning and takes 'Text'. +{-# WARNING traceId "'traceId' remains in code" #-} +traceId :: Text -> Text +traceId s = trace s s + +-- | Similar to 'undefined' but data type. +{-# WARNING Undefined "'Undefined' type remains in code" #-} +data Undefined = Undefined + deriving (P.Eq, P.Ord, P.Show, P.Read, P.Enum, P.Bounded, Data, Typeable, Generic) + +-- | 'P.undefined' that leaves warning in code on every usage. +{-# WARNING undefined "'undefined' function remains in code (or use 'error')" #-} +undefined :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => a +undefined = P.undefined diff --git a/src/Relude/DeepSeq.hs b/src/Relude/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/src/Relude/DeepSeq.hs @@ -0,0 +1,43 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module contains useful functions to evaluate expressions to weak-head +-- normal form or just normal form. Useful to force traces or @error@ inside +-- monadic computation or to remove space leaks. + +module Relude.DeepSeq + ( module Control.DeepSeq + , evaluateNF + , evaluateNF_ + , evaluateWHNF + , evaluateWHNF_ + ) where + +import Control.DeepSeq (NFData (..), deepseq, force, ($!!)) + +import Relude.Base (seq) +import Relude.Function ((.)) +import Relude.Monad (MonadIO, liftIO, (<$!>)) + +import qualified Control.Exception.Base (evaluate) + +-- | Lifted alias for 'Control.Exception.Base.evaluate' with clearer name. +evaluateWHNF :: MonadIO m => a -> m a +evaluateWHNF = liftIO . Control.Exception.Base.evaluate + +-- | Like 'evaluateWNHF' but discards value. +evaluateWHNF_ :: MonadIO m => a -> m () +evaluateWHNF_ what = (`seq` ()) <$!> evaluateWHNF what + +-- | Alias for @evaluateWHNF . force@ with clearer name. +evaluateNF :: (NFData a, MonadIO m) => a -> m a +evaluateNF = evaluateWHNF . force + +-- | Alias for @evaluateWHNF . rnf@. Similar to 'evaluateNF' +-- but discards resulting value. +evaluateNF_ :: (NFData a, MonadIO m) => a -> m () +evaluateNF_ = evaluateWHNF . rnf diff --git a/src/Relude/Exception.hs b/src/Relude/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Exception.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Re-exports most useful functionality from 'safe-exceptions'. Also +-- provides some functions to work with exceptions over 'MonadError'. + +module Relude.Exception + ( module Control.Exception + + , Bug (..) + , bug + , pattern Exc + ) where + +import Control.Exception (Exception (..), SomeException (..)) +import Data.List ((++)) +import GHC.Show (Show) +import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack) + +import Relude.Function ((.)) +import Relude.Monad (Maybe (..)) + +import qualified Control.Exception as E (displayException, throw, toException) + +-- | Type that represents exceptions used in cases when a particular codepath +-- is not meant to be ever executed, but happens to be executed anyway. +data Bug = Bug SomeException CallStack + deriving (Show) + +instance Exception Bug where + displayException (Bug e cStack) = E.displayException e ++ "\n" + ++ prettyCallStack cStack + +-- | Generate a pure value which, when forced, will throw the given exception +impureThrow :: Exception e => e -> a +impureThrow = E.throw . E.toException + +-- | Generate a pure value which, when forced, will synchronously +-- throw the exception wrapped into 'Bug' data type. +bug :: (HasCallStack, Exception e) => e -> a +bug e = impureThrow (Bug (E.toException e) callStack) + +{- | Pattern synonym to easy pattern matching on exceptions. So intead of +writing something like this: + +@ +isNonCriticalExc e + | Just (_ :: NodeAttackedError) <- fromException e = True + | Just DialogUnexpected{} <- fromException e = True + | otherwise = False +@ + +you can use 'Exc' pattern synonym: + +@ +isNonCriticalExc = \case + Exc (_ :: NodeAttackedError) -> True -- matching all exceptions of type 'NodeAttackedError' + Exc DialogUnexpected{} -> True + _ -> False +@ + +This pattern is bidirectional. You can use @Exc e@ instead of @toException e@. +-} +pattern Exc :: Exception e => e -> SomeException +pattern Exc e <- (fromException -> Just e) + where + Exc e = toException e diff --git a/src/Relude/Extra/Bifunctor.hs b/src/Relude/Extra/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Extra/Bifunctor.hs @@ -0,0 +1,16 @@ +module Relude.Extra.Bifunctor + ( bimapF + , firstF + , secondF + ) where + +import Relude + +bimapF :: (Functor f, Bifunctor p) => (a -> c) -> (b -> d) -> f (p a b) -> f (p c d) +bimapF f g = fmap (bimap f g) + +firstF :: (Functor f, Bifunctor p) => (a -> c) -> f (p a b) -> f (p c b) +firstF = fmap . first + +secondF :: (Functor f, Bifunctor p) => (b -> d) -> f (p a b) -> f (p a d) +secondF = fmap . second diff --git a/src/Relude/Extra/Enum.hs b/src/Relude/Extra/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Extra/Enum.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Relude.Extra.Enum + ( universe + , next + , safeToEnum + ) where + +import Relude + +-- $setup +-- >>> :set -XTypeApplications + +{- | Returns all values of some 'Bounded' 'Enum' in ascending order. + +>>> data TrafficLight = Red | Blue | Green deriving (Show, Enum, Bounded) +>>> universe :: [TrafficLight] +[Red,Blue,Green] +>>> universe :: [Bool] +[False,True] +-} +universe :: (Bounded a, Enum a) => [a] +universe = [minBound .. maxBound] + +{- | Like 'succ', but doesn't fail on 'maxBound'. Instead it returns 'minBound'. + +>>> next False +True +>>> next True +False +>>> succ True +*** Exception: Prelude.Enum.Bool.succ: bad argument + +-} +next :: (Eq a, Bounded a, Enum a) => a -> a +next e + | e == maxBound = minBound + | otherwise = succ e + +{- | Returns 'Nothing' if given 'Int' outside range. + +>>> safeToEnum @Bool 0 +Just False +>>> safeToEnum @Bool 1 +Just True +>>> safeToEnum @Bool 2 +Nothing +>>> safeToEnum @Bool (-1) +Nothing +-} +safeToEnum :: forall a . (Bounded a, Enum a) => Int -> Maybe a +safeToEnum i = guard (fromEnum @a minBound <= i && i <= fromEnum @a maxBound) *> Just (toEnum i) diff --git a/src/Relude/Extra/Group.hs b/src/Relude/Extra/Group.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Extra/Group.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- +Copyright: (c) 2017-2018 Serokelll + (c) 2018 Kowainik +License: MIT +-} + +module Relude.Extra.Group + ( groupBy + , groupOneBy + ) where + +import Relude +import Relude.Extra.Map + +import Data.List.NonEmpty ((<|)) + +{- | Groups elements using results of the given function as keys. + +>>> groupBy even [1..6] :: HashMap Bool (NonEmpty Int) +fromList [(False,5 :| [3,1]),(True,6 :| [4,2])] +-} +groupBy :: forall f t a . (Foldable f, DynamicMap t, Val t ~ NonEmpty a, Monoid t) + => (a -> Key t) -> f a -> t +groupBy f = flipfoldl' hmGroup mempty + where + hmGroup :: a -> t -> t + hmGroup x = + let val :: Maybe (NonEmpty a) -> NonEmpty a + val Nothing = one x + val (Just xs) = x <| xs + in alter (Just . val) (f x) + +{- | Similar to 'groupBy' but keeps only one element as value. + +>>> groupOneBy even [1 .. 6] :: HashMap Bool Int +fromList [(False,1),(True,2)] +-} +groupOneBy :: forall f t a . (Foldable f, DynamicMap t, Val t ~ a, Monoid t) + => (a -> Key t) -> f a -> t +groupOneBy f = flipfoldl' hmGroup mempty + where + hmGroup :: a -> t -> t + hmGroup val m = let key = f val in + case lookup key m of + Nothing -> insert key val m + Just _ -> m diff --git a/src/Relude/Extra/Map.hs b/src/Relude/Extra/Map.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Extra/Map.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | Contains implememtation of polymorhic type classes for things like 'Set' +and 'Map'. +-} + +module Relude.Extra.Map + ( StaticMap (..) + , DynamicMap (..) + , (!?) + , notMember + , lookupDefault + + -- * To pairs + , toPairs + , keys + , elems + ) where + +import GHC.Exts (IsList (Item, toList)) + +import Relude.Applicative (pure, (*>)) +import Relude.Base (Eq, Int, Ord, Type) +import Relude.Bool (Bool, guard, not) +import Relude.Container.Reexport (HashMap, HashSet, Hashable, IntMap, IntSet, Map, Set, fst, snd) +import Relude.Function ((.)) +import Relude.List (map) +import Relude.Monad.Reexport (Maybe (..), fromMaybe) + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +---------------------------------------------------------------------------- +-- Static Map +---------------------------------------------------------------------------- + +{- | Read-only map or set. Contains polymorhic functions which work for both +sets and maps. +-} +class StaticMap t where + type Key t :: Type + type Val t :: Type + + size :: t -> Int + lookup :: Key t -> t -> Maybe (Val t) + member :: Key t -> t -> Bool + +instance Ord k => StaticMap (Map k v) where + type Key (Map k v) = k + type Val (Map k v) = v + + size = M.size + lookup = M.lookup + member = M.member + {-# INLINE size #-} + {-# INLINE lookup #-} + {-# INLINE member #-} + +instance (Eq k, Hashable k) => StaticMap (HashMap k v) where + type Key (HashMap k v) = k + type Val (HashMap k v) = v + + size = HM.size + lookup = HM.lookup + member = HM.member + {-# INLINE size #-} + {-# INLINE lookup #-} + {-# INLINE member #-} + +instance StaticMap (IntMap v) where + type Key (IntMap v) = Int + type Val (IntMap v) = v + + size = IM.size + lookup = IM.lookup + member = IM.member + {-# INLINE size #-} + {-# INLINE lookup #-} + {-# INLINE member #-} + +instance Ord a => StaticMap (Set a) where + type Key (Set a) = a + type Val (Set a) = a + + size = S.size + member = S.member + lookup k m = guard (member k m) *> pure k + {-# INLINE size #-} + {-# INLINE lookup #-} + {-# INLINE member #-} + +instance (Eq a, Hashable a) => StaticMap (HashSet a) where + type Key (HashSet a) = a + type Val (HashSet a) = a + + size = HS.size + member = HS.member + lookup k m = guard (member k m) *> pure k + {-# INLINE size #-} + {-# INLINE lookup #-} + {-# INLINE member #-} + +instance StaticMap IntSet where + type Key IntSet = Int + type Val IntSet = Int + + size = IS.size + member = IS.member + lookup k m = guard (member k m) *> pure k + {-# INLINE size #-} + {-# INLINE lookup #-} + {-# INLINE member #-} + +-- | Operator version of 'lookup' function. +infixl 9 !? +(!?) :: StaticMap t => t -> Key t -> Maybe (Val t) +(!?) m k = lookup k m +{-# INLINE (!?) #-} + +-- | Inverse of 'member' function. +notMember :: StaticMap t => Key t -> t -> Bool +notMember k = not . member k +{-# INLINE notMember #-} + +{- | Return the value to which the specified key is mapped, or the default value +if this map contains no mapping for the key. +-} +lookupDefault :: StaticMap t + => Val t -- ^ Default value to return. + -> Key t -- ^ Key to search + -> t -- ^ Container to search + -> Val t +lookupDefault def k = fromMaybe def . lookup k +{-# INLINE lookupDefault #-} + +---------------------------------------------------------------------------- +-- Dynamic Map +---------------------------------------------------------------------------- + +{- | Modifiable Map. +-} +class StaticMap t => DynamicMap t where + -- insertions + insert :: Key t -> Val t -> t -> t + insertWith :: (Val t -> Val t -> Val t) -> Key t -> Val t -> t -> t + + -- deletions + delete :: Key t -> t -> t + alter :: (Maybe (Val t) -> Maybe (Val t)) -> Key t -> t -> t + +instance Ord k => DynamicMap (Map k v) where + insert = M.insert + insertWith = M.insertWith + delete = M.delete + alter = M.alter + + {-# INLINE insert #-} + {-# INLINE insertWith #-} + {-# INLINE delete #-} + {-# INLINE alter #-} + +instance (Eq k, Hashable k) => DynamicMap (HashMap k v) where + insert = HM.insert + insertWith = HM.insertWith + delete = HM.delete + alter = HM.alter + + {-# INLINE insert #-} + {-# INLINE insertWith #-} + {-# INLINE delete #-} + {-# INLINE alter #-} + +instance DynamicMap (IntMap v) where + insert = IM.insert + insertWith = IM.insertWith + delete = IM.delete + alter = IM.alter + + {-# INLINE insert #-} + {-# INLINE insertWith #-} + {-# INLINE delete #-} + {-# INLINE alter #-} + +---------------------------------------------------------------------------- +-- ToPairs +---------------------------------------------------------------------------- + +-- $setup +-- >>> import qualified Data.HashMap.Strict as HashMap + +{- | Converts the structure to the list of the key-value pairs. + +>>> toPairs (HashMap.fromList [('a', "xxx"), ('b', "yyy")]) +[('a',"xxx"),('b',"yyy")] +-} +toPairs :: (IsList t, Item t ~ (a, b)) => t -> [(a, b)] +toPairs = toList + +{- | Converts the structure to the list of the keys. + +>>> keys (HashMap.fromList [('a', "xxx"), ('b', "yyy")]) +"ab" +-} +keys :: (IsList t, Item t ~ (a, b)) => t -> [a] +keys = map fst . toList + +{- | Converts the structure to the list of the values. + +>>> elems (HashMap.fromList [('a', "xxx"), ('b', "yyy")]) +["xxx","yyy"] +-} +elems :: (IsList t, Item t ~ (a, b)) => t -> [b] +elems = map snd . toList diff --git a/src/Relude/Foldable.hs b/src/Relude/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Foldable.hs @@ -0,0 +1,9 @@ +-- | This module exports all 'Foldable' and 'Traversable' related stuff. + +module Relude.Foldable + ( module Relude.Foldable.Fold + , module Relude.Foldable.Reexport + ) where + +import Relude.Foldable.Fold +import Relude.Foldable.Reexport diff --git a/src/Relude/Foldable/Fold.hs b/src/Relude/Foldable/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Foldable/Fold.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +-- | Fixes and additions to 'Foldable'. + +module Relude.Foldable.Fold + ( flipfoldl' + , foldMapA + , foldMapM + , safeHead + , sum + , product + + , elem + , notElem + + , allM + , anyM + , andM + , orM + ) where + +import GHC.TypeLits (ErrorMessage (..), TypeError) + +import Relude.Applicative (Applicative (..), pure) +import Relude.Base (Constraint, Eq, IO, Num (..), Type, ($!)) +import Relude.Bool (Bool (..)) +import Relude.Container.Reexport (HashSet, Set) +import Relude.Foldable.Reexport (Foldable (..)) +import Relude.Function (flip, (.)) +import Relude.Functor ((<$>)) +import Relude.Monad.Reexport (Maybe (..), Monad (..)) +import Relude.Monoid (Monoid (..)) + +import qualified Data.Foldable as F + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Relude.Base (String, Rational, even, (/)) +-- >>> import Relude.Bool (when) +-- >>> import Relude.Monad (Maybe (..), (>=>)) +-- >>> import Relude.Print (print, putTextLn) +-- >>> import Relude.String (Text, readMaybe) +-- >>> import qualified Data.HashMap.Strict as HashMap + +safeHead :: Foldable f => f a -> Maybe a +safeHead = foldr (\x _ -> Just x) Nothing +{-# INLINE safeHead #-} + +{- | Similar to 'foldl'' but takes a function with its arguments flipped. + +>>> flipfoldl' (/) 5 [2,3] :: Rational +15 % 2 + +-} +flipfoldl' :: Foldable f => (a -> b -> b) -> b -> f a -> b +flipfoldl' f = foldl' (flip f) +{-# INLINE flipfoldl' #-} + +foldMapA :: (Monoid b, Applicative m, Foldable f) => (a -> m b) -> f a -> m b +foldMapA f = foldr step (pure mempty) + where + step a mb = mappend <$> f a <*> mb +{-# INLINE foldMapA #-} + +foldMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b +foldMapM f xs = foldr step return xs mempty + where + step x r z = f x >>= \y -> r $! z `mappend` y +{-# INLINE foldMapM #-} + +{- | Stricter version of 'F.sum'. + +>>> sum [1..10] +55 +-} +sum :: forall a f . (Foldable f, Num a) => f a -> a +sum = foldl' (+) 0 +{-# INLINE sum #-} + +{- | Stricter version of 'F.product'. + +>>> product [1..10] +3628800 +-} +product :: forall a f . (Foldable f, Num a) => f a -> a +product = foldl' (*) 1 +{-# INLINE product #-} + +{- | Like 'F.elem' but doesn't work on 'Set' and 'HashSet' for performance reasons. + +>>> elem 'x' ("abc" :: String) +False +>>> elem False (one True :: Set Bool) +... + • Do not use 'elem' and 'notElem' methods from 'Foldable' on Set + Suggestions: + Instead of + elem :: (Foldable t, Eq a) => a -> t a -> Bool + use + member :: ??? -- TODO +... + Instead of + notElem :: (Foldable t, Eq a) => a -> t a -> Bool + use + notMember :: ??? -- TODO +... +-} +elem :: (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool +elem = F.elem +{-# INLINE elem #-} + +{- | Like 'F.notElem' but doesn't work on 'Set' and 'HashSet' for performance reasons. + +>>> notElem 'x' ("abc" :: String) +True +>>> notElem False (one True :: Set Bool) +... + • Do not use 'elem' and 'notElem' methods from 'Foldable' on Set + Suggestions: + Instead of + elem :: (Foldable t, Eq a) => a -> t a -> Bool + use + member :: ??? -- TODO +... + Instead of + notElem :: (Foldable t, Eq a) => a -> t a -> Bool + use + notMember :: ??? -- TODO +... +-} +notElem :: (Foldable f, DisallowElem f, Eq a) => a -> f a -> Bool +notElem = F.notElem +{-# INLINE notElem #-} + +{- | Monadic version of 'F.and'. + +>>> andM [Just True, Just False] +Just False +>>> andM [Just True] +Just True +>>> andM [Just True, Just False, Nothing] +Just False +>>> andM [Just True, Nothing] +Nothing +>>> andM [putTextLn "1" >> pure True, putTextLn "2" >> pure False, putTextLn "3" >> pure True] +1 +2 +False +-} +andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool +andM = go . toList + where + go [] = pure True + go (p:ps) = do + q <- p + if q then go ps else pure False + +{- | Monadic version of 'F.or'. + +>>> orM [Just True, Just False] +Just True +>>> orM [Just True, Nothing] +Just True +>>> orM [Nothing, Just True] +Nothing +-} +orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool +orM = go . toList + where + go [] = pure False + go (p:ps) = do + q <- p + if q then pure True else go ps + +{- | Monadic version of 'F.all'. + +>>> allM (readMaybe >=> pure . even) ["6", "10"] +Just True +>>> allM (readMaybe >=> pure . even) ["5", "aba"] +Just False +>>> allM (readMaybe >=> pure . even) ["aba", "10"] +Nothing +-} +allM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool +allM p = go . toList + where + go [] = pure True + go (x:xs) = do + q <- p x + if q then go xs else pure False + +{- | Monadic version of 'F.any'. + +>>> anyM (readMaybe >=> pure . even) ["5", "10"] +Just True +>>> anyM (readMaybe >=> pure . even) ["10", "aba"] +Just True +>>> anyM (readMaybe >=> pure . even) ["aba", "10"] +Nothing +-} +anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool +anyM p = go . toList + where + go [] = pure False + go (x:xs) = do + q <- p x + if q then pure True else go xs + +{-# SPECIALIZE andM :: [IO Bool] -> IO Bool #-} +{-# SPECIALIZE orM :: [IO Bool] -> IO Bool #-} +{-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-} +{-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-} + +---------------------------------------------------------------------------- +-- Type level tricks +---------------------------------------------------------------------------- + +type family DisallowElem (f :: Type -> Type) :: Constraint where + DisallowElem Set = TypeError (ElemErrorMessage Set) + DisallowElem HashSet = TypeError (ElemErrorMessage HashSet) + DisallowElem f = () + +type family ElemErrorMessage (t :: k) :: ErrorMessage where + ElemErrorMessage t = + Text "Do not use 'elem' and 'notElem' methods from 'Foldable' on " :<>: ShowType t + :$$: Text "Suggestions:" + :$$: Text " Instead of" + :$$: Text " elem :: (Foldable t, Eq a) => a -> t a -> Bool" + :$$: Text " use" + :$$: Text " member :: ??? -- TODO" + :$$: Text "" + :$$: Text " Instead of" + :$$: Text " notElem :: (Foldable t, Eq a) => a -> t a -> Bool" + :$$: Text " use" + :$$: Text " notMember :: ??? -- TODO" + :$$: Text "" diff --git a/src/Relude/Foldable/Reexport.hs b/src/Relude/Foldable/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Foldable/Reexport.hs @@ -0,0 +1,9 @@ +module Relude.Foldable.Reexport + ( module Data.Foldable + , module Data.Traversable + ) where + +import Data.Foldable (Foldable (fold, foldMap, foldl', foldr, length, null, toList), all, and, any, + asum, concat, concatMap, find, foldlM, forM_, for_, mapM_, or, sequenceA_, + sequence_, traverse_) +import Data.Traversable (Traversable (..), forM, mapAccumL, mapAccumR) diff --git a/src/Relude/Function.hs b/src/Relude/Function.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Function.hs @@ -0,0 +1,20 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports very basic and primitive functions and function combinators. + +module Relude.Function + ( module Data.Function + , identity + ) where + +import Data.Function (const, fix, flip, id, on, ($), (&), (.)) + +-- | Renamed version of 'Prelude.id'. +identity :: a -> a +identity = id +{-# INLINE identity #-} diff --git a/src/Relude/Functor.hs b/src/Relude/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Functor.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} + +-- | Convenient functions to work with 'Functor'. + +module Relude.Functor + ( module Relude.Functor.Fmap + , module Relude.Functor.Reexport + ) where + +import Relude.Functor.Fmap +import Relude.Functor.Reexport diff --git a/src/Relude/Functor/Fmap.hs b/src/Relude/Functor/Fmap.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Functor/Fmap.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module contains useful functions to work with 'Functor' type class. + +module Relude.Functor.Fmap + ( (<<$>>) + ) where + +import Relude.Function ((.)) +import Relude.Functor.Reexport (Functor (..)) + +-- $setup +-- >>> import Relude.Base (negate) +-- >>> import Relude.Monad (Maybe (..)) + +-- | Alias for @fmap . fmap@. Convenient to work with two nested 'Functor's. +-- +-- >>> negate <<$>> Just [1,2,3] +-- Just [-1,-2,-3] +(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<<$>>) = fmap . fmap +infixl 4 <<$>> diff --git a/src/Relude/Functor/Reexport.hs b/src/Relude/Functor/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Functor/Reexport.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports functionality regarding 'Functor' type class. + +module Relude.Functor.Reexport + ( module Control.Arrow + , module Data.Bifunctor + , module Data.Functor + , module Data.Functor.Compose + , module Data.Functor.Identity + ) where + +import Control.Arrow ((&&&)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Functor (Functor (..), void, ($>), (<$>)) +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Identity (Identity (..)) diff --git a/src/Relude/Lifted.hs b/src/Relude/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Lifted.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Lifted versions of base functions. + +module Relude.Lifted + ( module Relude.Lifted.Concurrent + , module Relude.Lifted.Exit + , module Relude.Lifted.File + , module Relude.Lifted.IORef + ) where + +import Relude.Lifted.Concurrent +import Relude.Lifted.Exit +import Relude.Lifted.File +import Relude.Lifted.IORef diff --git a/src/Relude/Lifted/Concurrent.hs b/src/Relude/Lifted/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Lifted/Concurrent.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Concurrency useful and common functions. + +module Relude.Lifted.Concurrent + ( -- * MVar + MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , swapMVar + , takeMVar + , tryPutMVar + , tryReadMVar + , tryTakeMVar + + -- * STM + , STM + , TVar + , atomically + , newTVarIO + , readTVarIO + , STM.modifyTVar' + , STM.newTVar + , STM.readTVar + , STM.writeTVar + ) where + +import Control.Concurrent.MVar (MVar) +import Control.Concurrent.STM.TVar (TVar) +import Control.Monad.STM (STM) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Bool (Bool) +import Data.Function (($), (.)) +import Data.Maybe (Maybe) + +import qualified Control.Concurrent.MVar as CCM (newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, + takeMVar, tryPutMVar, tryReadMVar, tryTakeMVar) +import qualified Control.Concurrent.STM.TVar as STM (modifyTVar', newTVar, newTVarIO, readTVar, + readTVarIO, writeTVar) +import qualified Control.Monad.STM as STM (atomically) + +---------------------------------------------------------------------------- +-- Lifted Control.Concurrent.MVar +---------------------------------------------------------------------------- + +-- | Lifted to 'MonadIO' version of 'CCM.newEmptyMVar'. +newEmptyMVar :: MonadIO m => m (MVar a) +newEmptyMVar = liftIO CCM.newEmptyMVar +{-# INLINE newEmptyMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.newMVar'. +newMVar :: MonadIO m => a -> m (MVar a) +newMVar = liftIO . CCM.newMVar +{-# INLINE newMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.putMVar'. +putMVar :: MonadIO m => MVar a -> a -> m () +putMVar m a = liftIO $ CCM.putMVar m a +{-# INLINE putMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.readMVar'. +readMVar :: MonadIO m => MVar a -> m a +readMVar = liftIO . CCM.readMVar +{-# INLINE readMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.swapMVar'. +swapMVar :: MonadIO m => MVar a -> a -> m a +swapMVar m v = liftIO $ CCM.swapMVar m v +{-# INLINE swapMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.takeMVar'. +takeMVar :: MonadIO m => MVar a -> m a +takeMVar = liftIO . CCM.takeMVar +{-# INLINE takeMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.tryPutMVar'. +tryPutMVar :: MonadIO m => MVar a -> a -> m Bool +tryPutMVar m v = liftIO $ CCM.tryPutMVar m v +{-# INLINE tryPutMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.tryReadMVar'. +tryReadMVar :: MonadIO m => MVar a -> m (Maybe a) +tryReadMVar = liftIO . CCM.tryReadMVar +{-# INLINE tryReadMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.tryTakeMVar'. +tryTakeMVar :: MonadIO m => MVar a -> m (Maybe a) +tryTakeMVar = liftIO . CCM.tryTakeMVar +{-# INLINE tryTakeMVar #-} + +---------------------------------------------------------------------------- +-- Lifted STM +---------------------------------------------------------------------------- + +-- | Lifted to 'MonadIO' version of 'STM.atomically'. +atomically :: MonadIO m => STM a -> m a +atomically = liftIO . STM.atomically +{-# INLINE atomically #-} + +-- | Lifted to 'MonadIO' version of 'STM.newTVarIO'. +newTVarIO :: MonadIO m => a -> m (TVar a) +newTVarIO = liftIO . STM.newTVarIO +{-# INLINE newTVarIO #-} + +-- | Lifted to 'MonadIO' version of 'STM.readTVarIO'. +readTVarIO :: MonadIO m => TVar a -> m a +readTVarIO = liftIO . STM.readTVarIO +{-# INLINE readTVarIO #-} diff --git a/src/Relude/Lifted/Exit.hs b/src/Relude/Lifted/Exit.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Lifted/Exit.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Lifted versions of functions that work with exit processes. + +module Relude.Lifted.Exit + ( exitWith + , exitFailure + , exitSuccess + , die + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.String (String) +import Prelude ((>>)) +import System.Exit (ExitCode) +import System.IO (stderr) + +import qualified System.Exit as XIO +import qualified System.IO (hPutStrLn) + +-- | Lifted version of 'System.Exit.exitWith'. +exitWith :: MonadIO m => ExitCode -> m a +exitWith a = liftIO (XIO.exitWith a) +{-# INLINE exitWith #-} + +-- | Lifted version of 'System.Exit.exitFailure'. +exitFailure :: MonadIO m => m a +exitFailure = liftIO XIO.exitFailure +{-# INLINE exitFailure #-} + +-- | Lifted version of 'System.Exit.exitSuccess'. +exitSuccess :: MonadIO m => m a +exitSuccess = liftIO XIO.exitSuccess +{-# INLINE exitSuccess #-} + +-- | Lifted version of 'System.Exit.die'. +-- 'XIO.die' is available since base-4.8, but it's more convenient to +-- redefine it instead of using CPP. +die :: MonadIO m => String -> m () +die err = liftIO (System.IO.hPutStrLn stderr err) >> exitFailure +{-# INLINE die #-} diff --git a/src/Relude/Lifted/File.hs b/src/Relude/Lifted/File.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Lifted/File.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Lifted versions of functions working with files and common IO. +-- All functions are specialized to 'Data.Text.Text'. + +module Relude.Lifted.File + ( appendFile + , getLine + , openFile + , readFile + , writeFile + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Text (Text) +import Prelude (FilePath) +import System.IO (Handle, IOMode) + +import qualified Data.Text.IO as XIO +import qualified System.IO as XIO (openFile) + +---------------------------------------------------------------------------- +-- Text +---------------------------------------------------------------------------- + +-- | Lifted version of 'Data.Text.appendFile'. +appendFile :: MonadIO m => FilePath -> Text -> m () +appendFile a b = liftIO (XIO.appendFile a b) +{-# INLINE appendFile #-} + +-- | Lifted version of 'Data.Text.getLine'. +getLine :: MonadIO m => m Text +getLine = liftIO XIO.getLine +{-# INLINE getLine #-} + +-- | Lifted version of 'Data.Text.readFile'. +readFile :: MonadIO m => FilePath -> m Text +readFile a = liftIO (XIO.readFile a) +{-# INLINE readFile #-} + +-- | Lifted version of 'Data.Text.writeFile'. +writeFile :: MonadIO m => FilePath -> Text -> m () +writeFile a b = liftIO (XIO.writeFile a b) +{-# INLINE writeFile #-} + +-- | Lifted version of 'System.IO.openFile'. +openFile :: MonadIO m => FilePath -> IOMode -> m Handle +openFile a b = liftIO (XIO.openFile a b) +{-# INLINE openFile #-} + +-- 'withFile' can't be lifted into 'MonadIO', as it uses 'bracket' diff --git a/src/Relude/Lifted/IORef.hs b/src/Relude/Lifted/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Lifted/IORef.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Lifted reexports from 'Data.IORef' module. + +module Relude.Lifted.IORef + ( IORef + , atomicModifyIORef + , atomicModifyIORef' + , atomicWriteIORef + , modifyIORef + , modifyIORef' + , newIORef + , readIORef + , writeIORef + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Function (($), (.)) +import Data.IORef (IORef) + +import qualified Data.IORef as Ref (atomicModifyIORef, atomicModifyIORef', atomicWriteIORef, + modifyIORef, modifyIORef', newIORef, readIORef, writeIORef) + +-- | Lifted version of 'Ref.newIORef'. +newIORef :: MonadIO m => a -> m (IORef a) +newIORef = liftIO . Ref.newIORef +{-# INLINE newIORef #-} + +-- | Lifted version of 'Ref.readIORef'. +readIORef :: MonadIO m => IORef a -> m a +readIORef = liftIO . Ref.readIORef +{-# INLINE readIORef #-} + +-- | Lifted version of 'Ref.writeIORef'. +writeIORef :: MonadIO m => IORef a -> a -> m () +writeIORef ref what = liftIO $ Ref.writeIORef ref what +{-# INLINE writeIORef #-} + +-- | Lifted version of 'Ref.modifyIORef'. +modifyIORef :: MonadIO m => IORef a -> (a -> a) -> m () +modifyIORef ref how = liftIO $ Ref.modifyIORef ref how +{-# INLINE modifyIORef #-} + +-- | Lifted version of 'Ref.modifyIORef''. +modifyIORef' :: MonadIO m => IORef a -> (a -> a) -> m () +modifyIORef' ref how = liftIO $ Ref.modifyIORef' ref how +{-# INLINE modifyIORef' #-} + +-- | Lifted version of 'Ref.atomicModifyIORef'. +atomicModifyIORef :: MonadIO m => IORef a -> (a -> (a, b)) -> m b +atomicModifyIORef ref how = liftIO $ Ref.atomicModifyIORef ref how +{-# INLINE atomicModifyIORef #-} + +-- | Lifted version of 'Ref.atomicModifyIORef''. +atomicModifyIORef' :: MonadIO m => IORef a -> (a -> (a, b)) -> m b +atomicModifyIORef' ref how = liftIO $ Ref.atomicModifyIORef' ref how +{-# INLINE atomicModifyIORef' #-} + +-- | Lifted version of 'Ref.atomicWriteIORef'. +atomicWriteIORef :: MonadIO m => IORef a -> a -> m () +atomicWriteIORef ref what = liftIO $ Ref.atomicWriteIORef ref what +{-# INLINE atomicWriteIORef #-} diff --git a/src/Relude/List.hs b/src/Relude/List.hs new file mode 100644 --- /dev/null +++ b/src/Relude/List.hs @@ -0,0 +1,18 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +{-# LANGUAGE Safe #-} + +-- | Utility functions to work with lists. + +module Relude.List + ( module Relude.List.Reexport + , module Relude.List.Safe + ) where + +import Relude.List.Reexport +import Relude.List.Safe diff --git a/src/Relude/List/Reexport.hs b/src/Relude/List/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/List/Reexport.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE Trustworthy #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports functinons to work with list, 'NonEmpty' and String types. + +module Relude.List.Reexport + ( module Data.List + , module Data.List.NonEmpty + , module GHC.Exts + ) where + +import Data.List (break, cycle, drop, dropWhile, filter, genericDrop, genericLength, + genericReplicate, genericSplitAt, genericTake, group, inits, intercalate, + intersperse, isPrefixOf, iterate, map, permutations, repeat, replicate, reverse, + scanl, scanr, sort, sortBy, sortOn, splitAt, subsequences, tails, take, takeWhile, + transpose, unfoldr, unzip, unzip3, zip, zip3, zipWith, (++)) +import Data.List.NonEmpty (NonEmpty (..), head, init, last, nonEmpty, tail) + +import GHC.Exts (sortWith) diff --git a/src/Relude/List/Safe.hs b/src/Relude/List/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Relude/List/Safe.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module contains safe functions to work with list type (mostly with 'NonEmpty'). + +module Relude.List.Safe + ( viaNonEmpty + , uncons + , whenNotNull + , whenNotNullM + ) where + +import Relude.Applicative (Applicative, pass) +import Relude.Function ((.)) +import Relude.Functor (fmap) +import Relude.List.Reexport (NonEmpty (..), nonEmpty) +import Relude.Monad (Maybe (..), Monad (..)) + +-- $setup +-- >>> import Relude.Applicative (pure) +-- >>> import Relude.Base ((==)) +-- >>> import Relude.Bool (Bool (..), not) +-- >>> import Relude.Foldable (length) +-- >>> import Relude.Function (($)) +-- >>> import Relude.List.Reexport (head) +-- >>> import Relude.Print (print) + +{- | For safe work with lists using functinons for 'NonEmpty'. + +>>> viaNonEmpty head [1] +Just 1 +>>> viaNonEmpty head [] +Nothing + +-} +viaNonEmpty :: (NonEmpty a -> b) -> [a] -> Maybe b +viaNonEmpty f = fmap f . nonEmpty +{-# INLINE viaNonEmpty #-} + +{- | Destructuring list into its head and tail if possible. This function is total. + +>>> uncons [] +Nothing +>>> uncons [1..5] +Just (1,[2,3,4,5]) +>>> uncons (5 : [1..5]) >>= \(f, l) -> pure $ f == length l +Just True + +-} +uncons :: [a] -> Maybe (a, [a]) +uncons [] = Nothing +uncons (x:xs) = Just (x, xs) + +{- | Performs given action over 'NonEmpty' list if given list is non empty. + +>>> whenNotNull [] $ \(b :| _) -> print (not b) +>>> whenNotNull [False,True] $ \(b :| _) -> print (not b) +True + +-} +whenNotNull :: Applicative f => [a] -> (NonEmpty a -> f ()) -> f () +whenNotNull [] _ = pass +whenNotNull (x:xs) f = f (x :| xs) +{-# INLINE whenNotNull #-} + +-- | Monadic version of 'whenNotNull'. +whenNotNullM :: Monad m => m [a] -> (NonEmpty a -> m ()) -> m () +whenNotNullM ml f = ml >>= \l -> whenNotNull l f +{-# INLINE whenNotNullM #-} diff --git a/src/Relude/Monad.hs b/src/Relude/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Monad.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Reexporting useful monadic stuff. + +module Relude.Monad + ( module Relude.Monad.Either + , module Relude.Monad.Maybe + , module Relude.Monad.Reexport + , module Relude.Monad.Trans + ) where + +import Relude.Monad.Either +import Relude.Monad.Maybe +import Relude.Monad.Reexport +import Relude.Monad.Trans diff --git a/src/Relude/Monad/Either.hs b/src/Relude/Monad/Either.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Monad/Either.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE Safe #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Utilites to work with @Either@ data type. + +module Relude.Monad.Either + ( fromLeft + , fromRight + , maybeToLeft + , maybeToRight + , leftToMaybe + , rightToMaybe + , whenLeft + , whenLeft_ + , whenLeftM + , whenLeftM_ + , whenRight + , whenRight_ + , whenRightM + , whenRightM_ + ) where + +import Control.Applicative (Applicative) +import Control.Monad (Monad (..)) +import Data.Function (const) +import Data.Maybe (Maybe (..), maybe) + +import Relude.Applicative (pure) +import Relude.Function ((.)) +import Relude.Monad.Reexport (Either (..), MonadFail (..), either) +import Relude.String (IsString, fromString) + +-- $setup +-- >>> import Relude.Bool (Bool (..)) + +instance IsString str => MonadFail (Either str) where + fail = Left . fromString + +-- | Extracts value from 'Left' or return given default value. +-- +-- >>> fromLeft 0 (Left 3) +-- 3 +-- >>> fromLeft 0 (Right 5) +-- 0 +fromLeft :: a -> Either a b -> a +fromLeft _ (Left a) = a +fromLeft a (Right _) = a + +-- | Extracts value from 'Right' or return given default value. +-- +-- >>> fromRight 0 (Left 3) +-- 0 +-- >>> fromRight 0 (Right 5) +-- 5 +fromRight :: b -> Either a b -> b +fromRight b (Left _) = b +fromRight _ (Right b) = b + +-- | Maps left part of 'Either' to 'Maybe'. +-- +-- >>> leftToMaybe (Left True) +-- Just True +-- >>> leftToMaybe (Right "aba") +-- Nothing +leftToMaybe :: Either l r -> Maybe l +leftToMaybe = either Just (const Nothing) + +-- | Maps right part of 'Either' to 'Maybe'. +-- +-- >>> rightToMaybe (Left True) +-- Nothing +-- >>> rightToMaybe (Right "aba") +-- Just "aba" +rightToMaybe :: Either l r -> Maybe r +rightToMaybe = either (const Nothing) Just + +-- | Maps 'Maybe' to 'Either' wrapping default value into 'Left'. +-- +-- >>> maybeToRight True (Just "aba") +-- Right "aba" +-- >>> maybeToRight True Nothing +-- Left True +maybeToRight :: l -> Maybe r -> Either l r +maybeToRight l = maybe (Left l) Right + +-- | Maps 'Maybe' to 'Either' wrapping default value into 'Right'. +-- +-- >>> maybeToLeft True (Just "aba") +-- Left "aba" +-- >>> maybeToLeft True Nothing +-- Right True +maybeToLeft :: r -> Maybe l -> Either l r +maybeToLeft r = maybe (Right r) Left + +-- | Applies given action to 'Either' content if 'Left' is given and returns +-- the result. In case of 'Right' the default value will be returned. +whenLeft :: Applicative f => a -> Either l r -> (l -> f a) -> f a +whenLeft _ (Left l) f = f l +whenLeft a (Right _) _ = pure a +{-# INLINE whenLeft #-} + +-- | Applies given action to 'Either' content if 'Left' is given. +whenLeft_ :: Applicative f => Either l r -> (l -> f ()) -> f () +whenLeft_ = whenLeft () +{-# INLINE whenLeft_ #-} + +-- | Monadic version of 'whenLeft'. +whenLeftM :: Monad m => a -> m (Either l r) -> (l -> m a) -> m a +whenLeftM a me f = me >>= \e -> whenLeft a e f +{-# INLINE whenLeftM #-} + +-- | Monadic version of 'whenLeft_'. +whenLeftM_ :: Monad m => m (Either l r) -> (l -> m ()) -> m () +whenLeftM_ me f = me >>= \e -> whenLeft_ e f +{-# INLINE whenLeftM_ #-} + +-- | Applies given action to 'Either' content if 'Right' is given and returns +-- the result. In case of 'Left' the default value will be returned. +whenRight :: Applicative f => a -> Either l r -> (r -> f a) -> f a +whenRight a (Left _) _ = pure a +whenRight _ (Right r) f = f r +{-# INLINE whenRight #-} + +-- | Applies given action to 'Either' content if 'Right' is given. +whenRight_ :: Applicative f => Either l r -> (r -> f ()) -> f () +whenRight_ = whenRight () +{-# INLINE whenRight_ #-} + +-- | Monadic version of 'whenRight'. +whenRightM :: Monad m => a -> m (Either l r) -> (r -> m a) -> m a +whenRightM a me f = me >>= \e -> whenRight a e f +{-# INLINE whenRightM #-} + +-- | Monadic version of 'whenRight_'. +whenRightM_ :: Monad m => m (Either l r) -> (r -> m ()) -> m () +whenRightM_ me f = me >>= \e -> whenRight_ e f +{-# INLINE whenRightM_ #-} diff --git a/src/Relude/Monad/Maybe.hs b/src/Relude/Monad/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Monad/Maybe.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Utility functions to work with 'Data.Maybe' data type as monad. + +module Relude.Monad.Maybe + ( (?:) + , whenJust + , whenJustM + , whenNothing + , whenNothing_ + , whenNothingM + , whenNothingM_ + ) where + +import Relude.Applicative (Applicative, pass, pure) +import Relude.Monad.Reexport (fromMaybe) +import Relude.Monad.Reexport (Maybe (..), Monad (..)) + +-- $setup +-- >>> import Relude.Bool (Bool (..), not) +-- >>> import Relude.Function (($)) +-- >>> import Relude.Print (putTextLn, print) +-- >>> import Relude.String (readMaybe) + +{- | Similar to 'fromMaybe' but with flipped arguments. + +>>> readMaybe "True" ?: False +True + +>>> readMaybe "Tru" ?: False +False + +-} +infixr 0 ?: +(?:) :: Maybe a -> a -> a +mA ?: b = fromMaybe b mA +{-# INLINE (?:) #-} + +{- | Specialized version of 'for_' for 'Maybe'. It's used for code readability. +Also helps to avoid space leaks: +. + +>>> whenJust Nothing $ \b -> print (not b) +>>> whenJust (Just True) $ \b -> print (not b) +False + +-} +whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f () +whenJust (Just x) f = f x +whenJust Nothing _ = pass +{-# INLINE whenJust #-} + +-- | Monadic version of 'whenJust'. +whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () +whenJustM mm f = mm >>= \m -> whenJust m f +{-# INLINE whenJustM #-} + +-- | Performs default 'Applicative' action if 'Nothing' is given. +-- Otherwise returns content of 'Just' pured to 'Applicative'. +-- +-- >>> whenNothing Nothing [True, False] +-- [True,False] +-- >>> whenNothing (Just True) [True, False] +-- [True] +whenNothing :: Applicative f => Maybe a -> f a -> f a +whenNothing (Just x) _ = pure x +whenNothing Nothing m = m +{-# INLINE whenNothing #-} + +-- | Performs default 'Applicative' action if 'Nothing' is given. +-- Do nothing for 'Just'. Convenient for discarding 'Just' content. +-- +-- >>> whenNothing_ Nothing $ putTextLn "Nothing!" +-- Nothing! +-- >>> whenNothing_ (Just True) $ putTextLn "Nothing!" +whenNothing_ :: Applicative f => Maybe a -> f () -> f () +whenNothing_ Nothing m = m +whenNothing_ _ _ = pass +{-# INLINE whenNothing_ #-} + +-- | Monadic version of 'whenNothing'. +whenNothingM :: Monad m => m (Maybe a) -> m a -> m a +whenNothingM mm action = mm >>= \m -> whenNothing m action +{-# INLINE whenNothingM #-} + +-- | Monadic version of 'whenNothingM_'. +whenNothingM_ :: Monad m => m (Maybe a) -> m () -> m () +whenNothingM_ mm action = mm >>= \m -> whenNothing_ m action +{-# INLINE whenNothingM_ #-} diff --git a/src/Relude/Monad/Reexport.hs b/src/Relude/Monad/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Monad/Reexport.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports functions to work with monads. + +module Relude.Monad.Reexport + ( -- * Reexport transformers + module Control.Monad.Except + , module Control.Monad.Reader + , module Control.Monad.State.Strict + , module Control.Monad.Trans + , module Control.Monad.Trans.Identity + , module Control.Monad.Trans.Maybe + + -- * Reexport monadic functions + , module Control.Monad + , module Control.Monad.Fail + + -- * Reexport 'Maybe' + , module Data.Maybe + + -- * Reexport 'Either' + , module Data.Either + ) where + +-- Monad transformers +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.Reader (MonadReader, Reader, ReaderT (..), ask, asks, local, reader, runReader) +import Control.Monad.State.Strict (MonadState, State, StateT (..), evalState, evalStateT, execState, + execStateT, get, gets, modify, modify', put, runState, state, + withState) +import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) +import Control.Monad.Trans.Identity (IdentityT (runIdentityT)) +import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT, maybeToExceptT) + +-- Control.Monad +import Control.Monad (Monad (return, (>>), (>>=)), MonadPlus (..), filterM, forever, join, + mapAndUnzipM, mfilter, replicateM, replicateM_, zipWithM, zipWithM_, (<$!>), + (<=<), (=<<), (>=>)) +import Control.Monad.Fail (MonadFail (..)) + +-- Maybe +import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, + maybe, maybeToList) + +-- Either +import Data.Either (Either (..), either, isLeft, isRight, lefts, partitionEithers, rights) diff --git a/src/Relude/Monad/Trans.hs b/src/Relude/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Monad/Trans.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE Safe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Monad transformers utilities. + +module Relude.Monad.Trans + ( -- * Convenient functions to work with 'Reader' monad + usingReader + , usingReaderT + + -- * Convenient functions to work with 'State' monad + , evaluatingState + , evaluatingStateT + , executingState + , executingStateT + , usingState + , usingStateT + ) where + +import Prelude (flip, fst, snd) + +import Relude.Functor (Functor, (<$>)) +import Relude.Monad.Reexport (Reader, ReaderT, State, StateT, runReader, runReaderT, runState, + runStateT) + +-- | Shorter and more readable alias for @flip runReaderT@. +usingReaderT :: r -> ReaderT r m a -> m a +usingReaderT = flip runReaderT +{-# INLINE usingReaderT #-} + +-- | Shorter and more readable alias for @flip runReader@. +usingReader :: r -> Reader r a -> a +usingReader = flip runReader +{-# INLINE usingReader #-} + +-- | Shorter and more readable alias for @flip runStateT@. +usingStateT :: s -> StateT s m a -> m (a, s) +usingStateT = flip runStateT +{-# INLINE usingStateT #-} + +-- | Shorter and more readable alias for @flip runState@. +usingState :: s -> State s a -> (a, s) +usingState = flip runState +{-# INLINE usingState #-} + +-- | Alias for @flip evalStateT@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. +evaluatingStateT :: Functor f => s -> StateT s f a -> f a +evaluatingStateT s st = fst <$> usingStateT s st +{-# INLINE evaluatingStateT #-} + +-- | Alias for @flip evalState@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. +evaluatingState :: s -> State s a -> a +evaluatingState s st = fst (usingState s st) +{-# INLINE evaluatingState #-} + +-- | Alias for @flip execStateT@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. +executingStateT :: Functor f => s -> StateT s f a -> f s +executingStateT s st = snd <$> usingStateT s st +{-# INLINE executingStateT #-} + +-- | Alias for @flip execState@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. +executingState :: s -> State s a -> s +executingState s st = snd (usingState s st) +{-# INLINE executingState #-} diff --git a/src/Relude/Monoid.hs b/src/Relude/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Monoid.hs @@ -0,0 +1,34 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports functions to work with monoids plus adds extra useful functions. + +module Relude.Monoid + ( module Data.Monoid + , module Data.Semigroup + , maybeToMonoid + ) where + +import Data.Monoid (All (..), Alt (..), Any (..), Dual (..), Endo (..), First (..), Last (..), + Monoid (..), Product (..), Sum (..)) +import Data.Semigroup (Option (..), Semigroup (sconcat, stimes, (<>)), WrappedMonoid, cycle1, + mtimesDefault, stimesIdempotent, stimesIdempotentMonoid, stimesMonoid) + +import Relude.Monad.Reexport (Maybe, fromMaybe) + +-- $setup +-- >>> import Relude.Base (Int) +-- >>> import Relude.Monad (Maybe (..)) + +-- | Extracts 'Monoid' value from 'Maybe' returning 'mempty' if 'Nothing'. +-- +-- >>> maybeToMonoid (Just [1,2,3] :: Maybe [Int]) +-- [1,2,3] +-- >>> maybeToMonoid (Nothing :: Maybe [Int]) +-- [] +maybeToMonoid :: Monoid m => Maybe m -> m +maybeToMonoid = fromMaybe mempty diff --git a/src/Relude/Nub.hs b/src/Relude/Nub.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Nub.hs @@ -0,0 +1,92 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +{-| Functions to remove duplicates from a list. + + = Performance + To check the performance there was done a bunch of benchmarks. + Benchmarks were made on lists of 'Prelude.Int's and 'Data.Text.Text's. + There were two types of list to use: + + * Lists which consist of many different elements + + * Lists which consist of many same elements + + + Here are some recomendations for usage of particular functions based on benchmarking resutls. + + * 'hashNub' is faster than 'ordNub' when there're not so many different values in the list. + + * 'hashNub' is the fastest with 'Data.Text.Text'. + + * 'sortNub' has better performance than 'ordNub' but should be used when sorting is also needed. + + * 'unstableNub' has better performance than 'hashNub' but doesn't save the original order. +-} + +module Relude.Nub + ( hashNub + , ordNub + , sortNub + , unstableNub + ) where + +import Data.Eq (Eq) +import Data.Hashable (Hashable) +import Data.HashSet as HashSet +import Data.Ord (Ord) +import Prelude ((.)) + +import qualified Data.Set as Set + +{- | Like 'Prelude.nub' but runs in @O(n * log n)@ time and requires 'Ord'. + +>>> ordNub [3, 3, 3, 2, 2, -1, 1] +[3,2,-1,1] + +-} +ordNub :: (Ord a) => [a] -> [a] +ordNub = go Set.empty + where + go _ [] = [] + go s (x:xs) = + if x `Set.member` s + then go s xs + else x : go (Set.insert x s) xs + +{- | Like 'Prelude.nub' but runs in @O(n * log_16(n))@ time and requires 'Hashable'. + +>>> hashNub [3, 3, 3, 2, 2, -1, 1] +[3,2,-1,1] + +-} +hashNub :: (Eq a, Hashable a) => [a] -> [a] +hashNub = go HashSet.empty + where + go _ [] = [] + go s (x:xs) = + if x `HashSet.member` s + then go s xs + else x : go (HashSet.insert x s) xs + +{- | Like 'ordNub' but also sorts a list. + +>>> sortNub [3, 3, 3, 2, 2, -1, 1] +[-1,1,2,3] + +-} +sortNub :: (Ord a) => [a] -> [a] +sortNub = Set.toList . Set.fromList + +{- | Like 'hashNub' but has better performance and also doesn't save the order. + +>>> unstableNub [3, 3, 3, 2, 2, -1, 1] +[1,2,3,-1] + +-} +unstableNub :: (Eq a, Hashable a) => [a] -> [a] +unstableNub = HashSet.toList . HashSet.fromList diff --git a/src/Relude/Print.hs b/src/Relude/Print.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Print.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Generalization of 'Prelude.putStr' and 'Prelude.putStrLn' functions. + +module Relude.Print + ( Print (..) + , print + , putText + , putTextLn + , putLText + , putLTextLn + ) where + +import Data.Function ((.)) + +import Relude.Monad.Reexport (MonadIO, liftIO) + +import qualified Prelude (print, putStr, putStrLn) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL + +import qualified Relude.Base as Base + +-- | Polymorfic over string and lifted to 'MonadIO' printing functions. +class Print a where + putStr :: MonadIO m => a -> m () + putStrLn :: MonadIO m => a -> m () + +instance Print T.Text where + putStr = liftIO . T.putStr + putStrLn = liftIO . T.putStrLn + +instance Print TL.Text where + putStr = liftIO . TL.putStr + putStrLn = liftIO . TL.putStrLn + +instance Print BS.ByteString where + putStr = liftIO . BS.putStr + putStrLn = liftIO . BS.putStrLn + +instance Print BL.ByteString where + putStr = liftIO . BL.putStr + putStrLn = liftIO . BL.putStrLn + +instance Print [Base.Char] where + putStr = liftIO . Prelude.putStr + putStrLn = liftIO . Prelude.putStrLn + +-- | Lifted version of 'Prelude.print'. +print :: forall a m . (MonadIO m, Base.Show a) => a -> m () +print = liftIO . Prelude.print + +-- | Specialized to 'T.Text' version of 'putStr' or forcing type inference. +putText :: MonadIO m => T.Text -> m () +putText = putStr +{-# SPECIALIZE putText :: T.Text -> Base.IO () #-} + +-- | Specialized to 'T.Text' version of 'putStrLn' or forcing type inference. +putTextLn :: MonadIO m => T.Text -> m () +putTextLn = putStrLn +{-# SPECIALIZE putTextLn :: T.Text -> Base.IO () #-} + +-- | Specialized to 'TL.Text' version of 'putStr' or forcing type inference. +putLText :: MonadIO m => TL.Text -> m () +putLText = putStr +{-# SPECIALIZE putLText :: TL.Text -> Base.IO () #-} + +-- | Specialized to 'TL.Text' version of 'putStrLn' or forcing type inference. +putLTextLn :: MonadIO m => TL.Text -> m () +putLTextLn = putStrLn +{-# SPECIALIZE putLTextLn :: TL.Text -> Base.IO () #-} diff --git a/src/Relude/String.hs b/src/Relude/String.hs new file mode 100644 --- /dev/null +++ b/src/Relude/String.hs @@ -0,0 +1,16 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | Type classes for convertion between different string representations. + +module Relude.String + ( module Relude.String.Conversion + , module Relude.String.Reexport + ) where + +import Relude.String.Conversion +import Relude.String.Reexport diff --git a/src/Relude/String/Conversion.hs b/src/Relude/String/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Relude/String/Conversion.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module implements type class which allow to have conversion to and +-- from 'Text', 'String' and 'ByteString' types (including both strict and lazy +-- versions). Usually you need to export 'Text' modules qualified and use +-- 'T.pack' \/ 'T.unpack' functions to convert to\/from 'Text'. Now you can +-- just use 'toText' \/ 'toString' functions. + +module Relude.String.Conversion + ( -- * Convenient type aliases + LText + , LByteString + + -- * Conversion type classes + , ConvertUtf8 (..) + , ToString (..) + , ToLText (..) + , ToText (..) + , LazyStrict (..) + , fromLazy + , fromStrict + + -- * Show and read functions + , readEither + , show + ) where + +import Data.Bifunctor (first) +import Data.Either (Either) +import Data.Function (id, (.)) +import Data.String (String) + +import Relude.Functor ((<$>)) +import Relude.String.Reexport (ByteString, IsString, Read, Text, fromString) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.UTF8 as LBU +import qualified Data.ByteString.UTF8 as BU +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import qualified Text.Read (readEither) + +import qualified GHC.Show as Show (Show (show)) + +-- $setup +-- >>> :set -XTypeApplications -XOverloadedStrings +-- >>> import Relude.Base (Int) +-- >>> import Relude.Function (($)) +-- >>> import Relude.Print (putStrLn) + +-- | Type synonym for 'Data.Text.Lazy.Text'. +type LText = LT.Text + +-- | Type synonym for 'Data.ByteString.Lazy.ByteString'. +type LByteString = LB.ByteString + + +-- | Type class for conversion to utf8 representation of text. +class ConvertUtf8 a b where + -- | Encode as utf8 string (usually 'B.ByteString'). + -- + -- >>> encodeUtf8 @Text @ByteString "патак" + -- "\208\191\208\176\209\130\208\176\208\186" + encodeUtf8 :: a -> b + + -- | Decode from utf8 string. + -- + -- >>> decodeUtf8 @Text @ByteString "\208\191\208\176\209\130\208\176\208\186" + -- "\1087\1072\1090\1072\1082" + -- >>> putStrLn $ decodeUtf8 @Text @ByteString "\208\191\208\176\209\130\208\176\208\186" + -- патак + decodeUtf8 :: b -> a + + {- | Decode as utf8 string but returning execption if byte sequence is malformed. + +#if MIN_VERSION_text(1,2,3) + >>> decodeUtf8 @Text @ByteString "\208\208\176\209\130\208\176\208\186" + "\65533\1072\1090\1072\1082" +#else + >>> decodeUtf8 @Text @ByteString "\208\208\176\209\130\208\176\208\186" + "\65533\65533\1090\1072\1082" +#endif + >>> decodeUtf8Strict @Text @ByteString "\208\208\176\209\130\208\176\208\186" + Left Cannot decode byte '\xd0': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream + -} + decodeUtf8Strict :: b -> Either T.UnicodeException a + +instance ConvertUtf8 String B.ByteString where + encodeUtf8 = BU.fromString + decodeUtf8 = BU.toString + decodeUtf8Strict = (T.unpack <$>) . decodeUtf8Strict + +instance ConvertUtf8 T.Text B.ByteString where + encodeUtf8 = T.encodeUtf8 + decodeUtf8 = T.decodeUtf8With T.lenientDecode + decodeUtf8Strict = T.decodeUtf8' + +instance ConvertUtf8 LT.Text B.ByteString where + encodeUtf8 = LB.toStrict . encodeUtf8 + decodeUtf8 = LT.decodeUtf8With T.lenientDecode . LB.fromStrict + decodeUtf8Strict = decodeUtf8Strict . LB.fromStrict + +instance ConvertUtf8 String LB.ByteString where + encodeUtf8 = LBU.fromString + decodeUtf8 = LBU.toString + decodeUtf8Strict = (T.unpack <$>) . decodeUtf8Strict + +instance ConvertUtf8 T.Text LB.ByteString where + encodeUtf8 = LB.fromStrict . T.encodeUtf8 + decodeUtf8 = T.decodeUtf8With T.lenientDecode . LB.toStrict + decodeUtf8Strict = T.decodeUtf8' . LB.toStrict + +instance ConvertUtf8 LT.Text LB.ByteString where + encodeUtf8 = LT.encodeUtf8 + decodeUtf8 = LT.decodeUtf8With T.lenientDecode + decodeUtf8Strict = LT.decodeUtf8' + +-- | Type class for converting other strings to 'T.Text'. +class ToText a where + toText :: a -> T.Text + +instance ToText String where + toText = T.pack + +instance ToText T.Text where + toText = id + +instance ToText LT.Text where + toText = LT.toStrict + +-- | Type class for converting other strings to 'LT.Text'. +class ToLText a where + toLText :: a -> LT.Text + +instance ToLText String where + toLText = LT.pack + +instance ToLText T.Text where + toLText = LT.fromStrict + +instance ToLText LT.Text where + toLText = id + +-- | Type class for converting other strings to 'String'. +class ToString a where + toString :: a -> String + +instance ToString String where + toString = id + +instance ToString T.Text where + toString = T.unpack + +instance ToString LT.Text where + toString = LT.unpack + +-- | Polymorhpic version of 'Text.Read.readEither'. +-- +-- >>> readEither @Text @Int "123" +-- Right 123 +-- >>> readEither @Text @Int "aa" +-- Left "Prelude.read: no parse" +readEither :: (ToString a, Read b) => a -> Either Text b +readEither = first toText . Text.Read.readEither . toString + +-- | Generalized version of 'Prelude.show'. +show :: forall b a . (Show.Show a, IsString b) => a -> b +show x = fromString (Show.show x) +{-# SPECIALIZE show :: Show.Show a => a -> Text #-} +{-# SPECIALIZE show :: Show.Show a => a -> LText #-} +{-# SPECIALIZE show :: Show.Show a => a -> ByteString #-} +{-# SPECIALIZE show :: Show.Show a => a -> LByteString #-} +{-# SPECIALIZE show :: Show.Show a => a -> String #-} + + +-- | Type class for lazy-strict conversions. +class LazyStrict l s | l -> s, s -> l where + toLazy :: s -> l + toStrict :: l -> s + +fromLazy :: LazyStrict l s => l -> s +fromLazy = toStrict +{-# INLINE fromLazy #-} +{-# SPECIALIZE fromLazy :: LByteString -> ByteString #-} +{-# SPECIALIZE fromLazy :: LText -> Text #-} + +fromStrict :: LazyStrict l s => s -> l +fromStrict = toLazy +{-# INLINE fromStrict #-} +{-# SPECIALIZE fromStrict :: ByteString -> LByteString #-} +{-# SPECIALIZE fromStrict :: Text -> LText #-} + +instance LazyStrict LByteString ByteString where + toLazy = LB.fromStrict + {-# INLINE toLazy #-} + toStrict = LB.toStrict + {-# INLINE toStrict #-} + +instance LazyStrict LText Text where + toLazy = LT.fromStrict + {-# INLINE toLazy #-} + toStrict = LT.toStrict + {-# INLINE toStrict #-} diff --git a/src/Relude/String/Reexport.hs b/src/Relude/String/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Relude/String/Reexport.hs @@ -0,0 +1,30 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +-- | This module reexports functions to work with 'Text' and 'ByteString' types. + +module Relude.String.Reexport + ( -- * String + module Data.String + + -- * Text + , module Data.Text + , module Data.Text.Encoding + , module Data.Text.Encoding.Error + , module Text.Read + + -- * ByteString + , module Data.ByteString + ) where + +import Data.ByteString (ByteString) +import Data.String (IsString (..)) +import Data.Text (Text, lines, unlines, unwords, words) +import Data.Text.Encoding (decodeUtf8', decodeUtf8With) +import Data.Text.Encoding.Error (OnDecodeError, OnError, UnicodeException, lenientDecode, + strictDecode) +import Text.Read (Read, readMaybe, reads) diff --git a/src/Relude/Unsafe.hs b/src/Relude/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Relude/Unsafe.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE Unsafe #-} + +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +{- | Unsafe functions to work with lists and 'Maybe'. +Sometimes unavoidable but better don't use them. This module +is intended to be imported qualified and it's not even included +in default prelude exports. + +@ +import qualified Relude.Unsafe as Unsafe + +foo :: [a] -> a +foo = Unsafe.head +@ + +-} + +module Relude.Unsafe + ( head + , tail + , init + , last + , at + , (!!) + , fromJust + ) where + +import Data.List (head, init, last, tail, (!!)) +import Data.Maybe (fromJust) + +import Relude.Base (Int) +import Relude.Function (flip) + +-- | Similar to '!!' but with flipped arguments. +at :: Int -> [a] -> a +at = flip (!!) diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,16 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +module Main (main) where + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = do + sourceFiles <- glob "src/**/*.hs" + doctest $ "-XNoImplicitPrelude" : sourceFiles diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,18 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +module Main where + +import Relude + +import Test.Tasty (defaultMain) + +import Test.Relude.Property (hedgehogTestTree) + +main :: IO () +main = do + defaultMain hedgehogTestTree diff --git a/test/Test/Relude/Property.hs b/test/Test/Relude/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Relude/Property.hs @@ -0,0 +1,133 @@ +{- +Copyright: (c) 2016 Stephen Diehl + (c) 20016-2018 Serokell + (c) 2018 Kowainik +License: MIT +-} + +module Test.Relude.Property + ( hedgehogTestTree + ) where + +import Relude + +import Data.List (nub) +import Hedgehog (Gen, MonadGen, Property, assert, forAll, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Relude as U + +hedgehogTestTree :: TestTree +hedgehogTestTree = testGroup "Tests" [utfProps, listProps, boolMProps] + +utfProps :: TestTree +utfProps = testGroup "utf8 conversion property tests" + [ testProperty "String to ByteString invertible" prop_StringToBytes + , testProperty "Text to ByteString invertible" prop_TextToBytes + , testProperty "ByteString to Text or String invertible" prop_BytesTo + ] + +unicode' :: MonadGen m => m U.Char +unicode' = do + a <- Gen.unicode + if elem a ['\65534', '\65535'] + then unicode' + else return a + +utf8String :: Gen U.String +utf8String = Gen.string (Range.linear 0 10000) unicode' + +utf8Text :: Gen T.Text +utf8Text = Gen.text (Range.linear 0 10000) unicode' + +utf8Bytes :: Gen B.ByteString +utf8Bytes = Gen.utf8 (Range.linear 0 10000) unicode' + +-- "\65534" fails, but this is from BU.toString +-- > import qualified Data.ByteString.UTF8 as BU +-- > BU.toString (BU.fromString "\65534") == "\65533" +-- > True + +prop_StringToBytes :: Property +prop_StringToBytes = property $ do + str <- forAll utf8String + assert $ str == (decodeUtf8 (encodeUtf8 str :: B.ByteString)) + && str == (decodeUtf8 (encodeUtf8 str :: LB.ByteString)) + + +prop_TextToBytes :: Property +prop_TextToBytes = property $ do + txt <- forAll utf8Text + assert $ txt == (decodeUtf8 (encodeUtf8 txt :: B.ByteString)) + && txt == (decodeUtf8 (encodeUtf8 txt :: LB.ByteString)) + +-- "\239\191\190" fails, but this is the same as "\65534" :: String +prop_BytesTo :: Property +prop_BytesTo = property $ do + utf <- forAll utf8Bytes + assert $ utf == (encodeUtf8 (decodeUtf8 utf :: U.String)) + && utf == (encodeUtf8 (decodeUtf8 utf :: T.Text)) + && utf == (encodeUtf8 (decodeUtf8 utf :: LT.Text)) + +-- ordNub + +listProps :: TestTree +listProps = testGroup "list function property tests" + [ testProperty "Hedgehog ordNub xs == nub xs" prop_ordNubCorrect + , testProperty "Hedgehog hashNub xs == nub xs" prop_hashNubCorrect + , testProperty "Hedgehog sortNub xs == sort $ nub xs" prop_sortNubCorrect + , testProperty "Hedgehog sort $ unstableNub xs == sort $ nub xs" prop_unstableNubCorrect + ] + +genIntList :: Gen [U.Int] +genIntList = Gen.list (Range.linear 0 10000) Gen.enumBounded + +prop_ordNubCorrect :: Property +prop_ordNubCorrect = property $ do + xs <- forAll genIntList + U.ordNub xs === nub xs + +prop_hashNubCorrect :: Property +prop_hashNubCorrect = property $ do + xs <- forAll genIntList + U.hashNub xs === nub xs + +prop_sortNubCorrect :: Property +prop_sortNubCorrect = property $ do + xs <- forAll genIntList + U.sortNub xs === (U.sort $ nub xs) + +prop_unstableNubCorrect :: Property +prop_unstableNubCorrect = property $ do + xs <- forAll genIntList + (U.sort $ U.unstableNub xs) === (U.sort $ nub xs) + + +-- logicM +-- this section needs a little more thought + +genBoolList :: Gen [U.Bool] +genBoolList = Gen.list (Range.linear 0 1000) Gen.bool + +boolMProps :: TestTree +boolMProps = testGroup "lifted logic function property tests" + [ testProperty "Hedgehog andM" prop_andM + , testProperty "Hedgehog orM" prop_orM + ] + +prop_andM :: Property +prop_andM = property $ do + bs <- forAll genBoolList + U.andM (return <$> bs) === ((return $ U.and bs) :: U.Maybe U.Bool) + +prop_orM :: Property +prop_orM = property $ do + bs <- forAll genBoolList + U.orM (return <$> bs) === ((return $ U.or bs) :: U.Maybe U.Bool)