Add generic prisms

CHANGELOG.md

@@ -8,6 +8,7 @@ Breaking changes:
 
 New features:
 - Add `sans` and `both` (#97 by @xgrommx)
+- Generic prisms (#137 by @amesgen)
 
 Bugfixes:
 

spago.dhall

@@ -24,6 +24,7 @@
   , "record"
   , "transformers"
   , "tuples"
+  , "typelevel-prelude"
   ]
 , packages = ./packages.dhall
 , sources = [ "src/**/*.purs", "test/**/*.purs" ]

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

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
+    }