module Data.TypeRig.Riggable where

import Control.Arrow
import Data.Either
import Data.Functor
import Data.Functor.Invariant
import Data.Kind
import Data.List.NonEmpty
import Data.Maybe
import Data.Semigroup
import Data.TypeRig.Productable
import Data.TypeRig.Summable
import Prelude hiding ((.), id)
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec

-- | Composability via a [rig](https://ncatlab.org/nlab/show/rig) of types.
type Riggable :: (Type -> Type) -> Constraint
class (Productable f, Summable f) => Riggable f where
    rOptional :: forall a. f a -> f (Maybe a)
    rOptional f a
fa = let
        eitherToMaybe :: Either a () -> Maybe a
        eitherToMaybe :: Either a () -> Maybe a
eitherToMaybe (Left a
a) = forall a. a -> Maybe a
Just a
a
        eitherToMaybe (Right ()) = forall a. Maybe a
Nothing
        maybeToEither :: Maybe a -> Either a ()
        maybeToEither :: Maybe a -> Either a ()
maybeToEither (Just a
a) = forall a b. a -> Either a b
Left a
a
        maybeToEither Maybe a
Nothing = forall a b. b -> Either a b
Right ()
        in forall (f :: Type -> Type) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap Either a () -> Maybe a
eitherToMaybe Maybe a -> Either a ()
maybeToEither forall a b. (a -> b) -> a -> b
$ f a
fa forall (f :: Type -> Type) a b.
Summable f =>
f a -> f b -> f (Either a b)
<+++> forall (f :: Type -> Type). Productable f => f ()
rUnit
    rList1 :: f a -> f (NonEmpty a)
    rList1 f a
fa = let
        pairToNonEmpty :: (a, [a]) -> NonEmpty a
        pairToNonEmpty :: forall a. (a, [a]) -> NonEmpty a
pairToNonEmpty (a
a, [a]
as) = a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as
        nonEmptyToPair :: NonEmpty a -> (a, [a])
        nonEmptyToPair :: forall a. NonEmpty a -> (a, [a])
nonEmptyToPair (a
a :| [a]
as) = (a
a, [a]
as)
        in forall (f :: Type -> Type) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap forall a. (a, [a]) -> NonEmpty a
pairToNonEmpty forall a. NonEmpty a -> (a, [a])
nonEmptyToPair forall a b. (a -> b) -> a -> b
$ f a
fa forall (f :: Type -> Type) a b.
Productable f =>
f a -> f b -> f (a, b)
<***> forall (f :: Type -> Type) a. Riggable f => f a -> f [a]
rList f a
fa
    rList :: f a -> f [a]
    rList f a
fa = let
        eitherToList :: Either (NonEmpty a) () -> [a]
        eitherToList :: forall a. Either (NonEmpty a) () -> [a]
eitherToList (Left (a
a :| [a]
aa)) = a
a forall a. a -> [a] -> [a]
: [a]
aa
        eitherToList (Right ()) = []
        listToEither :: [a] -> Either (NonEmpty a) ()
        listToEither :: forall a. [a] -> Either (NonEmpty a) ()
listToEither (a
a:[a]
aa) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ a
a forall a. a -> [a] -> NonEmpty a
:| [a]
aa
        listToEither [] = forall a b. b -> Either a b
Right ()
        in forall (f :: Type -> Type) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap forall a. Either (NonEmpty a) () -> [a]
eitherToList forall a. [a] -> Either (NonEmpty a) ()
listToEither forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. Riggable f => f a -> f (NonEmpty a)
rList1 f a
fa forall (f :: Type -> Type) a b.
Summable f =>
f a -> f b -> f (Either a b)
<+++> forall (f :: Type -> Type). Productable f => f ()
rUnit

instance Riggable Endo where
    rOptional :: forall a. Endo a -> Endo (Maybe a)
rOptional (Endo a -> a
f) = forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f
    rList1 :: forall a. Endo a -> Endo (NonEmpty a)
rList1 (Endo a -> a
f) = forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f
    rList :: forall a. Endo a -> Endo [a]
rList (Endo a -> a
f) = forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f

instance Riggable m => Riggable (Kleisli m a) where
    rOptional :: forall a. Kleisli m a a -> Kleisli m a (Maybe a)
rOptional (Kleisli a -> m a
f) = forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. (a -> b) -> a -> b
$ \a
a -> forall (f :: Type -> Type) a. Riggable f => f a -> f (Maybe a)
rOptional forall a b. (a -> b) -> a -> b
$ a -> m a
f a
a
    rList1 :: forall a. Kleisli m a a -> Kleisli m a (NonEmpty a)
rList1 (Kleisli a -> m a
f) = forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. (a -> b) -> a -> b
$ \a
a -> forall (f :: Type -> Type) a. Riggable f => f a -> f (NonEmpty a)
rList1 forall a b. (a -> b) -> a -> b
$ a -> m a
f a
a
    rList :: forall a. Kleisli m a a -> Kleisli m a [a]
rList (Kleisli a -> m a
f) = forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. (a -> b) -> a -> b
$ \a
a -> forall (f :: Type -> Type) a. Riggable f => f a -> f [a]
rList forall a b. (a -> b) -> a -> b
$ a -> m a
f a
a

instance Riggable ReadPrec.ReadPrec where
    rOptional :: forall a. ReadPrec a -> ReadPrec (Maybe a)
rOptional ReadPrec a
ra = forall a. (Int -> ReadP a) -> ReadPrec a
ReadPrec.readP_to_Prec forall a b. (a -> b) -> a -> b
$ \Int
prec -> forall a. a -> ReadP a -> ReadP a
ReadP.option forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ReadPrec a -> Int -> ReadP a
ReadPrec.readPrec_to_P ReadPrec a
ra Int
prec
    rList :: forall a. ReadPrec a -> ReadPrec [a]
rList ReadPrec a
ra = forall a. (Int -> ReadP a) -> ReadPrec a
ReadPrec.readP_to_Prec forall a b. (a -> b) -> a -> b
$ \Int
prec -> forall a. ReadP a -> ReadP [a]
ReadP.many forall a b. (a -> b) -> a -> b
$ forall a. ReadPrec a -> Int -> ReadP a
ReadPrec.readPrec_to_P ReadPrec a
ra Int
prec