Pure profunctor lenses

profunctorlens.hs

{-# LANGUAGE Rank2Types #-}

import Control.Applicative (Applicative(..), (<$>), Const(..))
import Control.Lens.Internal.Review (Reviewed(..))
import Control.Lens.Internal.Bazaar (Bazaar(..))
import Data.Monoid (Monoid(..), First(..))
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Functor.Identity



type Equality s t a b = forall p. p a b -> p s t



type Iso s t a b = forall p. Profunctor p => p a b -> p s t

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



class Strong p => Lensing p where
  strength :: p a b -> p (b -> t, a) t
  strength = rmap (uncurry id) . second'

instance Lensing (->) where
  strength ab (bt, a) = bt (ab a)
  
instance Lensing (Forget r) where
  strength (Forget ar) = Forget $ (ar . snd)

instance Functor f => Lensing (UpStar f) where
  strength (UpStar f) = UpStar $ \(bt, a) -> bt <$> f a
  
firstDefault :: Lensing p => p a b -> p (a, c) (b, c)
firstDefault = lens (\(a, c) -> (\b -> (b, c), a))

secondDefault :: Lensing p => p a b -> p (c, a) (c, b)
secondDefault = lens (\(c, a) -> (\b -> (c, b), a))


type Lens s t a b = forall p. Lensing p => p a b -> p s t

lens :: (s -> (b -> t, a)) -> Lens s t a b
lens f = lmap f . strength

view :: Lens s t a b -> s -> a
view l = runForget (l (Forget id))

over :: Lens s t a b -> (a -> b) -> s -> t
over l = l



class Choice p => Prisming p where
  costrength :: p a b -> p (Either b a) b
  costrength = rmap (either id id) . right'

instance Prisming (->) where
  costrength = either id

instance Prisming Reviewed where
  costrength = Reviewed . runReviewed

instance Monoid r => Prisming (Forget r) where
  costrength = Forget . either (const mempty) . runForget

instance Applicative f => Prisming (UpStar f) where
  costrength = UpStar . either pure . runUpStar

leftDefault :: Prisming p => p a b -> p (Either a c) (Either b c)
leftDefault = lmap (either Right (Left . Right)) . costrength . rmap Left

rightDefault :: Prisming p => p a b -> p (Either c a) (Either c b)
rightDefault = lmap (either (Left . Left) Right) . costrength . rmap Right


type Prism s t a b = forall p. Prisming p => p a b -> p s t

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism set get = lmap get . costrength . rmap set

review :: Prism s t a b -> b -> t
review l b = runReviewed (l (Reviewed b))

preview :: Prism s t a b -> s -> Maybe a
preview l = getFirst . runForget (l (Forget (First . Just)))



class (Lensing p, Prisming p) => Traversing p where
  walk :: p a b -> p (Bazaar (->) a b t) t

instance Traversing (->) where
  walk = (runIdentity .) . flip runBazaar . (Identity .)
  
instance Applicative f => Traversing (UpStar f) where
  walk = UpStar . flip runBazaar . runUpStar

instance Monoid r => Traversing (Forget r) where
  walk = Forget . (getConst .) . flip runBazaar . (Const .) . runForget

strengthDefault :: Traversing p => p a b -> p (b -> t, a) t
strengthDefault = lmap (\(bt, a) -> Bazaar $ \afb -> bt <$> afb a) . walk

costrengthDefault :: Traversing p => p a b -> p (Either b a) b
costrengthDefault = lmap (\eba -> Bazaar $ \afb -> either pure afb eba) . walk

walkRep :: (Applicative (Rep p), Representable p) => p a b -> p (Bazaar (->) a b t) t
walkRep = tabulate . flip runBazaar . rep


type Traversal s t a b = forall p. Traversing p => p a b -> p s t

traversal :: (s -> Bazaar (->) a b t) -> Traversal s t a b
traversal f = lmap f . walk

traverseOf :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
traverseOf l = runUpStar . l . UpStar