Some lensy bits for your review #24

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Journal.SumLens where

import Control.Lens
import Data.Constraint
import Data.Sum

projected :: e :< r => Prism' (Sum r v) (e v)
projected = prism' inject project

projectedC :: forall r v e. Const e :< r => Prism' (Sum r v) e
projectedC = prism' (inject . Const) (fmap getConst . project)

weakened :: Prism' (Sum (e ': r) v) (Sum r v)
weakened = prism' weaken $ \s -> case decompose s of
  Left es -> Just es
  Right _ -> Nothing

_shead :: Prism' (Sum (e ': r) v) (e v)
_shead = projected

_stail :: Prism' (Sum (e ': r) v) (Sum r v)
_stail = weakened

underneath :: e :< r => Prism' (Sum (s ': r) v) (e v)
underneath = weakened . projected

underneathC :: Const e :< r => Prism' (Sum (s ': r) v) e
underneathC = weakened . projectedC

decomposed :: Iso' (Sum (e ': r) v) (Either (Sum r v) (e v))
decomposed = iso decompose (either weaken inject)

-- | @applied@ is the optic version of apply, to make it easy to compose
--   applications with other optics:
--   @@
--   s ^. applied @Printable printItem
--     === apply @Printable printItem s
--   @@
applied ::
  forall c r v a.
  Apply c r =>
  (forall f. c f => f v -> a) ->
  Fold (Sum r v) a
applied k f s = s <$ f (apply @c k s)

-- | @HasTraversal'@ serves the same role as Apply, but for traversals across
--   sums that support a given optic. For example, and with direct analogy to
--   'Apply':
--   @@
--   class HasLot f where
--     _Lot :: Traversal' (f v) Lot
--
--   instance HasTraversal' HasLot fs => HasLot (Sum fs) where
--     _Lot = traversing @HasLot _Lot
--   @@
class HasTraversal' (c :: (* -> *) -> Constraint) (fs :: [* -> *]) where
  traversing :: (forall g. c g => Traversal' (g a) b) -> Traversal' (Sum fs a) b

instance c t => HasTraversal' c '[t] where
  traversing k f s = fmap inject (k f (decomposeLast s))

instance
  {-# OVERLAPPING #-}
  (HasTraversal' c (u ': r), c t) =>
  HasTraversal' c (t ': u ': r)
  where
  traversing k f s = case decompose s of
    Right e -> inject <$> k f e
    Left es -> weaken <$> traversing @c k f es