diff --git a/CHANGELOG.md b/CHANGELOG.md index 77ba20a..60db406 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ Breaking changes: New features: - Add `sans` and `both` (#97 by @xgrommx) +- Generic prisms (#137 by @amesgen) Bugfixes: diff --git a/spago.dhall b/spago.dhall index 14238a1..1c5bce9 100644 --- a/spago.dhall +++ b/spago.dhall @@ -24,6 +24,7 @@ , "record" , "transformers" , "tuples" + , "typelevel-prelude" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] diff --git a/src/Data/Lens/Constructor.purs b/src/Data/Lens/Constructor.purs new file mode 100644 index 0000000..b47f460 --- /dev/null +++ b/src/Data/Lens/Constructor.purs @@ -0,0 +1,108 @@ +module Data.Lens.Constructor + ( _Ctor + , class AsConstructor + , class AsConstructorRep + , _CtorRep + , class ArgumentRep + , arg + ) where + +import Prelude + +import Data.Either (Either(..)) +import Data.Generic.Rep as G +import Data.Lens.Iso (Iso, iso, withIso) +import Data.Lens.Prism (Prism, prism) +import Data.Tuple (Tuple(..)) +import Type.Prelude (Proxy(..)) + +class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where + -- | Construct a (type-changing) prism for a data constructor, by providing a + -- | proxy for the `Symbol` which corresponds to the constructor label. + -- | Note that you need to derive `Generic` for your data type. + -- | + -- | The lens is polymorphic to the rest of the constructors. + -- | + -- | For example: + -- | + -- | ```purescript + -- | data Foo a = Foo a | Bar Int | Baz | Multi Int String Boolean + -- | + -- | derive instance Generic Foo _ + -- | + -- | _Foo :: forall a b. Prism (Foo a) (Foo b) a b + -- | _Foo = _Ctor (Proxy :: _ "Foo") + -- | + -- | _Bar :: forall a. Prism' (Foo a) Int + -- | _Bar = _Ctor (Proxy :: _ "Bar") + -- | + -- | _Baz :: forall a. Prism' (Foo a) Unit + -- | _Baz = _Ctor (Proxy :: _ "Baz") + -- | + -- | _Multi :: forall a. Prism' (Foo a) (Tuple Int (Tuple String Boolean)) + -- | _Multi = _Ctor (Proxy :: _ "Multi") + -- | ``` + _Ctor :: Proxy ctor -> Prism s t a b + +instance + ( AsConstructorRep ctor rep rep' a b + , G.Generic s rep + , G.Generic t rep' + ) => + AsConstructor ctor s t a b where + _Ctor _ = iso G.from G.to <<< _CtorRep (Proxy :: _ ctor) + +class AsConstructorRep (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where + _CtorRep :: Proxy ctor -> Prism s t a b + +instance + ArgumentRep s t a b => + AsConstructorRep ctor (G.Constructor ctor s) (G.Constructor ctor t) a b where + _CtorRep _ = _Constructor <<< arg + +instance + ArgumentRep s t a b => + AsConstructorRep ctor + (G.Sum (G.Constructor ctor s) r) + (G.Sum (G.Constructor ctor t) r) + a + b where + _CtorRep _ = _Inl <<< _Constructor <<< arg +else instance + AsConstructorRep ctor s t a b => + AsConstructorRep ctor (G.Sum r s) (G.Sum r t) a b where + _CtorRep _ = _Inr <<< _CtorRep (Proxy :: _ ctor) + +class ArgumentRep s t a b | s -> a, t -> b where + arg :: Iso s t a b + +instance ArgumentRep G.NoArguments G.NoArguments Unit Unit where + arg = iso (\_ -> unit) (\_ -> G.NoArguments) + +instance ArgumentRep (G.Argument a) (G.Argument b) a b where + arg = _Argument + +instance + ( ArgumentRep s t a b + , ArgumentRep s' t' a' b' + ) => + ArgumentRep (G.Product s s') (G.Product t t') (Tuple a a') (Tuple b b') where + arg = withIso arg \from to -> withIso arg \from' to' -> iso + do \(G.Product s s') -> Tuple (from s) (from' s') + do \(Tuple a a') -> G.Product (to a) (to' a') + +_Inl :: forall a b c. Prism (G.Sum a c) (G.Sum b c) a b +_Inl = prism G.Inl case _ of + G.Inl a -> Right a + G.Inr c -> Left (G.Inr c) + +_Inr :: forall a b c. Prism (G.Sum c a) (G.Sum c b) a b +_Inr = prism G.Inr case _ of + G.Inl c -> Left (G.Inl c) + G.Inr a -> Right a + +_Constructor :: forall ctor a b. Iso (G.Constructor ctor a) (G.Constructor ctor b) a b +_Constructor = iso (\(G.Constructor a) -> a) G.Constructor + +_Argument :: forall a b. Iso (G.Argument a) (G.Argument b) a b +_Argument = iso (\(G.Argument a) -> a) G.Argument diff --git a/test/Main.purs b/test/Main.purs index f53006d..fc3746e 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -4,18 +4,22 @@ import Prelude import Control.Monad.State (evalState, get) import Data.Either (Either(..)) +import Data.Generic.Rep (class Generic) import Data.Lens (Getter', Prism', _1, _2, _Just, _Left, collectOf, lens, lens', lensStore, preview, prism', takeBoth, toArrayOf, traversed, view) +import Data.Lens.Constructor (_Ctor) import Data.Lens.Fold ((^?)) import Data.Lens.Fold.Partial ((^?!), (^@?!)) import Data.Lens.Grate (Grate, cloneGrate, grate, zipWithOf) import Data.Lens.Index (ix) import Data.Lens.Indexed (itraversed, reindexed) import Data.Lens.Lens (IndexedLens, cloneIndexedLens, ilens) +import Data.Lens.Prism (Prism) import Data.Lens.Record (prop) -import Data.Lens.Setter (iover) +import Data.Lens.Setter (iover, (%~)) import Data.Lens.Traversal (cloneTraversal) import Data.Lens.Zoom (ATraversal', IndexedTraversal', Lens, Lens', Traversal, Traversal', zoom) import Data.Maybe (Maybe(..)) +import Data.Show.Generic (genericShow) import Data.Tuple (Tuple(..), fst, snd) import Effect (Effect) import Partial.Unsafe (unsafePartial) @@ -127,6 +131,27 @@ lensStoreExampleInt = lens' case _ of LensStoreA i -> map LensStoreA <$> lensStore identity i LensStoreB i -> map LensStoreB <$> lensStore _2 i +-- Test generic prisms +data AA a = BB a | CC Int | DD | EE Int String Boolean + +derive instance Eq a => Eq (AA a) +derive instance Generic (AA a) _ + +instance Show a => Show (AA a) where + show = genericShow + +_BB :: forall a b. Prism (AA a) (AA b) a b +_BB = _Ctor (Proxy :: _ "BB") + +_CC :: forall a. Prism' (AA a) Int +_CC = _Ctor (Proxy :: _ "CC") + +_DD :: forall a. Prism' (AA a) Unit +_DD = _Ctor (Proxy :: _ "DD") + +_EE :: forall a. Prism' (AA a) (Tuple Int (Tuple String Boolean)) +_EE = _Ctor (Proxy :: _ "EE") + main :: Effect Unit main = do assertEqual' """view bars doc""" @@ -173,3 +198,11 @@ main = do { expected: Just 1 , actual: cloneTraversalTest } + assertEqual' """CC 3 ^? _CC""" + { expected: Just 3 + , actual: CC 3 ^? _CC + } + assertEqual' """_BB %~ (_ == 3) $ BB 2""" + { expected: BB false + , actual: _BB %~ (_ == 3) $ BB 2 + }