diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Clinton Mead (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Clinton Mead nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# freelude diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/freelude.cabal b/freelude.cabal new file mode 100644 --- /dev/null +++ b/freelude.cabal @@ -0,0 +1,64 @@ +name: freelude +version: 0.1.0.0 +synopsis: A generalisation of the Category->Functor->Applicative->Monad hierarchy and more +description: + This package generalises classes like Category, Functor etc to allow them to be defined on more data types, + for example, tuples and sets, whilst still attempting to maintain backward compatability. + + See the module "Freelude" for more details. +homepage: https://github.com/clintonmead/freelude#readme +license: BSD3 +license-file: LICENSE +author: Clinton Mead +maintainer: clintonmead@gmail.com +copyright: Copyright: (c) 2017 Clinton Mead +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Freelude + Freelude.FunctionRestrictedFunctor + Freelude.Impl.Category + Freelude.Impl.CategoryAsMonoid + Freelude.Impl.ExoFunctor + Freelude.Impl.MonoidAsCategory + Freelude.Impl.MakeFunctor + Freelude.Impl.RestrictedFunctor + Freelude.Impl.ToKind + build-depends: base == 4.10.*, indextype == 0.3.*, containers, transformers, array + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-kinds + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test, src + main-is: Test.hs + other-modules: + Freelude + Freelude.FunctionRestrictedFunctor + Freelude.Impl.Category + Freelude.Impl.CategoryAsMonoid + Freelude.Impl.ExoFunctor + Freelude.Impl.MonoidAsCategory + Freelude.Impl.MakeFunctor + Freelude.Impl.RestrictedFunctor + Freelude.Impl.ToKind + build-depends: base == 4.10.*, indextype == 0.3.*, containers, transformers, array + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: test, src + ghc-options: -threaded + main-is: DocTest.hs + build-depends: base == 4.10.*, doctest >= 0.8 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/clintonmead/freelude diff --git a/src/Freelude.hs b/src/Freelude.hs new file mode 100644 --- /dev/null +++ b/src/Freelude.hs @@ -0,0 +1,289 @@ +{-| +Module : Freelude +Description : Tutorial in this module +Copyright : (c) Clinton Mead 2017 +License : BSD3 +Maintainer : clintonmead@gmail.com +Stability : experimental +Portability : POSIX + += Overview + +Freelude is a replacement prelude which generalises classes like Category and Functor, +that is, allows one to make more types Categories and Functors than before. + +The structure and design is a bit of a work in progress. + +This package also includes classes like Applicative and Monad, but they are not as generalised as Functor, +as I'm as yet unsure of a sensible way to generalise them. + +I've tried to implement a lot of the ordinary instances in base and other GHC supplied modules, +but I'm probably missing some, so feel free to mention those which are missing or better still, just submit a patch. + +This module itself simply reimports Prelude but overrides a bunch of functions and classes, and also adds a number of classes and functions. + +Later on I'll probably develop a finer-grained approach. + += Motivation + +Wouldn't it be nice if we could write something like this: + +> (f1,f2) . (g1,g1) + +And get what we expect, namely (f1 . g1, f2 . g2). + +So lets try to write a 'Control.Category' instance for pairs: + +@ +instance Category ??? +@ + +There's nothing sensible we can replace the ???s with. + +This package resolves the above issue, and many others. + +For the moment, this documentation will just show some examples of how these new versions of +'Category', 'Functor' etc can be used. + += Usage + +Firstly, we want to ignore the normal "Prelude" and instead import "Freelude": + +> {-# LANGUAGE NoImplicitPrelude #-} +> import Freelude + +== Category + +Here's how to run categorical compostion on pairs: + +>>> :{ +let + f_pair :: (Read a, Enum b) => (String -> a, b -> b) + f_pair = (read, succ) + g_pair :: (Show b) => (Int -> Int, b -> String) + g_pair = ((*3), show) + applyPair (f1,f2) (x1,x2) = (f1 x1, f2 x2) +:} + +>>> let h_pair = g_pair . f_pair +>>> applyPair h_pair ("5",'a') +(15,"'b'") + +Note that we've successfully made @f@ and @g@, both tuples, into categories. + +It's not just tuples we can turn into categories. + +>>> :{ +let + f_list :: Num a => [a -> a] + f_list = [(+2), (*3)] + g_list :: Num a => [a -> a] + g_list = [(+4), (*5)] +:} + +>>> let h_list = f_list . g_list +>>> h_list <*> [6,7] +[12,13,32,37,30,33,90,105] + +Also, here's a 'Maybe' category: + +>>> ((Just (*2)) . Nothing) <*> (Just 4) +Nothing + +>>> ((Just (*2)) . (Just (*3))) <*> (Just 4) +Just 24 + +It's worth noting that we have also extended the '$' operator to work for non ordinary functions: + +>>> h_pair $ ("5",'a') +(15,"'b'") + +>>> h_list $ [6,7] +[12,13,32,37,30,33,90,105] + +>>> ((Just (*2)) . Nothing) $ (Just 4) +Nothing + +>>> ((Just (*2)) . (Just (*3))) $ (Just 4) +Just 24 + +In cases where the category is also a functor (like 'Maybe', '[]'), '$' is generally just '<*>', +but '$' is somewhat more general (it's defined for 'Control.Arrow.Kleisli' arrows for example). + +We can also nest categories: + +>>> :{ +let + f_list_maybe :: Num a => [Maybe (a -> a)] + f_list_maybe = [Just (+2), Just (*3)] + g_list_maybe :: Num a => [Maybe (a -> a)] + g_list_maybe = [Just (+4), Nothing] +:} + +>>> let h_list_maybe = f_list_maybe . g_list_maybe +>>> h_list_maybe $ [Just 6,Nothing] +[Just 12,Nothing,Nothing,Nothing,Just 30,Nothing,Nothing,Nothing] + +Above is also an example of how '$' is more general than '<*>'. + +== Functor + +Whilst we have 'Prelude.Functor's on pairs in the usual "Prelude", their definition is a little bit weird, namely the below: + +@fmap f (x,y) = (x, f y)@ + +For example: + +>>> Prelude.fmap (*3) (1,2) +(1,6) + +This does have some uses but I consider it surprising. arguably a more sensible definition is as follows: + +@fmap f (x,y) = (f x, f y)@ + +>>> :set -XTypeFamilies +>>> :set -XFlexibleContexts +>>> fmap (*3) (1,2) +(3,6) + +The above definition can not be defined with the normal instance of 'Prelude.Functor', but it be defined using "Freelude"s 'Functor' + +We can also define functors over things like 'Data.Set', which we couldn't before. + +>>> import qualified Data.Set as Set +>>> fmap (\x -> x * x) (Data.Set.fromList [1,-1,2,-2,3]) +fromList [1,4,9] + +And even unboxed arrays! + +>>> import Data.Array.Unboxed (UArray) +>>> import Data.Array.IArray as IArray +>>> let a = (IArray.array (1,3) [(1,4),(2,5),(3,6)]) :: UArray Int Int +>>> fmap (*3) a +array (1,3) [(1,12),(2,15),(3,18)] + +Note that both in the case of sets and unboxed arrays, ordinary 'Prelude.Functor' instances +can not be defined for them as there are constraints on their parameters. + +We also further generalise 'Functor'. Instead of thinking of 'Functor' +as a function between functions, we think of it as a function between categories. +So `fmap` can be defined on other categories. + +For example, we can define `fmap` on the category of a list of categories, like so: + +>>> let f_l = (fmap [(+2),(*3),(+4)]) :: Num a => [Maybe a -> Maybe a] +>>> :t f_l +f_l :: Num a => [Maybe a -> Maybe a] + +And indeed, this works roughly how we would expect: + +>>> f_l <*> [Just 3, Nothing] +[Just 5,Nothing,Just 9,Nothing,Just 7,Nothing] + +== Applicatives + +"Freelude" splits 'Prelude.Applicative' into three classes, namely: + +1. 'Lift' ('liftA2') +2. 'Pure' ('pure') +3. 'Apply' ('<*>') + +In the ordinary prelude, 'Prelude.<*>' is the primary function to be defined, +which has a signature as follows: + +> f (a -> b) -> f a -> f b + +But notice how the structure is required to be able to contain functions. +But we've already mentioned two strutures that can't: sets and unboxed arrays. + +As a result, whereas in the "Prelude", 'Prelude.<*>' is the primary function and +'Control.Applicative.liftA2' is defined in terms of it, for "Freelude" we've switched that around. + +In "Freelude", 'liftA2' is the primary definition +and '<*>' is optionally defined in terms of 'liftA2', +but only automatically when there is no restrictions on the type. + +Note that unlike `Functor' I haven't generalised 'Lift', 'Pure' and 'Apply' +to non function categories. This perhaps could be done in the future but there's some +thinking to do about the best and most useful way forward with this. + +Here's an example of 'liftA2' on sets: + +>>> liftA2 (*) (Data.Set.fromList [1,2,3,4]) (Data.Set.fromList [1,2,3,4]) +fromList [1,2,3,4,6,8,9,12,16] + +And we have full applicative on tuples: +>>> (*) <$> (2,3) <*> (4,5) +(8,15) + +== Monad + +Monad is defined as a subclass of 'Lift' and 'Pure', instead of 'Apply' and 'Pure' (i.e. @Applicative@). +The reason for this is that interestingly, although you can't +define @<*>@ for @Set@ as discussed above, you can define @>>=@. + +This is because the definition of @>>=@ is as follows: + +> f a -> (a -> f b) -> f b + +Note we don't have any of @f (a -> b)@ arguments that got us caught up trying to define @<*>@ for sets. + +>>> (Data.Set.fromList [1,2,3]) >>= (\x -> Data.Set.fromList [x,x*x,x+2]) +fromList [1,2,3,4,5,9] + +== Rebindable syntax + +You can use the extension @RebindableSyntax@ to use do-notation: + +>>> :set -XRebindableSyntax +>>> :{ +do + set_x <- Data.Set.fromList [1,2,3] + set_y <-(\x -> Data.Set.fromList [x,x*x,x+2]) set_x + pure set_y +:} +fromList [1,2,3,4,5,9] + += Defining your own instances + +I'll put a tutorial here at some point, but there's plenty of examples in "Freelude.Impl.Category" + += Rationale behind design + +I'll fill this out at some point also, noting that it currently makes quite significant use of +injective type families and constraint kinds. Since the design is still in a state of flux +it's probably not detailling yet anyway (I welcome suggestions/patches). + +It worth noting that some of the reasons for the design is to maintain the ability for the +type system to recognise certain invariants, which I will detail with examples in future. + += Notes + +You'll probably want GHC 8.2. Some things will work with 8.0, indeed the library itself should compile, +but the tests won't. + +In developing this library I've occasionally experienced GHC panics. +One thing that occasionally resolved this was including the extension @TypeInType@ in code that +uses the library. If you get a GHC panic perhaps try adding the extension @TypeInType@ +and trying again. + +A number of libraries that this depend on are build for and have dependencies on base for GHC 8.0, +This will cause dependency hell, but building this library with '--allow-newer' should fix all issues. + +-} + +module Freelude ( + module Prelude, + module Freelude.Impl.Category, + module Freelude.Impl.ExoFunctor +) where + +import Freelude.Impl.Category +import Freelude.Impl.ExoFunctor +import Prelude hiding ( + Functor(fmap), (<$>), (<$), + Applicative((<*>), pure), (<*), (*>), + Monad(return, (>>=), (>>)), (=<<), + (.), id, const, + ($), ($!) + ) diff --git a/src/Freelude/FunctionRestrictedFunctor.hs b/src/Freelude/FunctionRestrictedFunctor.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/FunctionRestrictedFunctor.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Freelude.FunctionRestrictedFunctor (fmap) where + +import Prelude hiding (fmap) +import Freelude.Impl.RestrictedFunctor +import Freelude.Impl.Category hiding (fmap) + +fmap :: + (Freelude.Impl.Category.Functor FunctionP p, ra ~ FunctorT p a, rb ~ FunctorT p b, CategoryC FunctionP a b, CategoryC FunctionP ra rb, FunctorSrcC p a, FunctorDstC p b) => + CategoryT FunctionP a b -> CategoryT FunctionP ra rb +fmap = restrictedfmap diff --git a/src/Freelude/Impl/Category.hs b/src/Freelude/Impl/Category.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/Category.hs @@ -0,0 +1,686 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Freelude.Impl.Category ( + 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) + +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 +-- * Instances from 'Control.Category' +-- ** '->' +instance {-# OVERLAPPABLE #-} (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.Equality.:-:' +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 + +-- ** 'Control.Category.Kleisli' + +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.Semigroup + +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)) + +-- ** 'Maybe' +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 + +-- ** Lists + +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 + +-- ** Identity + +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 + +-- ** Dual + +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 + +-- ** Tuples + +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) + +-- Functor + +type family FunctorT (p :: Type) (a :: Type) = (b :: Type) | b -> p a + +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 + +--type FunctorC cat p a b ra rb = (ra ~ FunctorT p a, rb ~ FunctorT p b, CategoryC cat a b, CategoryC cat ra rb, FunctorSrcC p a, FunctorDstC p b) + +class Semigroupoid cat => Functor cat p where + fmap :: + (ra ~ FunctorT p a, rb ~ FunctorT p b, 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, ra ~ FunctorT p a, rb ~ FunctorT p b, 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 +-- (Applicative p, cat ~ FunctionP, ra ~ FunctorT p a, rb ~ FunctorT p b, CategoryC cat a b, CategoryC cat ra rb, 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, ra ~ FunctorT p a, rb ~ FunctorT p b, 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 + (<$) :: + (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 + 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 {-# OVERLAPPABLE #-} (Functor cat p, Const cat) => ConstFunctor cat p + +infixl 4 <*>, <*, *>, <**> + +class Functor FunctionP p => Lift p where + liftA2 :: + (FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p c) => + (a -> b -> c) -> FunctorT p a -> FunctorT p b -> FunctorT p c + default liftA2 :: + (Monad p, Pure p, FunctorSrcC' p ~ 'Nothing, FunctorDstC' p ~ 'Nothing) => + (a -> b -> c) -> FunctorT p a -> FunctorT p b -> FunctorT p c + liftA2 f x y = (pure f >>= g x) >>= g y where + g x' y' = x' >>= (pure . y') + (*>) :: (FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p b) => FunctorT p a -> FunctorT p b -> FunctorT p b + (*>) = liftA2 (flip const) + (<*) :: (FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p a) => FunctorT p a -> FunctorT p b -> FunctorT p a + (<*) = liftA2 const + +class Lift p => Apply p where + (<*>) :: FunctorT p (a -> b) -> FunctorT p a -> FunctorT p b + default (<*>) :: (FunctorSrcC' p ~ 'Nothing, FunctorDstC' p ~ 'Nothing) => FunctorT p (a -> b) -> FunctorT p a -> FunctorT p b + (<*>) = liftA2 id + +(<**>) :: Apply p => FunctorT p a -> FunctorT p (a -> b) -> FunctorT p b +(<**>) = flip (<*>) + +class Pure p where + pure :: (FunctorDstC p a) => a -> FunctorT p a + +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) => FunctorT p a -> (a -> FunctorT p b) -> FunctorT p b + (>>) :: (FunctorSrcC p a, FunctorSrcC p b, FunctorDstC p b) => FunctorT p a -> FunctorT p b -> FunctorT p b + m >> k = m >>= Prelude.const k + +return :: (Monad p, FunctorDstC p a) => a -> FunctorT p a +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 instance FunctorSrcC' (BasicFunctorP _) = 'Nothing +type instance FunctorDstC' (BasicFunctorP _) = 'Nothing + +data ConstantP (a :: Type) +type instance FunctorT (BasicFunctorP (ConstantP a)) b = Constant a b +instance Functor FunctionP (BasicFunctorP (ConstantP a)) where + fmap = Prelude.fmap + +type instance FunctorT (BasicFunctorP Maybe) a = Maybe a +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 +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 +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 +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] +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 +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 +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 +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 +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 +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 +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 +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.>>) + +-- Arrays + +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 +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 + +data UArrayP (indexT :: Type) + +class (IArray UArray e) => UArrayC e +instance (IArray UArray e) => UArrayC e + +type instance FunctorT (UArrayP i) e = UArray i e +type instance FunctorSrcC' (UArrayP i) = 'Just UArrayC +type instance FunctorDstC' (UArrayP i) = 'Just UArrayC + +instance (Ix i) => Functor FunctionP (UArrayP i) where + fmap = arrayFmap +instance (Ix i, Num i) => Pure (UArrayP i) where + pure = arrayPure +instance (Ix i, Num i) => Lift (UArrayP i) where + liftA2 = arrayLiftA2 + +-- Sets + +data SetP + +class (Ord (ToType b)) => SetDstC b +instance (Ord (ToType b)) => SetDstC b + +type instance FunctorT SetP a = Set a +type instance FunctorSrcC' SetP = 'Nothing +type instance FunctorDstC' SetP = 'Just SetDstC + +instance Functor FunctionP SetP where + fmap = Data.Set.map +instance Pure SetP where + pure = Data.Set.singleton +instance Lift SetP where + liftA2 f x y = Data.Set.fromList (Control.Applicative.liftA2 f (Data.Set.toList x) (Data.Set.toList y)) +instance Monad SetP 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 + +-- Tuple +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) + +-- Non function category functors + +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 diff --git a/src/Freelude/Impl/CategoryAsMonoid.hs b/src/Freelude/Impl/CategoryAsMonoid.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/CategoryAsMonoid.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Freelude.Impl.CategoryAsMonoid ( + CategoryAsMonoid(getCategoryAsMonoid) +) where + +import Prelude hiding ((.), id) +import Freelude.Impl.Category +import Data.Semigroup (Semigroup((<>))) + +newtype CategoryAsMonoid a = CategoryAsMonoid { getCategoryAsMonoid :: a } + +instance (IsSemigroupoid t p a a) => Semigroup (CategoryAsMonoid t) where + CategoryAsMonoid x <> CategoryAsMonoid y = CategoryAsMonoid (x . y) + +instance (IsCategory t p a a, ExoIsCategory t p a a) => Monoid (CategoryAsMonoid t) where + mempty = CategoryAsMonoid id + mappend = (<>) diff --git a/src/Freelude/Impl/ExoFunctor.hs b/src/Freelude/Impl/ExoFunctor.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/ExoFunctor.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} + +module Freelude.Impl.ExoFunctor ( + ExoFunctor(exomap), ($), ($!) +) where + +import Freelude.Impl.Category +import Prelude hiding (id, ($), ($!), (<*>), (<$>)) +import Data.Functor.Identity (Identity(Identity)) + +{-# ANN module "HLint: ignore Redundant $" #-} + +class ExoFunctor c1 c2 where + exomap :: (ExoCategoryC c1 a b, ExoCategoryC c2 a b) => ExoCategoryT c1 a b -> ExoCategoryT c2 a b + +infixr 0 $, $! +($) :: (ExoFunctor c1 c2, ExoCategoryC c1 a b, ExoCategoryC c2 a b) => ExoCategoryT c1 a b -> ExoCategoryT c2 a b +($) = exomap + +($!) :: (ExoFunctor c1 FunctionP, ExoCategoryC c1 a b) => ExoCategoryT c1 a b -> (a -> b) +f $! x = let !vx = x in f $ vx + +instance ExoFunctor c c where + exomap = id + +instance ExoFunctor c1 c2 => ExoFunctor (Identity c1) c2 where + exomap (Identity x) = exomap x + +instance ExoFunctor c1 c2 => ExoFunctor c1 (Identity c2) where + exomap x = Identity (exomap x) + +instance ExoFunctor c1 c2 => ExoFunctor (Identity c1) (Identity c2) where + exomap (Identity x) = Identity (exomap x) + +instance (ExoFunctor p1 FunctionP, ExoFunctor p2 FunctionP) => ExoFunctor (p1, p2) FunctionP where + exomap (f1, f2) (x1, x2) = (f1 $ x1, f2 $ x2) + +instance (ExoFunctor p1 FunctionP, ExoFunctor p2 FunctionP, ExoFunctor p3 FunctionP) => ExoFunctor (p1, p2, p3) FunctionP where + exomap (f1, f2, f3) (x1, x2, x3) = (f1 $ x1, f2 $ x2, f3 $ x3) + +instance (ExoFunctor p1 FunctionP, ExoFunctor p2 FunctionP, ExoFunctor p3 FunctionP, ExoFunctor p4 FunctionP) => ExoFunctor (p1, p2, p3, p4) FunctionP where + exomap (f1, f2, f3, f4) (x1, x2, x3, x4) = (f1 $ x1, f2 $ x2, f3 $ x3, f4 $ x4) + +instance (ExoFunctor p1 FunctionP, ExoFunctor p2 FunctionP, ExoFunctor p3 FunctionP, ExoFunctor p4 FunctionP, ExoFunctor p5 FunctionP) => ExoFunctor (p1, p2, p3, p4, p5) FunctionP where + exomap (f1, f2, f3, f4, f5) (x1, x2, x3, x4, x5) = (f1 $ x1, f2 $ x2, f3 $ x3, f4 $ x4, f5 $ x5) + +instance (ExoFunctor p FunctionP) => ExoFunctor (FunctorCategoryP (BasicFunctorP Maybe) p) FunctionP where + exomap f x = exomap <$> f <*> x + +instance (ExoFunctor p FunctionP) => ExoFunctor (FunctorCategoryP (BasicFunctorP []) p) FunctionP where + exomap f x = exomap <$> f <*> x diff --git a/src/Freelude/Impl/MakeFunctor.hs b/src/Freelude/Impl/MakeFunctor.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/MakeFunctor.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Freelude.Impl.MakeFunctor ( + MakeFunctor(getFunctor) +) where + +import Prelude hiding (Functor, fmap, Monad) +import qualified Prelude +import Data.Kind (Type) +import Freelude.Impl.Category +import qualified Control.Applicative + +newtype MakeFunctor f a = MakeFunctor { getFunctor :: f a } + +data MakeFunctorP (f :: Type -> Type) + +type instance FunctorT (MakeFunctorP f) a = MakeFunctor f a +type instance FunctorSrcC' (MakeFunctorP _) = 'Nothing +type instance FunctorDstC' (MakeFunctorP _) = 'Nothing + +instance Prelude.Functor f => Functor FunctionP (MakeFunctorP f) where + fmap f (MakeFunctor x) = MakeFunctor (Prelude.fmap f x) + +instance Prelude.Applicative f => Lift (MakeFunctorP f) where + liftA2 f (MakeFunctor x) (MakeFunctor y) = MakeFunctor (Control.Applicative.liftA2 f x y) + +instance Prelude.Applicative f => Apply (MakeFunctorP f) where + (MakeFunctor f) <*> (MakeFunctor x) = MakeFunctor (f Prelude.<*> x) + +instance Prelude.Applicative f => Pure (MakeFunctorP f) where + pure x = MakeFunctor (Prelude.pure x) + +instance Prelude.Monad f => Monad (MakeFunctorP f) where + (MakeFunctor x) >>= f = MakeFunctor (x Prelude.>>= f') where + f' x' = getFunctor (f x') diff --git a/src/Freelude/Impl/MonoidAsCategory.hs b/src/Freelude/Impl/MonoidAsCategory.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/MonoidAsCategory.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} + +module Freelude.Impl.MonoidAsCategory ( + MonoidAsCategory(MonoidAsCategory, getMonoidAsCategory) + ) where + +import Freelude.Impl.Category +import Data.Void (Void) +import Data.Semigroup (Semigroup((<>))) +import Data.Monoid (Monoid(mempty)) +import Data.Type.Equality (type (~~)) + +newtype MonoidAsCategory a = MonoidAsCategory { getMonoidAsCategory :: a } + +class (a ~~ Void) => VoidC a +instance (a ~~ Void) => VoidC a + +type instance CategoryT (MonoidAsCategory a) Void Void = MonoidAsCategory a +type instance CategorySrcC' (MonoidAsCategory _) = 'Just VoidC +type instance CategoryDstC' (MonoidAsCategory _) = 'Just VoidC + +instance Semigroup m => Semigroupoid (MonoidAsCategory m) where + (MonoidAsCategory x) . (MonoidAsCategory y) = MonoidAsCategory (x <> y) + +instance (Semigroup m, Monoid m) => Category (MonoidAsCategory m) where + id = MonoidAsCategory mempty diff --git a/src/Freelude/Impl/RestrictedFunctor.hs b/src/Freelude/Impl/RestrictedFunctor.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/RestrictedFunctor.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Freelude.Impl.RestrictedFunctor ( + restrictedfmap + ) where + +import Prelude hiding (Functor(fmap), (<$>)) +import Freelude.Impl.Category hiding (Functor(fmap), (<$>)) +import qualified Freelude.Impl.Category + +restrictedfmap :: + (Freelude.Impl.Category.Functor FunctionP p, ra ~ FunctorT p a, rb ~ FunctorT p b, CategoryC FunctionP a b, CategoryC FunctionP ra rb, FunctorSrcC p a, FunctorDstC p b) => + CategoryT FunctionP a b -> CategoryT FunctionP ra rb +restrictedfmap = Freelude.Impl.Category.fmap diff --git a/src/Freelude/Impl/ToKind.hs b/src/Freelude/Impl/ToKind.hs new file mode 100644 --- /dev/null +++ b/src/Freelude/Impl/ToKind.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} + +module Freelude.Impl.ToKind (ToType, ToKind) where + +import Data.Kind (Type) + +type ToType a = ToKind Type a +type ToKind toK (a :: k) = ToKind' toK k a + +type family ToKind' toK k (a :: k) where + ToKind' k k a = a diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,2 @@ +import Test.DocTest +main = doctest ["-isrc", "src/Freelude.hs"] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeInType #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module Main where + +import Freelude.Impl.Category +import Freelude.Impl.ExoFunctor +import Prelude hiding ((.), fmap, pure, (=<<)) + +main :: IO () +main = pure () + +f1 :: (IsSemigroupoid t1 p a2 a3, IsSemigroupoid t2 p a1 a2, IsSemigroupoid t3 p a1 a3) => t1 -> t2 -> t3 +f1 x y = x . y +f1' x y = x . y + +f2 :: (IsSemigroupoid t1 p a3 a4, IsSemigroupoid t2 p a2 a3, IsSemigroupoid t3 p a1 a2, IsSemigroupoid t4 p a1 a4) => t1 -> t2 -> t3 -> t4 +f2 x y z = x . y . z +f2' x y z = x . y . z + +f3 x y = fmap x . fmap y +f3' x y = fmap x . fmap y + +f4 x y = fmap (x . y) +f4' x y = fmap (x . y) + +g :: a -> a -> a +g = undefined + +f5 x y = g (f3 x y) (f4 x y) + +f6 x y = exomap x . exomap y +f6' x y = exomap x . exomap y + +f7 x y = exomap (x . y) +f7' x y = exomap (x . y) + +f8 x y = g (f6 x y) (f7 x y)