module Freelude.Impl.Classes (
Semigroupoid((.)), (<<<), (>>>),
Category(id),
Const(const),
Arr(arr),
FunctionP,
CategoryT, ExoCategoryT,
CategorySrcC, CategorySrcC', ExoCategorySrcC,
CategoryDstC, CategoryDstC', ExoCategoryDstC,
CategoryC, ExoCategoryC,
IsSemigroupoid, ExoIsSemigroupoid,
IsCategory, ExoIsCategory,
FunctorT, FunctorSrcC, FunctorDstC, FunctorSrcC', FunctorDstC',
FromMaybeConstraintFunc,
UnconstrainedFunctor,
BasicFunctorP, FunctorCategoryP,
Functor(fmap), (<$>),
ConstFunctor((<$)),
Pure(pure),
Lift(liftA2, (<*), (*>)),
Apply((<*>)), (<**>),
Applicative,
Monad((>>=), (>>)), return, (=<<)
) where
import qualified Control.Category
import qualified Control.Applicative
import Data.Type.Equality ((:~:))
import Data.Type.Coercion (Coercion)
import Control.Arrow (Kleisli)
import Data.Monoid (Dual(Dual))
import qualified Control.Arrow
import Control.IndexT.Tuple (TupleConstraint)
import Control.IndexT (IndexT)
import Control.IndexT.Constructor (IndexC, IndexCK)
import Data.Functor.Identity (Identity(Identity))
import Prelude hiding (Functor(fmap), (<$>), Applicative((<*>), pure), Monad(return, (>>=), (>>)), (=<<), (.), id, const)
import qualified Prelude
import GHC.Exts (Constraint)
import Data.Kind (Type)
import Data.Set (Set)
import qualified Data.Set
import Data.Functor.Constant (Constant)
import Freelude.Impl.ToKind (ToType)
import Data.List.NonEmpty (NonEmpty)
import Data.Tree (Tree)
import Data.Semigroup (Option, Min, Max, Last, First)
import GHC.TypeLits (Nat)
import Data.Array (Array, Ix)
import qualified Data.Array.IArray
import Data.Array.IArray (IArray)
import Data.Array.Unboxed (UArray)
import qualified Data.Text as StrictText
import qualified Data.Text.Lazy as LazyText
import qualified Data.ByteString as StrictByteString
import qualified Data.ByteString.Lazy as LazyByteString
import Data.Word (Word8)
type family CategoryT (p :: Type) (a :: Type) (b :: Type) = (f :: Type) | f -> p a b
type family ExoCategoryT (p :: Type) (a :: Type) (b :: Type) = (f :: Type) | f -> p a b
type family CategorySrcC' (p :: Type) :: Maybe (Type -> Constraint)
type family CategoryDstC' (p :: Type) :: Maybe (Type -> Constraint)
type family ExoCategorySrcC (p :: Type) (a :: Type) :: Constraint
type family ExoCategoryDstC (p :: Type) (b :: Type) :: Constraint
class EmptyConstraint a
instance EmptyConstraint a
type family FromMaybeConstraintFunc (p :: Maybe (Type -> Constraint)) :: Type -> Constraint where
FromMaybeConstraintFunc 'Nothing = EmptyConstraint
FromMaybeConstraintFunc ('Just c) = c
type CategorySrcC p a = (FromMaybeConstraintFunc (CategorySrcC' p)) a
type CategoryDstC p a = (FromMaybeConstraintFunc (CategoryDstC' p)) a
type CategoryC p a b = (CategorySrcC p a, CategoryDstC p b)
type ExoCategoryC p a b = (ExoCategorySrcC p a, ExoCategoryDstC p b)
type IsSemigroupoid t p a b = (Semigroupoid p, t ~ CategoryT p a b, CategoryC p a b)
type ExoIsSemigroupoid t p a b = (Semigroupoid p, t ~ ExoCategoryT p a b, ExoCategoryC p a b)
type IsCategory t p a b = (IsSemigroupoid t p a b, Category p)
type ExoIsCategory t p a b = (ExoIsSemigroupoid t p a b, Category p)
class Semigroupoid p where
(.) :: (CategoryC p b c, CategoryC p a b, CategoryC p a c) => CategoryT p b c -> CategoryT p a b -> CategoryT p a c
class Semigroupoid p => Category p where
id :: (CategoryC p a a, ExoCategoryC p a a, t ~ CategoryT p a a, t ~ ExoCategoryT p a a) => t
class Semigroupoid p => Const p where
const :: CategoryC p a b => b -> CategoryT p a b
default const :: (Arr p, CategoryC p a b) => b -> CategoryT p a b
const = arr Prelude.. Prelude.const
instance (Semigroupoid p, Arr p) => Const p
class (Category p, Const p) => Arr p where
arr :: CategoryC p a b => (a -> b) -> CategoryT p a b
data FunctionP
type instance CategoryT FunctionP a b = (->) a b
type instance ExoCategoryT FunctionP a b = (->) a b
type instance CategorySrcC' FunctionP = 'Nothing
type instance CategoryDstC' FunctionP = 'Nothing
type instance ExoCategorySrcC FunctionP a = ()
type instance ExoCategoryDstC FunctionP b = ()
infixr 9 .
instance Semigroupoid FunctionP where
(.) = (Prelude..)
instance Category FunctionP where
id = Prelude.id
instance Const FunctionP
instance Arr FunctionP where
arr = id
(<<<) :: (Semigroupoid p, CategoryC p b c, CategoryC p a b, CategoryC p a c) => CategoryT p b c -> CategoryT p a b -> CategoryT p a c
(<<<) = (.)
(>>>) :: (Semigroupoid p, CategoryC p a b, CategoryC p b c, CategoryC p a c) => CategoryT p a b -> CategoryT p b c -> CategoryT p a c
(>>>) = flip (.)
data ProxyK k (a :: k)
data TypeEqP (k :: Type)
class (a ~ ProxyK k (IndexCK k 2 1 a)) => ProxyC k a
instance (a ~ ProxyK k (IndexCK k 2 1 a)) => ProxyC k a
type instance CategoryT (TypeEqP k) (ProxyK k a) (ProxyK k b) = (:~:) a b
type instance ExoCategoryT (TypeEqP k) (ProxyK k a) (ProxyK k b) = (:~:) a b
type instance CategorySrcC' (TypeEqP k) = 'Just (ProxyC k)
type instance CategoryDstC' (TypeEqP k) = 'Just (ProxyC k)
type instance ExoCategorySrcC (TypeEqP k) a = CategorySrcC (TypeEqP k) a
type instance ExoCategoryDstC (TypeEqP k) a = CategoryDstC (TypeEqP k) a
instance Semigroupoid (TypeEqP k) where
(.) = (Control.Category..)
instance Category (TypeEqP k) where
id = Control.Category.id
data CoercionP (k :: Type)
type instance CategoryT (CoercionP k) (ProxyK k a) (ProxyK k b) = Coercion a b
type instance CategorySrcC' (CoercionP k) = 'Just (ProxyC k)
type instance CategoryDstC' (CoercionP k) = 'Just (ProxyC k)
type instance ExoCategoryT (CoercionP k) (ProxyK k a) (ProxyK k b) = Coercion a b
type instance ExoCategorySrcC (CoercionP k) a = CategorySrcC (TypeEqP k) a
type instance ExoCategoryDstC (CoercionP k) a = CategoryDstC (TypeEqP k) a
instance Semigroupoid (CoercionP k) where
(.) = (Control.Category..)
instance Category (CoercionP k) where
id = Control.Category.id
data KleisliP (m :: Type -> Type)
type instance CategoryT (KleisliP m) a b = Kleisli m a b
type instance CategorySrcC' (KleisliP _) = 'Nothing
type instance CategoryDstC' (KleisliP _) = 'Nothing
type instance ExoCategoryT (KleisliP m) (m a) (m b) = Kleisli m a b
type instance ExoCategorySrcC (KleisliP _) _ = ()
type instance ExoCategoryDstC (KleisliP _) _ = ()
instance Prelude.Monad m => Semigroupoid (KleisliP m) where
(.) = (Control.Category..)
instance Prelude.Monad m => Category (KleisliP m) where
id = Control.Category.id
instance Prelude.Monad m => Const (KleisliP m)
instance Prelude.Monad m => Arr (KleisliP m) where
arr = Control.Arrow.arr
data FunctorCategoryP (functorP :: Type) (p :: Type)
type instance CategorySrcC' (FunctorCategoryP _ p) = CategorySrcC' p
type instance CategoryDstC' (FunctorCategoryP _ p) = CategoryDstC' p
type instance ExoCategorySrcC (FunctorCategoryP functorP p) a = (ExoCategorySrcC p (IndexC 1 0 a), a ~ FunctorT functorP (IndexC 1 0 a))
type instance ExoCategoryDstC (FunctorCategoryP functorP p) b = (ExoCategoryDstC p (IndexC 1 0 b), b ~ FunctorT functorP (IndexC 1 0 b))
type instance CategoryT (FunctorCategoryP (BasicFunctorP Maybe) p) a b = Maybe (CategoryT p a b)
type instance ExoCategoryT (FunctorCategoryP (BasicFunctorP Maybe) p) (Maybe a) (Maybe b) = Maybe (ExoCategoryT p a b)
instance Semigroupoid p => Semigroupoid (FunctorCategoryP (BasicFunctorP Maybe) p) where
x . y = (.) <$> x <*> y
instance Semigroupoid p => Category (FunctorCategoryP (BasicFunctorP Maybe) p) where
id = Nothing
instance Const (FunctorCategoryP (BasicFunctorP Maybe) FunctionP)
instance Arr (FunctorCategoryP (BasicFunctorP Maybe) FunctionP) where
arr = pure
type instance CategoryT (FunctorCategoryP (BasicFunctorP []) p) a b = [CategoryT p a b]
type instance ExoCategoryT (FunctorCategoryP (BasicFunctorP []) p) [a] [b] = [ExoCategoryT p a b]
instance Semigroupoid p => Semigroupoid (FunctorCategoryP (BasicFunctorP []) p) where
x . y = (.) <$> x <*> y
instance Semigroupoid p => Category (FunctorCategoryP (BasicFunctorP []) p) where
id = mempty
instance Const (FunctorCategoryP (BasicFunctorP []) FunctionP) where
instance Arr (FunctorCategoryP (BasicFunctorP []) FunctionP) where
arr = pure
type instance CategoryT (Identity p) a b = Identity (CategoryT p a b)
type instance CategorySrcC' (Identity p) = CategorySrcC' p
type instance CategoryDstC' (Identity p) = CategoryDstC' p
type instance ExoCategoryT (Identity p) a b = Identity (ExoCategoryT p a b)
type instance ExoCategorySrcC (Identity p) a = ExoCategorySrcC p a
type instance ExoCategoryDstC (Identity p) b = ExoCategoryDstC p b
instance Semigroupoid p => Semigroupoid (Identity p) where
x . y = (.) <$> x <*> y
instance Category p => Category (Identity p) where
id = Identity id
instance Const (Identity FunctionP)
instance Arr (Identity FunctionP) where
arr = pure
type instance CategoryT (Dual p) a b = Dual (CategoryT p b a)
type instance CategorySrcC' (Dual p) = CategoryDstC' p
type instance CategoryDstC' (Dual p) = CategorySrcC' p
type instance ExoCategoryT (Dual p) a b = Dual (ExoCategoryT p b a)
type instance ExoCategorySrcC (Dual p) a = ExoCategoryDstC p a
type instance ExoCategoryDstC (Dual p) b = ExoCategorySrcC p b
instance Semigroupoid p => Semigroupoid (Dual p) where
Dual x . Dual y = Dual (y . x)
instance Category p => Category (Dual p) where
id = Dual id
class (TupleConstraint 2 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a)) => Tuple2SrcC p1 p2 a
instance (TupleConstraint 2 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a)) => Tuple2SrcC p1 p2 a
class (TupleConstraint 2 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b)) => Tuple2DstC p1 p2 b
instance (TupleConstraint 2 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b)) => Tuple2DstC p1 p2 b
type instance CategoryT (p1, p2) (a1, a2) (b1, b2) = (CategoryT p1 a1 b1, CategoryT p2 a2 b2)
type instance CategorySrcC' (p1, p2) = 'Just (Tuple2SrcC p1 p2)
type instance CategoryDstC' (p1, p2) = 'Just (Tuple2DstC p1 p2)
type instance ExoCategoryT (p1, p2) (a1, a2) (b1, b2) = (ExoCategoryT p1 a1 b1, ExoCategoryT p2 a2 b2)
type instance ExoCategorySrcC (p1, p2) a = (TupleConstraint 2 a, ExoCategorySrcC p1 (IndexT 0 a), ExoCategorySrcC p2 (IndexT 1 a))
type instance ExoCategoryDstC (p1, p2) b = (TupleConstraint 2 b, ExoCategoryDstC p1 (IndexT 0 b), ExoCategoryDstC p2 (IndexT 1 b))
instance (Semigroupoid p1, Semigroupoid p2) => Semigroupoid (p1, p2) where
(x1, x2) . (y1, y2) = (x1 . y1, x2 . y2)
class (TupleConstraint 3 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a), CategorySrcC p3 (IndexT 2 a)) => Tuple3SrcC p1 p2 p3 a
instance (TupleConstraint 3 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a), CategorySrcC p3 (IndexT 2 a)) => Tuple3SrcC p1 p2 p3 a
class (TupleConstraint 3 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b), CategoryDstC p3 (IndexT 2 b)) => Tuple3DstC p1 p2 p3 b
instance (TupleConstraint 3 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b), CategoryDstC p3 (IndexT 2 b)) => Tuple3DstC p1 p2 p3 b
type instance CategoryT (p1, p2, p3) (a1, a2, a3) (b1, b2, b3) = (CategoryT p1 a1 b1, CategoryT p2 a2 b2, CategoryT p3 a3 b3)
type instance CategorySrcC' (p1, p2, p3) = 'Just (Tuple3SrcC p1 p2 p3)
type instance CategoryDstC' (p1, p2, p3) = 'Just (Tuple3DstC p1 p2 p3)
type instance ExoCategoryT (p1, p2, p3) (a1, a2, a3) (b1, b2, b3) = (ExoCategoryT p1 a1 b1, ExoCategoryT p2 a2 b2, ExoCategoryT p3 a3 b3)
type instance ExoCategorySrcC (p1, p2, p3) a = (TupleConstraint 3 a, ExoCategorySrcC p1 (IndexT 0 a), ExoCategorySrcC p2 (IndexT 1 a), ExoCategorySrcC p3 (IndexT 2 a))
type instance ExoCategoryDstC (p1, p2, p3) b = (TupleConstraint 3 b, ExoCategoryDstC p1 (IndexT 0 b), ExoCategoryDstC p2 (IndexT 1 b), ExoCategoryDstC p3 (IndexT 2 b))
instance (Semigroupoid p1, Semigroupoid p2, Semigroupoid p3) => Semigroupoid (p1, p2, p3) where
(x1, x2, x3) . (y1, y2, y3) = (x1 . y1, x2 . y2, x3 . y3)
class (TupleConstraint 4 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a), CategorySrcC p3 (IndexT 2 a), CategorySrcC p4 (IndexT 3 a)) => Tuple4SrcC p1 p2 p3 p4 a
instance (TupleConstraint 4 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a), CategorySrcC p3 (IndexT 2 a), CategorySrcC p4 (IndexT 3 a)) => Tuple4SrcC p1 p2 p3 p4 a
class (TupleConstraint 4 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b), CategoryDstC p3 (IndexT 2 b), CategoryDstC p4 (IndexT 3 b)) => Tuple4DstC p1 p2 p3 p4 b
instance (TupleConstraint 4 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b), CategoryDstC p3 (IndexT 2 b), CategoryDstC p4 (IndexT 3 b)) => Tuple4DstC p1 p2 p3 p4 b
type instance CategoryT (p1, p2, p3, p4) (a1, a2, a3, a4) (b1, b2, b3, b4) = (CategoryT p1 a1 b1, CategoryT p2 a2 b2, CategoryT p3 a3 b3, CategoryT p4 a4 b4)
type instance CategorySrcC' (p1, p2, p3, p4) = 'Just (Tuple4SrcC p1 p2 p3 p4)
type instance CategoryDstC' (p1, p2, p3, p4) = 'Just (Tuple4DstC p1 p2 p3 p4)
type instance ExoCategoryT (p1, p2, p3, p4) (a1, a2, a3, a4) (b1, b2, b3, b4) = (ExoCategoryT p1 a1 b1, ExoCategoryT p2 a2 b2, ExoCategoryT p3 a3 b3, ExoCategoryT p4 a4 b4)
type instance ExoCategorySrcC (p1, p2, p3, p4) a = (TupleConstraint 4 a, ExoCategorySrcC p1 (IndexT 0 a), ExoCategorySrcC p2 (IndexT 1 a), ExoCategorySrcC p3 (IndexT 2 a), ExoCategorySrcC p4 (IndexT 3 a))
type instance ExoCategoryDstC (p1, p2, p3, p4) b = (TupleConstraint 4 b, ExoCategoryDstC p1 (IndexT 0 b), ExoCategoryDstC p2 (IndexT 1 b), ExoCategoryDstC p3 (IndexT 2 b), ExoCategoryDstC p4 (IndexT 3 b))
instance (Semigroupoid p1, Semigroupoid p2, Semigroupoid p3, Semigroupoid p4) => Semigroupoid (p1, p2, p3, p4) where
(x1, x2, x3, x4) . (y1, y2, y3, y4) = (x1 . y1, x2 . y2, x3 . y3, x4 . y4)
class (TupleConstraint 5 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a), CategorySrcC p3 (IndexT 2 a), CategorySrcC p4 (IndexT 3 a), CategorySrcC p5 (IndexT 4 a)) => Tuple5SrcC p1 p2 p3 p4 p5 a
instance (TupleConstraint 5 a, CategorySrcC p1 (IndexT 0 a), CategorySrcC p2 (IndexT 1 a), CategorySrcC p3 (IndexT 2 a), CategorySrcC p4 (IndexT 3 a), CategorySrcC p5 (IndexT 4 a)) => Tuple5SrcC p1 p2 p3 p4 p5 a
class (TupleConstraint 5 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b), CategoryDstC p3 (IndexT 2 b), CategoryDstC p4 (IndexT 3 b), CategoryDstC p5 (IndexT 4 b)) => Tuple5DstC p1 p2 p3 p4 p5 b
instance (TupleConstraint 5 b, CategoryDstC p1 (IndexT 0 b), CategoryDstC p2 (IndexT 1 b), CategoryDstC p3 (IndexT 2 b), CategoryDstC p4 (IndexT 3 b), CategoryDstC p5 (IndexT 4 b)) => Tuple5DstC p1 p2 p3 p4 p5 b
type instance CategoryT (p1, p2, p3, p4, p5) (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) = (CategoryT p1 a1 b1, CategoryT p2 a2 b2, CategoryT p3 a3 b3, CategoryT p4 a4 b4, CategoryT p5 a5 b5)
type instance CategorySrcC' (p1, p2, p3, p4, p5) = 'Just (Tuple5SrcC p1 p2 p3 p4 p5)
type instance CategoryDstC' (p1, p2, p3, p4, p5) = 'Just (Tuple5DstC p1 p2 p3 p4 p5)
type instance ExoCategoryT (p1, p2, p3, p4, p5) (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) = (ExoCategoryT p1 a1 b1, ExoCategoryT p2 a2 b2, ExoCategoryT p3 a3 b3, ExoCategoryT p4 a4 b4, ExoCategoryT p5 a5 b5)
type instance ExoCategorySrcC (p1, p2, p3, p4, p5) a = (TupleConstraint 5 a, ExoCategorySrcC p1 (IndexT 0 a), ExoCategorySrcC p2 (IndexT 1 a), ExoCategorySrcC p3 (IndexT 2 a), ExoCategorySrcC p4 (IndexT 3 a), ExoCategorySrcC p5 (IndexT 4 a))
type instance ExoCategoryDstC (p1, p2, p3, p4, p5) b = (TupleConstraint 5 b, ExoCategoryDstC p1 (IndexT 0 b), ExoCategoryDstC p2 (IndexT 1 b), ExoCategoryDstC p3 (IndexT 2 b), ExoCategoryDstC p4 (IndexT 3 b), ExoCategoryDstC p5 (IndexT 4 b))
instance (Semigroupoid p1, Semigroupoid p2, Semigroupoid p3, Semigroupoid p4, Semigroupoid p5) => Semigroupoid (p1, p2, p3, p4, p5) where
(x1, x2, x3, x4, x5) . (y1, y2, y3, y4, y5) = (x1 . y1, x2 . y2, x3 . y3, x4 . y4, x5 . y5)
type family FunctorT (p :: Type) a = b | b -> p a
type FunctorTC p a ra = (FunctorT p a ~ ra)
type family FunctorSrcC' (p :: Type) :: Maybe (Type -> Constraint)
type family FunctorDstC' (p :: Type) :: Maybe (Type -> Constraint)
type FunctorSrcC p a = FromMaybeConstraintFunc (FunctorSrcC' p) a
type FunctorDstC p a = FromMaybeConstraintFunc (FunctorDstC' p) a
class Semigroupoid cat => Functor cat p where
fmap ::
(FunctorTC p a ra, FunctorTC p b rb, CategoryC cat a b, CategoryC cat ra rb, FunctorSrcC p a, FunctorDstC p b) =>
CategoryT cat a b -> CategoryT cat ra rb
default fmap ::
(Lift p, Pure p, FunctorTC p a ra, FunctorTC p b rb, CategoryC cat a b, CategoryC cat ra rb, FunctorSrcC p a, FunctorDstC p b, cat ~ FunctionP, FunctorSrcC' p ~ 'Nothing, FunctorDstC' p ~ 'Nothing) =>
CategoryT cat a b -> CategoryT cat ra rb
fmap f x = liftA2 (const f) (pure x) x
type UnconstrainedFunctor cat p = (Functor cat p, FunctorSrcC' p ~ 'Nothing, FunctorDstC' p ~ 'Nothing)
infixl 4 <$>
(<$>) ::
(Functor cat p, FunctorTC p a ra, FunctorTC p b rb, CategoryC cat a b, CategoryC cat ra rb, FunctorSrcC p a, FunctorDstC p b) =>
CategoryT cat a b -> CategoryT cat ra rb
(<$>) = fmap
infixl 4 <$
class Functor cat p => ConstFunctor cat p where
(<$) ::
(FunctorTC p a ra, FunctorTC p b rb, CategoryC cat a b, CategoryC cat ra rb, FunctorSrcC p a, FunctorDstC p b) =>
b -> CategoryT cat ra rb
default (<$) ::
(Const cat, ra ~ FunctorT p a, rb ~ FunctorT p b, CategoryC cat a b, CategoryC cat ra rb, FunctorSrcC p a, FunctorDstC p b) =>
b -> CategoryT cat ra rb
(<$) = fmap . const
instance (Functor cat p, Const cat) => ConstFunctor cat p
infixl 4 <*>, <*, *>, <**>
class Functor FunctionP p => Lift p where
liftA2 ::
(FunctorTC p a ra, FunctorTC p b rb, FunctorTC p c rc, FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p c) =>
(a -> b -> c) -> ra -> rb -> rc
default liftA2 ::
(FunctorTC p a ra, FunctorTC p b rb, FunctorTC p c rc, Monad p, Pure p, FunctorSrcC' p ~ 'Nothing, FunctorDstC' p ~ 'Nothing) =>
(a -> b -> c) -> ra -> rb -> rc
liftA2 f x y = (pure f >>= g x) >>= g y where
g x' y' = x' >>= (pure . y')
(*>) :: (FunctorTC p a ra, FunctorTC p b rb, FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p b) => ra -> rb -> rb
(*>) = liftA2 (flip const)
(<*) :: (FunctorTC p a ra, FunctorTC p b rb, FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p a) => ra -> rb -> ra
(<*) = liftA2 const
class Lift p => Apply p where
(<*>) :: (FunctorDstC p b, FunctorTC p (a -> b) rab, FunctorTC p a ra, FunctorTC p b rb) => rab -> ra -> rb
default (<*>) :: (FunctorSrcC' p ~ 'Nothing, FunctorDstC p b, FunctorTC p (a -> b) rab, FunctorTC p a ra, FunctorTC p b rb) => rab -> ra -> rb
(<*>) = liftA2 id
(<**>) :: (Apply p, FunctorDstC p b, FunctorTC p (a -> b) rab, FunctorTC p a ra, FunctorTC p b rb) => ra -> rab -> rb
(<**>) = flip (<*>)
class Pure p where
pure :: (FunctorDstC p a, FunctorTC p a ra) => a -> ra
type Applicative p = (Apply p, Pure p)
infixl 1 >>, >>=
class (Lift p, Pure p) => Monad p where
(>>=) :: (FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p b, FunctorTC p a ra, FunctorTC p b rb) => ra -> (a -> rb) -> rb
(>>) :: (FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p b, FunctorTC p a ra, FunctorTC p b rb) => ra -> rb -> rb
m >> k = m >>= Prelude.const k
return :: (Monad p, FunctorDstC p a, FunctorTC p a ra) => a -> ra
return = pure
infixr 1 =<<
(=<<) :: (Monad p, FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p b) => (a -> FunctorT p b) -> FunctorT p a -> FunctorT p b
(=<<) = flip (>>=)
data BasicFunctorP (f :: Type -> Type)
type instance FunctorT (BasicFunctorP (Constant a)) b = (Constant a) b
type instance FunctorSrcC' (BasicFunctorP (Constant a)) = 'Nothing
type instance FunctorDstC' (BasicFunctorP (Constant a)) = 'Nothing
instance Functor FunctionP (BasicFunctorP (Constant a)) where
fmap = Prelude.fmap
type instance FunctorT (BasicFunctorP Maybe) a = Maybe a
type instance FunctorSrcC' (BasicFunctorP Maybe) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Maybe) = 'Nothing
instance Functor FunctionP (BasicFunctorP Maybe) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Maybe) where
pure = Prelude.pure
instance Lift (BasicFunctorP Maybe) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Maybe) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Maybe) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP Identity) a = Identity a
type instance FunctorSrcC' (BasicFunctorP Identity) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Identity) = 'Nothing
instance Functor FunctionP (BasicFunctorP Identity) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Identity) where
pure = Prelude.pure
instance Lift (BasicFunctorP Identity) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Identity) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Identity) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP NonEmpty) a = NonEmpty a
type instance FunctorSrcC' (BasicFunctorP NonEmpty) = 'Nothing
type instance FunctorDstC' (BasicFunctorP NonEmpty) = 'Nothing
instance Functor FunctionP (BasicFunctorP NonEmpty) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP NonEmpty) where
pure = Prelude.pure
instance Lift (BasicFunctorP NonEmpty) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP NonEmpty) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP NonEmpty) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP (Either a)) b = Either a b
type instance FunctorSrcC' (BasicFunctorP (Either a)) = 'Nothing
type instance FunctorDstC' (BasicFunctorP (Either a)) = 'Nothing
instance Functor FunctionP (BasicFunctorP (Either a)) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP (Either a)) where
pure = Prelude.pure
instance Lift (BasicFunctorP (Either a)) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP (Either a)) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP (Either a)) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP []) a = [a]
type instance FunctorSrcC' (BasicFunctorP []) = 'Nothing
type instance FunctorDstC' (BasicFunctorP []) = 'Nothing
instance Functor FunctionP (BasicFunctorP []) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP []) where
pure = Prelude.pure
instance Lift (BasicFunctorP []) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP []) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP []) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP IO) a = IO a
type instance FunctorSrcC' (BasicFunctorP IO) = 'Nothing
type instance FunctorDstC' (BasicFunctorP IO) = 'Nothing
instance Functor FunctionP (BasicFunctorP IO) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP IO) where
pure = Prelude.pure
instance Lift (BasicFunctorP IO) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP IO) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP IO) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP Option) a = Option a
type instance FunctorSrcC' (BasicFunctorP Option) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Option) = 'Nothing
instance Functor FunctionP (BasicFunctorP Option) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Option) where
pure = Prelude.pure
instance Lift (BasicFunctorP Option) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Option) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Option) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP Tree) a = Tree a
type instance FunctorSrcC' (BasicFunctorP Tree) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Tree) = 'Nothing
instance Functor FunctionP (BasicFunctorP Tree) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Tree) where
pure = Prelude.pure
instance Lift (BasicFunctorP Tree) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Tree) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Tree) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP Min) a = Min a
type instance FunctorSrcC' (BasicFunctorP Min) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Min) = 'Nothing
instance Functor FunctionP (BasicFunctorP Min) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Min) where
pure = Prelude.pure
instance Lift (BasicFunctorP Min) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Min) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Min) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP Max) a = Max a
type instance FunctorSrcC' (BasicFunctorP Max) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Max) = 'Nothing
instance Functor FunctionP (BasicFunctorP Max) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Max) where
pure = Prelude.pure
instance Lift (BasicFunctorP Max) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Max) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Max) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP Last) a = Last a
type instance FunctorSrcC' (BasicFunctorP Last) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Last) = 'Nothing
instance Functor FunctionP (BasicFunctorP Last) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP Last) where
pure = Prelude.pure
instance Lift (BasicFunctorP Last) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP Last) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP Last) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
type instance FunctorT (BasicFunctorP First) a = First a
type instance FunctorSrcC' (BasicFunctorP First) = 'Nothing
type instance FunctorDstC' (BasicFunctorP First) = 'Nothing
instance Functor FunctionP (BasicFunctorP First) where
fmap = Prelude.fmap
instance Pure (BasicFunctorP First) where
pure = Prelude.pure
instance Lift (BasicFunctorP First) where
liftA2 = Control.Applicative.liftA2
instance Apply (BasicFunctorP First) where
(<*>) = (Prelude.<*>)
instance Monad (BasicFunctorP First) where
(>>=) = (Prelude.>>=)
(>>) = (Prelude.>>)
data StrictOrLazyP = StrictP | LazyP
data TextP (p :: StrictOrLazyP)
type instance FunctorSrcC' (TextP _) = 'Just ((~) Char)
type instance FunctorDstC' (TextP _) = 'Just ((~) Char)
type instance FunctorT (TextP 'StrictP) Char = StrictText.Text
instance Functor FunctionP (TextP 'StrictP) where
fmap = StrictText.map
instance Pure (TextP 'StrictP) where
pure = StrictText.singleton
instance Lift (TextP 'StrictP) where
liftA2 f x y = StrictText.pack (liftA2 f (StrictText.unpack x) (StrictText.unpack y))
instance Monad (TextP 'StrictP) where
x >>= f = StrictText.pack (StrictText.unpack x >>= (StrictText.unpack . f))
type instance FunctorT (TextP 'LazyP) Char = LazyText.Text
instance Functor FunctionP (TextP 'LazyP) where
fmap = LazyText.map
instance Pure (TextP 'LazyP) where
pure = LazyText.singleton
instance Lift (TextP 'LazyP) where
liftA2 f x y = LazyText.pack (liftA2 f (LazyText.unpack x) (LazyText.unpack y))
instance Monad (TextP 'LazyP) where
x >>= f = LazyText.pack (LazyText.unpack x >>= (LazyText.unpack . f))
data ByteStringP (p :: StrictOrLazyP)
type instance FunctorSrcC' (ByteStringP _) = 'Just ((~) Word8)
type instance FunctorDstC' (ByteStringP _) = 'Just ((~) Word8)
type instance FunctorT (ByteStringP 'StrictP) Word8 = StrictByteString.ByteString
instance Functor FunctionP (ByteStringP 'StrictP) where
fmap = StrictByteString.map
instance Pure (ByteStringP 'StrictP) where
pure = StrictByteString.singleton
instance Lift (ByteStringP 'StrictP) where
liftA2 f x y = StrictByteString.pack (liftA2 f (StrictByteString.unpack x) (StrictByteString.unpack y))
instance Monad (ByteStringP 'StrictP) where
x >>= f = StrictByteString.pack (StrictByteString.unpack x >>= (StrictByteString.unpack . f))
type instance FunctorT (ByteStringP 'LazyP) Word8 = LazyByteString.ByteString
instance Functor FunctionP (ByteStringP 'LazyP) where
fmap = LazyByteString.map
instance Pure (ByteStringP 'LazyP) where
pure = LazyByteString.singleton
instance Lift (ByteStringP 'LazyP) where
liftA2 f x y = LazyByteString.pack (liftA2 f (LazyByteString.unpack x) (LazyByteString.unpack y))
instance Monad (ByteStringP 'LazyP) where
x >>= f = LazyByteString.pack (LazyByteString.unpack x >>= (LazyByteString.unpack . f))
arrayFmap :: (IArray a e1, IArray a e2, Ix i) => (e1 -> e2) -> a i e1 -> a i e2
arrayFmap = Data.Array.IArray.amap
arrayPure :: (IArray a e, Ix i, Num i) => e -> a i e
arrayPure x = Data.Array.IArray.listArray (0,0) [x]
arrayLiftA2 :: (IArray a e1, IArray a e2, IArray a e3, Ix i, Num i) => (e1 -> e2 -> e3) -> a i e1 -> a i e2 -> a i e3
arrayLiftA2 f x y = Data.Array.IArray.array (lbound, ubound) [(index_f x_i y_i, f x_e y_e) | (x_i,x_e) <- Data.Array.IArray.assocs x, (y_i, y_e) <- Data.Array.IArray.assocs y] where
(x_l, x_u) = Data.Array.IArray.bounds x
(y_l, y_u) = Data.Array.IArray.bounds y
step = y_u y_l + 1
index_f x_i y_i = x_i * step + y_i
lbound = index_f x_l y_l
ubound = index_f x_u y_u
type instance FunctorT (BasicFunctorP (Array i)) e = Array i e
type instance FunctorSrcC' (BasicFunctorP (Array i)) = 'Nothing
type instance FunctorDstC' (BasicFunctorP (Array i)) = 'Nothing
instance (Ix i) => Functor FunctionP (BasicFunctorP (Array i)) where
fmap = arrayFmap
instance (Ix i, Num i) => Pure (BasicFunctorP (Array i)) where
pure = arrayPure
instance (Ix i, Num i) => Lift (BasicFunctorP (Array i)) where
liftA2 = arrayLiftA2
instance (Ix i, Num i) => Apply (BasicFunctorP (Array i))
class (IArray UArray e) => UArrayC e
instance (IArray UArray e) => UArrayC e
type instance FunctorT (BasicFunctorP (UArray i)) e = UArray i e
type instance FunctorSrcC' (BasicFunctorP (UArray i)) = 'Just UArrayC
type instance FunctorDstC' (BasicFunctorP (UArray i)) = 'Just UArrayC
instance (Ix i) => Functor FunctionP (BasicFunctorP (UArray i)) where
fmap = arrayFmap
instance (Ix i, Num i) => Pure (BasicFunctorP (UArray i)) where
pure = arrayPure
instance (Ix i, Num i) => Lift (BasicFunctorP (UArray i)) where
liftA2 = arrayLiftA2
class (Ord (ToType b)) => SetDstC b
instance (Ord (ToType b)) => SetDstC b
type instance FunctorT (BasicFunctorP Set) a = Set a
type instance FunctorSrcC' (BasicFunctorP Set) = 'Nothing
type instance FunctorDstC' (BasicFunctorP Set) = 'Just SetDstC
instance Functor FunctionP (BasicFunctorP Set) where
fmap = Data.Set.map
instance Pure (BasicFunctorP Set) where
pure = Data.Set.singleton
instance Lift (BasicFunctorP Set) where
liftA2 f x y = Data.Set.fromList (Control.Applicative.liftA2 f (Data.Set.toList x) (Data.Set.toList y))
instance Apply (BasicFunctorP Set)
instance Monad (BasicFunctorP Set) where
x >>= f = Data.Set.fromList (Data.Set.toList x >>= (Data.Set.toList . f))
data TupleP (n :: Nat)
type instance FunctorSrcC' (TupleP _) = 'Nothing
type instance FunctorDstC' (TupleP _) = 'Nothing
type instance FunctorT (TupleP 2) a = (a,a)
instance Functor FunctionP (TupleP 2) where
fmap f (x1,x2) = (f x1, f x2)
instance Pure (TupleP 2) where
pure x = (x,x)
instance Lift (TupleP 2) where
liftA2 f (x1,x2) (y1,y2) = (f x1 y1, f x2 y2)
instance Apply (TupleP 2) where
(<*>) (f1,f2) (x1,x2) = (f1 x1, f2 x2)
type instance FunctorT (TupleP 3) a = (a,a,a)
instance Functor FunctionP (TupleP 3) where
fmap f (x1,x2,x3) = (f x1, f x2, f x3)
instance Lift (TupleP 3) where
liftA2 f (x1,x2,x3) (y1,y2,y3) = (f x1 y1, f x2 y2, f x3 y3)
instance Pure (TupleP 3) where
pure x = (x,x,x)
instance Apply (TupleP 3) where
(<*>) (f1,f2,f3) (x1,x2,x3) = (f1 x1, f2 x2, f3 x3)
type instance FunctorT (TupleP 4) a = (a,a,a,a)
instance Functor FunctionP (TupleP 4) where
fmap f (x1,x2,x3,x4) = (f x1, f x2, f x3, f x4)
instance Pure (TupleP 4) where
pure x = (x,x,x,x)
instance Lift (TupleP 4) where
liftA2 f (x1,x2,x3,x4) (y1,y2,y3,y4) = (f x1 y1, f x2 y2, f x3 y3, f x4 y4)
instance Apply (TupleP 4) where
(<*>) (f1,f2,f3,f4) (x1,x2,x3,x4) = (f1 x1, f2 x2, f3 x3, f4 x4)
type instance FunctorT (TupleP 5) a = (a,a,a,a,a)
instance Functor FunctionP (TupleP 5) where
fmap f (x1,x2,x3,x4,x5) = (f x1, f x2, f x3, f x4, f x5)
instance Pure (TupleP 5) where
pure x = (x,x,x,x,x)
instance Lift (TupleP 5) where
liftA2 f (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (f x1 y1, f x2 y2, f x3 y3, f x4 y4, f x5 y5)
instance Apply (TupleP 5) where
(<*>) (f1,f2,f3,f4,f5) (x1,x2,x3,x4,x5) = (f1 x1, f2 x2, f3 x3, f4 x4, f5 x5)
instance Functor cat p => Functor (FunctorCategoryP (BasicFunctorP Maybe) cat) p where
fmap = fmap fmap
instance Functor cat p => Functor (FunctorCategoryP (BasicFunctorP []) cat) p where
fmap = fmap fmap
instance Functor cat p => Functor (Identity cat) p where
fmap = fmap fmap