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

Stylish edits

Browse Source
This commit is contained in:
Marcin Szamotulski 2019-08-31 14:04:14 +02:00
parent df0d3e4528
commit cd58b91419
2 changed files with 15 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -103,11 +103,11 @@ foldCat :: forall f c a b.
-> Cat f a b
-> c a b
foldCat _nat Id = id
foldCat nat (Cat tr queue) =
case queue of
NilQ -> nat tr
ConsQ Id queue' -> nat tr . foldQ (foldCat nat) queue'
ConsQ c queue' -> nat tr . foldCat nat c . foldQ (foldCat nat) queue'
foldCat nat (Cat tr q) =
case q of
NilQ -> nat tr
ConsQ Id q' -> nat tr . foldQ (foldCat nat) q'
ConsQ c q' -> nat tr . foldCat nat c . foldQ (foldCat nat) q'
-- TODO: implement foldl; it might require different representation. Function
-- composition is applied from right to left, so it should be more efficient.
@ -138,10 +138,10 @@ instance FreeAlgebra2 Cat where
instance Arrow f => Arrow (Cat f) where
arr = arrCat . arr
Cat tr queue *** Cat tr' queue' = Cat (tr *** tr') (zipWithQ (***) queue queue')
Cat tr queue *** Id = Cat (tr *** arr id) (zipWithQ (***) queue NilQ)
Id *** Cat tr' queue' = Cat (arr id *** tr') (zipWithQ (***) NilQ queue')
Id *** Id = Cat (arr id *** arr id) NilQ
Cat tr q *** Cat tr' q' = Cat (tr *** tr') (zipWithQ (***) q q')
Cat tr q *** Id = Cat (tr *** arr id) (zipWithQ (***) q NilQ)
Id *** Cat tr' q' = Cat (arr id *** tr') (zipWithQ (***) NilQ q')
Id *** Id = Cat (arr id *** arr id) NilQ
instance ArrowZero f => ArrowZero (Cat f) where
zeroArrow = arrCat zeroArrow

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

@ -202,9 +202,9 @@ foldQ :: forall (f :: k -> k -> *) c a b.
=> (forall x y. f x y -> c x y)
-> Queue f a b
-> c a b
foldQ nat queue = case queue of
NilQ -> id
ConsQ tr queue' -> nat tr . foldQ nat queue'
foldQ nat q = case q of
NilQ -> id
ConsQ tr q' -> nat tr . foldQ nat q'
zipWithQ :: forall f g a b a' b'.
Arrow f
@ -220,6 +220,9 @@ zipWithQ fn queueA queueB = case (queueA, queueB) of
-> ConsQ (trA' `fn` trB') (zipWithQ fn queueA' queueB')
--
-- Internal API
--
exec :: ListTr f b c -> ListTr (Op f) b a -> ListTr f b x -> Queue f a c
exec xs ys (ConsTr _ t) = Queue xs ys t