-- | -- Module : Data.Edison.Seq.JoinList -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Join lists. All running times are as listed in "Data.Edison.Seq" except -- for the following: -- -- * rcons, append @O( 1 )@ -- -- * ltail*, lview @O( 1 )@ when used single-threaded, @O( n )@ otherwise -- -- * lhead* @O( n )@ -- -- * inBounds, lookup @O( n )@ -- -- * copy @O( log i )@ -- -- * concat @O( n1 )@ -- -- * concatMap, (>>=) @O( n * t )@, where @n@ is the length of the input sequence and -- @t@ is the running time of @f@ module Data.Edison.Seq.JoinList ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldlWithIndex, take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Data.Edison.Seq as S ( Sequence(..) ) import Data.Edison.Seq.Defaults import Control.Monad import Data.Monoid import Test.QuickCheck -- signatures for exported functions moduleName :: String empty :: Seq a singleton :: a -> Seq a lcons :: a -> Seq a -> Seq a rcons :: a -> Seq a -> Seq a append :: Seq a -> Seq a -> Seq a lview :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.JoinList" data Seq a = E | L a | A (Seq a) (Seq a) -- invariant: E never a child of A half :: Int -> Int half n = n `div` 2 empty = E singleton = L lcons x E = L x lcons x xs = A (L x) xs rcons x E = L x rcons x xs = A xs (L x) append E ys = ys append xs E = xs append xs ys = A xs ys -- path reversal on lview/ltail lview E = fail "JoinList.lview: empty sequence" lview (L x) = return (x, E) lview (A xs ys) = lvw xs ys where lvw E _ = error "JoinList.lvw: bug" lvw (L x) zs = return (x, zs) lvw (A xs ys) zs = lvw xs (A ys zs) lhead E = error "JoinList.lhead: empty sequence" lhead (L x) = x lhead (A xs _) = lhead xs lheadM E = fail "JoinList.lheadM: empty sequence" lheadM (L x) = return x lheadM (A xs _) = lheadM xs ltail E = error "JoinList.ltail: empty sequence" ltail (L _) = E ltail (A xs ys) = ltl xs ys where ltl E _ = error "JoinList.ltl: bug" ltl (L _) zs = zs ltl (A xs ys) zs = ltl xs (A ys zs) ltailM E = fail "JoinList.ltailM: empty sequence" ltailM (L _) = return E ltailM (A xs ys) = return (ltl xs ys) where ltl E _ = error "JoinList.ltl: bug" ltl (L _) zs = zs ltl (A xs ys) zs = ltl xs (A ys zs) -- Don't want to do plain path reversal on rview/rtail because of expectation -- that left accesses are more common, so we would prefer to keep the left -- spine short. rview E = fail "JoinLis.rview: empty sequence" rview (L x) = return (x, E) rview (A xs ys) = rvw xs ys where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s rvw xs (A ys (L x)) = return (x, A xs ys) rvw xs (L x) = return (x, xs) rvw _ _ = error "JoinList.rvw: bug" rhead E = error "JoinList.rhead: empty sequence" rhead (L x) = x rhead (A _ ys) = rhead ys rheadM E = fail "JoinList.rheadM: empty sequence" rheadM (L x) = return x rheadM (A _ ys) = rheadM ys rtail E = error "JoinList.rtail: empty sequence" rtail (L _) = E rtail (A xs ys) = rtl xs ys where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s) rtl xs (A ys (L _)) = A xs ys rtl xs (L _) = xs rtl _ _ = error "JoinList.rtl: bug" rtailM E = fail "JoinList.rtailM: empty sequence" rtailM (L _) = return E rtailM (A xs ys) = return (rtl xs ys) where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s) rtl xs (A ys (L _)) = A xs ys rtl xs (L _) = xs rtl _ _ = error "JoinList.rtl: bug" null E = True null _ = False size xs = sz xs (0::Int) where sz E n = n sz (L _) n = n + (1::Int) sz (A xs ys) n = sz xs (sz ys n) reverse (A xs ys) = A (reverse ys) (reverse xs) reverse xs = xs -- L x or E toList xs = tol xs [] where tol E rest = rest tol (L x) rest = x:rest tol (A xs ys) rest = tol xs (tol ys rest) map _ E = E map f (L x) = L (f x) map f (A xs ys) = A (map f xs) (map f ys) fold = foldr fold' = foldr' fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr _ e E = e foldr f e (L x) = f x e foldr f e (A xs ys) = foldr f (foldr f e ys) xs foldr' _ e E = e foldr' f e (L x) = f x $! e foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs foldl _ e E = e foldl f e (L x) = f e x foldl f e (A xs ys) = foldl f (foldl f e xs) ys foldl' _ e E = e foldl' f e (L x) = e `seq` f e x foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys foldr1 _ E = error "JoinList.foldr1: empty sequence" foldr1 _ (L x) = x foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs foldr1' _ E = error "JoinLis.foldr1': empty sequence" foldr1' _ (L x) = x foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs foldl1 _ E = error "JoinList.foldl1: empty sequence" foldl1 _ (L x) = x foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys foldl1' _ E = error "JoinList.foldl1': empty sequence" foldl1' _ (L x) = x foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys copy n x | n <= 0 = E | otherwise = cpy n x where cpy n x -- n > 0 | even n = let xs = cpy (half n) x in A xs xs | n == 1 = L x | otherwise = let xs = cpy (half n) x in A (L x) (A xs xs) strict s@E = s strict s@(L _) = s strict s@(A l r) = strict l `seq` strict r `seq` s strictWith _ s@E = s strictWith f s@(L x) = f x `seq` s strictWith f s@(A l _) = strictWith f l `seq` strictWith f l `seq` s -- invariants: -- * 'E' is never a child of 'A' structuralInvariant E = True structuralInvariant s = check s where check E = False check (L _) = True check (A s1 s2) = check s1 && check s2 concat = concatUsingFoldr reverseOnto = reverseOntoUsingReverse fromList = fromListUsingCons concatMap = concatMapUsingFoldr reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' reduce1 = reduce1UsingLists reduce1' = reduce1'UsingLists inBounds = inBoundsUsingDrop lookup = lookupUsingDrop lookupM = lookupMUsingDrop lookupWithDefault = lookupWithDefaultUsingDrop update = updateUsingSplitAt adjust = adjustUsingSplitAt mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists take = takeUsingLview drop = dropUsingLtail splitAt = splitAtUsingLview subseq = subseqDefault filter = filterUsingLview partition = partitionUsingFoldr takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview zip = zipUsingLview zip3 = zip3UsingLview zipWith = zipWithUsingLview zipWith3 = zipWith3UsingLview unzip = unzipUsingFoldr unzip3 = unzip3UsingFoldr unzipWith = unzipWithUsingFoldr unzipWith3 = unzipWith3UsingFoldr -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance Monad Seq where return = singleton xs >>= k = concatMap k xs instance MonadPlus Seq where mplus = append mzero = empty instance Eq a => Eq (Seq a) where xs == ys = toList xs == toList ys instance Ord a => Ord (Seq a) where compare = defaultCompare instance Show a => Show (Seq a) where showsPrec = showsPrecUsingToList instance Read a => Read (Seq a) where readsPrec = readsPrecUsingFromList instance Arbitrary a => Arbitrary (Seq a) where arbitrary = sized arbTree where arbTree 0 = return E arbTree 1 = liftM L arbitrary arbTree n = frequency [(1, liftM L arbitrary), (4, liftM2 A (arbTree (n `div` 2)) (arbTree (n `div` 2)))] instance CoArbitrary a => CoArbitrary (Seq a) where coarbitrary E = variant 0 coarbitrary (L x) = variant 1 . coarbitrary x coarbitrary (A xs ys) = variant 2 . coarbitrary xs . coarbitrary ys instance Monoid (Seq a) where mempty = empty mappend = append