fastsum
fastsum copied to clipboard
Some lensy bits for your review
I've found these useful as a UI for fastsum
in my lens-oriented code:
{-# 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