Profunctor optics, obtained by the same template

Optics.hs

{-# OPTIONS_GHC -Wall  #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

import Control.Monad
import Data.Bifunctor

type AnOptic p s t a b = p a b -> p s t
type Optic c s t a b = forall p. c p => AnOptic p s t a b

-- * Getter

newtype GetterP a b s t = GetterP { runGetterP :: s -> a }

-- GetterP a b a b -> GetterP a b s t
-- (a -> a) -> (s -> a)
type AGetter s t a b = AnOptic (GetterP a b) s t a b

view :: AGetter s t a b -> s -> a
view = runGetterP . ($ GetterP id)

class LensC p => GetterC p where
  getterOp :: (s -> a) -> p a b -> p s t

instance IsoC (GetterP u v) where
  isoOp sa _bt (GetterP au) = GetterP (au . sa)

instance LensC (GetterP u v) where
  lensOp sa _sbt (GetterP au)= GetterP (au . sa)

instance GetterC (GetterP u v) where
  getterOp sa (GetterP au) = GetterP (au . sa)

type Getter s t a b = Optic GetterC s t a b

getter :: (s -> a) -> Getter s t a b
getter = getterOp

storeGetter :: Getter s t a b -> AGetter s t a b
storeGetter = id

cloneGetter :: AGetter s t a b -> Getter s t a b
cloneGetter = getter . view

-- * Setter

newtype SetterP a b s t = SetterP { runSetterP :: (a -> b) -> s -> t }

-- ASetterP a b a b -> ASetterP a b s t
-- ((a -> b) -> a -> b) -> ((a -> b) -> s -> t)
type ASetter s t a b = AnOptic (SetterP a b) s t a b

over :: ASetter s t a b -> (a -> b) -> s -> t
over = runSetterP . ($ SetterP id)

class (AffineTraversalC p) => SetterC p where
  setterOp :: ((a -> b) -> s -> t) -> p a b -> p s t

instance IsoC (SetterP u v) where
  isoOp sa bt (SetterP uvab) = SetterP (\uv s -> bt $ uvab uv $ sa s)

instance LensC (SetterP u v) where
  lensOp sa sbt (SetterP uvab) = SetterP $ \uv s -> sbt s $ uvab uv $ sa s

instance PrismC (SetterP u v) where
  prismOp seta bt (SetterP uvab) = SetterP $
    \uv s -> either id (bt . uvab uv) $ seta s

instance AffineTraversalC (SetterP u v) where
  affineTraversalOp seta sbt (SetterP uvab) = SetterP $
    \uv s -> either id (sbt s . uvab uv) $ seta s

instance SetterC (SetterP u v) where
  setterOp abst (SetterP uvab) = SetterP $ \uv -> abst $ uvab uv

type Setter s t a b = Optic SetterC s t a b

setter :: ((a -> b) -> s -> t) -> Setter s t a b
setter = setterOp

storeSetter :: Setter s t a b -> ASetter s t a b
storeSetter = id

cloneSetter :: ASetter s t a b -> Setter s t a b
cloneSetter = setter . over

-- * Lens

newtype LensP a b s t = LensP { runLensP :: (s -> a, s -> b -> t) }

-- LensP a b a b -> LensP s t a b
-- (a -> a, a -> b -> b) -> (s -> a, s -> b -> t)
type ALens s t a b = AnOptic (LensP a b) s t a b

viewAndSet :: ALens s t a b -> (s -> a, s -> b -> t)
viewAndSet = runLensP . ($ LensP (id, const id))

class IsoC p => LensC p where
  lensOp :: (s -> a) -> (s -> b -> t) -> p a b -> p s t

instance IsoC (LensP u v) where
  isoOp sa bt (LensP (au, avb)) =
    LensP (au . sa, \s v -> bt $ avb (sa s) v)

instance LensC (LensP u v) where
  lensOp sa sbt (LensP (au, avb)) =
    LensP (au . sa, \s v -> sbt s $ avb (sa s) v)

type Lens s t a b = Optic LensC s t a b

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens = lensOp

storeLens :: Lens s t a b -> ALens s t a b
storeLens = id

cloneLens :: ALens s t a b -> Lens s t a b
cloneLens = uncurry lens . viewAndSet

lensIsGetter :: Lens s t a b -> Getter s t a b
lensIsGetter = id

lensIsAffineTraversal :: Lens s t a b -> AffineTraversal s t a b
lensIsAffineTraversal = id

-- * Prism

newtype PrismP a b s t = PrismP { runPrismP :: (s -> Either t a, b -> t) }

-- PrismP a b a b -> PrismP s t a b
-- (b -> b, a -> Either b a) -> (b -> t, s -> Either t a)
type APrism s t a b = AnOptic (PrismP a b) s t a b

matchAndReview :: APrism s t a b -> (s -> Either t a, b -> t)
matchAndReview = runPrismP . ($ PrismP (Right, id))

class IsoC p => PrismC p where
  prismOp :: (s -> Either t a) -> (b -> t) -> p a b -> p s t

instance IsoC (PrismP u v) where
  isoOp sa bt (PrismP (aebu, vb)) = PrismP (first bt . aebu . sa, bt . vb)

instance PrismC (PrismP u v) where
  prismOp seta bt (PrismP (aebu, vb))= PrismP (first bt . aebu <=< seta, bt . vb)

type Prism s t a b = Optic PrismC s t a b

prism :: (s -> Either t a) -> (b -> t) -> Prism s t a b
prism = prismOp

storePrism :: Prism s t a b -> APrism s t a b
storePrism = id

clonePrism :: APrism s t a b -> Prism s t a b
clonePrism = uncurry prism . matchAndReview

prismIsAffineTraversal :: Prism s t a b -> AffineTraversal s t a b
prismIsAffineTraversal = id

-- * Iso

newtype IsoP a b s t = IsoP { runIsoP :: (s -> a, b -> t) }

-- IsoP a b a b -> IsoP a b s t
-- (a -> a, b -> b) -> (s -> a, b -> t)
type AnIso s t a b = AnOptic (IsoP a b) s t a b

viewAndReview :: AnIso s t a b -> (s -> a, b -> t)
viewAndReview = runIsoP . ($ IsoP (id, id))

class IsoC p where
  isoOp :: (s -> a) -> (b -> t) -> p a b -> p s t

instance IsoC (IsoP u v) where
  isoOp sa bt (IsoP (au, vb)) = IsoP (au . sa, bt . vb)

type Iso s t a b = Optic IsoC s t a b

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso = isoOp

storeIso :: Iso s t a b -> AnIso s t a b
storeIso = id

cloneIso :: AnIso s t a b -> Iso s t a b
cloneIso = uncurry iso . viewAndReview

isoIsPrism :: Iso s t a b -> Prism s t a b
isoIsPrism = id

isoIsLens :: Iso s t a b -> Lens s t a b
isoIsLens = id

-- * AffineTraversal

newtype AffineTraversalP a b s t
  = AffineTraversalP { runAffineTraversal :: (s -> Either t a, s -> b -> t) }

type AnAffineTraversal s t a b = AnOptic (AffineTraversalP a b) s t a b

matchingAndSet :: AnAffineTraversal s t a b -> (s -> Either t a, s -> b -> t)
matchingAndSet = runAffineTraversal . ($ AffineTraversalP (Right, const id))

class (LensC p, PrismC p) => AffineTraversalC p where
  affineTraversalOp :: (s -> Either t a) -> (s -> b -> t) -> p a b -> p s t

instance IsoC (AffineTraversalP u v) where
  isoOp sa bt (AffineTraversalP (aebu, avb))
    = AffineTraversalP (first bt . aebu . sa, \s v -> bt $ avb (sa s) v)

instance LensC (AffineTraversalP u v) where
  lensOp sa sbt (AffineTraversalP (aebu, avb))
    = AffineTraversalP (\s -> first (sbt s) $ aebu $ sa s, \s v -> sbt s $ avb (sa s) v)

instance PrismC (AffineTraversalP u v) where
  prismOp seta bt (AffineTraversalP (aebu, avb))
    = AffineTraversalP (either Left (first bt . aebu) . seta,
                       \s v -> either id (bt . (`avb` v)) $ seta s)

instance AffineTraversalC (AffineTraversalP u v) where
  affineTraversalOp seta sbt (AffineTraversalP (aebu, avb))
    = AffineTraversalP (\s -> case seta s of
                          Left t -> Left t
                          Right a -> either (Left . sbt s) Right $ aebu a
                        ,
                        \s v -> case seta s of
                          Left  t -> t
                          Right a -> sbt s $ avb a v
                       )

type AffineTraversal s t a b = Optic AffineTraversalC s t a b

affineTraversal :: (s -> Either t a) -> (s -> b -> t) -> AffineTraversal s t a b
affineTraversal = affineTraversalOp

storeAffineTraversal :: AffineTraversal s t a b -> AnAffineTraversal s t a b
storeAffineTraversal = id

cloneAffineTraversal :: AnAffineTraversal s t a b -> AffineTraversal s t a b
cloneAffineTraversal = uncurry affineTraversal . matchingAndSet

affineTraversalIsSetter :: AffineTraversal s t a b -> Setter s t a b
affineTraversalIsSetter = id

-- SSetter

newtype SSetterP a b s t = SSetterP { runSSetterP :: s -> b -> t }

type ASSetter s t a b = AnOptic (SSetterP a b) s t a b

sset :: ASSetter s t a b -> s -> b -> t
sset = runSSetterP . ($ SSetterP (const id))

class SSetterC p where
  ssetterOp :: (s -> b -> t) -> p a b -> p s t

instance SSetterC (SSetterP u v) where
  ssetterOp sbt (SSetterP avb) = SSetterP $ \s v -> sbt s (avb undefined v)

-- DiGetter

newtype DiGetterP a b s t = DiGetterP { runDiGetterP :: s -> (a, a) }

type ADiGetter s t a b = AnOptic (DiGetterP a b) s t a b

diget :: ADiGetter s t a b -> s -> (a, a)
diget = runDiGetterP . ($ DiGetterP (\a -> (a, a)))

class DiGetterC p where
  digetterOp :: (s -> (a, a)) -> p a b -> p s t

instance DiGetterC (DiGetterP u v) where
  digetterOp sa2 (DiGetterP _au2)= DiGetterP ((\(_a, _a') -> undefined) . sa2)

-- IndexedGetter

newtype IndexedGetterP i a b s t
  = IndexedGetterP { runIndexedGetterP :: i -> s -> a }

type AnIndexedGetter i s t a b = AnOptic (IndexedGetterP i a b) s t a b

iview :: AnIndexedGetter i s t a b -> i -> s -> a
iview = runIndexedGetterP . ($ IndexedGetterP (const id))

class IndexedGetterC i p where
  indexedGetterOp :: (i -> s -> a) -> p a b -> p s t

instance IndexedGetterC i (IndexedGetterP i u v) where
  indexedGetterOp isa (IndexedGetterP iau)
    = IndexedGetterP $ \i s -> iau i $ isa i s

type IndexedGetter i s t a b = Optic (IndexedGetterC i) s t a b

indexedGetter :: (i -> s -> a) -> IndexedGetter i s t a b
indexedGetter = indexedGetterOp

storeIndexedGetter :: IndexedGetter i s t a b -> AnIndexedGetter i s t a b
storeIndexedGetter = id

cloneIndexedGetter :: AnIndexedGetter i s t a b -> IndexedGetter i s t a b
cloneIndexedGetter = indexedGetter . iview

-- GetterM

newtype GetterMP m a b s t = GetterMP { runGetterMP :: s -> m a }

type AGetterM m s t a b = AnOptic (GetterMP m a b) s t a b

getM :: Applicative m => AGetterM m s t a b -> s -> m a
getM = runGetterMP . ($ GetterMP pure)

class GetterMC m p where
  getterMOp :: (s -> m a) -> p a b -> p s t

instance Monad m => GetterMC m (GetterMP m u v) where
  getterMOp sma (GetterMP amu)= GetterMP (amu <=< sma)

type GetterM m s t a b = Optic (GetterMC m) s t a b

getterM :: (s -> m a) -> GetterM m s t a b
getterM = getterMOp

{-
  matchingAndSet (affineTraversal seta sbt)
    ≡ matchingAndSet (\(AffineTraversal (aebu, avb)) ->
              AffineTraversalP
                        (\s -> case seta s of
                          Left t -> Left t
                          Right a -> either (Left . sbt s) Right $ aebu a
                        ,
                        \s v -> case seta s of
                          Left  t -> t
                          Right a -> sbt s $ avb a v
                        )
              ))
    ≡ runAffineTraversal $ (\(AffineTraversal (aebu, avb)) ->
              AffineTraversalP
                        (\s -> case seta s of
                          Left t -> Left t
                          Right a -> either (Left . sbt s) Right $ aebu a
                        ,
                        \s v -> case seta s of
                          Left  t -> t
                          Right a -> sbt s $ avb a v
                        )
              )) (AffineTraversal (Right, const id))
    ≡ runAffineTraversal $ (
              AffineTraversalP
                        (\s -> case seta s of
                          Left t -> Left t
                          Right a -> either (Left . sbt s) Right $ Right a
                        ,
                        \s v -> case seta s of
                          Left  t -> t
                          Right a -> sbt s $ const id a v
                        )
              )
    ≡ runAffineTraversal $ (
              AffineTraversalP
                        (\s -> case seta s of
                          Left t -> Left t
                          Right a -> Right a
                        ,
                        \s v -> case seta s of
                          Left  t -> t                -- = sbt s v  -- by law
                          Right a -> sbt s v
                        )
              )
    ≡ (seta, sbt)
-}