huggable optics

Huggable.hs

module Huggable where

swap :: (a, b) -> (b, a)
swap (a, b) = (b, a)

newtype Star f a b = Star { runStar :: a -> f b }
newtype Forget r a b = Forget { runForget :: a -> r }

class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d

instance Profunctor (->) where
  dimap f g p = g . p . f

instance Functor f => Profunctor (Star f) where
  dimap f g (Star h) = Star (fmap g . h . f)

instance Profunctor (Forget r) where
  dimap f _ (Forget p) = Forget (p . f)

class Profunctor p => Strong p where
  first :: p a b -> p (a, c) (b, c)
  second :: p a b -> p (c, a) (c, b)

instance Strong (->) where
  first f = \(a, b) -> (f a, b)
  second f = \(a, b) -> (a, f b)

instance Functor f => Strong (Star f) where
  first (Star f) = Star (\(a, b) -> fmap (\c -> (c, b)) (f a))
  second (Star f) = Star (\(a, b) -> fmap (\c -> (a, c)) (f b))

instance Strong (Forget r) where
  first (Forget p) = Forget (\(fst, _) -> p fst)
  second (Forget p) = Forget (\(_, snd) -> p snd)

class Profunctor p => Choice p where
  left :: p a b -> p (Either a c) (Either b c)
  right :: p a b -> p (Either c a) (Either c b)

instance Choice (->) where
  left f = either (Left . f) Right
  right f = either Left (Right . f)

instance (Functor f, Monad f) => Choice (Star f) where
  left (Star f) = Star (either (fmap Left . f) (fmap Right . return))
  right (Star f) = Star (either (fmap Left . return) (fmap Right . f))

class Bifunctor f where
  bimap :: (a -> b) -> (c -> d) -> f a c -> f b d

class Contravariant f where
  contramap :: (a -> b) -> f b -> f a

class Bicontravariant f where
  bicontramap :: (a -> b) -> (c -> d) -> f b d -> f a c

instance Bicontravariant (Forget r) where
  bicontramap f _ (Forget p) = Forget (p . f)

type Optic p s t a b = p a b -> p s t
type SimpleOptic p s a = p a a -> p s s

class Profunctor p => Iso p
class Strong p => Lens p
class (Bicontravariant p, Strong p) => Getter p
class Choice p => Prism p

instance Profunctor p => Iso p
instance Strong p => Lens p
instance (Bicontravariant p, Strong p) => Getter p
instance Choice p => Prism p

iso :: Iso shape => (s -> a) -> (b -> t) -> Optic shape s t a b
iso sa bt = dimap sa bt

lens :: Lens shape => (s -> a) -> (s -> b -> t) -> Optic shape s t a b
lens getter setter = dimap get set . first
  where get s = (getter s, s)
        set (b, s) = setter s b

view :: Optic (Forget a) s s a a -> s -> a
view o s = runForget (o (Forget id)) s

_fst :: Lens shape => Optic shape (a, b) (c, b) a c
_fst = lens fst (\(_, b) c -> (c, b))

_snd :: Lens shape => Optic shape (a, b) (a, c) b c
_snd = lens snd (\(a, _) c -> (a, c))

_head :: Lens shape => SimpleOptic shape [a] a
_head = lens head (\(_ : xs) x -> x : xs)

_tail :: Lens shape => SimpleOptic shape [a] [a]
_tail = lens tail (\(x : _) xs -> x : xs)

reversed :: Iso shape => SimpleOptic shape [a] [a]
reversed = iso reverse reverse

swapped :: Iso shape => SimpleOptic shape (a, b) (b, a)
swapped = iso swap swap

flipped :: Iso shape => SimpleOptic shape (a -> b -> c) (b -> a -> c)
flipped = iso flip flip