-- | -- Module : Data.Edison.Seq.Defaults -- Copyright : Copyright (c) 1998, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : internal (unstable) -- Portability : GHC, Hugs (MPTC and FD) -- -- This module provides default implementations of many of -- the sequence operations. It is used to fill in implementations -- and is not intended for end users. module Data.Edison.Seq.Defaults 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 Control.Monad.Identity import Data.Char (isSpace) import Data.Edison.Seq import qualified Data.Edison.Seq.ListSeq as L rconsUsingAppend :: Sequence s => a -> s a -> s a rconsUsingAppend x s = append s (singleton x) rconsUsingFoldr :: Sequence s => a -> s a -> s a rconsUsingFoldr x s = foldr lcons (singleton x) s appendUsingFoldr :: Sequence s => s a -> s a -> s a appendUsingFoldr s t | null t = s | otherwise = foldr lcons t s rviewDefault :: (Monad m, Sequence s) => s a -> m (a, s a) rviewDefault xs | null xs = fail $ instanceName xs ++ ".rview: empty sequence" | otherwise = return (rhead xs, rtail xs) rtailUsingLview :: (Sequence s) => s a -> s a rtailUsingLview xs = case lview xs of Nothing -> error $ instanceName xs ++ ".rtail: empty sequence" Just (x, xs) -> rt x xs where rt x xs = case lview xs of Nothing -> empty Just (y, ys) -> lcons x (rt y ys) rtailMUsingLview :: (Monad m,Sequence s) => s a -> m (s a) rtailMUsingLview xs = case lview xs of Nothing -> fail $ instanceName xs ++ ".rtailM: empty sequence" Just (x, xs) -> return (rt x xs) where rt x xs = case lview xs of Nothing -> empty Just (y, ys) -> lcons x (rt y ys) concatUsingFoldr :: Sequence s => s (s a) -> s a concatUsingFoldr = foldr append empty reverseUsingReverseOnto :: Sequence s => s a -> s a reverseUsingReverseOnto s = reverseOnto s empty reverseUsingLists :: Sequence s => s a -> s a reverseUsingLists = fromList . L.reverse . toList reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a reverseOntoUsingReverse = append . reverse fromListUsingCons :: Sequence s => [a] -> s a fromListUsingCons = L.foldr lcons empty toListUsingFoldr :: Sequence s => s a -> [a] toListUsingFoldr = foldr (:) [] mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b mapUsingFoldr f = foldr (lcons . f) empty concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b concatMapUsingFoldr f = foldr (append . f) empty foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b foldrUsingLists f e xs = L.foldr f e (toList xs) foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b foldr'UsingLists f e xs = L.foldr' f e (toList xs) foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b foldlUsingLists f e xs = L.foldl f e (toList xs) foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b foldl'UsingLists f e xs = L.foldl' f e (toList xs) foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldr1UsingLists f xs = L.foldr1 f (toList xs) foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldr1'UsingLists f xs = L.foldr1' f (toList xs) foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldl1UsingLists f xs = L.foldl1 f (toList xs) foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldl1'UsingLists f xs = L.foldl1' f (toList xs) fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a fold1UsingFold f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".fold1: empty sequence" Just (x, xs) -> fold f x xs fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a fold1'UsingFold' f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".fold1': empty sequence" Just (x, xs) -> fold' f x xs foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a foldr1UsingLview f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldr1: empty sequence" Just (x, xs) -> fr1 x xs where fr1 x xs = case lview xs of Nothing -> x Just (y,ys) -> f x (fr1 y ys) foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a foldr1'UsingLview f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldr1': empty sequence" Just (x,xs) -> fr1 x xs where fr1 x xs = case lview xs of Nothing -> x Just (y,ys) -> f x $! (fr1 y ys) foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a foldl1UsingFoldl f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldl1: empty sequence" Just (x,xs) -> foldl f x xs foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a foldl1'UsingFoldl' f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldl1': empty sequence" Just (x,xs) -> foldl' f x xs reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a reducerUsingReduce1 f e s | null s = e | otherwise = f (reduce1 f s) e reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a reducer'UsingReduce1' f e s | null s = e | otherwise = f (reduce1' f s) e reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a reducelUsingReduce1 f e s | null s = e | otherwise = f e (reduce1 f s) reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a reducel'UsingReduce1' f e s | null s = e | otherwise = f e (reduce1' f s) reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a reduce1UsingLists f s = L.reduce1 f (toList s) reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a reduce1'UsingLists f s = L.reduce1' f (toList s) copyUsingLists :: Sequence s => Int -> a -> s a copyUsingLists n x = fromList (L.copy n x) inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool inBoundsUsingDrop i s = i >= 0 && not (null (drop i s)) inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool inBoundsUsingLookupM i s = case lookupM i s of Just _ -> True Nothing -> False inBoundsUsingSize :: Sequence s => Int -> s a -> Bool inBoundsUsingSize i s = i >= 0 && i < size s lookupUsingLookupM :: Sequence s => Int -> s a -> a lookupUsingLookupM i s = runIdentity (lookupM i s) lookupUsingDrop :: Sequence s => Int -> s a -> a lookupUsingDrop i s | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript" | otherwise = lhead s' where s' = drop i s lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a lookupWithDefaultUsingLookupM d i s = case lookupM i s of Nothing -> d Just x -> x lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a lookupWithDefaultUsingDrop d i s | i < 0 || null s' = d | otherwise = lhead s' where s' = drop i s lookupMUsingDrop :: (Monad m, Sequence s) => Int -> s a -> m a lookupMUsingDrop i s -- XXX better error message! | i < 0 || null s' = fail $ instanceName s ++ ".lookupMUsingDrop: empty sequence" | otherwise = return (lhead s') where s' = drop i s filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a filterUsingLview p xs = case lview xs of Nothing -> empty Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a filterUsingLists p xs = fromList (L.filter p (toList xs)) filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a filterUsingFoldr p = foldr pcons empty where pcons x xs = if p x then lcons x xs else xs partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a) partitionUsingLists p xs = let (ys,zs) = L.partition p (toList xs) in (fromList ys, fromList zs) partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a) partitionUsingFoldr p = foldr pcons (empty, empty) where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs') updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a updateUsingAdjust i y = adjust (const y) i updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a updateUsingSplitAt i x xs | i < 0 = xs | otherwise = let (ys,zs) = splitAt i xs in if null zs then xs else append ys (lcons x (ltail zs)) adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a adjustUsingLists f i xs = fromList (L.adjust f i (toList xs)) adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a adjustUsingSplitAt f i xs | i < 0 = xs | otherwise = let (ys,zs) = splitAt i xs in case lview zs of Nothing -> xs Just (z,zs') -> append ys (lcons (f z) zs') {- insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a insertAtUsingLists i x xs = fromList (L.insertAt i x (toList xs)) insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a insertAtUsingSplitAt i x xs | (xs_before, xs_after) <- splitAt i xs = append xs_before (lcons x xs_after) deleteAtUsingLists :: Sequence s => Int -> s a -> s a deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs)) deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a deleteAtUsingSplitAt i xs | (xs_before, xs_after) <- splitAt i xs = append xs_before (ltail xs_after) -} mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs)) foldrWithIndexUsingLists :: Sequence s => (Int -> a -> b -> b) -> b -> s a -> b foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs) foldrWithIndex'UsingLists :: Sequence s => (Int -> a -> b -> b) -> b -> s a -> b foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs) foldlWithIndexUsingLists :: Sequence s => (b -> Int -> a -> b) -> b -> s a -> b foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs) foldlWithIndex'UsingLists :: Sequence s => (b -> Int -> a -> b) -> b -> s a -> b foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs) takeUsingLists :: Sequence s => Int -> s a -> s a takeUsingLists i s = fromList (L.take i (toList s)) takeUsingLview :: Sequence s => Int -> s a -> s a takeUsingLview i xs | i <= 0 = empty | otherwise = case lview xs of Nothing -> empty Just (x,xs') -> lcons x (take (i-1) xs') dropUsingLists :: Sequence s => Int -> s a -> s a dropUsingLists i s = fromList (L.drop i (toList s)) dropUsingLtail :: Sequence s => Int -> s a -> s a dropUsingLtail i xs | i <= 0 || null xs = xs | otherwise = dropUsingLtail (i-1) (ltail xs) splitAtDefault :: Sequence s => Int -> s a -> (s a, s a) splitAtDefault i s = (take i s, drop i s) splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a) splitAtUsingLview i xs | i <= 0 = (empty,xs) | otherwise = case lview xs of Nothing -> (empty,empty) Just (x,xs') -> (lcons x ys,zs) where (ys,zs) = splitAtUsingLview (i-1) xs' subseqDefault :: Sequence s => Int -> Int -> s a -> s a subseqDefault i len xs = take len (drop i xs) takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a takeWhileUsingLview p xs = case lview xs of Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs') _ -> empty dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a dropWhileUsingLview p xs = case lview xs of Just (x,xs') | p x -> dropWhileUsingLview p xs' _ -> xs splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a) splitWhileUsingLview p xs = case lview xs of Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs' in (lcons x front, back) _ -> (empty, xs) zipUsingLview :: Sequence s => s a -> s b -> s (a,b) zipUsingLview xs ys = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys') zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c) zip3UsingLview xs ys zs = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> case lview zs of Nothing -> empty Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs') zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c zipWithUsingLview f xs ys = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys') zipWith3UsingLview :: Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d zipWith3UsingLview f xs ys zs = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> case lview zs of Nothing -> empty Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs') zipUsingLists :: Sequence s => s a -> s b -> s (a,b) zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys)) zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c) zip3UsingLists xs ys zs = fromList (L.zip3 (toList xs) (toList ys) (toList zs)) zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c zipWithUsingLists f xs ys = fromList (L.zipWith f (toList xs) (toList ys)) zipWith3UsingLists :: Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d zipWith3UsingLists f xs ys zs = fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs)) unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b) unzipUsingLists xys = case L.unzip (toList xys) of (xs, ys) -> (fromList xs, fromList ys) unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b) unzipUsingFoldr = foldr pcons (empty,empty) where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys) unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c) unzip3UsingLists xyzs = case L.unzip3 (toList xyzs) of (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs) unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c) unzip3UsingFoldr = foldr tcons (empty,empty,empty) where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs) unzipWithUsingLists :: Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c) unzipWithUsingLists f g xys = case L.unzipWith f g (toList xys) of (xs, ys) -> (fromList xs, fromList ys) unzipWithUsingFoldr :: Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c) unzipWithUsingFoldr f g = foldr pcons (empty,empty) where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys) unzipWith3UsingLists :: Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d) unzipWith3UsingLists f g h xyzs = case L.unzipWith3 f g h (toList xyzs) of (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs) unzipWith3UsingFoldr :: Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d) unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty) where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs) showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS showsPrecUsingToList i xs rest | i == 0 = concat [ instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest) readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a) readsPrecUsingFromList _ xs = let result = maybeParens p xs p xs = tokenMatch ((instanceName x)++".fromList") xs >>= readsPrec 10 >>= \(l,rest) -> return (fromList l,rest) -- play games with the typechecker so we don't have to use -- extensions for scoped type variables ~[(x,_)] = result in result defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering defaultCompare a b = case (lview a, lview b) of (Nothing, Nothing) -> EQ (Nothing, _ ) -> LT (_ , Nothing) -> GT (Just (x,xs), Just (y,ys)) -> case compare x y of EQ -> defaultCompare xs ys c -> c dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a] dropMatch [] ys = return ys dropMatch (x:xs) (y:ys) | x == y = dropMatch xs ys | otherwise = mzero dropMatch _ _ = mzero tokenMatch :: MonadPlus m => String -> String -> m String tokenMatch token str = dropMatch token (munch str) >>= return . munch where munch = dropWhile isSpace readSParens :: ReadS a -> ReadS a readSParens p xs = return xs >>= tokenMatch "(" >>= p >>= \(x,xs') -> return xs' >>= tokenMatch ")" >>= \rest -> return (x,rest) maybeParens :: ReadS a -> ReadS a maybeParens p xs = readSParens p xs `mplus` p xs