unbound-generics-0.3.2: examples/Prof.hs

{-# language GADTs, RankNTypes #-}
module Prof where

import Data.Profunctor

data Shop a b s t where
  Shop :: (s -> a) -> (s -> b -> t) -> Shop a b s t

type Optic p s t a b  = p a b -> p s t
type Lens s t a b = forall p . (Strong p) => Optic p s t a b

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get set pab = dimap (\s -> (s, get s)) (uncurry set) (second' pab)

instance Profunctor (Shop a b) where
  dimap f g (Shop get set) = Shop (get . f) (\s -> g . set (f s))

instance Strong (Shop a b) where
   first' (Shop get set) = Shop (get . fst) (\(s,c) b -> (set s b, c))

withLens :: Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
withLens l k = case l (Shop id (const id)) of
                 Shop getter setter -> k getter setter


type Prism s t a b = forall p . (Choice p) => Optic p s t a b

prism :: (s -> Either t a) -> (b -> t) -> Prism s t a b
prism view review pab = dimap view (either id review) (right' pab)

data Market a b s t where
  Market :: (s -> Either t a) -> (b -> t) -> Market a b s t

instance Profunctor (Market a b) where
  dimap f g (Market view review) = Market (either (Left . g) Right . (view . f)) (g . review)

instance Choice (Market a b) where
  left' (Market view review) = Market (either (either (Left . Left) Right . view) (Left . Right)) (Left . review)

withPrism :: Prism s t a b -> ((s -> Either t a) -> (b -> t) -> r) -> r
withPrism l k = case l (Market Right id) of
                  Market view review -> k view review