free-category 0.0.4.3 → 0.0.4.4

raw patch · 7 files changed

+62/−114 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−3
• free-category.cabal +3/−3
• src/Control/Arrow/Free.hs +42/−15
• src/Control/Category/Free.hs +6/−31
• src/Control/Category/Free/Internal.hs +3/−43
• src/Control/Category/FreeEffect.hs +1/−1
• test/Test/Cat.hs +3/−18

@@ -1,8 +1,9 @@ # Changelog for free-category -## Version 0.0.4.3-- updated for GHC 9.0.1-- added Control.Category.FreeEffect.runEffCat (thanks to Manuel Bärenz)+## Version 0.0.4.4+- Added support for GHC: `9.0`, `9.2`, `9.4`.+- Dropped support for `GHC-8.6` or earlier.+- Added ArrChoice a free ArrowChoice.  ## Version 0.0.4.2 - updated for *GHC 8.10.1*

@@ -1,6 +1,6 @@ cabal-version:  2.0 name:           free-category-version:        0.0.4.3+version:        0.0.4.4 synopsis:       efficient data types for free categories and arrows description:   This package provides various data types for free categories, type@@ -12,7 +12,7 @@ bug-reports:    https://github.com/coot/free-category/issues author:         Marcin Szamotulski maintainer:     coot@coot.me-copyright:      (c) 2018-2021 Marcin Szamotulski+copyright:      (c) 2018-2022 Marcin Szamotulski license:        MPL-2.0 license-file:   LICENSE build-type:     Simple@@ -23,7 +23,7 @@     bench/report-O1.md     bench/report-O2.md stability:      experimental-tested-with:    GHC==8.6.5, GHC==8.8.4, GHC==8.10.4+tested-with:    GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.4, GHC==9.4.2  source-repository head   type: git

@@ -13,6 +13,7 @@   ( -- * Free arrow     Arr (Id, Arr, Prod)   , arrArr+  , liftArr   , mapArr   , foldArr @@ -27,15 +28,15 @@   , hoistFree2   , joinFree2   , bindFree2+    -- * Free 'ArrowChoice'+  , Choice (..)+  , liftArrChoice+  , foldArrChoice   ) where  import           Prelude hiding (id, (.))-import           Control.Arrow (Arrow (..))+import           Control.Arrow (Arrow (..), ArrowChoice (..), (>>>)) import           Control.Category (Category (..))-#if __GLASGOW_HASKELL__ < 804-import           Data.Monoid (Monoid (..))-import           Data.Semigroup (Semigroup (..))-#endif  import           Control.Algebra.Free2   ( AlgebraType0@@ -60,6 +61,10 @@ arrArr :: (b -> c) -> Arr f b c arrArr bc = Arr bc Id +liftArr :: f a b+        -> Arr f a b+liftArr f = Cons f nilQ+ mapArr :: f b c        -> Arr f a b        -> Arr f a c@@ -88,9 +93,6 @@  instance Monoid (Arr f o o) where     mempty = Id-#if __GLASGOW_HASKELL__ < 804-    mappend = (<>)-#endif  instance Arrow (Arr f) where   arr       = arrArr@@ -124,15 +126,15 @@              -> r a b       } --- |--- Isomorphism from @'Arr'@ to @'A'@, which is a specialisation of+-- | Isomorphism from @'Arr'@ to @'A'@, which is a specialisation of -- @'hoistFreeH2'@.+-- toA :: Arr f a b -> A f a b toA = hoistFreeH2 {-# INLINE toA #-} --- |--- Inverse of @'fromA'@, which also is a specialisatin of @'hoistFreeH2'@.+-- | Inverse of @'fromA'@, which also is a specialisation of @'hoistFreeH2'@.+-- fromA :: A f a b -> Arr f a b fromA = hoistFreeH2 {-# INLINE fromA #-}@@ -146,9 +148,6 @@  instance Monoid (A f o o) where     mempty = id-#if __GLASGOW_HASKELL__ < 804-    mappend = (<>)-#endif  instance Arrow (A f) where   arr f = A (\_ -> (arr f))@@ -168,3 +167,31 @@    codom2  = Proof   forget2 = Proof++data Choice f a b where+  NoChoice :: f a b+           -> Choice f a b++  Choose   :: ArrChoice f a c+           -> ArrChoice f b c+           -> Choice f (Either a b) c++type ArrChoice f a b = Arr (Choice f) a b++instance ArrowChoice (Arr (Choice f)) where+  f +++ g = liftArr $ Choose (f >>> arr Left) (g >>> arr Right)++liftArrChoice :: f a b+              -> ArrChoice f a b+liftArrChoice = liftArr . NoChoice++foldArrChoice :: forall f arr a b.+                 ArrowChoice arr+              => (forall x y. f x y -> arr x y)+              -> ArrChoice f a b+              -> arr a b+foldArrChoice fun = foldArr fun'+  where+    fun' :: Choice f x y -> arr x y+    fun' (NoChoice f) = fun f+    fun' (Choose f g) = foldArrChoice fun f ||| foldArrChoice fun g

@@ -11,20 +11,10 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE ViewPatterns          #-}-#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-}-#endif  {-# OPTIONS_HADDOCK show-extensions #-} -#if __GLASGOW_HASKELL__ <= 802--- ghc802 does not infer that 'cons' is used when using a bidirectional--- pattern-{-# OPTIONS_GHC -Wno-unused-top-binds    #-}--- the 'complete' pragma was introduced in ghc804-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-#endif- module Control.Category.Free     ( -- * Real time Queue       Queue (ConsQ, NilQ)@@ -37,7 +27,7 @@     , foldlQ     , zipWithQ -      -- * Type alligned list+      -- * Type aligned list     , ListTr (..)     , liftL     , foldNatL@@ -83,10 +73,6 @@                   , bindFree2                   ) import           Control.Arrow (Arrow (..), ArrowZero (..), ArrowChoice (..))-#if __GLASGOW_HASKELL__ < 804-import           Data.Monoid (Monoid (..))-import           Data.Semigroup (Semigroup (..))-#endif import           Data.Kind (Type)  import           Control.Category.Free.Internal@@ -96,8 +82,7 @@ -- CPS style free categories -- --- |--- CPS style encoded free category; one can use @'FreeAlgebra2'@ class+-- | CPS style encoded free category; one can use @'FreeAlgebra2'@ class -- instance: -- -- > liftFree2    @C :: f a b -> C f a b@@ -115,15 +100,15 @@ composeC (C g) (C f) = C $ \k -> g k . f k {-# INLINE [1] composeC #-} --- |--- Isomorphism from @'ListTr'@ to @'C'@, which is a specialisation of+-- | Isomorphism from @'ListTr'@ to @'C'@, which is a specialisation of -- @'hoistFreeH2'@.+-- toC :: ListTr f a b -> C f a b toC = hoistFreeH2 {-# INLINE toC #-} --- |--- Inverse of @'fromC'@, which also is a specialisation of @'hoistFreeH2'@.+-- | Inverse of @'fromC'@, which also is a specialisation of @'hoistFreeH2'@.+-- fromC :: C f a b -> ListTr f a b fromC = hoistFreeH2 {-# INLINE fromC #-}@@ -169,17 +154,10 @@   id  = C (\_ -> id)   (.) = composeC -#if __GLASGOW_HASKELL__ >= 806 -- | Show instance via 'ListTr' -- instance (forall x y. Show (f x y)) => Show (C f a b) where     show c = show (hoistFreeH2 c :: ListTr f a b)-#else--- | Blind show instance via 'ListTr'----instance Show (C f a b) where-    show c = show (hoistFreeH2 c :: ListTr f a b)-#endif  type instance AlgebraType0 C f = () type instance AlgebraType  C c = Category c@@ -212,6 +190,3 @@  instance Monoid (C f o o) where   mempty = id-#if __GLASGOW_HASKELL__ < 804-  mappend = (<>)-#endif

@@ -6,23 +6,12 @@ {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE ViewPatterns          #-}--#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-}-#endif  {-# OPTIONS_HADDOCK show-extensions #-} -#if __GLASGOW_HASKELL__ <= 802--- ghc802 does not infer that 'consQ' is used when using a bidirectional--- pattern-{-# OPTIONS_GHC -Wno-unused-top-binds    #-}--- the 'complete' pragma was introduced in ghc804-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}-#endif-- -- | Internal module, contains implementation of type aligned real time queues -- (C.Okasaki 'Purely Functional Data Structures'). --@@ -56,10 +45,6 @@ import           Prelude hiding (id, (.)) import           Control.Arrow import           Control.Category (Category (..))-#if __GLASGOW_HASKELL__ < 804-import           Data.Monoid (Monoid (..))-import           Data.Semigroup (Semigroup (..))-#endif import           Data.Kind (Type)  import           Control.Algebra.Free2 ( AlgebraType0@@ -68,7 +53,7 @@                                        , Proof (..)                                        ) --- | Oposite categoy in which arrows from @a@ to @b@ are represented by arrows+-- | Opposite category in which arrows from @a@ to @b@ are represented by arrows -- from @b@ to @a@ in the original category. -- newtype Op (f :: k -> k -> Type) (a :: k) (b :: k) = Op { runOp :: f b a }@@ -95,9 +80,6 @@  instance Category f => Monoid (Op f o o) where     mempty = id-#if __GLASGOW_HASKELL__ < 804-    mappend = (<>)-#endif   --@@ -208,15 +190,9 @@     (ConsTr trA' queueA', ConsTr trB' queueB')                                  -> ConsTr (trA' `fn` trB') (zipWithL fn queueA' queueB') -#if __GLASGOW_HASKELL__ >= 806 instance (forall (x :: k) (y :: k). Show (f x y)) => Show (ListTr f a b) where     show NilTr         = "NilTr"     show (ConsTr x xs) = "ConsTr " ++ show x ++ " " ++ show xs-#else-instance Show (ListTr f a b) where-    show NilTr         = "NilTr"-    show (ConsTr _ xs) = "ConsTr _ " ++ show xs-#endif  instance Category (ListTr f) where   id  = NilTr@@ -239,9 +215,6 @@  instance Monoid (ListTr f o o) where   mempty = NilTr-#if __GLASGOW_HASKELL__ < 804-  mappend = (<>)-#endif  instance Arrow f => Arrow (ListTr f) where   arr ab                          = arr ab `ConsTr` NilTr@@ -268,7 +241,7 @@ --  --- | Type alligned real time queues; Based on `Purely Functinal Data Structures`+-- | Type aligned real time queues; Based on `Purely Functional Data Structures` -- C.Okasaki.  This the most reliably behaved implementation of free categories -- in this package. --@@ -292,9 +265,7 @@ pattern NilQ <- (unconsQ -> EmptyL) where     NilQ = nilQ -#if __GLASGOW_HASKELL__ > 802 {-# complete NilQ, ConsQ #-}-#endif  composeQ :: forall k (f :: k -> k -> Type) x y z.             Queue f y z@@ -463,7 +434,6 @@  #-} -#if __GLASGOW_HASKELL__ >= 806 instance (forall (x :: k) (y :: k). Show (f x y))       => Show (Queue f a b) where     show (Queue f r s) =@@ -473,16 +443,6 @@         ++ show r         ++ ") "         ++ show (lengthListTr s)-#else-instance Show (Queue f r s) where-    show (Queue f r s) =-        "Queue "-      ++ show (lengthListTr f)-      ++ " "-      ++ show (lengthListTr r)-      ++ " "-      ++ show (lengthListTr s)-#endif  instance Category (Queue f) where     id  = NilQ

@@ -27,7 +27,7 @@ import Data.Algebra.Free (AlgebraType, AlgebraType0, Proof (..))  --- | Categories which can lift monadic actions, i.e. effectful categories.+-- | Categories which can lift monadic actions, i.e effectful categories. -- class Category c => EffectCategory c m | c -> m where   effect :: m (c a b) -> c a b

@@ -1,6 +1,9 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleInstances     #-}+#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE FlexibleContexts      #-}+#endif {-# LANGUAGE GADTs                 #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE PolyKinds             #-}@@ -8,9 +11,7 @@ {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TupleSections         #-} {-# LANGUAGE UndecidableInstances  #-}-#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE QuantifiedConstraints #-}-#endif  {-# OPTIONS_GHC -Wno-orphans #-} @@ -19,10 +20,6 @@ import           Prelude hiding ((.), id) import           Control.Category import           Data.Function (on)-#if __GLASGOW_HASKELL__ < 804-import           Data.Monoid (Monoid (..))-import           Data.Semigroup (Semigroup (..))-#endif import           Text.Show.Functions () import           Numeric.Natural (Natural) @@ -173,7 +170,6 @@ data ArbListTr where     ArbListTr :: Eq b => ListTr Tr a b -> Sing a -> Sing b -> ArbListTr -#if __GLASGOW_HASKELL__ >= 806 instance (forall x y. Show (Tr x y)) => Show ArbListTr where     show (ArbListTr listTr a b) =          "ArbListTr "@@ -182,14 +178,6 @@       ++ show b       ++ " "       ++ show listTr-#else-instance Show ArbListTr where-    show (ArbListTr _listTr a b) =-         "ArbListTr "-      ++ show a-      ++ " -> "-      ++ show b-#endif  instance Arbitrary ArbListTr where     arbitrary = sized $ \n -> do@@ -281,9 +269,6 @@  instance Monoid (IntCat '() '()) where     mempty = IntCat 0-#if __GLASGOW_HASKELL__ < 804-    mappend = (<>)-#endif  instance Arbitrary (IntCat '() '()) where     arbitrary = IntCat <$> arbitrary