patrickt / fastsum Goto Github PK

{-# 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

stronger :: f :< r => Sum r v -> a
stronger = undefined

weaker :: f :< r => Sum (e ': r) v -> a
weaker = stronger

class Producible m f where
  produce :: m (f v)

class Populate m (fs :: [* -> *]) where
  populate :: m (Sum fs b)

instance (Producible m t, MonadPlus m) => Populate m '[t] where
  populate = fmap inject (produce @m @t)

instance
  {-# OVERLAPPING #-}
  (Populate m (u ': r), Producible m t, MonadPlus m) =>
  Populate m (t ': u ': r)
  where
  populate =
    fmap inject (produce @m @t)
      <|> fmap weaken (populate @m @(u ': r))

instance Producible Parser (Const Entry) where
  produce = fmap Const parseEntry

-- | Try to extract the first type from the sum. On failure, return a
-- sum that eliminates that as a possibility. This would probably have
-- to be exported by the library so we don't have to export the Sum
-- constructor.
decomposeSum :: Sum (e ': es) b -> Either (Sum es b) (e b)
decomposeSum sum@(Sum n v) = maybe (Left (Sum (n - 1) v)) Right (projectSum sum)


-- | For a sum with precisely one type in the type list, we can safely
-- project that value.
decomposeLast :: Sum '[e] b -> e b
decomposeLast = either (error "impossible") id . decomposeSum