A quick reference for `lens` implementations

optics.hs

-- | Concrete and Van Larhoeven Lens and Prisms with no imports.

main = print $ set (addressL . zipCodeL) solomon 42


data AdminStatus = IsAdmin | IsNotAdmin
  deriving Show
  
data Person =
  Person
    { name :: String,
      age :: Maybe Int,
      address :: Address,
      isAdmin :: AdminStatus
    }
    deriving Show
    
data Address = 
  Address
    { streetNumber :: Int,
      streetName :: String,
      city :: String,
      zipCode :: Int,
      state :: String
    }
    deriving Show
    
solomon :: Person
solomon =
  Person
    { name = "Solomon",
      age = Just 35,
      address =
        Address
          { streetNumber = 1234,
            streetName = "Main St",
            city = "New York",
            zipCode = 10001,
            state = "NY"
          },
      isAdmin = IsNotAdmin
    }

viewZipCode p = zipCode (address p)
setZipCode p i = p { address = (address p) { zipCode = i } }
modify p f = p { address = (address p) { zipCode = f (zipCode (address p)) } }

--------------------------------------------------------------------
-- Concrete Lenses

data LensC s t a b = LensC
  { getter :: s -> b,
    setter :: b -> s -> t
  }

type LensC' s a = LensC s s a a
  
viewC :: LensC' s a -> s -> a
viewC = getter

setC :: LensC s t a b -> b -> s -> t
setC = setter

-- This type signature is weird looking. It helps to think about the LensC' version:
-- Lens b c -> Lens a b -> Lens a c 
composeC :: LensC b b c d -> LensC s t a b -> LensC s t x d
composeC f g =
  LensC 
    { getter = getter f . getter g,
      setter = \d s -> 
        let b = getter g s
            b' = setter f d b
         in setter g b' s
    }

addressC :: LensC' Person Address
addressC = LensC
  { getter = address,
    setter = \a p -> p { address = a }
  }

zipCodeC :: LensC' Address Int
zipCodeC = LensC
  { getter = zipCode,
    setter = \z a -> a { zipCode = z }
  }

--------------------------------------------------------------------------------
-- Van Larhoeven Lens Encoding

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

type Lens' s a = Lens s s a a

newtype Identity a = Identity { getIdentity :: a }
  deriving Functor

instance Applicative Identity where
  pure = Identity
  (<*>) (Identity f) (Identity a) = Identity (f a)
  
data Const a b = Const { getConst :: a }

instance Functor (Const a) where
  fmap _ (Const x) = Const x

instance Monoid m => Applicative (Const m) where
  pure _ = Const mempty
  Const a <*> Const b = Const (a <> b)
  
  
-- Lens' s a = (a -> Const a a) -> s -> (Const a s)
view :: forall s t a b. Lens s t a b -> s -> a
view l s =
  let l' = l @(Const a)
   in getConst $ l' Const s

-- Lens s t a b = (a -> Identity b) -> s -> (Identity t)
set :: Lens s t a b -> s -> b -> t
set l s b = getIdentity $ l (\_ -> Identity b) s

addressL :: Lens' Person Address
addressL f s = fmap (\a' -> s { address = a' }) $ f (address s)

zipCodeL :: Lens' Address Int
zipCodeL f s = fmap (\z' -> s { zipCode = z' }) $ f (zipCode s)

ageL :: Lens' Person (Maybe Int)
ageL = lens' age (\p a -> p { age = a })

lens' :: (s -> a) -> (s -> a -> s) -> Lens' s a 
lens' get set f s = (set s) <$> f (get s)

--------------------------------------------------------------------------------
-- Concrete Prisms

data PrismC s t a b = PrismC
  { into :: b -> t,
    out :: s -> Either t a
  }
type PrismC' s a = PrismC s s a a 

previewC :: PrismC' s a -> s -> Maybe a
previewC p s = either (const Nothing) Just $ out p s

matchingC :: PrismC s t a b -> s -> Either t a
matchingC p = out p

composePrismC :: PrismC b b' c c' -> PrismC a a' b b' -> PrismC a a' c c'
composePrismC f g =
  PrismC
    { into = into g . into f,
      out = \a -> do
          b <- out g a
          either (\x -> Left $ into g x) Right $ out f b
    }

_JustC :: PrismC (Maybe a) (Maybe b) a b
_JustC =
  PrismC 
    { into = Just,
      out = maybe (Left Nothing) Right
    }

_NothingC :: PrismC' (Maybe a) ()
_NothingC =
  PrismC 
    { into = const Nothing,
      out = maybe (Right ()) (Left . Just)
    }

_LeftC :: PrismC (Either a x) (Either b x) a b 
_LeftC =
  PrismC 
    { into = Left,
      out = either Right (Left . Right)
    }

_RightC :: PrismC (Either x a) (Either x b) a b 
_RightC =
  PrismC 
    { into = Right,
      out = either (Left . Left) Right
    }

--------------------------------------------------------------------------------
-- Van Larhoeven Prism Encoding

newtype Tagged s b = Tagged { unTagged :: b }

newtype First a = First { getFirst :: Maybe a }

instance Semigroup (First a) where
  First (Just a) <> _ = First (Just a)
  _ <> b = b

instance Monoid (First a) where
  mempty = First Nothing
  
class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d 

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

instance Profunctor Tagged where
  dimap f g (Tagged c) = Tagged (g c)
  
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 Choice Tagged where
  left' (Tagged b) = Tagged (Left b)
  right' (Tagged b) = Tagged (Right b)
  
type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

type Prism' s a = Prism s s a a

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (fmap bt)) . right'

prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))

review :: Prism' s a -> a -> s
review p a = getIdentity $ unTagged $ p (Tagged $ Identity a)

preview :: Prism' s a -> s -> Maybe a
preview p s = getFirst $ getConst $ p (\a -> Const (First $ Just a)) s

_Just :: Prism (Maybe a) (Maybe b) a b
_Just = prism Just (maybe (Left Nothing) Right)

_Nothing :: Prism' (Maybe a) ()
_Nothing = prism' (const Nothing) (maybe (Just ()) (const Nothing))