glassery.hs

{-# LANGUAGE RankNTypes, TupleSections #-}

module Main where

import Control.Arrow
import Data.Profunctor

type Optic p s t a b = p a b -> p s t
type An c s t a b = Optic (c a b) s t a b

type Lens s t a b =            forall p. Strong p               => Optic p s t a b
type Prism s t a b =           forall p. Choice p               => Optic p s t a b
type AffineTraversal s t a b = forall p. (Strong p, Choice p)   => Optic p s t a b
type Colens s t a b =          forall p. Costrong p             => Optic p s t a b
type Coprism s t a b =         forall p. Cochoice p             => Optic p s t a b
type Foo s t a b =             forall p. (Strong p, Cochoice p) => Optic p s t a b

data CLens a b s t = CLens (s -> a) (b -> s -> t)

instance Profunctor (CLens a b) where
  dimap f g (CLens view set) = CLens (view . f) set' where
    set' b = g . set b . f

instance Strong (CLens a b) where
  first' (CLens view set) = CLens (view . fst) (first . set) where

type ALens s t a b = An CLens s t a b

fromLens :: ALens s t a b -> CLens a b s t
fromLens p = p $ CLens id const

toLens :: CLens a b s t -> Lens s t a b
toLens (CLens view set) = dimap (view &&& id) (uncurry set) . first'

data CPrism a b s t = CPrism (s -> Either t a) (b -> t)

instance Profunctor (CPrism a b) where
  dimap f g (CPrism previewE review) = CPrism (left g . previewE . f) (g . review)

instance Choice (CPrism a b) where
  right' (CPrism previewE review) = CPrism (reassocE . right previewE) (Right . review) where

reassocE :: Either a (Either b c) -> Either (Either a b) c
reassocE (Left a)          = Left $ Left a
reassocE (Right (Left b))  = Left $ Right b
reassocE (Right (Right c)) = Right c

type APrism s t a b = An CPrism s t a b

fromPrism :: APrism s t a b -> CPrism a b s t
fromPrism p = p $ CPrism Right id

toPrism :: CPrism a b s t -> Prism s t a b
toPrism (CPrism previewE review) = dimap previewE (id ||| review) . right'

data CAffineTraversal a b s t = CAffineTraversal (s -> Either t a) (b -> s -> t)

instance Profunctor (CAffineTraversal a b) where
  dimap f g (CAffineTraversal previewE set) = CAffineTraversal (left g . previewE . f) set' where
    set' b = g . set b . f

instance Strong (CAffineTraversal a b) where
  first' (CAffineTraversal previewE set) = CAffineTraversal previewE' (first . set) where
    previewE' (s, c) = left (,c) $ previewE s

instance Choice (CAffineTraversal a b) where
  right' (CAffineTraversal previewE set) = CAffineTraversal (reassocE . right previewE) (right . set)

type AnAffineTraversal s t a b = An CAffineTraversal s t a b

fromAffineTraversal :: AnAffineTraversal s t a b -> CAffineTraversal a b s t
fromAffineTraversal p = p $ CAffineTraversal Right const

toAffineTraversal :: CAffineTraversal a b s t -> AffineTraversal s t a b
toAffineTraversal (CAffineTraversal previewE set) = dimap f (id ||| uncurry set) . right' . first' where
  f s = right (,s) $ previewE s

data CColens a b s t = CColens (s -> b -> a) (b -> t)

instance Profunctor (CColens a b) where
  dimap f g (CColens reset review) = CColens (reset . f) (g . review)

instance Costrong (CColens a b) where
  unfirst (CColens reset review) = CColens reset' (fst . review) where
    reset' s b = reset (s, snd (review b)) b

type AColens s t a b = An CColens s t a b

fromColens :: AColens s t a b -> CColens a b s t
fromColens p = p $ CColens const id

toColens :: CColens a b s t -> Colens s t a b
toColens (CColens reset review) = unfirst . dimap (uncurry reset) (review &&& id)

data CCoprism a b s t = CCoprism (s -> a) (b -> Either a t)

instance Profunctor (CCoprism a b) where
  dimap f g (CCoprism view repreviewE) = CCoprism (view . f) (right g . repreviewE)

instance Cochoice (CCoprism a b) where
  unright (CCoprism view repreviewE) = CCoprism (view . Right) (unnestWith view . repreviewE) where

unnestWith :: (Either c s -> a) -> Either a (Either c t) -> Either a t
unnestWtih _    (Left a)          = Left a
unnestWith view (Right (Left c))  = Left $ view $ Left c
unnestWith _    (Right (Right t)) = Right t

type ACoprism s t a b = An CCoprism s t a b

fromCoprism :: ACoprism s t a b -> CCoprism a b s t
fromCoprism p = p $ CCoprism id Right

toCoprism :: CCoprism a b s t -> ACoprism s t a b
toCoprism (CCoprism view repreviewE) = unright . dimap (id ||| view) repreviewE

data CFoo a b s t = CFoo (s -> a) (b -> s -> Either a t)

instance Profunctor (CFoo a b) where
  dimap f g (CFoo view preset) = CFoo (view . f) preset' where
    preset' b = right g . preset b . f

instance Strong (CFoo a b) where
  first' (CFoo view preset) = CFoo (view . fst) preset' where
    preset' b = moveIn . first (preset b)
    moveIn (Left a, _)  = Left a
    moveIn (Right t, c) = Right (t, c)

instance Cochoice (CFoo a b) where
  unright (CFoo view preset) = CFoo (view . Right) preset' where
    preset' b = unnestWith view . preset b . Right

type AFoo s t a b = An CFoo s t a b

fromFoo :: AFoo s t a b -> CFoo a b s t
fromFoo p = p $ CFoo id reset where
  reset b _ = Right b

toFoo :: CFoo a b s t -> Foo s t a b
toFoo (CFoo view preset) = unright . dimap f g . first' where
  f (Left as) = as
  f (Right s) = (view s, s)
  g (b, s) = left (,s) $ preset b s