mirror of
https://github.com/coot/free-category.git
synced 2024-10-26 15:15:00 +03:00
Rearange function, rewrite rules and type class instances
This commit is contained in:
Marcin Szamotulski
parent
c71fc6678b
commit
e5d030ebf7
@ -143,31 +143,6 @@ compose Id f = f
|
||||
compose f Id = f
|
||||
{-# INLINE [1] compose #-}
|
||||
|
||||
instance Category (Cat f) where
|
||||
id = Id
|
||||
(.) = compose
|
||||
|
||||
instance Semigroup (Cat f a a) where
|
||||
f <> g = f `compose` g
|
||||
|
||||
instance Monoid (Cat f o o) where
|
||||
mempty = id
|
||||
#if __GLASGOW_HASKELL__ < 804
|
||||
mappend = (<>)
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
-- | Show instance via 'ListTr'
|
||||
--
|
||||
instance (forall x y. Show (f x y)) => Show (Cat f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#else
|
||||
-- | Blind show instance via 'ListTr'
|
||||
--
|
||||
instance Show (Cat f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#endif
|
||||
|
||||
arrCat :: forall (f :: k -> k -> *) a b.
|
||||
f a b
|
||||
-> Cat f a b
|
||||
@ -304,6 +279,31 @@ unOp = unsafeCoerce
|
||||
|
||||
#-}
|
||||
|
||||
instance Category (Cat f) where
|
||||
id = Id
|
||||
(.) = compose
|
||||
|
||||
instance Semigroup (Cat f a a) where
|
||||
f <> g = f `compose` g
|
||||
|
||||
instance Monoid (Cat f o o) where
|
||||
mempty = id
|
||||
#if __GLASGOW_HASKELL__ < 804
|
||||
mappend = (<>)
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
-- | Show instance via 'ListTr'
|
||||
--
|
||||
instance (forall x y. Show (f x y)) => Show (Cat f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#else
|
||||
-- | Blind show instance via 'ListTr'
|
||||
--
|
||||
instance Show (Cat f a b) where
|
||||
show c = show (hoistFreeH2 c :: ListTr f a b)
|
||||
#endif
|
||||
|
||||
instance Arrow f => Arrow (Cat f) where
|
||||
arr = arrCat . arr
|
||||
{-# INLINE arr #-}
|
||||
@ -373,22 +373,6 @@ composeC :: C f y z -> C f x y -> C f x z
|
||||
composeC (C g) (C f) = C $ \k -> g k . f k
|
||||
{-# INLINE [1] composeC #-}
|
||||
|
||||
instance Category (C f) where
|
||||
id = C (const 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
|
||||
|
||||
-- |
|
||||
-- Isomorphism from @'Cat'@ to @'C'@, which is a specialisation of
|
||||
-- @'hoistFreeH2'@.
|
||||
@ -423,18 +407,6 @@ foldNatC :: forall (f :: k -> k -> *) c a b.
|
||||
foldNatC nat (C f) = f nat
|
||||
{-# INLINE [1] foldNatC #-}
|
||||
|
||||
type instance AlgebraType0 C f = ()
|
||||
type instance AlgebraType C c = Category c
|
||||
|
||||
instance FreeAlgebra2 C where
|
||||
liftFree2 = arrC
|
||||
{-# INLINE liftFree2 #-}
|
||||
foldNatFree2 = foldNatC
|
||||
{-# INLINE foldNatFree2 #-}
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
{-# RULES
|
||||
|
||||
"foldNatC/consC"
|
||||
@ -451,6 +423,32 @@ instance FreeAlgebra2 C where
|
||||
|
||||
#-}
|
||||
|
||||
instance Category (C f) where
|
||||
id = C (const 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
|
||||
|
||||
instance FreeAlgebra2 C where
|
||||
liftFree2 = arrC
|
||||
foldNatFree2 = foldNatC
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
instance Arrow f => Arrow (C f) where
|
||||
arr ab = C $ \k -> k (arr ab)
|
||||
{-# INLINE arr #-}
|
||||
|
||||
@ -233,25 +233,16 @@ data Queue (f :: k -> k -> *) (a :: k) (b :: k) where
|
||||
-> ListTr f b x
|
||||
-> Queue f a c
|
||||
|
||||
#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) =
|
||||
"Queue ("
|
||||
++ show f
|
||||
++ ") ("
|
||||
++ 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)
|
||||
pattern ConsQ :: f b c -> Queue f a b -> Queue f a c
|
||||
pattern ConsQ a as <- (unconsQ -> a :< as) where
|
||||
ConsQ = consQ
|
||||
|
||||
pattern NilQ :: () => a ~ b => Queue f a b
|
||||
pattern NilQ <- (unconsQ -> EmptyL) where
|
||||
NilQ = nilQ
|
||||
|
||||
#if __GLASGOW_HASKELL__ > 802
|
||||
{-# complete NilQ, ConsQ #-}
|
||||
#endif
|
||||
|
||||
composeQ :: forall (f :: k -> k -> *) x y z.
|
||||
@ -262,48 +253,6 @@ composeQ (ConsQ f q1) q2 = ConsQ f (q1 . q2)
|
||||
composeQ NilQ q2 = q2
|
||||
{-# INLINE [1] composeQ #-}
|
||||
|
||||
instance Category (Queue f) where
|
||||
id = NilQ
|
||||
(.) = composeQ
|
||||
|
||||
type instance AlgebraType0 Queue f = ()
|
||||
type instance AlgebraType Queue c = Category c
|
||||
|
||||
instance FreeAlgebra2 Queue where
|
||||
liftFree2 = arrQ
|
||||
foldNatFree2 = foldNatQ
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
instance Semigroup (Queue f o o) where
|
||||
f <> g = g `composeQ` f
|
||||
|
||||
instance Monoid (Queue f o o) where
|
||||
mempty = NilQ
|
||||
#if __GLASGOW_HASKELL__ < 804
|
||||
mappend = (<>)
|
||||
#endif
|
||||
|
||||
instance Arrow f => Arrow (Queue f) where
|
||||
arr ab = arr ab `ConsQ` NilQ
|
||||
|
||||
(ConsQ fxb cax) *** (ConsQ fyb cay)
|
||||
= (fxb *** fyb) `ConsQ` (cax *** cay)
|
||||
(ConsQ fxb cax) *** NilQ = (fxb *** arr id) `ConsQ` (cax *** NilQ)
|
||||
NilQ *** (ConsQ fxb cax) = (arr id *** fxb) `ConsQ` (NilQ *** cax)
|
||||
NilQ *** NilQ = NilQ
|
||||
|
||||
instance ArrowZero f => ArrowZero (Queue f) where
|
||||
zeroArrow = zeroArrow `ConsQ` NilQ
|
||||
|
||||
instance ArrowChoice f => ArrowChoice (Queue f) where
|
||||
(ConsQ fxb cax) +++ (ConsQ fyb cay)
|
||||
= (fxb +++ fyb) `ConsQ` (cax +++ cay)
|
||||
(ConsQ fxb cax) +++ NilQ = (fxb +++ arr id) `ConsQ` (cax +++ NilQ)
|
||||
NilQ +++ (ConsQ fxb cax) = (arr id +++ fxb) `ConsQ` (NilQ +++ cax)
|
||||
NilQ +++ NilQ = NilQ
|
||||
|
||||
nilQ :: Queue (f :: k -> k -> *) a a
|
||||
nilQ = Queue NilTr NilTr NilTr
|
||||
{-# INLINE [1] nilQ #-}
|
||||
@ -335,18 +284,6 @@ snocQ :: forall (f :: k -> k -> *) a b c.
|
||||
snocQ (Queue f r s) g = exec f (ConsTr (Op g) r) s
|
||||
{-# INLINE snocQ #-}
|
||||
|
||||
pattern ConsQ :: f b c -> Queue f a b -> Queue f a c
|
||||
pattern ConsQ a as <- (unconsQ -> a :< as) where
|
||||
ConsQ = consQ
|
||||
|
||||
pattern NilQ :: () => a ~ b => Queue f a b
|
||||
pattern NilQ <- (unconsQ -> EmptyL) where
|
||||
NilQ = nilQ
|
||||
|
||||
#if __GLASGOW_HASKELL__ > 802
|
||||
{-# complete NilQ, ConsQ #-}
|
||||
#endif
|
||||
|
||||
-- | 'foldr' of a 'Queue'
|
||||
--
|
||||
foldrQ :: forall (f :: k -> k -> *) c a b d.
|
||||
@ -474,6 +411,69 @@ hoistQ nat q = case q of
|
||||
|
||||
#-}
|
||||
|
||||
#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) =
|
||||
"Queue ("
|
||||
++ show f
|
||||
++ ") ("
|
||||
++ 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
|
||||
(.) = composeQ
|
||||
|
||||
type instance AlgebraType0 Queue f = ()
|
||||
type instance AlgebraType Queue c = Category c
|
||||
|
||||
instance FreeAlgebra2 Queue where
|
||||
liftFree2 = arrQ
|
||||
foldNatFree2 = foldNatQ
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
instance Semigroup (Queue f o o) where
|
||||
f <> g = g `composeQ` f
|
||||
|
||||
instance Monoid (Queue f o o) where
|
||||
mempty = NilQ
|
||||
#if __GLASGOW_HASKELL__ < 804
|
||||
mappend = (<>)
|
||||
#endif
|
||||
|
||||
instance Arrow f => Arrow (Queue f) where
|
||||
arr ab = arr ab `ConsQ` NilQ
|
||||
|
||||
(ConsQ fxb cax) *** (ConsQ fyb cay)
|
||||
= (fxb *** fyb) `ConsQ` (cax *** cay)
|
||||
(ConsQ fxb cax) *** NilQ = (fxb *** arr id) `ConsQ` (cax *** NilQ)
|
||||
NilQ *** (ConsQ fxb cax) = (arr id *** fxb) `ConsQ` (NilQ *** cax)
|
||||
NilQ *** NilQ = NilQ
|
||||
|
||||
instance ArrowZero f => ArrowZero (Queue f) where
|
||||
zeroArrow = zeroArrow `ConsQ` NilQ
|
||||
|
||||
instance ArrowChoice f => ArrowChoice (Queue f) where
|
||||
(ConsQ fxb cax) +++ (ConsQ fyb cay)
|
||||
= (fxb +++ fyb) `ConsQ` (cax +++ cay)
|
||||
(ConsQ fxb cax) +++ NilQ = (fxb +++ arr id) `ConsQ` (cax +++ NilQ)
|
||||
NilQ +++ (ConsQ fxb cax) = (arr id +++ fxb) `ConsQ` (NilQ +++ cax)
|
||||
NilQ +++ NilQ = NilQ
|
||||
|
||||
--
|
||||
-- Internal API
|
||||
--
|
||||
|
||||
Loading…
Reference in New Issue
Block a user