├── .github ├── PULL_REQUEST_TEMPLATE.md └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── bower.json ├── package.json ├── src └── Data │ ├── Compactable.purs │ ├── Filterable.purs │ └── Witherable.purs └── test └── Main.purs /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | **Description of the change** 2 | Clearly and concisely describe the purpose of the pull request. If this PR relates to an existing issue or change proposal, please link to it. Include any other background context that would help reviewers understand the motivation for this PR. 3 | 4 | --- 5 | 6 | **Checklist:** 7 | 8 | - [ ] Added the change to the changelog's "Unreleased" section with a link to this PR and your username 9 | - [ ] Linked any existing issues or proposals that this pull request should close 10 | - [ ] Updated or added relevant documentation in the README and/or documentation directory 11 | - [ ] Added a test for the contribution (if applicable) 12 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [main] 6 | pull_request: 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v2 13 | 14 | - uses: purescript-contrib/setup-purescript@main 15 | with: 16 | purescript: "unstable" 17 | 18 | - uses: actions/setup-node@v2 19 | with: 20 | node-version: "14.x" 21 | 22 | - name: Install dependencies 23 | run: | 24 | npm install -g bower 25 | npm install 26 | bower install --production 27 | 28 | - name: Build source 29 | run: npm run-script build 30 | 31 | - name: Run tests 32 | run: | 33 | bower install 34 | npm run-script test --if-present 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | !.gitignore 3 | !.github 4 | 5 | output 6 | generated-docs 7 | bower_components 8 | node_modules 9 | 10 | package-lock.json 11 | *.lock 12 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). 4 | 5 | ## [Unreleased] 6 | 7 | Breaking changes: 8 | 9 | New features: 10 | 11 | Bugfixes: 12 | 13 | Other improvements: 14 | 15 | ## [v5.0.0](https://github.com/purescript/purescript-filterable/releases/tag/v5.0.0) - 2022-04-27 16 | 17 | Breaking changes: 18 | - Update project and deps to PureScript v0.15.0 (#23 by @JordanMartinez) 19 | 20 | New features: 21 | 22 | Bugfixes: 23 | 24 | Other improvements: 25 | 26 | ## [v4.0.1](https://github.com/purescript/purescript-filterable/releases/tag/v4.0.1) - 2021-04-19 27 | 28 | Other improvements: 29 | - Renamed default branch to `main` from `master` (@thomashoneyman) 30 | - Fix UnusedName warnings revealed by v0.14.1 PureScript release (#22 by @JordanMartinez) 31 | 32 | ## [v4.0.0](https://github.com/purescript/purescript-filterable/releases/tag/v4.0.0) - 2021-03-07 33 | 34 | - Added support for PureScript 0.14 and dropped support for all previous versions. 35 | 36 | ## [v3.0.1](https://github.com/purescript/purescript-filterable/releases/tag/v3.0.1) - 2018-06-29 37 | 38 | - Added missing exports in Data.Compactable (@gabejohnson) 39 | 40 | ## [v3.0.0](https://github.com/purescript/purescript-filterable/releases/tag/v3.0.0) - 2018-05-25 41 | 42 | - Added support for PureScript 0.12, dropping support for previous compiler versions 43 | 44 | ## [v2.4.0](https://github.com/purescript/purescript-filterable/releases/tag/v2.4.0) - 2017-08-09 45 | 46 | - Added extra defaults for `partition` and `filter` (#10 by @i-am-tom) 47 | 48 | ## [v2.2.0](https://github.com/purescript/purescript-filterable/releases/tag/v2.2.0) - 2017-05-13 49 | 50 | - Added instances for `Map` 51 | 52 | ## [v2.0.1](https://github.com/purescript/purescript-filterable/releases/tag/v2.0.1) - 2017-05-13 53 | 54 | - Backported `partitionDefault`/`eitherBool` fix to 2.0.x 55 | 56 | ## [v2.1.0](https://github.com/purescript/purescript-filterable/releases/tag/v2.1.0) - 2017-05-13 57 | 58 | - Added instance of `Filterable` for `Data.List` (@afcondon) 59 | 60 | ## [v2.0.0](https://github.com/purescript/purescript-filterable/releases/tag/v2.0.0) - 2017-04-10 61 | 62 | - Added support for PureScript 0.11, dropping support for previous compiler versions 63 | 64 | ## [v1.0.0](https://github.com/purescript/purescript-filterable/releases/tag/v1.0.0) - 2016-10-18 65 | 66 | - Initial release of the `filterable` library 67 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 PureScript 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Filterable 2 | 3 | [![CI](https://github.com/purescript/purescript-filterable/workflows/CI/badge.svg?branch=main)](https://github.com/purescript/purescript-filterable/actions?query=workflow%3ACI+branch%3Amain) 4 | [![Release](https://img.shields.io/github/release/purescript/purescript-filterable.svg)](https://github.com/purescript/purescript-filterable/releases) 5 | [![Pursuit](https://pursuit.purescript.org/packages/purescript-filterable/badge)](https://pursuit.purescript.org/packages/purescript-filterable) 6 | 7 | Classes for _compactable_, _filterable_, and _witherable_ data structures. 8 | 9 | Inspired by [compactable](https://hackage.haskell.org/package/compactable) and [witherable](https://hackage.haskell.org/package/witherable) on hackage. 10 | 11 | ## Installation 12 | 13 | Install `filterable` with [Spago](https://github.com/purescript/spago): 14 | 15 | ```sh 16 | spago install filterable 17 | ``` 18 | 19 | ## Documentation 20 | 21 | Module documentation is [published on Pursuit](https://pursuit.purescript.org/packages/purescript-filterable). 22 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-filterable", 3 | "homepage": "https://github.com/purescript/purescript-filterable", 4 | "description": "Classes for filterable and witherable data structures", 5 | "author": "Liam Goodacre", 6 | "license": "MIT", 7 | "repository": { 8 | "type": "git", 9 | "url": "https://github.com/purescript/purescript-filterable.git" 10 | }, 11 | "ignore": [ 12 | "**/.*", 13 | "bower_components", 14 | "node_modules", 15 | "output", 16 | "test", 17 | "bower.json", 18 | "package.json" 19 | ], 20 | "dependencies": { 21 | "purescript-foldable-traversable": "^6.0.0", 22 | "purescript-identity": "^6.0.0", 23 | "purescript-arrays": "^7.0.0", 24 | "purescript-either": "^6.0.0", 25 | "purescript-lists": "^7.0.0", 26 | "purescript-ordered-collections": "^3.0.0" 27 | }, 28 | "devDependencies": { 29 | "purescript-assert": "^6.0.0", 30 | "purescript-console": "^6.0.0" 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "clean": "rimraf output && rimraf .pulp-cache", 5 | "build": "pulp build -- --censor-lib --strict", 6 | "test": "pulp test", 7 | "build:docs": "rimraf docs && pulp docs" 8 | }, 9 | "devDependencies": { 10 | "pulp": "16.0.0-0", 11 | "purescript-psa": "^0.8.2", 12 | "rimraf": "^3.0.2" 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /src/Data/Compactable.purs: -------------------------------------------------------------------------------- 1 | module Data.Compactable 2 | ( class Compactable 3 | , compact 4 | , separate 5 | , compactDefault 6 | , separateDefault 7 | , applyMaybe 8 | , applyEither 9 | , bindMaybe 10 | , bindEither 11 | ) where 12 | 13 | import Control.Alternative (empty, (<|>)) 14 | import Control.Applicative (class Apply, apply, pure) 15 | import Control.Apply ((<*>)) 16 | import Control.Bind (class Bind, bind, join) 17 | import Control.Monad.ST as ST 18 | import Data.Array ((!!)) 19 | import Data.Array.ST as STA 20 | import Data.Array.ST.Iterator as STAI 21 | import Data.Either (Either(Right, Left), hush, note) 22 | import Data.Foldable (foldl, foldr) 23 | import Data.Function (($)) 24 | import Data.Functor (class Functor, map, (<$>)) 25 | import Data.List as List 26 | import Data.Map as Map 27 | import Data.Maybe (Maybe(..)) 28 | import Data.Monoid (class Monoid, mempty) 29 | import Data.Tuple (Tuple(..)) 30 | import Prelude (class Ord, const, discard, unit, void, (<<<)) 31 | 32 | -- | `Compactable` represents data structures which can be _compacted_/_filtered_. 33 | -- | This is a generalization of catMaybes as a new function `compact`. `compact` 34 | -- | has relations with `Functor`, `Applicative`, `Monad`, `Plus`, and `Traversable` 35 | -- | in that we can use these classes to provide the ability to operate on a data type 36 | -- | by eliminating intermediate Nothings. This is useful for representing the 37 | -- | filtering out of values, or failure. 38 | -- | 39 | -- | To be compactable alone, no laws must be satisfied other than the type signature. 40 | -- | 41 | -- | If the data type is also a Functor the following should hold: 42 | -- | 43 | -- | - Functor Identity: `compact <<< map Just ≡ id` 44 | -- | 45 | -- | According to Kmett, (Compactable f, Functor f) is a functor from the 46 | -- | kleisli category of Maybe to the category of Hask. 47 | -- | `Kleisli Maybe -> Hask`. 48 | -- | 49 | -- | If the data type is also `Applicative` the following should hold: 50 | -- | 51 | -- | - `compact <<< (pure Just <*> _) ≡ id` 52 | -- | - `applyMaybe (pure Just) ≡ id` 53 | -- | - `compact ≡ applyMaybe (pure id)` 54 | -- | 55 | -- | If the data type is also a `Monad` the following should hold: 56 | -- | 57 | -- | - `flip bindMaybe (pure <<< Just) ≡ id` 58 | -- | - `compact <<< (pure <<< (Just (=<<))) ≡ id` 59 | -- | - `compact ≡ flip bindMaybe pure` 60 | -- | 61 | -- | If the data type is also `Plus` the following should hold: 62 | -- | 63 | -- | - `compact empty ≡ empty` 64 | -- | - `compact (const Nothing <$> xs) ≡ empty` 65 | 66 | class Compactable f where 67 | compact :: forall a. 68 | f (Maybe a) -> f a 69 | 70 | separate :: forall l r. 71 | f (Either l r) -> { left :: f l, right :: f r } 72 | 73 | compactDefault :: forall f a. Functor f => Compactable f => 74 | f (Maybe a) -> f a 75 | compactDefault = _.right <<< separate <<< map (note unit) 76 | 77 | separateDefault :: forall f l r. Functor f => Compactable f => 78 | f (Either l r) -> { left :: f l, right :: f r} 79 | separateDefault xs = { left: compact $ (hush <<< swapEither) <$> xs 80 | , right: compact $ hush <$> xs 81 | } 82 | where 83 | swapEither e = case e of 84 | Left x -> Right x 85 | Right y -> Left y 86 | 87 | instance compactableMaybe :: Compactable Maybe where 88 | compact = join 89 | 90 | separate Nothing = { left: Nothing, right: Nothing } 91 | separate (Just e) = case e of 92 | Left l -> { left: Just l, right: Nothing } 93 | Right r -> { left: Nothing, right: Just r } 94 | 95 | instance compactableEither :: Monoid m => Compactable (Either m) where 96 | compact (Left m) = Left m 97 | compact (Right m) = case m of 98 | Just v -> Right v 99 | Nothing -> Left mempty 100 | 101 | separate (Left x) = { left: Left x, right: Left x } 102 | separate (Right e) = case e of 103 | Left l -> { left: Right l, right: Left mempty } 104 | Right r -> { left: Left mempty, right: Right r } 105 | 106 | instance compactableArray :: Compactable Array where 107 | compact xs = ST.run do 108 | result <- STA.new 109 | iter <- STAI.iterator (xs !! _) 110 | 111 | STAI.iterate iter $ void <<< case _ of 112 | Nothing -> pure 0 113 | Just j -> STA.push j result 114 | 115 | STA.unsafeFreeze result 116 | 117 | separate xs = ST.run do 118 | ls <- STA.new 119 | rs <- STA.new 120 | iter <- STAI.iterator (xs !! _) 121 | 122 | STAI.iterate iter $ void <<< case _ of 123 | Left l -> STA.push l ls 124 | Right r -> STA.push r rs 125 | 126 | {left: _, right: _} <$> STA.unsafeFreeze ls <*> STA.unsafeFreeze rs 127 | 128 | instance compactableList :: Compactable List.List where 129 | compact = List.catMaybes 130 | separate = foldl go { left: empty, right: empty } where 131 | go acc = case _ of 132 | Left l -> acc { left = acc.left <|> pure l } 133 | Right r -> acc { right = acc.right <|> pure r } 134 | 135 | instance compactableMap :: Ord k => Compactable (Map.Map k) where 136 | compact = foldr select Map.empty <<< mapToList 137 | where 138 | select (Tuple k x) m = Map.alter (const x) k m 139 | 140 | separate = foldr select { left: Map.empty, right: Map.empty } <<< mapToList 141 | where 142 | select (Tuple k v) { left, right } = case v of 143 | Left l -> { left: Map.insert k l left, right } 144 | Right r -> { left: left, right: Map.insert k r right } 145 | 146 | mapToList :: forall k v. Ord k => 147 | Map.Map k v -> List.List (Tuple k v) 148 | mapToList = Map.toUnfoldable 149 | 150 | applyMaybe :: forall f a b. Apply f => Compactable f => 151 | f (a -> Maybe b) -> f a -> f b 152 | applyMaybe p = compact <<< apply p 153 | 154 | applyEither :: forall f a l r. Apply f => Compactable f => 155 | f (a -> Either l r) -> f a -> { left :: f l, right :: f r } 156 | applyEither p = separate <<< apply p 157 | 158 | bindMaybe :: forall m a b. Bind m => Compactable m => 159 | m a -> (a -> m (Maybe b)) -> m b 160 | bindMaybe x = compact <<< bind x 161 | 162 | bindEither :: forall m a l r. Bind m => Compactable m => 163 | m a -> (a -> m (Either l r)) -> { left :: m l, right :: m r } 164 | bindEither x = separate <<< bind x 165 | -------------------------------------------------------------------------------- /src/Data/Filterable.purs: -------------------------------------------------------------------------------- 1 | module Data.Filterable 2 | ( class Filterable 3 | , partitionMap 4 | , partition 5 | , filterMap 6 | , filter 7 | , eitherBool 8 | , partitionDefault 9 | , partitionDefaultFilter 10 | , partitionDefaultFilterMap 11 | , partitionMapDefault 12 | , maybeBool 13 | , filterDefault 14 | , filterDefaultPartition 15 | , filterDefaultPartitionMap 16 | , filterMapDefault 17 | , cleared 18 | , module Data.Compactable 19 | ) where 20 | 21 | import Control.Bind ((=<<)) 22 | import Control.Category ((<<<)) 23 | import Data.Array (partition, mapMaybe, filter) as Array 24 | import Data.Compactable (class Compactable, compact, separate) 25 | import Data.Either (Either(..)) 26 | import Data.Foldable (foldl, foldr) 27 | import Data.Functor (class Functor, map) 28 | import Data.HeytingAlgebra (not) 29 | import Data.List (List(..), filter, mapMaybe) as List 30 | import Data.Map (Map, empty, insert, alter, toUnfoldable) as Map 31 | import Data.Maybe (Maybe(..)) 32 | import Data.Monoid (class Monoid, mempty) 33 | import Data.Semigroup ((<>)) 34 | import Data.Tuple (Tuple(..)) 35 | import Prelude (const, class Ord) 36 | 37 | -- | `Filterable` represents data structures which can be _partitioned_/_filtered_. 38 | -- | 39 | -- | - `partitionMap` - partition a data structure based on an either predicate. 40 | -- | - `partition` - partition a data structure based on boolean predicate. 41 | -- | - `filterMap` - map over a data structure and filter based on a maybe. 42 | -- | - `filter` - filter a data structure based on a boolean. 43 | -- | 44 | -- | Laws: 45 | -- | - Functor Relation: `filterMap identity ≡ compact` 46 | -- | - Functor Identity: `filterMap Just ≡ identity` 47 | -- | - Kleisli Composition: `filterMap (l <=< r) ≡ filterMap l <<< filterMap r` 48 | -- | 49 | -- | - `filter ≡ filterMap <<< maybeBool` 50 | -- | - `filterMap p ≡ filter (isJust <<< p)` 51 | -- | 52 | -- | - Functor Relation: `partitionMap identity ≡ separate` 53 | -- | - Functor Identity 1: `_.right <<< partitionMap Right ≡ identity` 54 | -- | - Functor Identity 2: `_.left <<< partitionMap Left ≡ identity` 55 | -- | 56 | -- | - `f <<< partition ≡ partitionMap <<< eitherBool` where `f = \{ no, yes } -> { left: no, right: yes }` 57 | -- | - `f <<< partitionMap p ≡ partition (isRight <<< p)` where `f = \{ left, right } -> { no: left, yes: right}` 58 | -- | 59 | -- | Default implementations are provided by the following functions: 60 | -- | 61 | -- | - `partitionDefault` 62 | -- | - `partitionDefaultFilter` 63 | -- | - `partitionDefaultFilterMap` 64 | -- | - `partitionMapDefault` 65 | -- | - `filterDefault` 66 | -- | - `filterDefaultPartition` 67 | -- | - `filterDefaultPartitionMap` 68 | -- | - `filterMapDefault` 69 | class (Compactable f, Functor f) <= Filterable f where 70 | partitionMap :: forall a l r. 71 | (a -> Either l r) -> f a -> { left :: f l, right :: f r } 72 | 73 | partition :: forall a. 74 | (a -> Boolean) -> f a -> { no :: f a, yes :: f a } 75 | 76 | filterMap :: forall a b. 77 | (a -> Maybe b) -> f a -> f b 78 | 79 | filter :: forall a. 80 | (a -> Boolean) -> f a -> f a 81 | 82 | -- | Upgrade a boolean-style predicate to an either-style predicate mapping. 83 | eitherBool :: forall a. 84 | (a -> Boolean) -> a -> Either a a 85 | eitherBool p x = if p x then Right x else Left x 86 | 87 | -- | Upgrade a boolean-style predicate to a maybe-style predicate mapping. 88 | maybeBool :: forall a. 89 | (a -> Boolean) -> a -> Maybe a 90 | maybeBool p x = if p x then Just x else Nothing 91 | 92 | -- | A default implementation of `partitionMap` using `separate`. Note that this is 93 | -- | almost certainly going to be suboptimal compared to direct implementations. 94 | partitionMapDefault :: forall f a l r. Filterable f => 95 | (a -> Either l r) -> f a -> { left :: f l, right :: f r } 96 | partitionMapDefault p = separate <<< map p 97 | 98 | -- | A default implementation of `partition` using `partitionMap`. 99 | partitionDefault :: forall f a. Filterable f => 100 | (a -> Boolean) -> f a -> { no :: f a, yes :: f a } 101 | partitionDefault p xs = 102 | let o = partitionMap (eitherBool p) xs 103 | in {no: o.left, yes: o.right} 104 | 105 | -- | A default implementation of `partition` using `filter`. Note that this is 106 | -- | almost certainly going to be suboptimal compared to direct implementations. 107 | partitionDefaultFilter :: forall f a. Filterable f => 108 | (a -> Boolean) -> f a -> { no :: f a, yes :: f a } 109 | partitionDefaultFilter p xs = { yes: filter p xs, no: filter (not p) xs } 110 | 111 | -- | A default implementation of `filterMap` using `separate`. Note that this is 112 | -- | almost certainly going to be suboptimal compared to direct implementations. 113 | filterMapDefault :: forall f a b. Filterable f => 114 | (a -> Maybe b) -> f a -> f b 115 | filterMapDefault p = compact <<< map p 116 | 117 | -- | A default implementation of `partition` using `filterMap`. Note that this 118 | -- | is almost certainly going to be suboptimal compared to direct 119 | -- | implementations. 120 | partitionDefaultFilterMap :: forall f a. Filterable f => 121 | (a -> Boolean) -> f a -> { no :: f a, yes :: f a } 122 | partitionDefaultFilterMap p xs = 123 | { yes: filterMap (maybeBool p) xs 124 | , no: filterMap (maybeBool (not p)) xs 125 | } 126 | 127 | -- | A default implementation of `filter` using `filterMap`. 128 | filterDefault :: forall f a. Filterable f => 129 | (a -> Boolean) -> f a -> f a 130 | filterDefault = filterMap <<< maybeBool 131 | 132 | -- | A default implementation of `filter` using `partition`. 133 | filterDefaultPartition :: forall f a. Filterable f => 134 | (a -> Boolean) -> f a -> f a 135 | filterDefaultPartition p xs = (partition p xs).yes 136 | 137 | -- | A default implementation of `filter` using `partitionMap`. 138 | filterDefaultPartitionMap :: forall f a. Filterable f => 139 | (a -> Boolean) -> f a -> f a 140 | filterDefaultPartitionMap p xs = (partitionMap (eitherBool p) xs).right 141 | 142 | -- | Filter out all values. 143 | cleared :: forall f a b. Filterable f => 144 | f a -> f b 145 | cleared = filterMap (const Nothing) 146 | 147 | instance filterableArray :: Filterable Array where 148 | partitionMap p = foldl go {left: [], right: []} where 149 | go acc x = case p x of 150 | Left l -> acc { left = acc.left <> [l] } 151 | Right r -> acc { right = acc.right <> [r] } 152 | 153 | partition = Array.partition 154 | 155 | filterMap = Array.mapMaybe 156 | 157 | filter = Array.filter 158 | 159 | instance filterableMaybe :: Filterable Maybe where 160 | partitionMap _ Nothing = { left: Nothing, right: Nothing } 161 | partitionMap p (Just x) = case p x of 162 | Left a -> { left: Just a, right: Nothing } 163 | Right b -> { left: Nothing, right: Just b } 164 | 165 | partition p = partitionDefault p 166 | 167 | filterMap = (=<<) 168 | 169 | filter p = filterDefault p 170 | 171 | instance filterableEither :: Monoid m => Filterable (Either m) where 172 | partitionMap _ (Left x) = { left: Left x, right: Left x } 173 | partitionMap p (Right x) = case p x of 174 | Left a -> { left: Right a, right: Left mempty } 175 | Right b -> { left: Left mempty, right: Right b } 176 | 177 | partition p = partitionDefault p 178 | 179 | filterMap _ (Left l) = Left l 180 | filterMap p (Right r) = case p r of 181 | Nothing -> Left mempty 182 | Just x -> Right x 183 | 184 | filter p = filterDefault p 185 | 186 | instance filterableList :: Filterable List.List where 187 | -- partitionMap :: forall a l r. (a -> Either l r) -> List a -> { left :: List l, right :: List r } 188 | partitionMap p xs = foldr select { left: List.Nil, right: List.Nil } xs 189 | where 190 | select x { left, right } = case p x of 191 | Left l -> { left: List.Cons l left, right } 192 | Right r -> { left, right: List.Cons r right } 193 | 194 | -- partition :: forall a. (a -> Boolean) -> List a -> { no :: List a, yes :: List a } 195 | partition p xs = foldr select { no: List.Nil, yes: List.Nil } xs 196 | where 197 | -- select :: (a -> Boolean) -> a -> { no :: List a, yes :: List a } -> { no :: List a, yes :: List a } 198 | select x { no, yes } = if p x 199 | then { no, yes: List.Cons x yes } 200 | else { no: List.Cons x no, yes } 201 | 202 | -- filterMap :: forall a b. (a -> Maybe b) -> List a -> List b 203 | filterMap p = List.mapMaybe p 204 | 205 | -- filter :: forall a. (a -> Boolean) -> List a -> List a 206 | filter = List.filter 207 | 208 | instance filterableMap :: Ord k => Filterable (Map.Map k) where 209 | partitionMap p xs = 210 | foldr select { left: Map.empty, right: Map.empty } (toList xs) 211 | where 212 | toList :: forall v. Map.Map k v -> List.List (Tuple k v) 213 | toList = Map.toUnfoldable 214 | 215 | select (Tuple k x) { left, right } = case p x of 216 | Left l -> { left: Map.insert k l left, right } 217 | Right r -> { left, right: Map.insert k r right } 218 | 219 | partition p = partitionDefault p 220 | 221 | filterMap p xs = 222 | foldr select Map.empty (toList xs) 223 | where 224 | toList :: forall v. Map.Map k v -> List.List (Tuple k v) 225 | toList = Map.toUnfoldable 226 | 227 | select (Tuple k x) m = Map.alter (const (p x)) k m 228 | 229 | filter p = filterDefault p 230 | -------------------------------------------------------------------------------- /src/Data/Witherable.purs: -------------------------------------------------------------------------------- 1 | module Data.Witherable 2 | ( class Witherable 3 | , wilt 4 | , wither 5 | , partitionMapByWilt 6 | , filterMapByWither 7 | , traverseByWither 8 | , wilted 9 | , withered 10 | , witherDefault 11 | , wiltDefault 12 | , module Data.Filterable 13 | ) where 14 | 15 | import Control.Applicative (class Applicative, (<*>), pure) 16 | import Control.Category ((<<<), identity) 17 | import Data.Compactable (compact, separate) 18 | import Data.Either (Either(..)) 19 | import Data.Filterable (class Filterable) 20 | import Data.Functor (map, (<$>)) 21 | import Data.Identity (Identity(..)) 22 | import Data.List (List(..), (:)) 23 | import Data.List as List 24 | import Data.Map as Map 25 | import Data.Maybe (Maybe(..)) 26 | import Data.Monoid (class Monoid, mempty) 27 | import Data.Newtype (unwrap) 28 | import Data.Traversable (class Traversable, traverse) 29 | import Data.Tuple (Tuple(..)) 30 | import Prelude (class Ord) 31 | 32 | -- | `Witherable` represents data structures which can be _partitioned_ with 33 | -- | effects in some `Applicative` functor. 34 | -- | 35 | -- | - `wilt` - partition a structure with effects 36 | -- | - `wither` - filter a structure with effects 37 | -- | 38 | -- | Laws: 39 | -- | 40 | -- | - Naturality: `t <<< wither f ≡ wither (t <<< f)` 41 | -- | - Identity: `wither (pure <<< Just) ≡ pure` 42 | -- | - Composition: `Compose <<< map (wither f) <<< wither g ≡ wither (Compose <<< map (wither f) <<< g)` 43 | -- | - Multipass partition: `wilt p ≡ map separate <<< traverse p` 44 | -- | - Multipass filter: `wither p ≡ map compact <<< traverse p` 45 | -- | 46 | -- | Superclass equivalences: 47 | -- | 48 | -- | - `partitionMap p = runIdentity <<< wilt (Identity <<< p)` 49 | -- | - `filterMap p = runIdentity <<< wither (Identity <<< p)` 50 | -- | - `traverse f ≡ wither (map Just <<< f)` 51 | -- | 52 | -- | Default implementations are provided by the following functions: 53 | -- | 54 | -- | - `wiltDefault` 55 | -- | - `witherDefault` 56 | -- | - `partitionMapByWilt` 57 | -- | - `filterMapByWither` 58 | -- | - `traverseByWither` 59 | class (Filterable t, Traversable t) <= Witherable t where 60 | wilt :: forall m a l r. Applicative m => 61 | (a -> m (Either l r)) -> t a -> m { left :: t l, right :: t r } 62 | 63 | wither :: forall m a b. Applicative m => 64 | (a -> m (Maybe b)) -> t a -> m (t b) 65 | 66 | -- | A default implementation of `wilt` using `separate` 67 | wiltDefault :: forall t m a l r. Witherable t => Applicative m => 68 | (a -> m (Either l r)) -> t a -> m { left :: t l, right :: t r } 69 | wiltDefault p = map separate <<< traverse p 70 | 71 | -- | A default implementation of `wither` using `compact`. 72 | witherDefault :: forall t m a b. Witherable t => Applicative m => 73 | (a -> m (Maybe b)) -> t a -> m (t b) 74 | witherDefault p = map compact <<< traverse p 75 | 76 | -- | A default implementation of `partitionMap` given a `Witherable`. 77 | partitionMapByWilt :: forall t a l r. Witherable t => 78 | (a -> Either l r) -> t a -> { left :: t l, right :: t r } 79 | partitionMapByWilt p = unwrap <<< wilt (Identity <<< p) 80 | 81 | -- | A default implementation of `filterMap` given a `Witherable`. 82 | filterMapByWither :: forall t a b. Witherable t => 83 | (a -> Maybe b) -> t a -> t b 84 | filterMapByWither p = unwrap <<< wither (Identity <<< p) 85 | 86 | -- | A default implementation of `traverse` given a `Witherable`. 87 | traverseByWither :: forall t m a b. Witherable t => Applicative m => 88 | (a -> m b) -> t a -> m (t b) 89 | traverseByWither f = wither (map Just <<< f) 90 | 91 | -- | Partition between `Left` and `Right` values - with effects in `m`. 92 | wilted :: forall t m l r. Witherable t => Applicative m => 93 | t (m (Either l r)) -> m { left :: t l, right :: t r } 94 | wilted = wilt identity 95 | 96 | -- | Filter out all the `Nothing` values - with effects in `m`. 97 | withered :: forall t m x. Witherable t => Applicative m => 98 | t (m (Maybe x)) -> m (t x) 99 | withered = wither identity 100 | 101 | instance witherableArray :: Witherable Array where 102 | wilt = wiltDefault 103 | wither = witherDefault 104 | 105 | instance witherableList :: Witherable List where 106 | wilt p = map rev <<< List.foldl go (pure { left: Nil, right: Nil }) where 107 | rev { left, right } = { left: List.reverse left, right: List.reverse right } 108 | go acc x = (\{left, right} -> 109 | case _ of 110 | Left l -> { left: l : left, right } 111 | Right r -> { left, right: r : right } 112 | ) <$> acc <*> p x 113 | 114 | wither p = map List.reverse <<< List.foldl go (pure Nil) where 115 | go acc x = (\comp -> 116 | case _ of 117 | Nothing -> comp 118 | Just j -> j : comp 119 | ) <$> acc <*> p x 120 | 121 | instance witherableMap :: Ord k => Witherable (Map.Map k) where 122 | wilt p = List.foldl go (pure { left: Map.empty, right: Map.empty }) <<< toList 123 | where 124 | toList :: forall v. Ord k => Map.Map k v -> List.List (Tuple k v) 125 | toList = Map.toUnfoldable 126 | 127 | go acc (Tuple k x) = (\{left, right} -> 128 | case _ of 129 | Left l -> { left: Map.insert k l left, right } 130 | Right r -> { left, right: Map.insert k r right } 131 | ) <$> acc <*> p x 132 | 133 | wither p = List.foldl go (pure Map.empty) <<< toList 134 | where 135 | toList :: forall v. Ord k => Map.Map k v -> List.List (Tuple k v) 136 | toList = Map.toUnfoldable 137 | 138 | go acc (Tuple k x) = (\comp -> 139 | case _ of 140 | Nothing -> comp 141 | Just j -> Map.insert k j comp 142 | ) <$> acc <*> p x 143 | 144 | instance witherableMaybe :: Witherable Maybe where 145 | wilt _ Nothing = pure { left: Nothing, right: Nothing } 146 | wilt p (Just x) = map convert (p x) where 147 | convert (Left l) = { left: Just l, right: Nothing } 148 | convert (Right r) = { left: Nothing, right: Just r } 149 | 150 | wither _ Nothing = pure Nothing 151 | wither p (Just x) = p x 152 | 153 | instance witherableEither :: Monoid m => Witherable (Either m) where 154 | wilt _ (Left el) = pure { left: Left el, right: Left el } 155 | wilt p (Right er) = map convert (p er) where 156 | convert (Left l) = { left: Right l, right: Left mempty } 157 | convert (Right r) = { left: Left mempty, right: Right r } 158 | 159 | wither _ (Left el) = pure (Left el) 160 | wither p (Right er) = map convert (p er) where 161 | convert Nothing = Left mempty 162 | convert (Just r) = Right r 163 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Compactable (compact, separate) 6 | import Data.Either (Either(..)) 7 | import Data.Filterable (filter, filterMap, partition, partitionMap) 8 | import Data.Identity (Identity(Identity)) 9 | import Data.List (List(Nil), (:)) 10 | import Data.Map (fromFoldable) as Map 11 | import Data.Maybe (Maybe(..)) 12 | import Data.Tuple.Nested ((/\)) 13 | import Data.Witherable (wilt, wither) 14 | import Effect (Effect) 15 | import Effect.Console (log) 16 | import Test.Assert (assertEqual) 17 | 18 | testCompactable :: Effect Unit 19 | testCompactable = do 20 | log "Test compactableMaybe instance" *> do 21 | let parts1 = separate $ Just ((Left 1) :: Either Int Int) 22 | assertEqual { actual: parts1.left 23 | , expected: Just 1 24 | } 25 | assertEqual { actual: parts1.right 26 | , expected: Nothing 27 | } 28 | 29 | let parts2 = separate $ Just ((Right 2) :: Either Int Int) 30 | assertEqual { actual: parts2.left 31 | , expected: Nothing 32 | } 33 | assertEqual { actual: parts2.right 34 | , expected: Just 2 35 | } 36 | 37 | let parts3 = separate $ (Nothing :: Maybe (Either Int Int)) 38 | assertEqual { actual: parts3.left 39 | , expected: Nothing 40 | } 41 | assertEqual { actual: parts3.right 42 | , expected: Nothing 43 | } 44 | 45 | log "Text compactableEither instance" *> do 46 | assertEqual { actual: compact (Left [1] :: Either (Array Int) (Maybe Int)) 47 | , expected: Left [1] 48 | } 49 | 50 | assertEqual { actual: compact (Right Nothing :: Either (Array Int) (Maybe Int)) 51 | , expected: Left [] 52 | } 53 | 54 | assertEqual { actual: compact (Right (Just 3) :: Either (Array Int) (Maybe Int)) 55 | , expected: Right 3 56 | } 57 | 58 | let parts1 = separate (Left [1] :: Either (Array Int) (Either Int Int)) 59 | assertEqual { actual: parts1.left 60 | , expected: Left [1] 61 | } 62 | assertEqual { actual: parts1.right 63 | , expected: Left [1] 64 | } 65 | 66 | let parts2 = separate (Right (Left 2) :: Either (Array Int) (Either Int Int)) 67 | assertEqual { actual: parts2.left 68 | , expected: Right 2 69 | } 70 | assertEqual { actual: parts2.right 71 | , expected: Left [] 72 | } 73 | 74 | let parts3 = separate (Right (Right 3) :: Either (Array Int) (Either Int Int)) 75 | assertEqual { actual: parts3.left 76 | , expected: Left [] 77 | } 78 | assertEqual { actual: parts3.right 79 | , expected: Right 3 80 | } 81 | 82 | log "Test compactableArray instance" *> do 83 | let testList = [Left 1, Right 2, Left 3, Right 4, Left 5, Right 6, Left 7, Right 8] 84 | let parts = separate testList 85 | assertEqual { actual: parts.left 86 | , expected: [1, 3, 5, 7] 87 | } 88 | assertEqual { actual: parts.right 89 | , expected: [2, 4, 6, 8] 90 | } 91 | 92 | log "Test compactableList instance" *> do 93 | let testList = (Left 1 : Right 2 : Left 3 : Right 4 : Left 5 : Right 6 : Left 7 : Right 8 : Nil) 94 | let parts = separate testList 95 | assertEqual { actual: parts.left 96 | , expected: 1 : 3 : 5 : 7 : Nil 97 | } 98 | assertEqual { actual: parts.right 99 | , expected: 2 : 4 : 6 : 8 : Nil 100 | } 101 | 102 | log "Test compactableMap instance" *> do 103 | let m = Map.fromFoldable 104 | assertEqual { actual: compact $ m [1 /\ Just 1, 2 /\ Nothing, 3 /\ Just 3, 4 /\ Nothing] 105 | , expected: m [1 /\ 1, 3 /\ 3] 106 | } 107 | 108 | let parts = separate $ m [1 /\ Left 1, 2 /\ Right 2, 3 /\ Left 3, 4 /\ Right 4] 109 | assertEqual { actual: parts.left 110 | , expected: m [1 /\ 1, 3 /\ 3] 111 | } 112 | assertEqual { actual: parts.right 113 | , expected: m [2 /\ 2, 4 /\ 4] 114 | } 115 | 116 | testFilterable :: Effect Unit 117 | testFilterable = do 118 | log "Test filterableMaybe instance" *> do 119 | assertEqual { actual: filterMap pred (Just 6) 120 | , expected: Just 60 121 | } 122 | assertEqual { actual: filterMap pred (Just 5) 123 | , expected: Nothing 124 | } 125 | assertEqual { actual: filterMap pred Nothing 126 | , expected: Nothing 127 | } 128 | 129 | assertEqual { actual: filter (_ > 5) (Just 6) 130 | , expected: Just 6 131 | } 132 | assertEqual { actual: filter (_ > 5) (Just 5) 133 | , expected: Nothing 134 | } 135 | assertEqual { actual: filter (_ > 5) Nothing 136 | , expected: Nothing 137 | } 138 | 139 | log "Test filterableList instance" *> do 140 | let testlist = (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : 9 : Nil) 141 | assertEqual { actual: filterMap pred testlist 142 | , expected: 60 : 70 : 80 : 90 : Nil 143 | } 144 | assertEqual { actual: filter (_ > 5) testlist 145 | , expected: 6 : 7 : 8 : 9 : Nil 146 | } 147 | assertEqual { actual: partition (_ > 5) testlist 148 | , expected: { no: (1 : 2 : 3 : 4 : 5 : Nil), yes: (6 : 7 : 8 : 9 : Nil) } 149 | } 150 | assertEqual { actual: (partitionMap Right $ (1 : 2 : 3 : 4 : 5 : Nil)).right 151 | , expected: 1 : 2 : 3 : 4 : 5 : Nil 152 | } 153 | assertEqual { actual: (partitionMap Left $ (1 : 2 : 3 : 4 : 5 : Nil)).left 154 | , expected: 1 : 2 : 3 : 4 : 5 : Nil 155 | } 156 | 157 | log "Test filterableArray instance" *> do 158 | assertEqual { actual: filterMap pred [1,2,3,4,5,6,7,8,9] 159 | , expected: [60,70,80,90] 160 | } 161 | assertEqual { actual: filter (_ > 5) [1,2,3,4,5,6,7,8,9] 162 | , expected: [6,7,8,9] 163 | } 164 | assertEqual { actual: partition (_ > 5) [1,2,3,4,5,6,7,8,9] 165 | , expected: { no: [1,2,3,4,5], yes: [6,7,8,9] } 166 | } 167 | log "Test filterableMap instance" *> do 168 | let predE x = if x > 5 then Right (x * 10) else Left x 169 | let m = Map.fromFoldable 170 | let xs = m [4 /\ 4, 5 /\ 5, 6 /\ 6, 7 /\ 7] 171 | assertEqual { actual: filterMap pred xs 172 | , expected: m [6 /\ 60, 7 /\ 70] 173 | } 174 | assertEqual { actual: filter (_ > 5) xs 175 | , expected: m [6 /\ 6, 7 /\ 7] 176 | } 177 | assertEqual { actual: partition (_ > 5) xs 178 | , expected: { no: m [4 /\ 4, 5 /\ 5], yes: m [6 /\ 6, 7 /\ 7] } 179 | } 180 | assertEqual { actual: partitionMap predE xs 181 | , expected: { left: m [4 /\ 4, 5 /\ 5], right: m [6 /\ 60, 7 /\ 70] } 182 | } 183 | where 184 | pred x = if x > 5 then Just (x * 10) else Nothing 185 | 186 | testWitherable :: Effect Unit 187 | testWitherable = do 188 | log "Test witherableMaybe instance" *> do 189 | assertEqual { actual: map _.right (wilt predE (Just 6)) 190 | , expected: Identity (Just 60) 191 | } 192 | assertEqual { actual: map _.left (wilt predE (Just 5)) 193 | , expected: Identity (Just 5) 194 | } 195 | assertEqual { actual: map _.right (wilt predE Nothing) 196 | , expected: Identity Nothing 197 | } 198 | 199 | assertEqual { actual: wither predM (Just 6) 200 | , expected: Identity (Just 60) 201 | } 202 | assertEqual { actual: wither predM (Just 5) 203 | , expected: Identity Nothing 204 | } 205 | assertEqual { actual: wither predM Nothing 206 | , expected: Identity Nothing 207 | } 208 | 209 | log "Test witherableEither instance" *> do 210 | assertEqual { actual: map _.right (wilt predE (Right 6 :: Either (Array Int) Int)) 211 | , expected: Identity (Right 60) 212 | } 213 | assertEqual { actual: map _.left (wilt predE (Right 5 :: Either (Array Int) Int)) 214 | , expected: Identity (Right 5) 215 | } 216 | assertEqual { actual: map _.right (wilt predE (Left [] :: Either (Array Int) Int)) 217 | , expected: Identity (Left []) 218 | } 219 | 220 | assertEqual { actual: wither predM (Just 6) 221 | , expected: Identity (Just 60) 222 | } 223 | assertEqual { actual: wither predM (Just 5) 224 | , expected: Identity Nothing 225 | } 226 | assertEqual { actual: wither predM Nothing 227 | , expected: Identity Nothing 228 | } 229 | 230 | log "Test witherableList instance" *> do 231 | let testlist = (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : 9 : Nil) 232 | let resultWilt = wilt predE testlist 233 | assertEqual { actual: map _.right resultWilt 234 | , expected: Identity (60 : 70 : 80 : 90 : Nil) 235 | } 236 | assertEqual { actual: map _.left resultWilt 237 | , expected: Identity (1 : 2 : 3 : 4 : 5 : Nil) 238 | } 239 | assertEqual { actual: map _.right (wilt predE Nil) 240 | , expected: Identity Nil 241 | } 242 | 243 | assertEqual { actual: wither predM testlist 244 | , expected: Identity (60 : 70 : 80 : 90 : Nil) 245 | } 246 | assertEqual { actual: wither predM Nil 247 | , expected: Identity Nil 248 | } 249 | 250 | log "Test witherableArray instance" *> do 251 | let testarray = [1, 2, 3, 4, 5, 6, 7, 8, 9] 252 | let resultWilt = wilt predE testarray 253 | assertEqual { actual: map _.right resultWilt 254 | , expected: Identity [60, 70, 80, 90] 255 | } 256 | assertEqual { actual: map _.left resultWilt 257 | , expected: Identity [1, 2, 3, 4, 5] 258 | } 259 | assertEqual { actual: map _.right (wilt predE []) 260 | , expected: Identity [] 261 | } 262 | 263 | assertEqual { actual: wither predM testarray 264 | , expected: Identity [60, 70, 80, 90] 265 | } 266 | assertEqual { actual: wither predM [], expected: Identity [] } 267 | 268 | log "Test witherableMap instance" *> do 269 | let m = Map.fromFoldable 270 | let xs = m [4 /\ 4, 5 /\ 5, 6 /\ 6, 7 /\ 7] 271 | let resultWilt = wilt predE xs 272 | assertEqual { actual: map _.right resultWilt 273 | , expected: Identity (m [6 /\ 60, 7 /\ 70]) 274 | } 275 | assertEqual { actual: map _.left resultWilt 276 | , expected: Identity (m [4 /\ 4, 5 /\ 5]) 277 | } 278 | 279 | assertEqual { actual: wither predM xs 280 | , expected: Identity (m [6 /\ 60, 7 /\ 70]) 281 | } 282 | 283 | where 284 | predM x = if x > 5 then Identity (Just (x * 10)) else Identity Nothing 285 | predE x = if x > 5 then Identity (Right (x * 10)) else Identity (Left x) 286 | 287 | main :: Effect Unit 288 | main = do 289 | testCompactable 290 | testFilterable 291 | testWitherable 292 | log "All done!" 293 | --------------------------------------------------------------------------------