├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml ├── src └── Control │ └── Lens │ ├── Error.hs │ └── Error │ └── Internal │ └── LensFail.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | lens-errors.cabal 3 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for lens-errors 2 | 3 | ## 0.2.2.0 4 | - Adds new `Fizzler` and `Fizzler'` type aliases for working with fizzlers 5 | - Adds new `fizzler` helper for building fizzlers. 6 | 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Chris Penner (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Chris Penner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lens-errors 2 | 3 | [HACKAGE](http://hackage.haskell.org/package/lens-errors) 4 | 5 | Handling failure deep inside a lens chain intelligently is hard; 6 | You tried to crawl deep into a tree, but it failed and you're not sure why! 7 | This helps with that. 8 | 9 | This library doesn't aim to serve every single use case; or provide a TON of 10 | error combinators, it mostly gives you the tools to write your own. 11 | 12 | # Example 13 | Here's what a usage could look like; 14 | 15 | Let's say we have a nice tree: 16 | 17 | ```haskelll 18 | let tree = Node 0 [Node 1 [Node 2 []]] 19 | ``` 20 | 21 | But we want to get the node at the bottom! No problem, we can write a traversal 22 | for that! 23 | 24 | ```haskell 25 | λ> tree ^.. branches . ix 0 . branches . ix 10 . root 26 | [] 27 | ``` 28 | 29 | Oh; we failed! We can probably guess in this example why the failure occured, 30 | but in larger more complex traversals it can be pretty tough to find sometimes; 31 | and since traversals branch out we might even fail in more than one place at a time! 32 | 33 | `lens-errors` gives us 34 | a whole shwack of `fizzle` combinators which will allow us to effectively 35 | 'kill' a branch of the traversal with an error message while allowing other 36 | branches to continue to limp along and see if they can succeed. 37 | 38 | Why `fizzle` you ask? Words like `fail` or `throw` seem to strong, in this 39 | case only certain branches of the traversal might fizzle out while allowing others to continue. 40 | 41 | Let's build a new traversal which reports a nice error if we fail to index 42 | into the child branch we want: 43 | 44 | ```haskell 45 | let tryIx n = ix n `orFizzleWith` (\xs -> [show n <> " was out of bounds in list: " <> show xs]) 46 | ``` 47 | 48 | Here we use `orFizzleWith` which will try to run the given traversal; but 49 | will build and throw a nice error if the traversal returns no elements. 50 | 51 | Now that we've added errors to our lens chain the standard lens-running combinators 52 | like `^.` and `%~` won't work any more, but we've got new ones. Let's try `^&..` 53 | which runs a traversal and collects the elements into a list, with nice errors along the way! 54 | 55 | ```haskell 56 | >>> tree ^&.. branches . tryIx 0 . branches . tryIx 10 . root 57 | (["10 was out of bounds in list: [Node {rootLabel = 2, subForest = []}]"],[]) 58 | ``` 59 | 60 | What a great error message! Now we know exactly why we didn't manage to find any 61 | elements there. 62 | 63 | You'll notice we actually returned a tuple of type `([String], [Int])`; We return 64 | the errors in the left half and values in the right. Because of the branching factor 65 | of traversals, it's entirely possible for one branch to fail and another to succeed! 66 | 67 | Let's see an example of that. 68 | 69 | ```haskell 70 | >>> [1, 2, 3, 4] ^&.. traversed . fizzleWithUnless (\n -> show n <> " wasn't even!") even 71 | ("1 wasn't even!3 wasn't even!", [2, 4]) 72 | ``` 73 | 74 | Here we see two interesting things! One is that it returned some elements successfully! 75 | But also, it returned a funny looking error message; looks like our messages got smushed together! 76 | 77 | `lens-error` lets you use any error type you want given you follow two conditions: 78 | 79 | 1. All lenses in the chain must agree on the same error type 80 | 2. The error type must be a Monoid. 81 | 82 | The error combinators will end up mashing all your errors together, so usually 83 | it's nice to just wrap them all in a list; up to you though! 84 | 85 | There are a few more `fizzle` combinators available; hopefully you can build what you need with them :) 86 | 87 | For instance we can include failure messages on prisms. 88 | 89 | If we use `^&?`; We'll find the first successfull result; otherwise return all 90 | the errors we encountered. 91 | 92 | ```haskell 93 | >>> let prismError p name = p `orFizzleWith` (\v -> ["Value " <> show v <> " didn't match: " <> name]) 94 | >>> let _R = prismError _Right "_Right" 95 | 96 | >>> [Left (1 :: Int), Left 2, Right (3 :: Int)] ^&? traversed . _R 97 | Success 3 98 | >>> [Left (1 :: Int), Left 2, Left 3] ^&? traversed . _R 99 | Failure [ "Value Left 1 didn't match: _Right" 100 | , "Value Left 2 didn't match: _Right" 101 | , "Value Left 3 didn't match: _Right"] 102 | ``` 103 | 104 | # More examples 105 | 106 | For more examples you can reference the [test suite](./test/Spec.hs). 107 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: lens-errors 2 | version: 0.2.2.0 3 | github: "ChrisPenner/lens-errors" 4 | license: BSD3 5 | author: "Chris Penner" 6 | maintainer: "christopher.penner@gmail.com" 7 | copyright: "Chris Penner" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | synopsis: Error handling in lens chains 13 | category: Lenses 14 | 15 | # To avoid duplicated efforts in documentation and dealing with the 16 | # complications of embedding Haddock markup inside cabal files, it is 17 | # common to point users to the README.md file. 18 | description: Please see the README on GitHub at 19 | 20 | dependencies: 21 | - base >= 4.7 && < 5 22 | - lens 23 | - either 24 | 25 | library: 26 | source-dirs: src 27 | 28 | ghc-options: 29 | - -Wall 30 | 31 | tests: 32 | lens-errors-test: 33 | main: Spec.hs 34 | source-dirs: test 35 | ghc-options: 36 | - -threaded 37 | - -rtsopts 38 | - -with-rtsopts=-N 39 | dependencies: 40 | - lens-errors 41 | - hspec 42 | - containers 43 | -------------------------------------------------------------------------------- /src/Control/Lens/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | module Control.Lens.Error 8 | ( 9 | -- * Actions 10 | examine 11 | , examineList 12 | , preexamine 13 | , trySet 14 | , tryModify 15 | , tryModify' 16 | 17 | -- * Operators 18 | , (^&.) 19 | , (^&..) 20 | , (^&?) 21 | , (.&~) 22 | , (%&~) 23 | , (%%&~) 24 | 25 | -- * Failing 26 | , fizzler 27 | , fizzleWhen 28 | , fizzleUnless 29 | , fizzleWith 30 | , fizzleWithWhen 31 | , fizzleWithUnless 32 | , maybeFizzleWith 33 | , orFizzle 34 | , orFizzleWith 35 | 36 | -- * Adjusting Errors 37 | , adjustingErrors 38 | , adjustingErrorsWith 39 | 40 | -- * Types 41 | , Fizzler 42 | , Fizzler' 43 | 44 | -- * Classes 45 | , LensFail(..) 46 | 47 | -- * Re-exports 48 | , module Data.Either.Validation 49 | ) where 50 | 51 | import Control.Lens.Error.Internal.LensFail 52 | import Control.Lens 53 | import Data.Either.Validation 54 | import Data.Monoid 55 | 56 | -- | Represents a lens-like which may fail with an error of type @e@ 57 | type Fizzler e s t a b = forall f. (LensFail e f, Applicative f) => LensLike f s t a b 58 | 59 | -- | Represents a simple 'Fizzler' 60 | type Fizzler' e s a = Fizzler e s s a a 61 | 62 | -- | Construct a fizzler allowing failure both in the getter and setter. 63 | fizzler :: (s -> Either e a) -> (s -> b -> Either e t) -> Fizzler e s t a b 64 | fizzler viewFizzler setFizzle f s = 65 | case viewFizzler s of 66 | Left e -> fizzle e 67 | Right a -> joinErrors (go <$> f a) 68 | where 69 | go b = case setFizzle s b of 70 | Left e -> fizzle e 71 | Right t -> pure t 72 | 73 | -- | Cause the current traversal to fizzle with a failure when the focus matches a predicate 74 | -- 75 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. _2 . traversed . fizzleWhen ["failure"] even :: ([String], [Int]) 76 | -- (["failure","failure"],[1,3]) 77 | fizzleWhen :: e -> (s -> Bool) -> Fizzler' e s s 78 | fizzleWhen e check f s | check s = fizzle e 79 | | otherwise = f s 80 | 81 | -- | Cause the current traversal to fizzle with a failure when the focus fails a predicate 82 | -- 83 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. _2 . traversed . fizzleUnless ["failure"] even 84 | -- (["failure","failure"],[2,4]) 85 | fizzleUnless :: e -> (s -> Bool) -> Fizzler' e s s 86 | fizzleUnless e check = fizzleWhen e (not . check) 87 | 88 | -- | Given a function which might produce an error, fizzle on 'Just', pass through on 'Nothing' 89 | -- 90 | -- > >>> let p x 91 | -- > >>> | even x = Just [show x <> " was even"] 92 | -- > >>> | otherwise = Nothing 93 | -- > >>> ("hi", [1, 2, 3, 4]) ^&.. _2 . traversed . maybeFizzleWith p 94 | -- > (["2 was even","4 was even"],[1,3]) 95 | maybeFizzleWith :: (s -> Maybe e) -> Fizzler' e s s 96 | maybeFizzleWith check f s = 97 | case check s of 98 | Nothing -> f s 99 | Just e -> fizzle e 100 | 101 | -- | Fizzle using the given error builder when the focus matches a predicate 102 | -- 103 | -- >>> let p x = [show x <> " was even"] 104 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. _2 . traversed . fizzleWithWhen p even 105 | -- (["2 was even","4 was even"],[1,3]) 106 | fizzleWithWhen :: (s -> e) -> (s -> Bool) -> Fizzler' e s s 107 | fizzleWithWhen mkErr check f s 108 | | check s = fizzle $ mkErr s 109 | | otherwise = f s 110 | 111 | -- | Fizzle using the given error builder when the focus fails a predicate 112 | -- 113 | -- >>> let p x = [show x <> " was even"] 114 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. _2 . traversed . fizzleWithUnless p odd 115 | -- (["2 was even","4 was even"],[1,3]) 116 | fizzleWithUnless :: (s -> e) -> (s -> Bool) -> Fizzler' e s s 117 | fizzleWithUnless mkErr check = fizzleWithWhen mkErr (not . check) 118 | 119 | -- | Always fizzle with the given error builder 120 | -- >>> let p x = [show x] 121 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. _2 . traversed . fizzleWith p 122 | -- (["1","2","3","4"],[]) 123 | fizzleWith :: (s -> e) -> Fizzler e s t a b 124 | fizzleWith mkErr _ s = fizzle (mkErr s) 125 | 126 | -- | Fail with the given error when the provided traversal produces no elements. 127 | -- 128 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. (_2 . traversed . filtered (> 10)) `orFizzle` ["nothing over 10"] 129 | -- (["nothing over 10"],[]) 130 | orFizzle :: 131 | (LensFail e f, Applicative f) => 132 | Traversing (->) f s t a b -> e -> LensLike f s t a b 133 | orFizzle l e = orFizzleWith l (const e) 134 | 135 | -- | Fail using the given error builder when the provided traversal produces no elements. 136 | -- 137 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. (_2 . traversed . filtered (> 10)) `orFizzleWith` (\(_, xs) -> ["searched " <> show (length xs) <> " elements, no luck"]) 138 | -- (["searched 4 elements, no luck"],[]) 139 | orFizzleWith :: 140 | (LensFail e f, Applicative f) => 141 | Traversing (->) f s t a b -> (s -> e) -> LensLike f s t a b 142 | orFizzleWith l mkErr = l `failing` fizzleWith mkErr 143 | 144 | infixl 8 ^&. 145 | -- | Operator alias of 'examine' 146 | -- 147 | -- View the focus of a lens or traversal over a monoid. Returns the element and the monoidal 148 | -- sum of any errors encountered. Analogous to '^.' with error collection. 149 | -- 150 | -- >>> ("hi", [1, 2, 3, 4]) ^&. _2 . traversed . fizzleWithWhen (\n -> [show n]) even . to (:[]) 151 | -- (["2","4"],[1,3]) 152 | (^&.) :: Monoid e => s -> Getting (e, a) s a -> (e, a) 153 | (^&.) s l = examine l s 154 | 155 | infixl 8 ^&.. 156 | -- | Operator alias of 'examineList' 157 | -- 158 | -- View the focuses of a traversal as a list. 159 | -- Returns the elements and the monoidal sum of any errors encountered. Analogous to '^..' 160 | -- with error collection. 161 | -- 162 | -- >>> ("hi", [1, 2, 3, 4]) ^&.. (_2 . traversed . fizzleWithWhen (\n -> [show n]) even) 163 | -- (["2","4"],[1,3]) 164 | (^&..) :: Monoid e => s -> Getting (e, [a]) s a -> (e, [a]) 165 | (^&..) s l = examineList l s 166 | 167 | -- | See also '^&.' 168 | -- 169 | -- View the focus of a lens or traversal over a monoid. Returns the element and the monoidal 170 | -- sum of any errors encountered. Analogous to '^.' with error collection. 171 | -- 172 | -- >>> examine (_2 . traversed . fizzleWithWhen (\n -> [show n]) even . to (:[])) ("hi", [1, 2, 3, 4]) 173 | -- (["2","4"],[1,3]) 174 | examine :: Monoid e => Getting (e, a) s a -> s -> (e, a) 175 | examine l = getConst . l (Const . (mempty,)) 176 | 177 | -- | See also '^&..' 178 | -- 179 | -- View the focuses of a traversal as a list. 180 | -- Returns the elements and the monoidal sum of any errors encountered. Analogous to '^..' 181 | -- with error collection. 182 | -- 183 | -- >>> examineList ((_2 . traversed . fizzleWithWhen (\n -> [show n]) even)) ("hi", [1, 2, 3, 4]) 184 | -- (["2","4"],[1,3]) 185 | examineList :: Monoid e => Getting (e, [a]) s a -> s -> (e, [a]) 186 | examineList l = getConst . l (Const . (mempty,) . (:[])) 187 | 188 | infixl 8 ^&? 189 | -- | Operator alias of 'preexamine' 190 | -- 191 | -- Find the first element of a traversal; or return all errors found along the way. 192 | -- 193 | -- >>> [1, 2, 3, 4] ^&? traversed . fizzleWhen ["odd"] odd 194 | -- Success 2 195 | -- 196 | -- >>> [1, 2, 3, 4] ^&? traversed . fizzleWithWhen (\s -> [show s <> " is too small"]) (<10) 197 | -- Failure ["1 is too small","2 is too small","3 is too small","4 is too small"] 198 | (^&?) :: Monoid e => s -> Getting (e, First a) s a -> Validation e a 199 | (^&?) s l = unpack . getConst . l (Const . (mempty,) . First . Just) $ s 200 | where 201 | unpack (_, First (Just a)) = Success a 202 | unpack (e, First (Nothing)) = Failure e 203 | 204 | -- | See also '^&?' 205 | -- 206 | -- Find the first element of a traversal; or return all errors found along the way. 207 | -- 208 | -- >>> preexamine (traversed . fizzleWhen ["odd"] odd) [1, 2, 3, 4] 209 | -- Success 2 210 | -- 211 | -- >>> preexamine (traversed . fizzleWithWhen (\s -> [show s <> " is too small"]) (<10)) [1, 2, 3, 4] 212 | -- Failure ["1 is too small","2 is too small","3 is too small","4 is too small"] 213 | preexamine :: Monoid e => Getting (e, First a) s a -> s -> Validation e a 214 | preexamine l s = s ^&? l 215 | 216 | infixl 8 .&~ 217 | -- | Operator alias of 'trySet 218 | -- 219 | -- Set the focus of a lens/traversal. Returns a monoidal summary of failures or the altered 220 | -- structure. 221 | -- 222 | -- >>> ("hi", [1, 2, 3, 4]) & _2 . ix 1 . fizzleWhen ["shouldn't fail"] (const False) .&~ 42 223 | -- Success ("hi",[1,42,3,4]) 224 | -- 225 | -- >>> ("hi", [1, 2, 3, 4]) & _2 . ix 1 . fizzleWithWhen (\n -> [n]) even .&~ 42 226 | -- Failure [2] 227 | (.&~) :: LensLike (Validation e) s t a b -> b -> s -> Validation e t 228 | (.&~) l b s = s & l %%~ Success . const b 229 | 230 | -- | See also '.&~' 231 | -- 232 | -- Set the focus of a lens/traversal. Returns a monoidal summary of failures or the altered 233 | -- structure. 234 | -- 235 | -- >>> trySet (_2 . ix 1 . fizzleWhen ["shouldn't fail"] (const False)) 42 ("hi", [1, 2, 3, 4]) 236 | -- Success ("hi",[1,42,3,4]) 237 | -- 238 | -- >>> trySet (_2 . ix 1 . fizzleWithWhen (\n -> [n]) even) 42 ("hi", [1, 2, 3, 4]) 239 | -- Failure [2] 240 | trySet :: LensLike (Validation e) s t a b -> b -> s -> Validation e t 241 | trySet = (.&~) 242 | 243 | infixl 8 %&~ 244 | -- | Operator alias of 'tryModify' 245 | -- 246 | -- Modify the focus of a lens/traversal. Returns a monoidal summary of failures or the altered 247 | -- structure. 248 | -- 249 | -- >>> ("hi", [1, 2, 3, 4]) & _2 . traversed . fizzleWhen ["shouldn't fail"] (const False) %&~ (*100) 250 | -- Success ("hi",[100,200,300,400]) 251 | -- 252 | -- >>> ("hi", [1, 2, 3, 4]) & _2 . traversed . fizzleWithWhen (\n -> [n]) even %&~ (*100) 253 | -- Failure [2,4] 254 | (%&~) :: LensLike (Validation e) s t a b -> (a -> b) -> s -> Validation e t 255 | (%&~) l f s = s & l %%~ Success . f 256 | 257 | -- | See also '%&~' 258 | -- 259 | -- Modify the focus of a lens/traversal. Returns a monoidal summary of failures or the altered 260 | -- structure. 261 | -- 262 | -- >>> tryModify (_2 . traversed . fizzleWhen ["shouldn't fail"] (const False)) (*100) ("hi", [1, 2, 3, 4]) 263 | -- Success ("hi",[100,200,300,400]) 264 | -- 265 | -- >>> tryModify (_2 . traversed . fizzleWithWhen (\n -> [n]) even) (*100) ("hi", [1, 2, 3, 4]) 266 | -- Failure [2,4] 267 | tryModify :: LensLike (Validation e) s t a b -> (a -> b) -> s -> Validation e t 268 | tryModify l f s = s & l %&~ f 269 | 270 | infixl 8 %%&~ 271 | -- | Operator alias of 'tryModify'' 272 | -- 273 | -- Modify the focus of a lens/traversal with a function which may fail. 274 | -- Returns a monoidal summary of failures or the altered structure. 275 | -- 276 | -- The definition of this function is actually just: 277 | -- 278 | -- > (%%&~) = (%%~) 279 | -- 280 | -- But this combinator is provided for discoverability, completeness, and hoogle-ability. 281 | -- 282 | -- >>> ("hi", [1, 2, 3, 4]) & _2 . traversed . fizzleWithWhen (\n -> [n]) even %%&~ Success . (*100) 283 | -- Failure [2,4] 284 | -- >>> ("hi", [1, 2, 3, 4]) & _2 . traversed %%&~ (\n -> Failure [show n <> " failed"]) 285 | -- Failure ["1 failed","2 failed","3 failed","4 failed"] 286 | (%%&~) :: LensLike (Validation e) s t a b -> (a -> Validation e b) -> s -> Validation e t 287 | (%%&~) = (%%~) 288 | 289 | -- | See also '%%&~' 290 | -- 291 | -- Modify the focus of a lens/traversal with a function which may fail. 292 | -- Returns a monoidal summary of failures or the altered structure. 293 | -- 294 | -- >>> tryModify' (_2 . traversed . fizzleWithWhen (\n -> [n]) even) (Success . (*100)) ("hi", [1, 2, 3, 4]) 295 | -- Failure [2,4] 296 | -- >>> tryModify' (_2 . traversed) (\n -> Failure [show n <> " failed"]) ("hi", [1, 2, 3, 4]) 297 | -- Failure ["1 failed","2 failed","3 failed","4 failed"] 298 | tryModify' :: LensLike (Validation e) s t a b -> (a -> Validation e b) -> s -> Validation e t 299 | tryModify' l f s = s & l %%~ f 300 | 301 | 302 | -- | Adjust any errors which occur in the following branch. 303 | -- Note that we can't change the error type, but this can be helpful for adding context 304 | -- to errors if they occur at a position without enough context. 305 | -- 306 | -- This is does nothing when no errors occur. 307 | -- 308 | -- >>> [1, 2, 3, 4 :: Int] ^&.. traversed . fizzleWhen ["got 4"] (== 4) . adjustingErrors (fmap (<> "!")) . fizzleWhen ["got 3"] (== 3) 309 | -- (["got 3!","got 4"],[1,2]) 310 | adjustingErrors :: (e -> e) -> Fizzler' e s s 311 | adjustingErrors addCtx f s = alterErrors addCtx (f s) 312 | 313 | -- | Adjust any errors which occur in the following branch, using the value available at 314 | -- the current position to add context.. 315 | -- Note that we can't change the error type, but this can be helpful for adding context 316 | -- to errors if they occur at a position without enough context. 317 | -- 318 | -- This is does nothing when no errors occur. 319 | -- 320 | -- >>> [1, 2, 3, 4 :: Int] ^&.. traversed . fizzleWhen ["got 4"] (== 4) . adjustingErrorsWith (\n -> fmap (\e -> show n <> ": " <> e)) . fizzleWhen ["fail"] (== 3) 321 | -- (["3: fail","got 4"],[1,2]) 322 | adjustingErrorsWith :: (s -> e -> e) -> Fizzler' e s s 323 | adjustingErrorsWith addCtx f s = alterErrors (addCtx s) (f s) 324 | -------------------------------------------------------------------------------- /src/Control/Lens/Error/Internal/LensFail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | module Control.Lens.Error.Internal.LensFail where 5 | 6 | import Data.Functor.Const 7 | import Data.Either.Validation 8 | import Control.Monad 9 | import Data.Functor.Contravariant 10 | 11 | class LensFail e f | f -> e where 12 | fizzle :: e -> f a 13 | alterErrors :: (e -> e) -> f a -> f a 14 | joinErrors :: f (f a) -> f a 15 | 16 | instance Monoid a => LensFail e (Const (e, a)) where 17 | fizzle e = Const (e, mempty) 18 | alterErrors f (Const (e, a)) = Const (f e, a) 19 | joinErrors = phantom 20 | 21 | instance LensFail e (Const (Either e a)) where 22 | fizzle e = Const (fizzle e) 23 | alterErrors f (Const (Left e)) = Const (Left (f e)) 24 | alterErrors _ fa = fa 25 | joinErrors = phantom 26 | 27 | instance LensFail e (Const (Validation e a)) where 28 | fizzle e = Const (fizzle e) 29 | alterErrors f (Const (Failure e)) = Const (Failure (f e)) 30 | alterErrors _ fa = fa 31 | joinErrors = phantom 32 | 33 | instance LensFail e (Either e) where 34 | fizzle e = Left e 35 | alterErrors f (Left e) = Left (f e) 36 | alterErrors _ fa = fa 37 | joinErrors = join 38 | 39 | instance LensFail e (Validation e) where 40 | fizzle e = Failure e 41 | alterErrors f (Failure e) = Failure (f e) 42 | alterErrors _ fa = fa 43 | joinErrors (Failure e) = Failure e 44 | joinErrors (Success a) = a 45 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.3 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | import Control.Lens 6 | import Control.Lens.Error 7 | import Test.Hspec 8 | import Data.Tree 9 | import Data.Tree.Lens 10 | 11 | numbers :: (String, [ Int ]) 12 | numbers = ("hi", [1, 2, 3, 4]) 13 | 14 | main :: IO () 15 | main = hspec $ do 16 | describe "fizzler" $ do 17 | let fizzHead :: Fizzler' [String] [Int] Int 18 | fizzHead = fizzler getter setter 19 | getter :: [Int] -> Either [String] Int 20 | getter [] = Left ["empty list!"] 21 | getter (x:_) = Right x 22 | setter :: [Int] -> Int -> Either [String] [Int] 23 | setter (x:_) _ | x < 0 = Left ["refusing to set over negative head"] 24 | setter (_:xs) x = Right (x : xs) 25 | setter [] _ = Right [] 26 | it "should get when succesful" $ do 27 | ("hi", [1, 2, 3, 4]) ^&.. _2 . fizzHead 28 | `shouldBe` (([], [1])) 29 | it "should return errors from getter" $ do 30 | ("hi", []) ^&.. _2 . fizzHead 31 | `shouldBe` ((["empty list!"], [])) 32 | it "should set when succesful" $ do 33 | (("hi", [1, 2, 3, 4]) & _2 . fizzHead %&~ (*10)) 34 | `shouldBe` (Success ("hi", [10, 2, 3, 4])) 35 | it "should return errors from getter when setting iff that fails first" $ do 36 | (("hi", []) & _2 . fizzHead %&~ (*10)) 37 | `shouldBe` Failure ["empty list!"] 38 | it "should return errors from setter iff getter passes but setter fails" $ do 39 | (("hi", [-10, 2, 3, 4]) & _2 . fizzHead %&~ (*10)) 40 | `shouldBe` Failure ["refusing to set over negative head"] 41 | 42 | describe "examine (^&.)" $ do 43 | it "should view properly through traversals/folds" $ do 44 | numbers ^&. _2 . traversed . to show 45 | `shouldBe` ((), "1234") 46 | 47 | it "should view properly through successful assertions" $ do 48 | numbers ^&. _2 . traversed . fizzleWhen ["shouldn't fail"] (const False) . to show 49 | `shouldBe` ([], "1234") 50 | 51 | it "should collect failures when they occur" $ do 52 | numbers ^&. _2 . traversed . fizzleWithWhen (\n -> [show n]) (const True) . to show 53 | `shouldBe` (["1", "2", "3", "4"], "") 54 | 55 | it "should collect failures AND successes when they occur" $ do 56 | numbers ^&. _2 . traversed . fizzleWithWhen (\n -> [show n]) even . to (:[]) 57 | `shouldBe` (["2", "4"], [1, 3]) 58 | 59 | describe "examineList (^&..)" $ do 60 | it "should view properly through traversals/folds" $ do 61 | numbers ^&.. _2 . traversed 62 | `shouldBe` ((), [1, 2, 3, 4]) 63 | 64 | it "should view properly through successful assertions" $ do 65 | numbers ^&.. (_2 . traversed . fizzleWhen ["shouldn't fail"] (const False)) 66 | `shouldBe` ([], [1, 2, 3, 4]) 67 | 68 | it "should collect failures when they occur" $ do 69 | numbers ^&.. (_2 . traversed . fizzleWithWhen (\n -> [show n]) (const True)) 70 | `shouldBe` (["1", "2", "3", "4"], []) 71 | 72 | it "should collect failures AND successes when they occur" $ do 73 | numbers ^&.. (_2 . traversed . fizzleWithWhen (\n -> [show n]) even) 74 | `shouldBe` (["2", "4"], [1, 3]) 75 | 76 | describe "preexamine ^&?" $ do 77 | it "Should find first success or return all errors" $ do 78 | let prismError p name = p `orFizzleWith` (\v -> ["Value " <> show v <> " didn't match: " <> name]) 79 | let _R = prismError _Right "_Right" 80 | ([Left (1 :: Int), Left 2, Right (3 :: Int)] ^&? traversed . _R) 81 | `shouldBe` (Success 3) 82 | ([Left (1 :: Int), Left 2, Left 3] ^&? traversed . _R) 83 | `shouldBe` (Failure [ "Value Left 1 didn't match: _Right" 84 | , "Value Left 2 didn't match: _Right" 85 | , "Value Left 3 didn't match: _Right"]) 86 | describe "trySet .&~" $ do 87 | it "should set successfully" $ do 88 | (numbers & _2 . ix 1 . fizzleWhen ["shouldn't fail"] (const False) .&~ 42) 89 | `shouldBe` Success ("hi",[1,42,3,4]) 90 | it "should return failures" $ do 91 | (numbers & _2 . ix 1 . fizzleWithWhen (\n -> [n]) even .&~ 42) 92 | `shouldBe` Failure [2] 93 | 94 | describe "tryModify %&~" $ do 95 | it "should edit successfully with no assertions" $ do 96 | (numbers & _2 . traversed %&~ (*100)) 97 | `shouldBe` (Success ("hi", [100, 200, 300, 400]) :: Validation () (String, [Int])) 98 | it "should edit successfully through valid assertions" $ do 99 | (numbers & _2 . traversed . fizzleWhen ["shouldn't fail"] (const False) %&~ (*100)) 100 | `shouldBe` (Success ("hi", [100, 200, 300, 400])) 101 | it "should return failures" $ do 102 | (numbers & _2 . traversed . fizzleWithWhen (\n -> [n]) (const True) %&~ (*100)) 103 | `shouldBe` Failure [1, 2, 3, 4] 104 | it "should collect all failures if anything fails" $ do 105 | (numbers & _2 . traversed . fizzleWithWhen (\n -> [n]) even %&~ (*100)) 106 | `shouldBe` Failure [2, 4] 107 | 108 | describe "tryModify' %%&~" $ do 109 | it "should edit successfully with no assertions" $ do 110 | (numbers & _2 . traversed %%&~ Success . (*100)) 111 | `shouldBe` (Success ("hi", [100, 200, 300, 400]) :: Validation () (String, [Int])) 112 | it "should edit successfully through valid assertions" $ do 113 | (numbers & _2 . traversed . fizzleWhen ["shouldn't fail"] (const False) %%&~ Success . (*100)) 114 | `shouldBe` (Success ("hi", [100, 200, 300, 400])) 115 | it "should return failures" $ do 116 | (numbers & _2 . traversed . fizzleWithWhen (\n -> [n]) (const True) %%&~ Success . (*100)) 117 | `shouldBe` Failure [1, 2, 3, 4] 118 | it "should collect all failures if anything fails" $ do 119 | (numbers & _2 . traversed . fizzleWithWhen (\n -> [n]) even %%&~ Success . (*100)) 120 | `shouldBe` Failure [2, 4] 121 | it "should fail if the function fails" $ do 122 | (numbers & _2 . traversed %%&~ (\n -> Failure [show n <> " failed"])) 123 | `shouldBe` (Failure ["1 failed","2 failed","3 failed","4 failed"] :: Validation [String] (String, [Int])) 124 | 125 | describe "fizzleWhen" $ do 126 | it "should fizzle when predicate is true" $ do 127 | numbers ^&.. _2 . traversed . fizzleWhen ["failure"] even 128 | `shouldBe` (["failure", "failure"], [1, 3]) 129 | describe "fizzleUnless" $ do 130 | it "should fizzle when predicate is false" $ do 131 | numbers ^&.. _2 . traversed . fizzleUnless ["failure"] even 132 | `shouldBe` (["failure", "failure"], [2, 4]) 133 | describe "maybeFizzleWith" $ do 134 | it "should fizzle when returning Just" $ do 135 | let p x 136 | | even x = Just [show x <> " was even"] 137 | | otherwise = Nothing 138 | numbers ^&.. _2 . traversed . maybeFizzleWith p 139 | `shouldBe` (["2 was even", "4 was even"], [1, 3]) 140 | describe "fizzleWithWhen" $ do 141 | it "should fizzle using the error builder when predicate is true" $ do 142 | let p x = [show x <> " was even"] 143 | numbers ^&.. _2 . traversed . fizzleWithWhen p even 144 | `shouldBe` (["2 was even", "4 was even"], [1, 3]) 145 | describe "fizzleWithUnless" $ do 146 | it "should fizzle using the error builder when predicate is false" $ do 147 | let p x = [show x <> " was even"] 148 | numbers ^&.. _2 . traversed . fizzleWithUnless p odd 149 | `shouldBe` (["2 was even", "4 was even"], [1, 3]) 150 | describe "fizzleWith" $ do 151 | it "should always fizzle using the error builder" $ do 152 | let p x = [show x] 153 | numbers ^&.. _2 . traversed . fizzleWith p 154 | `shouldBe` (["1", "2", "3", "4"], [] :: [Int]) 155 | describe "orFizzle" $ do 156 | it "should always fizzle using the error builder" $ do 157 | numbers ^&.. (_2 . traversed . filtered (> 10)) `orFizzle` ["nothing over 10"] 158 | `shouldBe` (["nothing over 10"], []) 159 | describe "orFizzleWith" $ do 160 | it "should always fizzle using the error builder" $ do 161 | numbers ^&.. (_2 . traversed . filtered (> 10)) `orFizzleWith` (\(_, xs) -> ["searched " <> show (length xs) <> " elements, no luck"]) 162 | `shouldBe` (["searched 4 elements, no luck"], []) 163 | describe "adjustingErrors" $ do 164 | it "should alter errors from its sub-branch, but not outside of it" $ do 165 | [1, 2, 3, 4 :: Int] ^&.. traversed . fizzleWhen ["got 4"] (== 4) . adjustingErrors (fmap (<> "!")) . fizzleWhen ["got 3"] (== 3) 166 | `shouldBe` (["got 3!", "got 4"], [1, 2]) 167 | describe "adjustingErrorsWith" $ do 168 | it "should alter errors from its sub-branch, but not outside of it, using the value to construct the error" $ do 169 | [1, 2, 3, 4 :: Int] ^&.. traversed . fizzleWhen ["got 4"] (== 4) . adjustingErrorsWith (\n -> fmap (\e -> show n <> ": " <> e)) . fizzleWhen ["fail"] (== 3) 170 | `shouldBe` (["3: fail","got 4"], [1, 2]) 171 | 172 | describe "real examples" $ do 173 | it "tree get success" $ do 174 | let tree = Node "top" [Node "mid" [Node "bottom" []]] 175 | let tryIx n = ix n `orFizzleWith` (\xs -> [show n <> " was out of bounds in list: " <> show xs]) 176 | tree ^&.. branches . tryIx 0 . branches . tryIx 0 . root 177 | `shouldBe` ([],["bottom"]) 178 | it "tree get failure" $ do 179 | let tree = Node "top" [Node "mid" [Node "bottom" []]] 180 | let tryIx n = ix n `orFizzleWith` (\xs -> [show n <> " was out of bounds in list: " <> show xs]) 181 | tree ^&.. branches . tryIx 0 . branches . tryIx 10 . root 182 | `shouldBe` (["10 was out of bounds in list: [Node {rootLabel = \"bottom\", subForest = []}]"],[]) 183 | it "tree set" $ do 184 | let tree = Node "top" [Node "mid" [Node "bottom" []]] :: Tree String 185 | let tryIx :: (Applicative f, LensFail [String] f, Show a) => Int -> LensLike' f [a] a 186 | tryIx n = ix n `orFizzleWith` (\xs -> [show n <> " was out of bounds in list: " <> show xs]) 187 | (tree & branches . tryIx 0 . branches . tryIx 10 . root %&~ (<> "!!")) 188 | `shouldBe` (Failure ["10 was out of bounds in list: [Node {rootLabel = \"bottom\", subForest = []}]"]) 189 | 190 | 191 | --------------------------------------------------------------------------------