LeftLike.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Lens
import Data.Maybe 
import Data.Monoid

data Constant a b =
  Constant a

data Or a b =
  Yes a
  | No b
  deriving (Eq, Show)

data These a b =
  This a 
  | That b
  | Both a b
  deriving (Eq, Show)

class LeftLike p f k where
  _LeftLike ::
    Optic' p f (k a b) a

instance (Profunctor p, Functor f) => LeftLike p f Constant where
  _LeftLike =
    iso
      (\(Constant a) -> a)
      Constant

instance (Choice p, Applicative f) => LeftLike p f Or where
  _LeftLike =
    prism'
      Yes
      (\o -> case o of
               Yes a -> Just a
               No _ -> Nothing)

instance (Choice p, Applicative f) => LeftLike p f These where
  _LeftLike =
    prism'
      This
      (\t -> case t of
               This a -> Just a
               That _ -> Nothing
               Both _ _ -> Nothing)

instance (Choice p, Applicative f) => LeftLike p f Either where
  _LeftLike =
    prism'
      Left
      (\e -> case e of
               Left a -> Just a
               Right _ -> Nothing)

getLeft ::
  LeftLike (->) (Const (First a)) k =>
  a
  -> k a b
  -> a 
getLeft a x =
  fromMaybe a (x ^? _LeftLike)