mirror of
https://github.com/coot/free-category.git
synced 2024-09-11 14:17:30 +03:00
GHC-9.0 support
This commit is contained in:
parent
2404d78385
commit
48a058e210
@ -1,3 +1,3 @@
|
||||
index-state: 2021-03-13T00:00:00Z
|
||||
index-state: 2021-03-15T00:00:00Z
|
||||
packages: free-category.cabal
|
||||
examples/examples.cabal
|
||||
|
@ -5,10 +5,10 @@
|
||||
"homepage": "https://input-output-hk.github.io/haskell.nix",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "08887404bb23e7e6c49e3d4404394a6c03162c0c",
|
||||
"sha256": "055mc75v9sa8b7xajq5vn3pqfbqnpwn6wznbisb9rpr0n8w6ds66",
|
||||
"rev": "6c9facfada85bd298691ecb2b5b2d124c342f869",
|
||||
"sha256": "07w6wq6rsiq4j26vmi0mvh68wajjj8bd4qjbny2gkdf9jnnf9jj8",
|
||||
"type": "tarball",
|
||||
"url": "https://github.com/input-output-hk/haskell.nix/archive/08887404bb23e7e6c49e3d4404394a6c03162c0c.tar.gz",
|
||||
"url": "https://github.com/input-output-hk/haskell.nix/archive/6c9facfada85bd298691ecb2b5b2d124c342f869.tar.gz",
|
||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
},
|
||||
"iohk-nix": {
|
||||
@ -17,10 +17,10 @@
|
||||
"homepage": null,
|
||||
"owner": "input-output-hk",
|
||||
"repo": "iohk-nix",
|
||||
"rev": "666e57027dca46964c6a26efcc2042b247d354a5",
|
||||
"sha256": "0v5sgs8wf47x4csr6f70z2hi47my5r981m71nqgkj04n0sr6lz4b",
|
||||
"rev": "bc4216c5b0e14dbde5541763f4952f99c3c712fa",
|
||||
"sha256": "0y5n3limj5dg1vgxyxafg0ky35qq7w97rr00gr3yl16xx5jrhs6w",
|
||||
"type": "tarball",
|
||||
"url": "https://github.com/input-output-hk/iohk-nix/archive/666e57027dca46964c6a26efcc2042b247d354a5.tar.gz",
|
||||
"url": "https://github.com/input-output-hk/iohk-nix/archive/bc4216c5b0e14dbde5541763f4952f99c3c712fa.tar.gz",
|
||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
},
|
||||
"niv": {
|
||||
|
@ -138,7 +138,7 @@ fromA = hoistFreeH2
|
||||
{-# INLINE fromA #-}
|
||||
|
||||
instance Category (A f) where
|
||||
id = A (const id)
|
||||
id = A (\_ -> id)
|
||||
A f . A g = A $ \k -> f k . g k
|
||||
|
||||
instance Semigroup (A f o o) where
|
||||
@ -151,7 +151,7 @@ instance Monoid (A f o o) where
|
||||
#endif
|
||||
|
||||
instance Arrow (A f) where
|
||||
arr f = A (const (arr f))
|
||||
arr f = A (\_ -> (arr f))
|
||||
A f *** A g = A $ \k -> f k *** g k
|
||||
first (A f) = A $ \k -> first (f k)
|
||||
second (A f) = A $ \k -> second (f k)
|
||||
|
@ -87,6 +87,7 @@ import Control.Arrow (Arrow (..), ArrowZero (..), ArrowChoice (..))
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Data.Semigroup (Semigroup (..))
|
||||
#endif
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Control.Category.Free.Internal
|
||||
|
||||
@ -127,20 +128,20 @@ fromC :: C f a b -> ListTr f a b
|
||||
fromC = hoistFreeH2
|
||||
{-# INLINE fromC #-}
|
||||
|
||||
liftC :: forall k (f :: k -> k -> *) a b.
|
||||
liftC :: forall k (f :: k -> k -> Type) a b.
|
||||
f a b
|
||||
-> C f a b
|
||||
liftC = \f -> C $ \k -> k f
|
||||
{-# INLINE [1] liftC #-}
|
||||
|
||||
consC :: forall k (f :: k -> k -> *) a b c.
|
||||
consC :: forall k (f :: k -> k -> Type) a b c.
|
||||
f b c
|
||||
-> C f a b
|
||||
-> C f a c
|
||||
consC bc ab = liftC bc `composeC` ab
|
||||
{-# INLINE [1] consC #-}
|
||||
|
||||
foldNatC :: forall k (f :: k -> k -> *) c a b.
|
||||
foldNatC :: forall k (f :: k -> k -> Type) c a b.
|
||||
Category c
|
||||
=> (forall x y. f x y -> c x y)
|
||||
-> C f a b
|
||||
@ -165,7 +166,7 @@ foldNatC nat (C f) = f nat
|
||||
#-}
|
||||
|
||||
instance Category (C f) where
|
||||
id = C (const id)
|
||||
id = C (\_ -> id)
|
||||
(.) = composeC
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
|
@ -60,6 +60,7 @@ import Control.Category (Category (..))
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Data.Semigroup (Semigroup (..))
|
||||
#endif
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Control.Algebra.Free2 ( AlgebraType0
|
||||
, AlgebraType
|
||||
@ -70,14 +71,14 @@ import Control.Algebra.Free2 ( AlgebraType0
|
||||
-- | Oposite categoy in which arrows from @a@ to @b@ are represented by arrows
|
||||
-- from @b@ to @a@ in the original category.
|
||||
--
|
||||
newtype Op (f :: k -> k -> *) (a :: k) (b :: k) = Op { runOp :: f b a }
|
||||
newtype Op (f :: k -> k -> Type) (a :: k) (b :: k) = Op { runOp :: f b a }
|
||||
deriving Show
|
||||
|
||||
-- | 'Op' is an endo-functor of the category of categories.
|
||||
--
|
||||
hoistOp :: forall k
|
||||
(f :: k -> k -> *)
|
||||
(g :: k -> k -> *)
|
||||
(f :: k -> k -> Type)
|
||||
(g :: k -> k -> Type)
|
||||
a b.
|
||||
(forall x y. f x y -> g x y)
|
||||
-> Op f a b
|
||||
@ -122,7 +123,7 @@ instance Category f => Monoid (Op f o o) where
|
||||
-- Note that even though this is a naive version, it behaves quite well in
|
||||
-- simple benchmarks and quite stable regardless of the level of optimisations.
|
||||
--
|
||||
data ListTr :: (k -> k -> *) -> k -> k -> * where
|
||||
data ListTr :: (k -> k -> Type) -> k -> k -> Type where
|
||||
NilTr :: ListTr f a a
|
||||
ConsTr :: f b c -> ListTr f a b -> ListTr f a c
|
||||
|
||||
@ -130,7 +131,7 @@ lengthListTr :: ListTr f a b -> Int
|
||||
lengthListTr NilTr = 0
|
||||
lengthListTr (ConsTr _ xs) = 1 + lengthListTr xs
|
||||
|
||||
composeL :: forall k (f :: k -> k -> *) x y z.
|
||||
composeL :: forall k (f :: k -> k -> Type) x y z.
|
||||
ListTr f y z
|
||||
-> ListTr f x y
|
||||
-> ListTr f x z
|
||||
@ -138,12 +139,12 @@ composeL (ConsTr x xs) ys = ConsTr x (xs . ys)
|
||||
composeL NilTr ys = ys
|
||||
{-# INLINE [1] composeL #-}
|
||||
|
||||
liftL :: forall k (f :: k -> k -> *) x y.
|
||||
liftL :: forall k (f :: k -> k -> Type) x y.
|
||||
f x y -> ListTr f x y
|
||||
liftL f = ConsTr f NilTr
|
||||
{-# INLINE [1] liftL #-}
|
||||
|
||||
foldNatL :: forall k (f :: k -> k -> *) c a b.
|
||||
foldNatL :: forall k (f :: k -> k -> Type) c a b.
|
||||
Category c
|
||||
=> (forall x y. f x y -> c x y)
|
||||
-> ListTr f a b
|
||||
@ -173,7 +174,7 @@ foldNatL fun (ConsTr bc ab) = fun bc . foldNatFree2 fun ab
|
||||
|
||||
-- | 'foldr' of a 'ListTr'
|
||||
--
|
||||
foldrL :: forall k (f :: k -> k -> *) c a b d.
|
||||
foldrL :: forall k (f :: k -> k -> Type) c a b d.
|
||||
(forall x y z. f y z -> c x y -> c x z)
|
||||
-> c a b
|
||||
-> ListTr f b d
|
||||
@ -186,7 +187,7 @@ foldrL nat ab (ConsTr xd bx) = nat xd (foldrL nat ab bx)
|
||||
--
|
||||
-- TODO: make it strict, like 'foldl''.
|
||||
--
|
||||
foldlL :: forall k (f :: k -> k -> *) c a b d.
|
||||
foldlL :: forall k (f :: k -> k -> Type) c a b d.
|
||||
(forall x y z. c y z -> f x y -> c x z)
|
||||
-> c b d
|
||||
-> ListTr f a b
|
||||
@ -276,7 +277,7 @@ instance ArrowChoice f => ArrowChoice (ListTr f) where
|
||||
-- Internal invariant: sum of lengths of two last least is equal the length of
|
||||
-- the first one.
|
||||
--
|
||||
data Queue (f :: k -> k -> *) (a :: k) (b :: k) where
|
||||
data Queue (f :: k -> k -> Type) (a :: k) (b :: k) where
|
||||
Queue :: forall f a c b x.
|
||||
ListTr f b c
|
||||
-> !(ListTr (Op f) b a)
|
||||
@ -295,7 +296,7 @@ pattern NilQ <- (unconsQ -> EmptyL) where
|
||||
{-# complete NilQ, ConsQ #-}
|
||||
#endif
|
||||
|
||||
composeQ :: forall k (f :: k -> k -> *) x y z.
|
||||
composeQ :: forall k (f :: k -> k -> Type) x y z.
|
||||
Queue f y z
|
||||
-> Queue f x y
|
||||
-> Queue f x z
|
||||
@ -303,11 +304,11 @@ composeQ (ConsQ f q1) q2 = ConsQ f (q1 . q2)
|
||||
composeQ NilQ q2 = q2
|
||||
{-# INLINE [1] composeQ #-}
|
||||
|
||||
nilQ :: Queue (f :: k -> k -> *) a a
|
||||
nilQ :: Queue (f :: k -> k -> Type) a a
|
||||
nilQ = Queue NilTr NilTr NilTr
|
||||
{-# INLINE [1] nilQ #-}
|
||||
|
||||
consQ :: forall k (f :: k -> k -> *) a b c.
|
||||
consQ :: forall k (f :: k -> k -> Type) a b c.
|
||||
f b c
|
||||
-> Queue f a b
|
||||
-> Queue f a c
|
||||
@ -327,7 +328,7 @@ unconsQ (Queue (ConsTr tr f) r s) = tr :< exec f r s
|
||||
unconsQ _ = error "Queue.uncons: invariant violation"
|
||||
{-# INLINE unconsQ #-}
|
||||
|
||||
snocQ :: forall k (f :: k -> k -> *) a b c.
|
||||
snocQ :: forall k (f :: k -> k -> Type) a b c.
|
||||
Queue f b c
|
||||
-> f a b
|
||||
-> Queue f a c
|
||||
@ -336,7 +337,7 @@ snocQ (Queue f r s) g = exec f (ConsTr (Op g) r) s
|
||||
|
||||
-- | 'foldr' of a 'Queue'
|
||||
--
|
||||
foldrQ :: forall k (f :: k -> k -> *) c a b d.
|
||||
foldrQ :: forall k (f :: k -> k -> Type) c a b d.
|
||||
(forall x y z. f y z -> c x y -> c x z)
|
||||
-> c a b
|
||||
-> Queue f b d
|
||||
@ -368,7 +369,7 @@ foldrQ nat ab (ConsQ xd bx) = nat xd (foldrQ nat ab bx)
|
||||
|
||||
#-}
|
||||
|
||||
liftQ :: forall k (f :: k -> k -> *) a b.
|
||||
liftQ :: forall k (f :: k -> k -> Type) a b.
|
||||
f a b -> Queue f a b
|
||||
liftQ = \fab -> ConsQ fab NilQ
|
||||
{-# INLINE [1] liftQ #-}
|
||||
@ -377,7 +378,7 @@ liftQ = \fab -> ConsQ fab NilQ
|
||||
--
|
||||
-- /complexity/ @O\(n\)@
|
||||
--
|
||||
foldNatQ :: forall k (f :: k -> k -> *) c a b.
|
||||
foldNatQ :: forall k (f :: k -> k -> Type) c a b.
|
||||
Category c
|
||||
=> (forall x y. f x y -> c x y)
|
||||
-> Queue f a b
|
||||
@ -408,7 +409,7 @@ foldNatQ nat = foldrQ (\f c -> nat f . c) id
|
||||
--
|
||||
-- TODO: make it strict, like 'foldl''.
|
||||
--
|
||||
foldlQ :: forall k (f :: k -> k -> *) c a b d.
|
||||
foldlQ :: forall k (f :: k -> k -> Type) c a b d.
|
||||
(forall x y z. c y z -> f x y -> c x z)
|
||||
-> c b d
|
||||
-> Queue f a b
|
||||
@ -435,8 +436,8 @@ zipWithQ fn queueA queueB = case (queueA, queueB) of
|
||||
-- transformation. This in analogy to @'map' :: (a -> b) -> [a] -> [b]@.
|
||||
--
|
||||
hoistQ :: forall k
|
||||
(f :: k -> k -> *)
|
||||
(g :: k -> k -> *)
|
||||
(f :: k -> k -> Type)
|
||||
(g :: k -> k -> Type)
|
||||
a b.
|
||||
(forall x y. f x y -> g x y)
|
||||
-> Queue f a b
|
||||
|
@ -21,6 +21,7 @@ import Prelude hiding (id, (.))
|
||||
import Control.Arrow (Kleisli (..))
|
||||
import Control.Category (Category (..))
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
import Data.Kind (Type)
|
||||
|
||||
import Control.Algebra.Free2 (FreeAlgebra2 (..))
|
||||
import Data.Algebra.Free (AlgebraType, AlgebraType0, Proof (..))
|
||||
@ -40,7 +41,7 @@ instance EffectCategory (->) Identity where
|
||||
-- | Category transformer, which adds @'EffectCategory'@ instance to the
|
||||
-- underlying base category.
|
||||
--
|
||||
data EffCat :: (* -> *) -> (k -> k -> *) -> k -> k -> * where
|
||||
data EffCat :: (Type -> Type) -> (k -> k -> Type) -> k -> k -> Type where
|
||||
Base :: c a b -> EffCat m c a b
|
||||
Effect :: m (EffCat m c a b) -> EffCat m c a b
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user