Skip to content

Commit 8dc86be

Browse files
vrom911vrom911
authored
[#24] Extra interface functions (#45)
* [#24] Extra interface functions Resolves #24 * Rename vars * Add hs-boot for Validation to break cyclic deps
1 parent 9e45fe6 commit 8dc86be

6 files changed

Lines changed: 258 additions & 1 deletion

File tree

‎CHANGELOG.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,10 @@ The changelog is available [on GitHub][2].
88
* [#41](https://github.com/kowainik/relude/issues/41):
99
Support GHC-8.10.1.
1010
(by [@chshersh](https://github.com/chshersh))
11+
* [#24](https://github.com/kowainik/relude/issues/24):
12+
Add `validationAll`, `when*` and `maybe*` combinators into
13+
`Validation.Combinators`.
14+
(by [@vrom911](https://github.com/vrom911))
1115

1216
## 0.0.0.0
1317

‎src/Validation.hs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,25 @@ module Validation
8282
-- $either
8383
, validationToEither
8484
, eitherToValidation
85+
86+
-- * Combinators
87+
, validateAll
88+
89+
-- ** When* functions
90+
, whenSuccess
91+
, whenFailure
92+
, whenSuccess_
93+
, whenFailure_
94+
, whenSuccessM
95+
, whenFailureM
96+
, whenSuccessM_
97+
, whenFailureM_
98+
99+
-- ** 'Maybe' conversion
100+
, failureToMaybe
101+
, successToMaybe
102+
, maybeToFailure
103+
, maybeToSuccess
85104
) where
86105

87106
import Control.Applicative (Alternative (..), Applicative (..))
@@ -97,6 +116,8 @@ import Data.List.NonEmpty (NonEmpty (..))
97116
import GHC.Generics (Generic, Generic1)
98117
import GHC.TypeLits (ErrorMessage (..), TypeError)
99118

119+
import Validation.Combinators
120+
100121

101122
-- $setup
102123
-- >>> import Control.Applicative (liftA3)

‎src/Validation.hs-boot‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
module Validation
2+
( Validation (..)
3+
, validation
4+
) where
5+
6+
7+
data Validation e a
8+
= Failure e
9+
| Success a
10+
11+
instance (Semigroup e) => Applicative (Validation e)
12+
13+
validation :: (e -> x) -> (a -> x) -> Validation e a -> x

‎src/Validation/Combinators.hs‎

Lines changed: 216 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,216 @@
1+
{- |
2+
Copyright: (c) 2020 Kowainik
3+
SPDX-License-Identifier: MPL-2.0
4+
Maintainer: Kowainik <xrom.xkov@gmail.com>
5+
6+
Helpful combinators to work with 'Validation' data type.
7+
-}
8+
9+
module Validation.Combinators
10+
( validateAll
11+
12+
-- * When* functions
13+
, whenSuccess
14+
, whenFailure
15+
, whenSuccess_
16+
, whenFailure_
17+
, whenSuccessM
18+
, whenFailureM
19+
, whenSuccessM_
20+
, whenFailureM_
21+
22+
-- * 'Maybe' conversion
23+
, failureToMaybe
24+
, successToMaybe
25+
, maybeToFailure
26+
, maybeToSuccess
27+
28+
) where
29+
30+
import Data.Foldable (foldl')
31+
32+
import {-# SOURCE #-} Validation (Validation (..), validation)
33+
34+
35+
{- | Validate all given checks in a 'Foldable'. Returns the 'Success' of the
36+
start element when all checks are successful.
37+
38+
39+
A basic example of usage could look like this:
40+
41+
@
42+
> let validatePassword = validateAll
43+
[ validateEmptyPassword
44+
, validateShortPassword
45+
]
46+
47+
> validateAll "VeryStrongPassword"
48+
Success "VeryStrongPassword"
49+
50+
> validateAll ""
51+
Failure (EmptyPassword :| [ShortPassword])
52+
@
53+
-}
54+
validateAll
55+
:: forall e b a f
56+
. (Foldable f, Semigroup e)
57+
=> f (a -> Validation e b)
58+
-> a
59+
-> Validation e a
60+
validateAll fs a = foldl' (\res f -> res <* f a) (Success a) fs
61+
{-# INLINE validateAll #-}
62+
63+
{- | Applies the given action to 'Validation' if it is 'Failure' and returns the
64+
result. In case of 'Success' the default value is returned.
65+
66+
>>> whenFailure "bar" (Failure 42) (\a -> "foo" <$ print a)
67+
42
68+
"foo"
69+
70+
>>> whenFailure "bar" (Success 42) (\a -> "foo" <$ print a)
71+
"bar"
72+
-}
73+
whenFailure :: Applicative f => x -> Validation e a -> (e -> f x) -> f x
74+
whenFailure _ (Failure e) f = f e
75+
whenFailure a (Success _) _ = pure a
76+
{-# INLINE whenFailure #-}
77+
78+
{- | Applies given action to the 'Validation' content if it is 'Failure'.
79+
80+
Similar to 'whenFailure' but the default value is '()'.
81+
82+
>>> whenFailure_ (Success 42) putStrLn
83+
>>> whenFailure_ (Failure "foo") putStrLn
84+
foo
85+
-}
86+
whenFailure_ :: Applicative f => Validation e a -> (e -> f ()) -> f ()
87+
whenFailure_ = whenFailure ()
88+
{-# INLINE whenFailure_ #-}
89+
90+
{- | Monadic version of 'whenFailure'.
91+
Applies monadic action to the given 'Validation' in case of 'Failure'.
92+
Returns the resulting value, or provided default.
93+
94+
>>> whenFailureM "bar" (pure $ Failure 42) (\a -> "foo" <$ print a)
95+
42
96+
"foo"
97+
98+
>>> whenFailureM "bar" (pure $ Success 42) (\a -> "foo" <$ print a)
99+
"bar"
100+
-}
101+
whenFailureM :: Monad m => x -> m (Validation e a) -> (e -> m x) -> m x
102+
whenFailureM x mv f = mv >>= \v -> whenFailure x v f
103+
{-# INLINE whenFailureM #-}
104+
105+
{- | Monadic version of 'whenFailure_'.
106+
Applies monadic action to the given 'Validation' in case of 'Failure'.
107+
Similar to 'whenFailureM' but the default is '()'.
108+
109+
>>> whenFailureM_ (pure $ Success 42) putStrLn
110+
>>> whenFailureM_ (pure $ Failure "foo") putStrLn
111+
foo
112+
-}
113+
whenFailureM_ :: Monad m => m (Validation e a) -> (e -> m ()) -> m ()
114+
whenFailureM_ mv f = mv >>= \v -> whenFailure_ v f
115+
{-# INLINE whenFailureM_ #-}
116+
117+
{- | Applies the given action to 'Validation' if it is 'Success' and returns the
118+
result. In case of 'Failure' the default value is returned.
119+
120+
>>> whenSuccess "bar" (Failure "foo") (\a -> "success!" <$ print a)
121+
"bar"
122+
123+
>>> whenSuccess "bar" (Success 42) (\a -> "success!" <$ print a)
124+
42
125+
"success!"
126+
-}
127+
whenSuccess :: Applicative f => x -> Validation e a -> (a -> f x) -> f x
128+
whenSuccess x (Failure _) _ = pure x
129+
whenSuccess _ (Success a) f = f a
130+
{-# INLINE whenSuccess #-}
131+
132+
{- | Applies given action to the 'Validation' content if it is 'Success'.
133+
134+
Similar to 'whenSuccess' but the default value is '()'.
135+
136+
>>> whenSuccess_ (Failure "foo") print
137+
>>> whenSuccess_ (Success 42) print
138+
42
139+
-}
140+
whenSuccess_ :: Applicative f => Validation e a -> (a -> f ()) -> f ()
141+
whenSuccess_ = whenSuccess ()
142+
{-# INLINE whenSuccess_ #-}
143+
144+
{- | Monadic version of 'whenSuccess'.
145+
Applies monadic action to the given 'Validation' in case of 'Success'.
146+
Returns the resulting value, or provided default.
147+
148+
>>> whenSuccessM "bar" (pure $ Failure "foo") (\a -> "success!" <$ print a)
149+
"bar"
150+
151+
>>> whenSuccessM "bar" (pure $ Success 42) (\a -> "success!" <$ print a)
152+
42
153+
"success!"
154+
-}
155+
whenSuccessM :: Monad m => x -> m (Validation e a) -> (a -> m x) -> m x
156+
whenSuccessM x mv f = mv >>= \v -> whenSuccess x v f
157+
{-# INLINE whenSuccessM #-}
158+
159+
{- | Monadic version of 'whenSuccess_'.
160+
Applies monadic action to the given 'Validation' in case of 'Success'.
161+
Similar to 'whenSuccessM' but the default is '()'.
162+
163+
>>> whenSuccessM_ (pure $ Failure "foo") print
164+
>>> whenSuccessM_ (pure $ Success 42) print
165+
42
166+
-}
167+
whenSuccessM_ :: Monad m => m (Validation e a) -> (a -> m ()) -> m ()
168+
whenSuccessM_ mv f = mv >>= \v -> whenSuccess_ v f
169+
{-# INLINE whenSuccessM_ #-}
170+
171+
172+
{- | Maps 'Failure' of 'Validation' to 'Just'.
173+
174+
>>> failureToMaybe (Failure True)
175+
Just True
176+
>>> failureToMaybe (Success "aba")
177+
Nothing
178+
-}
179+
failureToMaybe :: Validation e a -> Maybe e
180+
failureToMaybe = validation Just (const Nothing)
181+
{-# INLINE failureToMaybe #-}
182+
183+
{- | Maps 'Success' of 'Validation' to 'Just'.
184+
185+
>>> successToMaybe (Failure True)
186+
Nothing
187+
>>> successToMaybe (Success "aba")
188+
Just "aba"
189+
-}
190+
successToMaybe :: Validation e a -> Maybe a
191+
successToMaybe = validation (const Nothing) Just
192+
{-# INLINE successToMaybe #-}
193+
194+
{- | Maps 'Just' to 'Failure' In case of 'Nothing' it wraps the given default
195+
value into 'Success'.
196+
197+
>>> maybeToFailure True (Just "aba")
198+
Failure "aba"
199+
>>> maybeToFailure True Nothing
200+
Success True
201+
-}
202+
maybeToFailure :: a -> Maybe e -> Validation e a
203+
maybeToFailure a = maybe (Success a) Failure
204+
{-# INLINE maybeToFailure #-}
205+
206+
{- | Maps 'Just' to 'Success'. In case of 'Nothing' it wraps the given default
207+
value into 'Failure'
208+
209+
>>> maybeToSuccess True (Just "aba")
210+
Success "aba"
211+
>>> maybeToSuccess True Nothing
212+
Failure True
213+
-}
214+
maybeToSuccess :: e -> Maybe a -> Validation e a
215+
maybeToSuccess e = maybe (Failure e) Success
216+
{-# INLINE maybeToSuccess #-}

‎test/Doctest.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,4 +23,6 @@ main = doctest
2323
: "-XRecordWildCards"
2424
: "-XScopedTypeVariables"
2525
: "-XTypeApplications"
26-
: [ "src/Validation.hs" ]
26+
: [ "src/Validation.hs"
27+
, "src/Validation/Combinators.hs"
28+
]

‎validation-selective.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -73,6 +73,7 @@ library
7373
import: common-options
7474
hs-source-dirs: src
7575
exposed-modules: Validation
76+
Validation.Combinators
7677
build-depends: deepseq ^>= 1.4.3.0
7778
, selective >= 0.3 && < 0.5
7879

0 commit comments

Comments
 (0)