Distributor.hs

module Data.Distributor
  ( -- * lax monoidal profunctors
    Monoidal (unit, (>*<)) , dimap2, (>*), (*<)
  , replicateP, replicateP_, foreverP
  , Mon (Mon), liftMon
    -- * lax distributors
  , Distributor (zero, (>+<), several, several1, possibly)
  , dialt, (>|<)
  , Dist (DistEmpty, DistEither)
  , DistAlt (DistAlts), liftDistAlt
  , DistRing (DistRing)
  , Lint (Lint)
    -- * choice and cochoice profunctors
  , dimapMaybe, alternate, discriminate
  , ChcMon (ChcPure, ChcAp), liftChcMon
  , PartialExchange (PartialExchange)
    -- * partial isomorphisms
  , PartialIso, PartialIso', APartialIso, APartialIso'
  , partialIso, withPartialIso
  , coPartialIso, iterating, crossPartialIso, altPartialIso
  , difoldl1, difoldr1, difoldl, difoldr, difoldl'
    -- * streams
  , Nil (_Nil), nil, Null (_Null, _NotNull)
  , _Stream, _HeadTailMay, _HeadTail
  , Stream (_LengthIs, _SplitAt)
  , SimpleStream (_All, _AllNot, _Span, _Break)
    -- * pattern matching
  , (>$?<), (>?$<), (>?$?<)
  , eot, inCase, onCase, dichainl, dichainl'
  ) where

import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Lens hiding (chosen)
import Control.Monad
import Data.Bifunctor.Clown
import Data.Bifunctor.Joker
import Data.Bifunctor.Product
import Data.Functor.Adjunction (Adjunction, unabsurdL, cozipL)
import Data.Functor.Contravariant.Divisible hiding (chosen)
import qualified Data.Functor.Contravariant.Divisible as Con (chosen)
import Data.Profunctor hiding (WrappedArrow(..))
import qualified Data.Profunctor as Pro (WrappedArrow(..))
import Data.Profunctor.Composition
import Data.Profunctor.Monad
import Data.Void
import Generics.Eot
import GHC.Base (Constraint, Type)
import qualified Numeric.Algebra as Alg
import Witherable

class Profunctor p => Monoidal p where

  unit :: p () ()
  default unit :: (forall x. Applicative (p x)) => p () ()
  unit = pure ()

  (>*<) :: p a b -> p c d -> p (a,c) (b,d)
  infixr 4 >*<
  default (>*<)
    :: (forall x. Applicative (p x))
    => p a b -> p c d -> p (a,c) (b,d)
  x >*< y = (,) <$> lmap fst x <*> lmap snd y

instance Monoidal (->) where
  unit = id
  (>*<) = (***)
instance Monoid s => Monoidal (Forget s) where
  unit = Forget mempty
  Forget f >*< Forget g = Forget (\(a,c) -> f a <> g c)
instance Divisible f => Monoidal (Clown f) where
  unit = Clown conquer
  Clown x >*< Clown y = Clown (divided x y)
instance Applicative f => Monoidal (Joker f) where
  unit = Joker (pure ())
  Joker x >*< Joker y = Joker ((,) <$> x <*> y)
instance Arrow p => Monoidal (Pro.WrappedArrow p) where
  unit = Pro.WrapArrow returnA
  Pro.WrapArrow p >*< Pro.WrapArrow q = Pro.WrapArrow (p *** q)
instance (Monoidal p, Monoidal q)
  => Monoidal (Procompose p q) where
    unit = Procompose unit unit
    Procompose wb aw >*< Procompose vb av =
      Procompose (wb >*< vb) (aw >*< av)
instance (Monoidal p, Monoidal q)
  => Monoidal (Product p q) where
    unit = Pair unit unit
    Pair x0 y0 >*< Pair x1 y1 = Pair (x0 >*< x1) (y0 >*< y1)
instance Functor f => Monoidal (Costar f) where
  unit = Costar (const ())
  Costar f >*< Costar g =
    Costar (\ac -> (f (fst <$> ac), g (snd <$> ac)))
instance Applicative f => Monoidal (Star f) where
  unit = Star (const (pure ()))
  Star f >*< Star g =
    Star (\(a,c) -> (,) <$> f a <*> g c)
deriving via (Star m) instance Monad m => Monoidal (Kleisli m)

dimap2
  :: Monoidal p
  => (s -> a)
  -> (s -> c)
  -> (b -> d -> t)
  -> p a b -> p c d -> p s t
dimap2 f g h p q = dimap (f &&& g) (uncurry h) (p >*< q)

(>*) :: Monoidal p => p () c -> p a b -> p a b
u >* ab = dimap (pure () &&& id) snd (u >*< ab) 
infixr 4 >*

(*<) :: Monoidal p => p a b -> p () c -> p a b
ab *< u = dimap (id &&& pure ()) fst (ab >*< u) 
infixr 4 *<

replicateP :: Monoidal p => Int -> p a b -> p [a] [b]
replicateP n _ | n <= 0 = dimap (\_ -> ()) (\_ -> []) unit
replicateP n p =
  dimap (head &&& tail) (uncurry (:)) (p >*< replicateP (n-1) p)

replicateP_ :: Monoidal p => Int -> p () b -> p a ()
replicateP_ n _ | n <= 0 = lmap (pure ()) unit
replicateP_ n p = p >* replicateP_ (n-1) p

foreverP :: Monoidal p => p () c -> p a b
foreverP p = let p' = p >* p' in p'

type Mon
  :: ((Type -> Type) -> (Type -> Type))
  -- ^ your choice of free applicative
  -> (Type -> Type -> Type) 
  -> Type -> Type -> Type
data Mon ap p a b where
  Mon :: (a -> s) -> ap (p s) b -> Mon ap p a b
instance (forall f. Functor (ap f))
  => Functor (Mon ap p a) where
    fmap g (Mon f x) = Mon f (g <$> x)
instance (forall f. Applicative (ap f))
  => Applicative (Mon ap p a) where
    pure b = Mon id (pure b)
    Mon f0 x0 <*> Mon f1 x1 =
      lmap f0 (liftMon x0) <*> lmap f1 (liftMon x1)
instance (forall f. Functor (ap f)) => Profunctor (Mon ap p) where
  dimap h g (Mon f x) = Mon (f . h) (g <$> x)
instance (forall f. Applicative (ap f)) => Monoidal (Mon ap p) where
  unit = Mon id (pure ())
  Mon f0 x0 >*< Mon f1 x1 =
    lmap (f0 *** f1) (liftMon x0 >*< liftMon x1)

liftMon :: ap (p a) b -> Mon ap p a b
liftMon = Mon id

type Distributor :: (Type -> Type -> Type) -> Constraint
class Monoidal p => Distributor p where

  zero :: p Void Void
  default zero :: (forall x. Alternative (p x)) => p Void Void
  zero = empty

  (>+<) :: p a b -> p c d -> p (Either a c) (Either b d)
  default (>+<)
    :: (Choice p, Cochoice p, forall x. Alternative (p x))
    => p a b -> p c d -> p (Either a c) (Either b d)
  p >+< q = alternate (Left p) <|> alternate (Right q)
  infixr 3 >+<

  several
    :: (Cons s s a a, Cons t t b b, Nil t b)
    => p a b -> p s t
  several p = withIso _Stream $ \consE unconsE ->
    dimap consE unconsE (unit >+< several1 p)

  several1
    :: (Cons s s a a, Cons t t b b, Nil t b)
    => p a b -> p (a,s) (b,t)
  several1 p = p >*< several p

  possibly :: p a b -> p (Maybe a) (Maybe b)
  possibly p = dimap
    (maybe (Left ()) Right)
    (either (const Nothing) Just)
    (unit >+< p)

instance Distributor (->) where
  zero = id
  (>+<) = (+++)
instance Monoid s => Distributor (Forget s) where
  zero = Forget absurd
  Forget kL >+< Forget kR = Forget (either kL kR)
instance Decidable f => Distributor (Clown f) where
  zero = Clown (contramap absurd lost)
  Clown x >+< Clown y = Clown (Con.chosen x y)
instance Alternative g => Distributor (Joker g) where
  zero = Joker empty
  Joker x >+< Joker y = Joker (Left <$> x <|> Right <$> y)
instance (ArrowZero p, ArrowChoice p)
  => Distributor (Pro.WrappedArrow p) where
    zero = zeroArrow
    (>+<) = (+++)
instance (Distributor p, Distributor q)
  => Distributor (Procompose p q) where
    zero = Procompose zero zero
    Procompose xL yL >+< Procompose xR yR =
      Procompose (xL >+< xR) (yL >+< yR)
instance (Distributor p, Distributor q)
  => Distributor (Product p q) where
    zero = Pair zero zero
    Pair x0 y0 >+< Pair x1 y1 = Pair (x0 >+< x1) (y0 >+< y1)
deriving via (Star m) instance Monad m => Distributor (Kleisli m)
instance Applicative f => Distributor (Star f) where
  zero = Star absurd
  Star f >+< Star g =
    Star (either (fmap Left . f) (fmap Right . g))
instance Adjunction f u => Distributor (Costar f) where
  zero = Costar unabsurdL
  Costar f >+< Costar g = Costar (bimap f g . cozipL)

dialt
  :: Distributor p
  => (s -> Either a c)
  -> (b -> t)
  -> (d -> t)
  -> p a b -> p c d -> p s t
dialt f g h p q = dimap f (either g h) (p >+< q)

(>|<) :: Distributor p => p a b -> p c b -> p (Either a c) b
(>|<) = dialt id id id
infixr 3 >|<

data Dist ap p a b where
  DistEmpty
    :: (a -> Void)
    -> Dist ap p a b
  DistEither
    :: (a -> Either s c)
    -> ap (p s) b
    -> Dist ap p c b
    -> Dist ap p a b
instance (forall f. Functor (ap f))
  => Functor (Dist ap p a) where fmap = rmap
instance (forall f. Applicative (ap f))
  => Applicative (Dist ap p a) where
  pure b = liftDist (pure b)
  -- 0*x=0
  liftA2 _ (DistEmpty absurdum) _ = DistEmpty absurdum
  -- (x+y)*z=x*z+y*z
  liftA2 g (DistEither f x y) z =
    let
      ff a = bimap (,a) (,a) (f a)
    in
      dialt ff id id
        (uncurry g <$> (liftDist x >*< z))
        (uncurry g <$> (y >*< z))
instance (forall f. Functor (ap f))
  => Profunctor (Dist ap p) where
  dimap f _ (DistEmpty absurdum) = DistEmpty (absurdum . f)
  dimap f' g' (DistEither f x y) =
    DistEither (f . f') (g' <$> x) (g' <$> y)
instance (forall f. Applicative (ap f)) => Monoidal (Dist ap p)
instance (forall f. Applicative (ap f))
  => Distributor (Dist ap p) where
  zero = DistEmpty absurd
  -- 0+x=x
  DistEmpty absurdum >+< x =
    dimap (either (absurd . absurdum) id) Right x
  -- (x+y)+z=x+(y+z)
  DistEither f x y >+< z =
    let
      assocE (Left (Left a)) = Left a
      assocE (Left (Right b)) = Right (Left b)
      assocE (Right c) = Right (Right c)
      f' = assocE . either (Left . f) Right
    in
      dialt f' Left id (liftDist x) (y >+< z)

liftDist :: ap (p a) b -> Dist ap p a b
liftDist x = DistEither Left x (DistEmpty id)

newtype DistAlt p a b = DistAlts [p a b]
instance (forall x. Functor (p x)) => Functor (DistAlt p a) where
  fmap f (DistAlts alts) = DistAlts (map (fmap f) alts)
instance (forall x. Applicative (p x))
  => Applicative (DistAlt p a) where
  pure b = liftDistAlt (pure b)
  DistAlts xs <*> DistAlts ys =
    DistAlts [x <*> y | x <- xs, y <- ys]
instance (forall x. Applicative (p x))
  => Alternative (DistAlt p a) where
    empty = DistAlts []
    DistAlts altsL <|> DistAlts altsR = DistAlts (altsL ++ altsR)
instance Profunctor p => Profunctor (DistAlt p) where
  dimap f g (DistAlts alts) = DistAlts (map (dimap f g) alts)
instance (forall x. Applicative (p x), Profunctor p)
  => Monoidal (DistAlt p)
instance Choice p => Choice (DistAlt p) where
  left' (DistAlts alts) = DistAlts (map left' alts)
  right' (DistAlts alts) = DistAlts (map right' alts)
instance Cochoice p => Cochoice (DistAlt p) where
  unleft (DistAlts alts) = DistAlts (map unleft alts)
  unright (DistAlts alts) = DistAlts (map unright alts)
instance (Choice p, Cochoice p, forall x. Applicative (p x))
  => Distributor (DistAlt p)

liftDistAlt :: p a b -> DistAlt p a b
liftDistAlt p = DistAlts [p]

newtype DistRing r a b = DistRing r deriving (Eq, Ord, Show)
instance Profunctor (DistRing r) where
  dimap _ _ (DistRing r) = DistRing r
instance Choice (DistRing r) where
  left' (DistRing r) = DistRing r
  right' (DistRing r) = DistRing r
instance Cochoice (DistRing r) where
  unleft (DistRing r) = DistRing r
  unright (DistRing r) = DistRing r
instance Alg.Unital r => Monoidal (DistRing r) where
  unit = DistRing Alg.one
  DistRing r0 >*< DistRing r1 = DistRing (r0 Alg.* r1)
instance Alg.Ring r => Distributor (DistRing r) where
  zero = DistRing Alg.zero
  DistRing r0 >+< DistRing r1 = DistRing (r0 Alg.+ r1)

newtype Lint f r a b = Lint (a -> f r)
instance Functor (Lint f r a) where
  fmap _ (Lint f) = Lint f
instance Functor f => Profunctor (Lint f r) where
  dimap g _ (Lint linter) = Lint (linter . g)
instance (Applicative f, Monoid r) => Applicative (Lint f r a) where
  pure _ = Lint (\_ -> pure mempty)
  Lint l <*> Lint r = Lint $ \a -> liftA2 (<>) (l a) (r a)
instance (Alternative f, Monoid r) => Alternative (Lint f r a) where
  empty = Lint (\_ -> empty)
  Lint l <|> Lint r = Lint $ \a -> l a <|> r a
instance (Applicative f, Filterable f) => Filterable (Lint f r a) where
  mapMaybe = dimapMaybe Just
instance (Applicative f, Monoid r) => Monoidal (Lint f r)
instance Functor f => Cochoice (Lint f r) where
  unleft (Lint linter) = Lint $ linter . Left
  unright (Lint linter) = Lint $ linter . Right
instance (Applicative f, Filterable f) => Choice (Lint f r) where
  left' (Lint linter) = Lint $
    either linter (\_ -> catMaybes (pure Nothing))
  right' (Lint linter) = Lint $
    either (\_ -> catMaybes (pure Nothing)) linter
instance (Alternative f, Filterable f, Monoid r) => Distributor (Lint f r)

dimapMaybe
  :: (Choice p, Cochoice p)
  => (s -> Maybe a) -> (b -> Maybe t)
  -> p a b -> p s t
dimapMaybe f g =
  let
    m2e h = maybe (Left ()) Right . h
    fg = dimap (>>= m2e f) (>>= m2e g)
  in
    unright . fg . right'

-- prop> left' = alternate . Left
-- prop> right' = alternate . Right
alternate
  :: (Choice p, Cochoice p)
  => Either (p a b) (p s t)
  -> p (Either a s) (Either b t)
alternate (Left p) =
  dimapMaybe (either Just (pure Nothing)) (Just . Left) p
alternate (Right p) =
  dimapMaybe (either (pure Nothing) Just) (Just . Right) p

-- prop> unleft = fst . discriminate
-- prop> unright = snd . discriminate
discriminate
  :: (Choice p, Cochoice p)
  => p (Either a s) (Either b t)
  -> (p a b, p s t)
discriminate p =
  ( dimapMaybe (Just . Left) (either Just (pure Nothing)) p
  , dimapMaybe (Just . Right) (either (pure Nothing) Just) p
  )

data ChcMon p a b where
  ChcPure :: Maybe b -> ChcMon p a b
  ChcAp
    :: (a -> Maybe s)
    -> ChcMon p a (t -> Maybe b)
    -> p s t
    -> ChcMon p a b
instance Functor (ChcMon p a) where fmap = rmap
instance Filterable (ChcMon p a) where
  mapMaybe = dimapMaybe Just
instance Applicative (ChcMon p a) where
  pure = ChcPure . Just
  ChcPure Nothing <*> _ = ChcPure Nothing
  ChcPure (Just f) <*> x = f <$> x
  ChcAp f g x <*> y =
    let
      apply h a t = ($ a) <$> h t
    in
      ChcAp f (apply <$> g <*> y) x
instance Profunctor (ChcMon p) where
  dimap _ g (ChcPure b) = ChcPure (g <$> b)
  dimap f' g' (ChcAp f g x) =
    ChcAp (f . f') ((fmap g' .) <$> lmap f' g) x
instance Monoidal (ChcMon p)
instance Choice (ChcMon p) where
  left' (ChcPure b) = ChcPure (Left <$> b)
  left' (ChcAp f g x) =
    let
      apply e t = either ((Left <$>) . ($ t)) (Just . Right) e
    in
      ChcAp (either f (pure Nothing)) (apply <$> (left' g)) x
  right' (ChcPure b) = ChcPure (Right <$> b)
  right' (ChcAp f g x) =
    let
      apply e t = either (Just . Left) ((Right <$>) . ($ t)) e
    in
      ChcAp (either (pure Nothing) f) (apply <$> (right' g)) x
instance Cochoice (ChcMon p) where
  unleft (ChcPure b) =
    ChcPure (either Just (pure Nothing) =<< b)
  unleft (ChcAp f g x) =
    let
      g' = (Left . (either Just (pure Nothing) <=<)) <$> g
    in
      ChcAp (f . Left) (unleft g') x
  unright (ChcPure b) =
    ChcPure (either (pure Nothing) Just =<< b)
  unright (ChcAp f g x) =
    let
      g' = (Right . (either (pure Nothing) Just <=<)) <$> g
    in
      ChcAp (f . Right) (unright g') x
instance ProfunctorFunctor ChcMon where
  promap _ (ChcPure b) = ChcPure b
  promap h (ChcAp f g x) = ChcAp f (promap h g) (h x)

liftChcMon :: p a b -> ChcMon p a b
liftChcMon = ChcAp Just (pure Just)

data PartialExchange s t a b =
  PartialExchange (a -> Maybe s) (t -> Maybe b)
instance Semigroup (PartialExchange s t a b) where
  PartialExchange f g <> PartialExchange f' g' =
    PartialExchange (\s -> f s <|> f' s) (\b -> g b <|> g' b)    
instance Monoid (PartialExchange s t a b) where
  mempty = PartialExchange nope nope where
    nope _ = Nothing
instance Functor (PartialExchange s t a) where fmap = rmap
instance Filterable (PartialExchange s t a) where
  mapMaybe = dimapMaybe Just
instance Monoid s => Applicative (PartialExchange s t a) where
  pure b = PartialExchange (\_ -> mempty) (\_ -> Just b)
  PartialExchange f' g' <*> PartialExchange f g = PartialExchange
    (\a -> (<>) <$> f' a <*> f a)
    (\t -> g' t <*> g t)
instance Monoid s => Alternative (PartialExchange s t a) where
  empty = mempty
  (<|>) = (<>)
instance Profunctor (PartialExchange s t) where
  dimap f' g' (PartialExchange f g) =
    PartialExchange (f . f') (fmap g' . g)
instance Monoid s => Monoidal (PartialExchange s t)
instance Monoid s => Distributor (PartialExchange s t)
instance Choice (PartialExchange s t) where
  left' (PartialExchange f g) =
    PartialExchange (either f (pure Nothing)) ((Left <$>) . g)
  right' (PartialExchange f g) =
    PartialExchange (either (pure Nothing) f) ((Right <$>) . g)
instance Cochoice (PartialExchange s t) where
  unleft (PartialExchange f g) =
    PartialExchange (f . Left) (either Just (pure Nothing) <=< g)
  unright (PartialExchange f g) =
    PartialExchange (f . Right) (either (pure Nothing) Just <=< g)

type PartialIso s t a b = forall p f.
  (Choice p, Cochoice p, Applicative f, Filterable f)
    => p a (f b) -> p s (f t)

type PartialIso' s a = PartialIso s s a a

type APartialIso s t a b =
  PartialExchange a b a (Maybe b) -> PartialExchange a b s (Maybe t)

type APartialIso' s a = APartialIso s s a a

partialIso :: (s -> Maybe a) -> (b -> Maybe t) -> PartialIso s t a b
partialIso f g =
  let
    m2e = maybe (Left ()) Right
  in
    unright . iso (m2e . f =<<) (mapMaybe g) . right'

withPartialIso
  :: APartialIso s t a b
  -> ((s -> Maybe a) -> (b -> Maybe t) -> r)
  -> r
withPartialIso i k =
  case i (PartialExchange Just (Just . Just)) of
    PartialExchange f g -> k f (join . g)

coPartialIso
  :: APartialIso b a t s
  -> PartialIso s t a b
coPartialIso i =
  withPartialIso i $ \f g -> partialIso g f

iterating :: APartialIso a b a b -> Iso a b a b
iterating i = withPartialIso i $ \f g ->
  iso (iter f) (iter g) where
    iter h state = maybe state (iter h) (h state)

crossPartialIso
  :: APartialIso s t a b
  -> APartialIso u v c d
  -> PartialIso (s,u) (t,v) (a,c) (b,d)
crossPartialIso x y =
  withPartialIso x $ \e f ->
  withPartialIso y $ \g h ->
    partialIso
      (\(s,u) -> (,) <$> e s <*> g u)
      (\(t,v) -> (,) <$> f t <*> h v)

altPartialIso
  :: APartialIso s t a b
  -> APartialIso u v c d
  -> PartialIso
      (Either s u) (Either t v)
      (Either a c) (Either b d)
altPartialIso x y =
  withPartialIso x $ \e f ->
  withPartialIso y $ \g h ->
    partialIso
      (either ((Left <$>) . e) ((Right <$>) . g))
      (either ((Left <$>) . f) ((Right <$>) . h)) 

difoldl1
  :: Cons s t a b
  => APartialIso (c,a) (d,b) c d
  -> Iso (c,s) (d,t) (c,s) (d,t)
difoldl1 i =
  let
    associate = iso
      (\(c,(a,s)) -> ((c,a),s))
      (\((d,b),t) -> (d,(b,t)))
    step
      = crossPartialIso id _Cons
      . associate
      . crossPartialIso i id
  in iterating step

difoldr1
  :: Cons s t a b
  => APartialIso (a,c) (b,d) c d
  -> Iso (s,c) (t,d) (s,c) (t,d)
difoldr1 i =
  let
    reorder = iso
      (\((a,s),c) -> (s,(a,c)))
      (\(t,(b,d)) -> ((b,t),d))
    step
      = crossPartialIso _Cons id
      . reorder
      . crossPartialIso id i
  in iterating step

difoldl
  :: (Null s t a b, Cons s t a b)
  => APartialIso (c,a) (d,b) c d
  -> PartialIso (c,s) (d,t) c d
difoldl i =
  let
    unit' = iso
      (\(a,()) -> a)
      (\a -> (a,()))
  in
    difoldl1 i
    . crossPartialIso id _Null
    . unit'

difoldl'
  :: (Nil s a, Cons s s a a)
  => APrism' (c,a) c
  -> Prism' (c,s) c
difoldl' i =
  let
    unit' = iso
      (\(a,()) -> a)
      (\a -> (a,()))
  in
    difoldl1 (clonePrism i)
    . aside _Nil
    . unit'

difoldr
  :: (Null s t a b, Cons s t a b)
  => APartialIso (a,c) (b,d) c d
  -> PartialIso (s,c) (t,d) c d
difoldr i =
  let
    unit' = iso
      (\((),c) -> c)
      (\d -> ((),d))
  in
    difoldr1 i
    . crossPartialIso _Null id
    . unit'

class Nil s a | s -> a where
  _Nil :: Prism' s ()
instance Nil (Maybe a) a where
  _Nil = _Nothing
instance Nil [a] a where
  _Nil = prism (pure []) $ \case
    [] -> Right ()
    x -> Left x
instance Nil (Either () a) a where
  _Nil = _Left

nil :: Nil s a => s
nil = review _Nil ()

class
  ( Nil s a
  , Nil t b
  , Null s s a a
  , Null t t b b
  ) => Null s t a b | b s -> t, a t -> s where
  _Null :: PartialIso s t () ()
  _NotNull :: PartialIso s t s t
instance Null (Maybe a) (Maybe b) a b where
  _Null = partialIso
    (maybe (Just ()) (pure Nothing))
    (pure (Just Nothing))
  _NotNull = partialIso nonemp nonemp where
    nonemp Nothing = Nothing
    nonemp (Just x) = Just (Just x)
instance Null [a] [b] a b where
  _Null = partialIso
    (\l -> if null l then Just () else Nothing)
    (pure (Just []))
  _NotNull = partialIso nonemp nonemp where
    nonemp l = if not (null l) then Just l else Nothing
instance Null (Either () a) (Either () b) a b where
  _Null = partialIso
    (either Just (pure Nothing))
    (pure (Just (Left ())))
  _NotNull = partialIso nonemp nonemp where
    nonemp (Left ()) = Nothing
    nonemp (Right x) = Just (Right x)

_Stream
  :: (Cons s s a a, Cons t t b b, Nil t b)
  => Iso s t (Either () (a,s)) (Either () (b,t))
_Stream
  = _HeadTailMay
  . iso (maybe (Left ()) Right) (either (pure Nothing) Just)

_HeadTailMay
  :: (Cons s s a a, Cons t t b b, Nil t b)
  => Iso s t (Maybe (a,s)) (Maybe (b,t))
_HeadTailMay = iso (preview _Cons) (maybe nil (uncurry cons))

_HeadTail
  :: (Null s t a b, Cons s s a a, Cons t t b b)
  => PartialIso s t (a,s) (b,t)
_HeadTail = _NotNull . _HeadTailMay . _Just

class
  ( Null s t a b
  , Cons s t a b
  , Stream s s a a
  , Stream t t b b
  ) => Stream s t a b where
  _LengthIs :: (Int -> Bool) -> PartialIso s t s t
  _SplitAt :: Int -> PartialIso s t (s,s) (t,t)
instance Stream [a] [b] a b where
  _LengthIs f = partialIso lengthen lengthen where
    lengthen :: [c] -> Maybe [c]
    lengthen list = if f (length list) then Just list else Nothing
  _SplitAt n
    = _LengthIs (>= n)
    . iso (splitAt n) (uncurry (<>))
    . crossPartialIso (_LengthIs (== (max 0 n))) id

class (Nil s a, Cons s s a a) => SimpleStream s a where
  _All :: (a -> Bool) -> PartialIso' s s
  _AllNot :: (a -> Bool) -> PartialIso' s s
  _Span :: (a -> Bool) -> PartialIso' s (s,s)
  _Break :: (a -> Bool) -> PartialIso' s (s,s)
instance SimpleStream [a] a where
  _All f = partialIso every every where
    every list = if all f list then Just list else Nothing
  _AllNot f = partialIso everyNot everyNot where
    everyNot list = if all (not . f) list then Just list else Nothing
  _Span f = iso (span f) (uncurry (<>)) . crossPartialIso (_All f) id
  _Break f = iso (break f) (uncurry (<>)) . crossPartialIso (_AllNot f) id

(>$?<)
  :: Choice p
  => APrism s t a b
  -> p a b
  -> p s t
i >$?< p = withPrism i $ \f g ->
  dimap g (either id f) (right' p)
infixr 4 >$?<

(>?$<)
  :: Cochoice p
  => APrism b a t s
  -> p a b
  -> p s t
i >?$< p = withPrism i $ \f g ->
  unright (dimap (either id f) g p)
infixr 4 >?$<

(>?$?<)
  :: (Choice p, Cochoice p)
  => APartialIso s t a b
  -> p a b
  -> p s t
i >?$?< p =
  withPartialIso i $ \f g -> dimapMaybe f g p
infixr 4 >?$?<

-- positional pattern matching
eot
  :: (HasEot a, HasEot b, Profunctor p)
  => p (Eot a) (Eot b) -> p a b
eot = dimap toEot fromEot

-- inexhaustive abstract pattern matching
inCase
  :: (Choice p, Cochoice p, forall x. Alternative (p x))
  => APartialIso s t a b
  -> p a b
  -> p s t
  -> p s t
inCase i = flip (<|>) . (>?$?<) i

-- exhaustive abstract pattern matching
onCase
  :: (Cochoice p, Distributor p)
  => APrism b a t s
  -> p a b
  -> p c Void
  -> p s t
onCase p =
  flip (dialt Right absurd id) . (>?$<) p

dichainl
  :: forall p s t a b. (Choice p, Cochoice p, Distributor p)
  => APartialIso s t (s,(a,s)) (t,(b,t))
  -> p a b
  -> p s t
  -> p s t
dichainl i opr arg =
  coPartialIso (difoldl (coPartialIso i)) >?$?<
    arg >*< several @p @[(a,s)] (opr >*< arg)

dichainl'
  :: forall p s a. (Cochoice p, Distributor p)
  => APrism' (s,(a,s)) s
  -> p a a
  -> p s s
  -> p s s
dichainl' p opr arg =
  difoldl' p >?$< arg >*< several @p @[(a,s)] (opr >*< arg)