mirror of
https://github.com/coot/free-category.git
synced 2024-10-26 15:15:00 +03:00
Renamed Queue interface
* `snoc` -> `snocQ` * `cons` -> `consQ` * `uncons` -> `unconsQ`
This commit is contained in:
parent
99121aff4f
commit
d3b19e4d59
@ -79,7 +79,7 @@ instance Category (Arr f) where
|
||||
id = Id
|
||||
Id . f = f
|
||||
f . Id = f
|
||||
(Cons f g) . h = Cons f (g `snoc` h)
|
||||
(Cons f g) . h = Cons f (g `snocQ` h)
|
||||
(Arr f g) . h = Arr f (g . h)
|
||||
(Prod f g) . h = Prod (f . h) (g . h)
|
||||
|
||||
|
@ -112,7 +112,7 @@ import Unsafe.Coerce (unsafeCoerce)
|
||||
-- )
|
||||
-- @
|
||||
--
|
||||
-- Type aligned 'Queue's have efficient 'snoc' and 'uncons' operations which
|
||||
-- Type aligned 'Queue's have efficient 'snocQ' and 'unconsQ' operations which
|
||||
-- allow to implement efficient composition and folding for 'Cat'.
|
||||
--
|
||||
data Cat (f :: k -> k -> *) a b where
|
||||
@ -125,7 +125,7 @@ instance Category (Cat f) where
|
||||
id = Id
|
||||
|
||||
f . Cat q (g :: g x a)
|
||||
= Cat (q `snoc` op f) g
|
||||
= Cat (q `snocQ` op f) g
|
||||
Id . f = f
|
||||
f . Id = f
|
||||
|
||||
|
@ -15,7 +15,7 @@
|
||||
{-# OPTIONS_HADDOCK show-extensions #-}
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 802
|
||||
-- ghc802 does not infer that 'cons' is used when using a bidirectional
|
||||
-- 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
|
||||
@ -33,10 +33,10 @@ module Control.Category.Free.Internal
|
||||
, lengthListTr
|
||||
, Queue (NilQ, ConsQ)
|
||||
, emptyQ
|
||||
, cons
|
||||
, consQ
|
||||
, ViewL (..)
|
||||
, uncons
|
||||
, snoc
|
||||
, unconsQ
|
||||
, snocQ
|
||||
, foldNatQ
|
||||
, foldrQ
|
||||
, foldlQ
|
||||
@ -176,7 +176,7 @@ instance FreeAlgebra2 ListTr where
|
||||
-- | Type alligned real time queues; Based on `Purely Functinal Data Structures`
|
||||
-- C.Okasaki.
|
||||
--
|
||||
-- Upper bounds of `cons`, `snoc`, `uncons` are @O\(1\)@ (worst case).
|
||||
-- Upper bounds of `consQ`, `snocQ`, `unconsQ` are @O\(1\)@ (worst case).
|
||||
--
|
||||
-- Invariant: sum of lengths of two last least is equal the length of the first
|
||||
-- one.
|
||||
@ -212,12 +212,12 @@ instance Show (Queue f r s) where
|
||||
emptyQ :: Queue (f :: k -> k -> *) a a
|
||||
emptyQ = Queue NilTr NilTr NilTr
|
||||
|
||||
cons :: forall (f :: k -> k -> *) a b c.
|
||||
f b c
|
||||
-> Queue f a b
|
||||
-> Queue f a c
|
||||
cons bc (Queue f r s) = Queue (ConsTr bc f) r (ConsTr undefined s)
|
||||
{-# INLINE cons #-}
|
||||
consQ :: forall (f :: k -> k -> *) a b c.
|
||||
f b c
|
||||
-> Queue f a b
|
||||
-> Queue f a c
|
||||
consQ bc (Queue f r s) = Queue (ConsTr bc f) r (ConsTr undefined s)
|
||||
{-# INLINE consQ #-}
|
||||
|
||||
data ViewL f a b where
|
||||
EmptyL :: ViewL f a a
|
||||
@ -225,26 +225,26 @@ data ViewL f a b where
|
||||
|
||||
-- | 'uncons' a 'Queue', complexity: @O\(1\)@
|
||||
--
|
||||
uncons :: Queue f a b
|
||||
-> ViewL f a b
|
||||
uncons (Queue NilTr NilTr _) = EmptyL
|
||||
uncons (Queue (ConsTr tr f) r s) = tr :< exec f r s
|
||||
uncons _ = error "Queue.uncons: invariant violation"
|
||||
{-# INLINE uncons #-}
|
||||
unconsQ :: Queue f a b
|
||||
-> ViewL f a b
|
||||
unconsQ (Queue NilTr NilTr _) = EmptyL
|
||||
unconsQ (Queue (ConsTr tr f) r s) = tr :< exec f r s
|
||||
unconsQ _ = error "Queue.uncons: invariant violation"
|
||||
{-# INLINE unconsQ #-}
|
||||
|
||||
snoc :: forall (f :: k -> k -> *) a b c.
|
||||
Queue f b c
|
||||
-> f a b
|
||||
-> Queue f a c
|
||||
snoc (Queue f r s) g = exec f (ConsTr (Op g) r) s
|
||||
{-# INLINE snoc #-}
|
||||
snocQ :: forall (f :: k -> k -> *) a b c.
|
||||
Queue f b c
|
||||
-> f a b
|
||||
-> Queue f a 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 <- (uncons -> a :< as) where
|
||||
ConsQ = cons
|
||||
pattern ConsQ a as <- (unconsQ -> a :< as) where
|
||||
ConsQ = consQ
|
||||
|
||||
pattern NilQ :: () => a ~ b => Queue f a b
|
||||
pattern NilQ <- (uncons -> EmptyL) where
|
||||
pattern NilQ <- (unconsQ -> EmptyL) where
|
||||
NilQ = emptyQ
|
||||
|
||||
#if __GLASGOW_HASKELL__ > 802
|
||||
|
@ -20,11 +20,11 @@ import Test.Tasty.QuickCheck (testProperty)
|
||||
tests :: TestTree
|
||||
tests =
|
||||
testGroup "Queue"
|
||||
[ testProperty "cons" prop_cons
|
||||
, testProperty "uncons" prop_uncons
|
||||
, testProperty "snoc" prop_snoc
|
||||
, testProperty "foldr" (prop_foldr @Int)
|
||||
, testProperty "foldr" (prop_foldl @Int)
|
||||
[ testProperty "consQ" prop_consQ
|
||||
, testProperty "unconsQ" prop_unconsQ
|
||||
, testProperty "snocQ" prop_snocQ
|
||||
, testProperty "foldrQ" (prop_foldr @Int)
|
||||
, testProperty "foldrQ" (prop_foldl @Int)
|
||||
]
|
||||
|
||||
data K = K
|
||||
@ -58,21 +58,21 @@ instance Arbitrary (Queue Tr 'K 'K) where
|
||||
shrink q = map fromList $ shrinkList (const []) (toList q)
|
||||
|
||||
|
||||
prop_uncons :: Queue Tr 'K 'K -> Bool
|
||||
prop_uncons q = case (q, toList q) of
|
||||
prop_unconsQ :: Queue Tr 'K 'K -> Bool
|
||||
prop_unconsQ q = case (q, toList q) of
|
||||
(ConsQ a@A{} _, a' : _) -> a == a'
|
||||
(NilQ, []) -> True
|
||||
_ -> False
|
||||
|
||||
|
||||
prop_cons :: Tr 'K 'K -> Queue Tr 'K 'K -> Bool
|
||||
prop_cons a@A{} q = case cons a q of
|
||||
prop_consQ :: Tr 'K 'K -> Queue Tr 'K 'K -> Bool
|
||||
prop_consQ a@A{} q = case consQ a q of
|
||||
ConsQ a'@A{} _ -> a' == a'
|
||||
_ -> False
|
||||
|
||||
|
||||
prop_snoc :: Tr 'K 'K -> Queue Tr 'K 'K -> Bool
|
||||
prop_snoc a@A{} q = last (toList (q `snoc` a)) == a
|
||||
prop_snocQ :: Tr 'K 'K -> Queue Tr 'K 'K -> Bool
|
||||
prop_snocQ a@A{} q = last (toList (q `snocQ` a)) == a
|
||||
|
||||
|
||||
data TrA a (x :: K) (y :: K) where
|
||||
|
Loading…
Reference in New Issue
Block a user