From 48a058e210d2d69d8923d4b6bd53b52587073cf4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 18 Mar 2021 15:13:46 +0100 Subject: [PATCH] GHC-9.0 support --- cabal.project | 2 +- nix/sources.json | 12 ++++---- src/Control/Arrow/Free.hs | 4 +-- src/Control/Category/Free.hs | 9 +++--- src/Control/Category/Free/Internal.hs | 41 ++++++++++++++------------- src/Control/Category/FreeEffect.hs | 3 +- 6 files changed, 37 insertions(+), 34 deletions(-) diff --git a/cabal.project b/cabal.project index 0a4778d..62f1296 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/nix/sources.json b/nix/sources.json index 0424488..44ccb32 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -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///archive/.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///archive/.tar.gz" }, "niv": { diff --git a/src/Control/Arrow/Free.hs b/src/Control/Arrow/Free.hs index 9e4b7fe..0cab0d5 100644 --- a/src/Control/Arrow/Free.hs +++ b/src/Control/Arrow/Free.hs @@ -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) diff --git a/src/Control/Category/Free.hs b/src/Control/Category/Free.hs index e46ab68..292ebf2 100644 --- a/src/Control/Category/Free.hs +++ b/src/Control/Category/Free.hs @@ -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 diff --git a/src/Control/Category/Free/Internal.hs b/src/Control/Category/Free/Internal.hs index f33e9e2..bc34b43 100644 --- a/src/Control/Category/Free/Internal.hs +++ b/src/Control/Category/Free/Internal.hs @@ -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 diff --git a/src/Control/Category/FreeEffect.hs b/src/Control/Category/FreeEffect.hs index ce9f4fc..5c2ec5c 100644 --- a/src/Control/Category/FreeEffect.hs +++ b/src/Control/Category/FreeEffect.hs @@ -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