{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeFamilies, DeriveDataTypeable, DeriveGeneric #-} {-# LANGUAGE Trustworthy, UndecidableInstances, BangPatterns #-} {- | Module : SDP.Templates.AnyChunks Copyright : (c) Andrey Mulik 2020 License : BSD-style Maintainer : work.a.mulik@gmail.com Portability : non-portable (GHC extensions) "SDP.Templates.AnyChunks" provides 'AnyChunks' - list of data chunks. -} module SDP.Templates.AnyChunks ( -- * Export module SDP.IndexedM, module SDP.Scan, -- * Chunk list AnyChunks, fromChunks, fromChunksM, toChunks ) where import Prelude () import SDP.SafePrelude import SDP.IndexedM import SDP.SortM import SDP.Scan import qualified GHC.Exts as E import GHC.Generics import Data.Default.Class import Data.Typeable import Data.String import Data.Data import Text.Read.SDP import Text.Show.SDP import SDP.SortM.Tim import Control.Exception.SDP default () -------------------------------------------------------------------------------- {- | 'AnyChunks' is list of data chunks. AnyChunks shouldn't contain empty chunks, so the 'AnyChunks' constructor is made private (see 'fromChunks' and 'fromChunksM'). * Efficiency of operations on @'AnyChunks' rep e@ are very sensitive in the efficiency of 'Bordered', 'Linear' and 'Split' on @rep e@. * @'AnyChunks' rep e@ is only defined for Int-indexed @rep e@. * 'Eq', 'Ord', 'Eq1' and 'Ord1' instances compare @'AnyChunks' rep e@ as streams of equal size chunks. To do this, the comparison @rep e@ must also be lexicographic, also for @rep e@ must implement 'Bordered' and 'Split'. * 'Freeze' and 'Thaw' for @'AnyChunks' rep e@ are defined for all @rep e@ that already have 'Freeze' and 'Thaw' instances. -} newtype AnyChunks rep e = AnyChunks [rep e] deriving ( Typeable, Data, Generic ) -- | Construct immutable 'AnyChunks' safely. fromChunks :: (Nullable (rep e)) => [rep e] -> AnyChunks rep e fromChunks = AnyChunks . except isNull -- | Construct mutable 'AnyChunks' safely. fromChunksM :: (BorderedM1 m rep Int e) => [rep e] -> m (AnyChunks rep e) fromChunksM = fmap AnyChunks . go where go (x : xs) = do n <- getSizeOf x; n == 0 ? go xs $ (x :) <$> go xs go [] = return [] -- | Extract immutable 'AnyChunks' chunks safely. toChunks :: AnyChunks rep e -> [rep e] toChunks = E.coerce -------------------------------------------------------------------------------- {- Eq and Ord instances. -} instance (Eq (rep e), Bordered1 rep Int e, Split1 rep e) => Eq (AnyChunks rep e) where Z == Z = True xs@(AnyChunks (x : xs')) == ys@(AnyChunks (y : ys')) = if n1 > n2 then take n2 x == y && drop n2 xs == AnyChunks ys' else take n1 y == x && drop n1 ys == AnyChunks xs' where n1 = sizeOf x n2 = sizeOf y _ == _ = False instance (Ord (rep e), Bordered1 rep Int e, Split1 rep e) => Ord (AnyChunks rep e) where compare Z Z = EQ compare xs@(AnyChunks (x : xs')) ys@(AnyChunks (y : ys')) = if n1 > n2 then (take n2 x <=> y) <> (drop n2 xs <=> AnyChunks ys') else (x <=> take n1 y) <> (AnyChunks xs' <=> drop n1 ys) where n1 = sizeOf x n2 = sizeOf y compare Z _ = LT compare _ _ = GT -------------------------------------------------------------------------------- {- Show and Read instances. -} instance {-# OVERLAPPABLE #-} (Indexed1 rep Int e, Show e) => Show (AnyChunks rep e) where showsPrec = assocsPrec "unlist " instance (Indexed1 rep Int Char) => Show (AnyChunks rep Char) where showsPrec = shows ... const listL instance (Indexed1 rep Int e, Read e) => Read (AnyChunks rep e) where readPrec = indexedPrec' "ublist" readList = readListDefault -------------------------------------------------------------------------------- {- Semigroup, Monoid, Nullable, Default and Estimate instances. -} instance Nullable (AnyChunks rep e) where isNull = \ (AnyChunks es) -> null es lzero = AnyChunks [] instance Semigroup (AnyChunks rep e) where AnyChunks xs <> AnyChunks ys = AnyChunks (xs ++ ys) instance Monoid (AnyChunks rep e) where mempty = AnyChunks [] instance Default (AnyChunks rep e) where def = AnyChunks [] instance (Bordered1 rep Int e) => Estimate (AnyChunks rep e) where (<==>) = go 0 where go o (AnyChunks []) (AnyChunks []) = o <=> 0 go o (AnyChunks []) ys = o <=.> ys go o xs (AnyChunks []) = xs <.=> (-o) go o (AnyChunks (x : xs)) (AnyChunks (y : ys)) = go (o + sizeOf x - sizeOf y) (AnyChunks xs) (AnyChunks ys) (AnyChunks []) <.=> n = 0 <=> n (AnyChunks (x : xs)) <.=> n = c > n ? GT $ AnyChunks xs <.=> (n - c) where c = sizeOf x -------------------------------------------------------------------------------- {- Overloaded Lists and Strings support. -} instance (Linear1 (AnyChunks rep) Char) => IsString (AnyChunks rep Char) where fromString = fromList instance (Linear1 (AnyChunks rep) e) => E.IsList (AnyChunks rep e) where type Item (AnyChunks rep e) = e fromListN = fromListN fromList = fromList toList = listL -------------------------------------------------------------------------------- {- Functor and Applicative instances. -} instance (Functor rep) => Functor (AnyChunks rep) where fmap f (AnyChunks es) = AnyChunks (fmap f <$> es) instance (Applicative rep) => Applicative (AnyChunks rep) where AnyChunks fs <*> AnyChunks es = AnyChunks $ liftA2 (<*>) fs es pure e = AnyChunks [pure e] -------------------------------------------------------------------------------- {- Foldable and Traversable instances. -} instance (Foldable rep) => Foldable (AnyChunks rep) where foldr f base (AnyChunks es) = flip (foldr f) `foldr` base $ es foldl f base (AnyChunks es) = foldl (foldl f) base es elem e (AnyChunks es) = foldr ((||) . elem e) False es length (AnyChunks es) = foldr' ((+) . length) 0 es null (AnyChunks es) = null es instance (Traversable rep) => Traversable (AnyChunks rep) where traverse f (AnyChunks es) = AnyChunks <$> traverse (traverse f) es -------------------------------------------------------------------------------- {- Bordered, Linear and Split instances. -} instance (Bordered1 rep Int e) => Bordered (AnyChunks rep e) Int where sizeOf (AnyChunks es) = foldr' ((+) . sizeOf) 0 es indexIn es = \ i -> i >= 0 && i <. es -- | Quick unchecked offset. offsetOf = const id -- | Quick unchecked index. indexOf = const id lower _ = 0 upper es = sizeOf es - 1 bounds es = (0, sizeOf es - 1) instance (Bordered1 rep Int e, Linear1 rep e) => Linear (AnyChunks rep e) e where single e = AnyChunks [single e] toHead e (AnyChunks es@(x : xs)) = AnyChunks $ sizeOf x < lim ? (e :> x) : xs $ single e : es toHead e _ = single e toLast (AnyChunks (xs :< x)) e = isNull x ? AnyChunks xs :< e $ AnyChunks (xs :< (x :< e)) toLast _ e = single e uncons = go . toChunks where go ((x :> xs) : xss) = (x, AnyChunks (xs : xss)) go _ = pfailEx "(:>)" unsnoc = go . toChunks where go (xss :< (xs :< x)) = (AnyChunks (xss :< xs), x) go _ = pfailEx "(:<)" fromList = AnyChunks . fmap fromList . chunks lim listL = foldr ((++) . listL) [] . toChunks (AnyChunks (x : xs)) !^ i = let n = sizeOf x in i < n ? x !^ i $ AnyChunks xs !^ (i - n) _ !^ _ = error "in SDP.Unrolled.Unlist.(!^)" write es'@(AnyChunks es) n e = let go i (x : xs) = let c = sizeOf x in i < c ? write x i e : xs $ x : go (i - c) xs go _ xs = xs in n < 0 ? es' $ AnyChunks (go n es) -- | Deduplicated chunks. replicate n e = AnyChunks $ replicate count chunk :< rest where (count, rst) = n `divMod` lim chunk = replicate lim e rest = replicate rst e reverse (AnyChunks es) = AnyChunks (reverse <$> reverse es) force (AnyChunks es) = AnyChunks (force <$> es) partition p = both fromList . partition p . listL select f (AnyChunks es) = concatMap (select f) es extract f (AnyChunks es) = bimap concat AnyChunks . unzip $ extract f <$> es selects fs = second fromList . selects fs . listL ofoldr f' base' = go 0 f' base' . toChunks where go o f base (x : xs) = ofoldr (f . (o +)) (go (o + sizeOf x) f base xs) x go _ _ base _ = base ofoldl f' base' = go 0 f' base' . toChunks where go o f base (x : xs) = go (o + sizeOf x) f (ofoldl (f . (o +)) base x) xs go _ _ base _ = base o_foldr f base = foldr (flip $ o_foldr f) base . toChunks o_foldl f base = foldl (o_foldl f) base . toChunks instance (Bordered1 rep Int e, Split1 rep e) => Split (AnyChunks rep e) e where take n = AnyChunks . go n . toChunks where go c (x : xs) = let s = sizeOf x in case c <=> s of GT -> x : go (c - s) xs LT -> [take c x] EQ -> [x] go _ [] = [] drop n = AnyChunks . go n . toChunks where go c (x : xs) = let s = sizeOf x in case c <=> s of GT -> go (c - s) xs LT -> drop c x : xs EQ -> xs go _ [] = [] prefix f = foldr' (\ e n -> let p = prefix f e in p ==. e ? p + n $ p) 0 . toChunks suffix f = foldl' (\ n e -> let s = suffix f e in s ==. e ? s + n $ s) 0 . toChunks combo f = foldr' (\ e n -> let c = combo f e in c ==. e ? c + n $ c) 0 . toChunks -------------------------------------------------------------------------------- {- BorderedM, LinearM and SplitM instances. -} instance (BorderedM1 m rep Int e) => BorderedM m (AnyChunks rep e) Int where getLower _ = return 0 getUpper es = do n <- getSizeOf es; return (n - 1) getSizeOf = foldr (liftA2 (+) . getSizeOf) (return 0) . toChunks getIndices es = do n <- getSizeOf es; return [0 .. n - 1] nowIndexIn es = \ i -> i < 0 ? return False $ do n <- getSizeOf es; return (i < n) instance (BorderedM1 m rep Int e, SplitM1 m rep e) => LinearM m (AnyChunks rep e) e where nowNull = fmap and . mapM nowNull . toChunks getHead = getHead . head . toChunks getLast = getLast . last . toChunks newNull = return (AnyChunks []) prepend e' es' = AnyChunks <$> go e' (toChunks es') where go e es@(x : xs) = do n <- getSizeOf x; n < lim ? (: xs) <$> prepend e x $ (: es) <$> newLinear [e] go e _ = pure <$> newLinear [e] append es' e' = AnyChunks <$> go e' (toChunks es') where go e es@(xs :< x) = do n <- getSizeOf x; n < lim ? (xs :<) <$> append x e $ (es :<) <$> newLinear [e] go e _ = pure <$> newLinear [e] newLinear = fmap AnyChunks . mapM newLinear . chunks lim (!#>) (AnyChunks es) = go es where go (x : xs) i = do n <- getSizeOf x; i < n ? x !#> i $ go xs (i - n) go _ _ = overEx "(>!)" {-# INLINE writeM #-} writeM = go . toChunks where go (x : xs) i e = do n <- getSizeOf x; i < n ? writeM x i e $ go xs (i - n) e go _ _ _ = return () getLeft (AnyChunks es) = concat <$> mapM getLeft es getRight (AnyChunks es) = (concat . reverse) <$> mapM getRight es reversed (AnyChunks es) = (AnyChunks . reverse) <$> mapM reversed es filled c e = AnyChunks <$> sequence (replicate d (filled lim e) :< filled n e) where (d, n) = c `divMod` lim -- TODO: rewrite without SplitM copyTo src os trg ot c = when (c > 0) $ do when (os < 0 || ot < 0) $ underEx "copyTo" src' <- dropM os src trg' <- dropM ot trg go c src' trg' where go n xs@(AnyChunks (x : _)) ys@(AnyChunks (y : _)) = do n1 <- getSizeOf x n2 <- getSizeOf y let n' = minimum [n1, n2, n] copyTo x 0 y 0 n' dropM n' xs >>=<< dropM n' ys $ go (n - n') go n _ _ = when (n > 0) $ overEx "copyTo" -- | Unsafe, returns joined stream of existing chunks. merged = return . AnyChunks . foldr ((++) . toChunks) [] ofoldrM f base' = ofoldrCh 0 base' . toChunks where ofoldrCh !o base (x : xs) = do n <- getSizeOf x xs' <- ofoldrCh (o + n) base xs ofoldrM (f . (o +)) xs' x ofoldrCh _ base _ = return base ofoldlM f base' = ofoldlCh 0 base' . toChunks where ofoldlCh !o base (x : xs) = do n <- getSizeOf x x' <- ofoldlM (f . (o +)) base x ofoldlCh (o + n) x' xs ofoldlCh _ base _ = return base foldrM f base = foldr ((=<<) . flip (foldrM f)) (return base) . toChunks foldlM f base = foldl (flip $ (=<<) . flip (foldlM f)) (return base) . toChunks instance (BorderedM1 m rep Int e, SplitM1 m rep e) => SplitM m (AnyChunks rep e) e where takeM n (AnyChunks (e : es)) = n < 1 ? newNull $ do c <- getSizeOf e case n <=> c of EQ -> return (AnyChunks [e]) LT -> do t <- takeM n e; return (AnyChunks [t]) GT -> do (AnyChunks ts) <- takeM (n - c) (AnyChunks es); return $ AnyChunks (e : ts) takeM _ es = return es dropM n es'@(AnyChunks (e : es)) = n < 1 ? return es' $ do c <- getSizeOf e case n <=> c of EQ -> return (AnyChunks es) GT -> dropM (n - c) (AnyChunks es) LT -> do d <- dropM n e; return $ AnyChunks (d : es) dropM _ es = return es prefixM f (AnyChunks es) = foldr (\ e p -> do n <- getSizeOf e; c <- prefixM f e; c == n ? (+ c) <$> p $ return c) (return 0) es suffixM f (AnyChunks es) = foldl (\ p e -> do n <- getSizeOf e; c <- suffixM f e; c == n ? (+ c) <$> p $ return c) (return 0) es mprefix f (AnyChunks es) = foldr (\ e p -> do n <- getSizeOf e; c <- mprefix f e; c == n ? (+ c) <$> p $ return c) (return 0) es msuffix f (AnyChunks es) = foldl (\ p e -> do n <- getSizeOf e; c <- msuffix f e; c == n ? (+ c) <$> p $ return c) (return 0) es -------------------------------------------------------------------------------- {- Set and Scan instances. -} instance (Nullable (AnyChunks rep e), SetWith1 (AnyChunks rep) e, Ord e) => Set (AnyChunks rep e) e instance (SetWith1 rep e, Linear1 rep e, Ord (rep e), Bordered1 rep Int e) => SetWith (AnyChunks rep e) e where insertWith f' e' = AnyChunks . go f' e' . toChunks where go f e (x : xs) = memberWith f e x ? insertWith f e x : xs $ x : go f e xs go _ e _ = [single e] deleteWith f' e' = AnyChunks . go f' e' . toChunks where go f e (x : xs) = memberWith f e x ? deleteWith f e x : xs $ x : go f e xs go _ _ _ = [] intersectionWith f = fromList ... on (intersectionWith f) listL differenceWith f = fromList ... on (differenceWith f) listL symdiffWith f = fromList ... on (symdiffWith f) listL unionWith f = fromList ... on (unionWith f) listL lookupLTWith f o = foldr ((<|>) . lookupLTWith f o) Nothing . toChunks lookupLEWith f o = foldr ((<|>) . lookupLEWith f o) Nothing . toChunks lookupGTWith f o = foldr ((<|>) . lookupGTWith f o) Nothing . toChunks lookupGEWith f o = foldr ((<|>) . lookupGEWith f o) Nothing . toChunks memberWith f x (AnyChunks es) = memberWith f x `any` es isSubsetWith f xs ys = o_foldr (\ e b -> memberWith f e ys && b) True xs instance (Linear1 (AnyChunks rep) e) => Scan (AnyChunks rep e) e -------------------------------------------------------------------------------- {- Indexed instance. -} instance (Indexed1 rep Int e) => Map (AnyChunks rep e) Int e where toMap ascs = isNull ascs ? Z $ assoc (ascsBounds ascs) ascs toMap' defvalue ascs = isNull ascs ? Z $ assoc' (ascsBounds ascs) defvalue ascs (.!) = (!^) Z // ascs = toMap ascs AnyChunks es // ascs = AnyChunks (go 0 es ascs) where go _ [] _ = [] go _ xs [ ] = xs go l (x : xs) ies = x // as : go n xs bs where (as, bs) = partition (inRange (l, n - 1) . fst) ies n = l + sizeOf es p .$ AnyChunks (x : xs) = p .$ x <|> (+ sizeOf x) <$> p .$ AnyChunks xs _ .$ _ = Nothing p *$ AnyChunks (x : xs) = p *$ x ++ fmap (+ sizeOf x) (p *$ AnyChunks xs) _ *$ _ = [] kfoldr f base es = let bnds = bounds es in kfoldr (f . index bnds) base es kfoldl f base es = let bnds = bounds es in kfoldl (f . index bnds) base es instance (Indexed1 rep Int e) => Indexed (AnyChunks rep e) Int e where assoc bnds ascs = AnyChunks (go bnds ascs) where go (l, u) ies = isEmpty (l, u) ? [] $ assoc (l, n) as : go (n + 1, u) bs where (as, bs) = partition (inRange (l, n) . fst) ies n = min u (l + lim) assoc' bnds defvalue ascs = AnyChunks (go bnds ascs) where go (l, u) ies = isEmpty (l, u) ? [] $ assoc' (l, n) defvalue as : go (n + 1, u) bs where (as, bs) = partition (inRange (l, n) . fst) ies n = min u (l + lim) fromIndexed es = AnyChunks [fromIndexed es] -------------------------------------------------------------------------------- {- MapM, IndexedM and SortM instances. -} instance (SplitM1 m rep e, MapM1 m rep Int e, BorderedM1 m rep Int e) => MapM m (AnyChunks rep e) Int e where newMap ascs = AnyChunks <$> sequence (go (ascsBounds ascs) ascs) where go (l, u) ies = isEmpty (l, u) ? [] $ newMap as : go (n + 1, u) bs where (as, bs) = partition (inRange (l, n) . fst) ies n = min u (l + lim) newMap' defvalue ascs = AnyChunks <$> sequence (go (ascsBounds ascs) ascs) where go (l, u) ies = newMap' defvalue as : go (n + 1, u) bs where (as, bs) = partition (inRange (l, n) . fst) ies n = min u (l + lim) {-# INLINE (>!) #-} es >! i = i < 0 ? overEx "(>!)" $ es !#> i overwrite es'@(AnyChunks []) ascs = isNull ascs ? return es' $ newMap ascs overwrite es'@(AnyChunks es) ascs = es' <$ go 0 es ((< 0) . fst `except` ascs) where go o (x : xs) ie = unless (null ie) $ do n <- getSizeOf x let (as, bs) = partition (\ (i, _) -> i < n + o) ie overwrite x as >> go (n + o) xs bs go _ _ _ = return () kfoldrM = ofoldrM kfoldlM = ofoldlM instance (SplitM1 m rep e, IndexedM1 m rep Int e) => IndexedM m (AnyChunks rep e) Int e where fromAssocs bnds ascs = AnyChunks <$> sequence (go bnds ascs) where go (l, u) ies = isEmpty (l, u) ? [] $ fromAssocs (l, n) as : go (n + 1, u) bs where (as, bs) = partition (inRange (l, n) . fst) ies n = min u (l + lim) fromAssocs' bnds defvalue ascs = AnyChunks <$> sequence (go bnds ascs) where go (l, u) ies = fromAssocs' (l, n) defvalue as : go (n + 1, u) bs where (as, bs) = partition (inRange (l, n) . fst) ies n = min u (l + lim) {-# INLINE writeM' #-} writeM' es i e = (i < 0) `unless` writeM es i e fromIndexed' = newLinear . listL fromIndexedM = newLinear <=< getLeft instance (BorderedM1 m rep Int e, SortM1 m rep e, SplitM1 m rep e, LinearM1 m rep e) => SortM m (AnyChunks rep e) e where sortMBy = timSortBy sortedMBy f = go . toChunks where go (x1 : x2 : xs) = let restM = liftA2 f (getLast x1) (getHead x2) ?^ go (x2 : xs) $ return False in sortedMBy f x1 ?^ restM $ return False go [x1] = sortedMBy f x1 go [] = return True -------------------------------------------------------------------------------- -- | Creates new local immutable structure and thaw it as fast, as possible. instance {-# OVERLAPPABLE #-} (Linear1 imm e, Thaw1 m imm mut e) => Thaw m (AnyChunks imm e) (mut e) where -- @concat [e]@ may return e thaw (AnyChunks [e]) = thaw e -- any correct concat will create an intermediate structure in this case thaw (AnyChunks ess) = unsafeThaw (concat ess) unsafeThaw = unsafeThaw . concat . toChunks -- | Creates one-chunk mutable stream, may be memory inefficient. instance {-# OVERLAPPABLE #-} (Thaw1 m imm mut e) => Thaw m (imm e) (AnyChunks mut e) where unsafeThaw = fmap (AnyChunks . single) . unsafeThaw thaw = fmap (AnyChunks . single) . thaw instance {-# OVERLAPS #-} (Thaw1 m imm mut e) => Thaw m (AnyChunks imm e) (AnyChunks mut e) where unsafeThaw (AnyChunks imm) = AnyChunks <$> mapM unsafeThaw imm thaw (AnyChunks imm) = AnyChunks <$> mapM thaw imm -- | Creates one-chunk immutable stream, may be memory inefficient. instance {-# OVERLAPPABLE #-} (Freeze1 m mut imm e) => Freeze m (mut e) (AnyChunks imm e) where unsafeFreeze = fmap (AnyChunks . single) . unsafeFreeze freeze = fmap (AnyChunks . single) . freeze -- | Creates new immutable structure using 'merged'. instance {-# OVERLAPPABLE #-} (LinearM1 m mut e, Freeze1 m mut imm e) => Freeze m (AnyChunks mut e) (imm e) where unsafeFreeze (AnyChunks es) = unsafeFreeze =<< merged es freeze (AnyChunks es) = freeze =<< merged es instance {-# OVERLAPS #-} (Freeze1 m mut imm e) => Freeze m (AnyChunks mut e) (AnyChunks imm e) where unsafeFreeze (AnyChunks mut) = AnyChunks <$> mapM unsafeFreeze mut freeze (AnyChunks mut) = AnyChunks <$> mapM freeze mut -------------------------------------------------------------------------------- ascsBounds :: (Ord a) => [(a, b)] -> (a, a) ascsBounds = \ ((x, _) : xs) -> foldr (\ (e, _) (mn, mx) -> (min mn e, max mx e)) (x, x) xs overEx :: String -> a overEx = throw . IndexOverflow . showString "in SDP.Templates.AnyChunks." underEx :: String -> a underEx = throw . IndexUnderflow . showString "in SDP.Templates.AnyChunks." pfailEx :: String -> a pfailEx = throw . PatternMatchFail . showString "in SDP.Templates.AnyChunks." lim :: Int lim = 1024