Prisms with error reporting

verboseprism.hs

{-# LANGUAGE
    RankNTypes,
    TypeFamilies,
    DeriveFunctor,
    FlexibleContexts,
    DefaultSignatures,
    FlexibleInstances,
    MultiParamTypeClasses
#-}

import Control.Lens
import Control.Monad.Reader
import Data.Tagged

class Functor f => VerbosePointed e f where
    vpure :: e -> a -> f a
    default vpure :: Applicative f => e -> a -> f a
    vpure _ = pure

instance Monoid r => VerbosePointed e (Const r)
instance VerbosePointed e Identity

newtype ConstEither e r a = ConstEither { getConstEither :: Either e r }
    deriving Functor

instance e ~ e' => VerbosePointed e (ConstEither e' r) where
    vpure e _ = ConstEither (Left e)

type VerbosePrism e s t a b =
    forall p f.
    (Choice p, VerbosePointed e f) =>
    Optic p f s t a b

vpreview :: s -> LensLike' (ConstEither e a) s a -> Either e a
vpreview whole f = f (ConstEither . Right) whole & getConstEither

vprism :: e -> APrism s t a b -> VerbosePrism e s t a b
vprism e p =
    dimap (matching p)
    (either (vpure e) (fmap (review' p))) .
    right'

-- Control.Lens.review variant with a more general type
review' :: MonadReader b m => APrism s t a b -> m t
review' p = asks (runIdentity . unTagged . clonePrism p . Tagged . Identity)

vjust :: VerbosePrism String (Maybe a) (Maybe b) a b
vjust = vprism "Nothing when expecting Just" _Just