coot/free-category
1
1
Fork 0
mirror of https://github.com/coot/free-category.git synced 2024-11-22 16:22:05 +03:00
Code Issues Projects Releases Wiki Activity

GHC-9.0 support

Browse Source
This commit is contained in:
Marcin Szamotulski 2021-03-18 15:13:46 +01:00 committed by Marcin Szamotulski
parent 2404d78385
commit 48a058e210
6 changed files with 37 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@ -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

12
nix/sources.json
View File

@ -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": {

4
src/Control/Arrow/Free.hs
View File

@ -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)

9
src/Control/Category/Free.hs
View File

@ -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

41
src/Control/Category/Free/Internal.hs
View File

@ -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

3
src/Control/Category/FreeEffect.hs
View File

@ -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