Skip to content

Commit f6b7f20

Browse files
zrhozrho
committed
Moving towards feature parity with purescript-lens/optic.
1 parent 84f4285 commit f6b7f20

File tree

12 files changed

+323
-42
lines changed

12 files changed

+323
-42
lines changed

‎bower.json‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -10,15 +10,17 @@
1010
"bower_components",
1111
"output"
1212
],
13-
"repository": {
14-
"type": "git",
13+
"repository": {
14+
"type": "git",
1515
"url": "git://github.com/paf31/purescript-profunctor-lenses.git"
16-
},
16+
},
1717
"devDependencies": {
1818
"purescript-console": "^0.1.0"
1919
},
2020
"dependencies": {
2121
"purescript-const": "~0.5.0",
22-
"purescript-profunctor": "~0.3.0"
22+
"purescript-identity": "~0.4.0",
23+
"purescript-profunctor": "~0.3.0",
24+
"purescript-lists": "~0.7.0"
2325
}
2426
}

‎src/Data/Lens.purs‎

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,17 +5,26 @@
55
-- | - [`module Data.Lens.Prism`](Lens/Prism.md)
66
-- | - [`module Data.Lens.Traversal`](Lens/Traversal.md)
77
-- | - [`module Data.Lens.Types`](Lens/Types.md)
8+
-- | - [`module Data.Lens.Setter`](Lens/Setter.md)
9+
-- | - [`module Data.Lens.Getter`](Lens/Getter.md)
10+
-- | - [`module Data.Lens.Fold`](Lens/Fold.md)
811

9-
module Data.Lens
12+
module Data.Lens
1013
( module Data.Lens.Iso
1114
, module Data.Lens.Lens
1215
, module Data.Lens.Prism
1316
, module Data.Lens.Traversal
1417
, module Data.Lens.Types
18+
, module Data.Lens.Setter
19+
, module Data.Lens.Getter
20+
, module Data.Lens.Fold
1521
) where
1622

1723
import Data.Lens.Iso
1824
import Data.Lens.Lens
1925
import Data.Lens.Prism
2026
import Data.Lens.Traversal
21-
import Data.Lens.Types
27+
import Data.Lens.Types
28+
import Data.Lens.Setter
29+
import Data.Lens.Getter
30+
import Data.Lens.Fold

‎src/Data/Lens/Fold.purs‎

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
-- | This module defines functions for working with getters.
2+
3+
module Data.Lens.Fold
4+
( (^?), (^..)
5+
, preview, foldOf, foldMapOf, foldrOf, foldlOf, toListOf, has, hasn't
6+
) where
7+
8+
import Prelude
9+
import Data.Const
10+
import Data.Maybe
11+
import Data.List
12+
import Data.Maybe.First
13+
import Data.Monoid.Endo
14+
import Data.Monoid.Conj
15+
import Data.Monoid.Disj
16+
import Data.Monoid.Dual
17+
import Data.Profunctor.Star
18+
import Data.Lens.Types
19+
import Data.Lens.Internal.Tagged
20+
21+
infixl 8 ^?
22+
infixl 8 ^..
23+
24+
-- | Previews the first value of a fold, if there is any.
25+
preview :: forall s t a b. Fold (First a) s t a b -> s -> Maybe a
26+
preview p = runFirst <<< foldMapOf p (First <<< Just)
27+
28+
-- | Synonym for `preview`, flipped.
29+
(^?) :: forall s t a b. s -> Fold (First a) s t a b -> Maybe a
30+
(^?) s p = preview p s
31+
32+
-- | Folds all foci of a `Fold` to one. Note that this is the same as `view`.
33+
foldOf :: forall s t a b. Fold a s t a b -> s -> a
34+
foldOf p = getConst <<< runStar (p (Star Const))
35+
36+
-- | Maps and then folds all foci of a `Fold`.
37+
foldMapOf :: forall s t a b r. Fold r s t a b -> (a -> r) -> s -> r
38+
foldMapOf p f = getConst <<< runStar (p (Star (Const <<< f)))
39+
40+
-- | Right fold over a `Fold`.
41+
foldrOf :: forall s t a b r. Fold (Endo r) s t a b -> (a -> r -> r) -> r -> s -> r
42+
foldrOf p f r = flip runEndo r <<< foldMapOf p (Endo <<< f)
43+
44+
-- | Left fold over a `Fold`.
45+
foldlOf :: forall s t a b r. Fold (Dual (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r
46+
foldlOf p f r = flip runEndo r <<< runDual <<< foldMapOf p (Dual <<< Endo <<< flip f)
47+
48+
-- | Collects the foci of a `Fold` into a list.
49+
toListOf :: forall s t a b. Fold (Endo (List a)) s t a b -> s -> List a
50+
toListOf p = foldrOf p (:) Nil
51+
52+
-- | Synonym for `toListOf`, reversed.
53+
(^..) :: forall s t a b. s -> Fold (Endo (List a)) s t a b -> List a
54+
(^..) s p = toListOf p s
55+
56+
-- | Determines whether a `Fold` has at least one focus.
57+
has :: forall s t a b r. (BooleanAlgebra r) => Fold (Disj r) s t a b -> s -> r
58+
has p = runDisj <<< foldMapOf p (const (Disj top))
59+
60+
-- | Determines whether a `Fold` does not have a focus.
61+
hasn't :: forall s t a b r. (BooleanAlgebra r) => Fold (Conj r) s t a b -> s -> r
62+
hasn't p = runConj <<< foldMapOf p (const (Conj bottom))

‎src/Data/Lens/Getter.purs‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
-- | This module defines functions for working with getters.
2+
3+
module Data.Lens.Getter
4+
( (^.)
5+
, view, to
6+
) where
7+
8+
import Prelude
9+
import Data.Const
10+
import Data.Profunctor.Star
11+
import Data.Lens.Types
12+
import Data.Functor.Contravariant
13+
14+
infixl 8 ^.
15+
16+
-- | View the focus of a `Getter`.
17+
view :: forall s t a b. Getter s t a b -> s -> a
18+
view l s = getConst (runStar (l (Star Const)) s)
19+
20+
-- | Synonym for `view`, flipped.
21+
(^.) :: forall s t a b. s -> Getter s t a b -> a
22+
(^.) s l = view l s
23+
24+
-- | Convert a function into a getter.
25+
to :: forall s a f. (Contravariant f) => (s -> a) -> Optic (Star f) s s a a
26+
to f p = Star (cmap f <<< runStar p <<< f)

‎src/Data/Lens/Internal/Exchange.purs‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
-- | This module defines the `Exchange` profunctor
2+
3+
module Data.Lens.Internal.Exchange where
4+
5+
import Prelude
6+
import Data.Either
7+
import Data.Profunctor
8+
import qualified Data.Bifunctor as B
9+
import Data.Profunctor.Choice
10+
11+
-- | The `Exchange` profunctor characterizes an `Iso`.
12+
data Exchange a b s t = Exchange (s -> a) (b -> t)
13+
14+
instance functorExchange :: Functor (Exchange a b s) where
15+
map f (Exchange a b) = Exchange a (f <<< b)
16+
17+
instance profunctorExchange :: Profunctor (Exchange a b) where
18+
dimap f g (Exchange a b) = Exchange (a <<< f) (g <<< b)

‎src/Data/Lens/Internal/Market.purs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
-- | This module defines the `Market` profunctor
2+
3+
module Data.Lens.Internal.Market where
4+
5+
import Prelude
6+
import Data.Either
7+
import Data.Profunctor
8+
import qualified Data.Bifunctor as B
9+
import Data.Profunctor.Choice
10+
11+
-- | The `Market` profunctor characterizes a `Prism`.
12+
data Market a b s t = Market (b -> t) (s -> Either t a)
13+
14+
instance functorMarket :: Functor (Market a b s) where
15+
map f (Market a b) = Market (f <<< a) (B.lmap f <<< b)
16+
17+
instance profunctorMarket :: Profunctor (Market a b) where
18+
dimap f g (Market a b) = Market (g <<< a) (B.lmap g <<< b <<< f)
19+
20+
instance choiceMarket :: Choice (Market a b) where
21+
left (Market x y) = Market
22+
(Left <<< x) (either (B.lmap Left <<< y) (Left <<< Right))
23+
right (Market x y) = Market
24+
(Right <<< x) (either (Left <<< Left) (B.lmap Right <<< y))

‎src/Data/Lens/Iso.purs‎

Lines changed: 33 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,44 @@
11
-- | This module defines functions for working with isomorphisms.
22

3-
module Data.Lens.Iso
4-
( iso
3+
module Data.Lens.Iso
4+
( iso, withIso, cloneIso, au, auf, under, curried, uncurried, flipped
55
) where
6-
6+
77
import Prelude
8-
8+
99
import Data.Tuple
1010
import Data.Lens.Types
11+
import Data.Lens.Internal.Exchange
1112
import Data.Profunctor
1213
import Data.Profunctor.Strong
1314

1415
-- | Create an `Iso` from a pair of morphisms.
1516
iso :: forall s t a b. (s -> a) -> (b -> t) -> Iso s t a b
16-
iso f g pab = dimap f g pab
17+
iso f g pab = dimap f g pab
18+
19+
-- | Extracts the pair of morphisms from an isomorphism.
20+
withIso :: forall s t a b r. AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
21+
withIso l f = case l (Exchange id id) of
22+
Exchange g h -> f g h
23+
24+
-- | Extracts an `Iso` from `AnIso`.
25+
cloneIso :: forall s t a b. AnIso s t a b -> Iso s t a b
26+
cloneIso l = withIso l dimap
27+
28+
au :: forall s t a b e. AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a
29+
au l = withIso l \sa bt f e -> sa (f bt e)
30+
31+
auf :: forall s t a b e r p. (Profunctor p) => AnIso s t a b -> (p r a -> e -> b) -> p r s -> e -> t
32+
auf l = withIso l \sa bt f g e -> bt (f (rmap sa g) e)
33+
34+
under :: forall s t a b. AnIso s t a b -> (t -> s) -> b -> a
35+
under l = withIso l \sa bt ts -> sa <<< ts <<< bt
36+
37+
curried :: forall a b c d e f. Iso (Tuple a b -> c) (Tuple d e -> f) (a -> b -> c) (d -> e -> f)
38+
curried = iso curry uncurry
39+
40+
uncurried :: forall a b c d e f. Iso (a -> b -> c) (d -> e -> f) (Tuple a b -> c) (Tuple d e -> f)
41+
uncurried = iso uncurry curry
42+
43+
flipped :: forall a b c d e f. Iso (a -> b -> c) (d -> e -> f) (b -> a -> c) (e -> d -> f)
44+
flipped = iso flip flip

‎src/Data/Lens/Lens.purs‎

Lines changed: 3 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,15 @@
11
-- | This module defines functions for working with lenses.
22

3-
module Data.Lens.Lens
3+
module Data.Lens.Lens
44
( lens
55
, lens'
6-
, view
76
) where
8-
7+
98
import Prelude
10-
11-
import Data.Const
9+
1210
import Data.Tuple
1311
import Data.Lens.Types
1412
import Data.Profunctor
15-
import Data.Profunctor.Star
1613
import Data.Profunctor.Strong
1714

1815
lens' :: forall s t a b. (s -> Tuple a (b -> t)) -> Lens s t a b
@@ -21,7 +18,3 @@ lens' to pab = dimap to (\(Tuple b f) -> f b) (first pab)
2118
-- | Create a `Lens` from a getter/setter pair.
2219
lens :: forall s t a b. (s -> a) -> (s -> b -> t) -> Lens s t a b
2320
lens get set = lens' \s -> Tuple (get s) \b -> set s b
24-
25-
-- | View the focus of a `Lens`.
26-
view :: forall s t a b. Lens s t a b -> s -> a
27-
view l s = getConst (runStar (l (Star Const)) s)

‎src/Data/Lens/Prism.purs‎

Lines changed: 36 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,9 @@
11
-- | This module defines functions for working with lenses.
22

3-
module Data.Lens.Prism where
3+
module Data.Lens.Prism
4+
( prism, prism', review, nearly, only, clonePrism, withPrism, matching
5+
, is, isn't
6+
) where
47

58
import Prelude
69

@@ -11,17 +14,42 @@ import Data.Maybe
1114
import Data.Maybe.First
1215
import Data.Lens.Types
1316
import Data.Lens.Internal.Tagged
17+
import Data.Lens.Internal.Market
18+
import Control.MonadPlus
1419
import Data.Profunctor (dimap, rmap)
15-
import Data.Profunctor.Choice (left)
20+
import Data.Profunctor.Choice
1621

1722
-- | Create a `Prism` from a constructor/pattern pair.
18-
prism :: forall s t a b. (b -> t) -> (s -> Either a t) -> Prism s t a b
19-
prism to fro pab = dimap fro (either id id) (left (rmap to pab))
23+
prism :: forall s t a b. (b -> t) -> (s -> Either t a) -> Prism s t a b
24+
prism to fro pab = dimap fro (either id id) (right (rmap to pab))
25+
26+
prism' :: forall s a. (a -> s) -> (s -> Maybe a) -> PrismP s a
27+
prism' to fro = prism to (\s -> maybe (Left s) Right (fro s))
2028

2129
-- | Review a value through a `Prism`.
22-
review :: forall s t a b. Prism s t a b -> b -> t
30+
review :: forall s t a b. Review s t a b -> b -> t
2331
review p = unTagged <<< p <<< Tagged
2432

25-
-- | Previews the value of a `Prism`, if there is any.
26-
preview :: forall s t a b. Prism s t a b -> s -> Maybe a
27-
preview p = runFirst <<< getConst <<< runStar (p (Star (Const <<< pure)))
33+
nearly :: forall a. a -> (a -> Boolean) -> PrismP a Unit
34+
nearly x f = prism' (const x) (guard <<< f)
35+
36+
only :: forall a. (Eq a) => a -> Prism a a Unit Unit
37+
only x = nearly x (== x)
38+
39+
clonePrism :: forall s t a b. APrism s t a b -> Prism s t a b
40+
clonePrism l = withPrism l go where
41+
-- the type checker doesn't like `prism` for `go`...
42+
go to fro pab = dimap fro (either id id) (right (rmap to pab))
43+
44+
withPrism :: forall s t a b r. APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
45+
withPrism l f = case l (Market id Right) of
46+
Market g h -> f g h
47+
48+
matching :: forall s t a b. APrism s t a b -> s -> Either t a
49+
matching l = withPrism l \_ f -> f
50+
51+
is :: forall s t a b r. (BooleanAlgebra r) => APrism s t a b -> s -> r
52+
is l = either (const bottom) (const top) <<< matching l
53+
54+
isn't :: forall s t a b r. (BooleanAlgebra r) => APrism s t a b -> s -> r
55+
isn't l = not <<< is l

‎src/Data/Lens/Setter.purs‎

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
-- | This module defines functions for working with setters.
2+
3+
module Data.Lens.Setter
4+
( (%~), (.~), (+~), (-~), (*~), (//~), (||~), (&&~), (<>~), (++~), (?~)
5+
, over, set
6+
) where
7+
8+
import Prelude
9+
import Data.Const
10+
import Data.Profunctor.Star
11+
import Data.Lens.Types
12+
import Data.Maybe
13+
14+
infixr 4 %~
15+
infixr 4 .~
16+
infixr 4 +~
17+
infixr 4 -~
18+
infixr 4 *~
19+
infixr 4 //~
20+
infixr 4 ||~
21+
infixr 4 &&~
22+
infixr 4 <>~
23+
infixr 4 ++~
24+
infixr 4 ?~
25+
26+
-- | Apply a function to the foci of a `Setter`.
27+
over :: forall s t a b. Setter s t a b -> (a -> b) -> s -> t
28+
over l = l
29+
30+
-- | Synonym for `over`.
31+
(%~) :: forall s t a b. Setter s t a b -> (a -> b) -> s -> t
32+
(%~) = over
33+
34+
-- | Set the foci of a `Setter` to a constant value.
35+
set :: forall s t a b. Setter s t a b -> b -> s -> t
36+
set l b = over l (const b)
37+
38+
-- | Synonym for `set`.
39+
(.~) :: forall s t a b. Setter s t a b -> b -> s -> t
40+
(.~) = set
41+
42+
(+~) :: forall s t a a. (Semiring a) => Setter s t a a -> a -> s -> t
43+
(+~) p = over p <<< flip (+)
44+
45+
(*~) :: forall s t a a. (Semiring a) => Setter s t a a -> a -> s -> t
46+
(*~) p = over p <<< flip (*)
47+
48+
(-~) :: forall s t a a. (Ring a) => Setter s t a a -> a -> s -> t
49+
(-~) p = over p <<< flip (-)
50+
51+
(//~) :: forall s t a a. (DivisionRing a) => Setter s t a a -> a -> s -> t
52+
(//~) p = over p <<< flip (/)
53+
54+
(||~) :: forall s t a a. (BooleanAlgebra a) => Setter s t a a -> a -> s -> t
55+
(||~) p = over p <<< flip (||)
56+
57+
(&&~) :: forall s t a a. (BooleanAlgebra a) => Setter s t a a -> a -> s -> t
58+
(&&~) p = over p <<< flip (&&)
59+
60+
(<>~) :: forall s t a a. (Semigroup a) => Setter s t a a -> a -> s -> t
61+
(<>~) p = over p <<< flip (<>)
62+
63+
(++~) :: forall s t a a. (Semigroup a) => Setter s t a a -> a -> s -> t
64+
(++~) p = over p <<< flip (++)
65+
66+
(?~) :: forall s t a b. Setter s t a (Maybe b) -> b -> s -> t
67+
(?~) p = set p <<< Just

0 commit comments

Comments
 (0)