LeftLike.hs

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

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

data Constant a b =
  Constant a
  deriving (Eq, Show)
  
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)

data Possibly a b =
  Impossible
  | PossiblyA a
  | PossiblyB 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)

instance (Choice p, Applicative f) => LeftLike p f Possibly where
  _LeftLike =
    prism'
      PossiblyA
      (\e -> case e of
               PossiblyA a -> Just a
               PossiblyB _ -> Nothing
               Impossible -> Nothing)

getLeft ::
  LeftLike (->) (Const (First a)) k =>
  a
  -> k a b
  -> a 
getLeft a x =
  fromMaybe a (x ^? _LeftLike)
     
data NEL a = 
  NEL a [a]
  deriving (Eq, Show)

headNEL ::
  Lens' (NEL a) a
headNEL =
  lens
    (\(NEL h _) -> h)
    (\(NEL _ t) h -> NEL h t)

newtype ValidationNEL e a =
  ValidationNEL (Either (NEL e) a)
  deriving (Eq, Show)

makeWrapped ''ValidationNEL

instance (p ~ (->), Applicative f) => LeftLike p f ValidationNEL where
  _LeftLike =
    _Wrapped . _LeftLike . headNEL

putLeft ::
  LeftLike Tagged Identity k =>
  a
  -> k a b
putLeft =
  (_LeftLike #)