-- Copyright 2015 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE DeriveFunctor #-} -- | A Stream is a collection of 'LEvent.LEvent's which is hopefully sorted in -- time order. module Derive.Stream ( Stream -- * construct , empty, from_logs, from_event_logs, from_events, from_sorted_list , from_event, from_sorted_events -- * extract , to_list, write_logs, partition, logs_of, events_of, length -- * transform , take_while, drop_while, cat_maybes , sort , merge_asc_lists , merge_log, merge_logs , levent_key -- ** specific transformations , first, first_last -- ** zip , zip, zip_on, zip3, zip3_on, zip4 -- * misc util , pretty_short_events, short_events ) where import Prelude hiding (length, zip, zip3) import qualified Control.DeepSeq as DeepSeq import qualified Data.List as List import qualified Util.Log as Log import qualified Util.Pretty as Pretty import qualified Util.Lists as Lists import qualified Derive.LEvent as LEvent import qualified Derive.PSignal as PSignal import qualified Derive.Score as Score import qualified Perform.Signal as Signal import Global hiding (first) import Types {- | A list seems inefficient, since each call appends to the stream. A block call will then append a bunch of events which need to be copied, and recopied as part of the larger chunk for the next block call up. It's possible the head of the stream will also be copied every time something is appended to it, but I'm not sure about that. It could also be that the number of events is low enough that all the inefficiency doesnt actually matter, but I'm not sure. I need to understand profiling to tell. TODO one possibility is a MergeList: data MergeList a = Chunk [a] | Merge (MergeList a) (MergeList a) This way I don't need to copy large chunks multiple times. Also, if I make sure there is no data dependency between the merge branches, I can evaluate them in parallel. Each call generates a chunk [Event], and the chunks are then joined with (<>). This means every cons is copied once, but I think this is hard to avoid if I want to merge streams. TODO the Functor and Traversable can destroy the order, but this isn't checked. Maybe I shouldn't have them? -} -- data Stream a = Stream !Sorted ![LEvent.LEvent a] -- deriving (Show, Functor, Foldable.Foldable, Traversable.Traversable) -- | Currently I don't actually track order, and just trust the callers. newtype Stream a = Stream [LEvent.LEvent a] deriving (Int -> Stream a -> ShowS forall a. Show a => Int -> Stream a -> ShowS forall a. Show a => [Stream a] -> ShowS forall a. Show a => Stream a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Stream a] -> ShowS $cshowList :: forall a. Show a => [Stream a] -> ShowS show :: Stream a -> String $cshow :: forall a. Show a => Stream a -> String showsPrec :: Int -> Stream a -> ShowS $cshowsPrec :: forall a. Show a => Int -> Stream a -> ShowS Show, forall a b. a -> Stream b -> Stream a forall a b. (a -> b) -> Stream a -> Stream b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: forall a b. a -> Stream b -> Stream a $c<$ :: forall a b. a -> Stream b -> Stream a fmap :: forall a b. (a -> b) -> Stream a -> Stream b $cfmap :: forall a b. (a -> b) -> Stream a -> Stream b Functor) data Sorted = Unsorted | Sorted deriving (Int -> Sorted -> ShowS [Sorted] -> ShowS Sorted -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Sorted] -> ShowS $cshowList :: [Sorted] -> ShowS show :: Sorted -> String $cshow :: Sorted -> String showsPrec :: Int -> Sorted -> ShowS $cshowsPrec :: Int -> Sorted -> ShowS Show, Sorted -> Sorted -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Sorted -> Sorted -> Bool $c/= :: Sorted -> Sorted -> Bool == :: Sorted -> Sorted -> Bool $c== :: Sorted -> Sorted -> Bool Eq) instance Semigroup Sorted where Sorted Sorted <> :: Sorted -> Sorted -> Sorted <> Sorted Sorted = Sorted Sorted Sorted _ <> Sorted _ = Sorted Unsorted instance Monoid Sorted where mempty :: Sorted mempty = Sorted Sorted mappend :: Sorted -> Sorted -> Sorted mappend = forall a. Semigroup a => a -> a -> a (<>) emap :: ([LEvent.LEvent a] -> [LEvent.LEvent b]) -> Stream a -> Stream b emap :: forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap [LEvent a] -> [LEvent b] f = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . [LEvent a] -> [LEvent b] f forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list instance Semigroup (Stream Score.Event) where Stream Event s1 <> :: Stream Event -> Stream Event -> Stream Event <> Stream Event s2 = forall a. [LEvent a] -> Stream a from_sorted_list forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a] Lists.mergeOn LEvent Event -> RealTime levent_key (forall a. Stream a -> [LEvent a] to_list Stream Event s1) (forall a. Stream a -> [LEvent a] to_list Stream Event s2) -- Stream s1 e1 <> Stream s2 e2 = case (s1, s2) of -- (Sorted, Sorted) -> from_sorted_list $ Lists.mergeOn levent_key e1 e2 -- _ -> from_list (e1 <> e2) instance Monoid (Stream Score.Event) where mempty :: Stream Event mempty = forall a. [LEvent a] -> Stream a from_sorted_list forall a. Monoid a => a mempty mappend :: Stream Event -> Stream Event -> Stream Event mappend = forall a. Semigroup a => a -> a -> a (<>) mconcat :: [Stream Event] -> Stream Event mconcat = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Ord k => (a -> k) -> [[a]] -> [a] Lists.mergeLists LEvent Event -> RealTime levent_key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a. Stream a -> [LEvent a] to_list -- mconcat streams = from_sorted_list groups -- where -- groups = Lists.mergeLists levent_key -- [events | Stream _ events <- map sort streams] -- To my surprise, GHC will accept an overlapping instance Monoid (Stream a). -- Maybe it's ok because it's unambiguous, but I still like specific instances. -- This means calls have to use Stream.empty instead of mempty, but that's not -- such a big deal. instance Semigroup (Stream Signal.Control) where Stream Control s1 <> :: Stream Control -> Stream Control -> Stream Control <> Stream Control s2 = forall a. [LEvent a] -> Stream a from_sorted_list (forall a. Stream a -> [LEvent a] to_list Stream Control s1 forall a. Semigroup a => a -> a -> a <> forall a. Stream a -> [LEvent a] to_list Stream Control s2) -- | Signal.Control streams don't need sorted order. instance Monoid (Stream Signal.Control) where mempty :: Stream Control mempty = forall a. Stream a empty mappend :: Stream Control -> Stream Control -> Stream Control mappend = forall a. Semigroup a => a -> a -> a (<>) instance Semigroup (Stream PSignal.PSignal) where Stream PSignal s1 <> :: Stream PSignal -> Stream PSignal -> Stream PSignal <> Stream PSignal s2 = forall a. [LEvent a] -> Stream a from_sorted_list (forall a. Stream a -> [LEvent a] to_list Stream PSignal s1 forall a. Semigroup a => a -> a -> a <> forall a. Stream a -> [LEvent a] to_list Stream PSignal s2) instance Monoid (Stream PSignal.PSignal) where mempty :: Stream PSignal mempty = forall a. Stream a empty mappend :: Stream PSignal -> Stream PSignal -> Stream PSignal mappend = forall a. Semigroup a => a -> a -> a (<>) instance DeepSeq.NFData a => DeepSeq.NFData (Stream a) where rnf :: Stream a -> () rnf = forall a. NFData a => a -> () DeepSeq.rnf forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list instance Pretty a => Pretty (Stream a) where -- format (Stream sorted events) = -- Pretty.text (showt sorted) Pretty.<+> Pretty.format events format :: Stream a -> Doc format (Stream [LEvent a] events) = forall a. Pretty a => a -> Doc Pretty.format [LEvent a] events -- * construct empty :: Stream a empty :: forall a. Stream a empty = forall a. [LEvent a] -> Stream a from_sorted_list [] from_logs :: [Log.Msg] -> Stream a from_logs :: forall a. [Msg] -> Stream a from_logs = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a. Msg -> LEvent a LEvent.Log from_event_logs :: a -> [Log.Msg] -> Stream a from_event_logs :: forall a. a -> [Msg] -> Stream a from_event_logs a e [Msg] logs = forall a. [LEvent a] -> Stream a from_sorted_list (forall a. a -> LEvent a LEvent.Event a e forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map forall a. Msg -> LEvent a LEvent.Log [Msg] logs) from_sorted_list :: [LEvent.LEvent a] -> Stream a from_sorted_list :: forall a. [LEvent a] -> Stream a from_sorted_list = forall a. [LEvent a] -> Stream a Stream -- Sorted from_list :: [LEvent.LEvent a] -> Stream a from_list :: forall a. [LEvent a] -> Stream a from_list = forall a. [LEvent a] -> Stream a Stream -- Unsorted from_events :: [a] -> Stream a from_events :: forall a. [a] -> Stream a from_events = forall a. [LEvent a] -> Stream a from_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a. a -> LEvent a LEvent.Event from_event :: a -> Stream a from_event :: forall a. a -> Stream a from_event = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. a -> [a] -> [a] :[]) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> LEvent a LEvent.Event -- | Promise that the stream is really sorted. from_sorted_events :: [a] -> Stream a from_sorted_events :: forall a. [a] -> Stream a from_sorted_events = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a. a -> LEvent a LEvent.Event -- * extract to_list :: Stream a -> [LEvent.LEvent a] to_list :: forall a. Stream a -> [LEvent a] to_list (Stream [LEvent a] events) = [LEvent a] events write_logs :: Log.LogMonad m => Stream a -> m [a] write_logs :: forall (m :: * -> *) a. LogMonad m => Stream a -> m [a] write_logs = forall (m :: * -> *) d. LogMonad m => [LEvent d] -> m [d] LEvent.write_logs forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list partition :: Stream a -> ([a], [Log.Msg]) partition :: forall a. Stream a -> ([a], [Msg]) partition = forall d. [LEvent d] -> ([d], [Msg]) LEvent.partition forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list logs_of :: Stream a -> [Log.Msg] logs_of :: forall a. Stream a -> [Msg] logs_of = forall d. [LEvent d] -> [Msg] LEvent.logs_of forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list events_of :: Stream a -> [a] events_of :: forall a. Stream a -> [a] events_of = forall d. [LEvent d] -> [d] LEvent.events_of forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list length :: Stream a -> Int length :: forall a. Stream a -> Int length = forall (t :: * -> *) a. Foldable t => t a -> Int List.length forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list -- * transform take_while :: (a -> Bool) -> Stream a -> Stream a take_while :: forall a. (a -> Bool) -> Stream a -> Stream a take_while = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] takeWhile forall b c a. (b -> c) -> (a -> b) -> a -> c . forall d. (d -> Bool) -> LEvent d -> Bool LEvent.log_or drop_while :: (a -> Bool) -> Stream a -> Stream a drop_while :: forall a. (a -> Bool) -> Stream a -> Stream a drop_while = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] dropWhile forall b c a. (b -> c) -> (a -> b) -> a -> c . forall d. (d -> Bool) -> LEvent d -> Bool LEvent.log_or -- | 'Data.Maybe.catMaybes' for Stream. cat_maybes :: Stream (Maybe a) -> Stream a cat_maybes :: forall a. Stream (Maybe a) -> Stream a cat_maybes = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall {a}. [LEvent (Maybe a)] -> [LEvent a] go where go :: [LEvent (Maybe a)] -> [LEvent a] go [] = [] go (LEvent (Maybe a) x : [LEvent (Maybe a)] xs) = case LEvent (Maybe a) x of LEvent.Log Msg log -> forall a. Msg -> LEvent a LEvent.Log Msg log forall a. a -> [a] -> [a] : [LEvent (Maybe a)] -> [LEvent a] go [LEvent (Maybe a)] xs LEvent.Event (Just a e) -> forall a. a -> LEvent a LEvent.Event a e forall a. a -> [a] -> [a] : [LEvent (Maybe a)] -> [LEvent a] go [LEvent (Maybe a)] xs LEvent.Event Maybe a Nothing -> [LEvent (Maybe a)] -> [LEvent a] go [LEvent (Maybe a)] xs sort :: Stream Score.Event -> Stream Score.Event -- sort s@(Stream Sorted _) = s -- sort (Stream Unsorted events) = -- from_sorted_list $ Lists.sortOn levent_key events sort :: Stream Event -> Stream Event sort (Stream [LEvent Event] events) = forall a. [LEvent a] -> Stream a from_sorted_list forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn LEvent Event -> RealTime levent_key [LEvent Event] events -- | Merge sorted lists of events. If the lists themselves are also sorted, -- I can produce output without scanning the entire input list, so this should -- be more efficient for a large input list than (<>). -- -- This assumes all the streams are sorted. I could check first, but this -- would destroy the laziness. Instead, let it be out of order, and Convert -- will complain about it. merge_asc_lists :: [Stream Score.Event] -> Stream Score.Event merge_asc_lists :: [Stream Event] -> Stream Event merge_asc_lists [Stream Event] streams = forall a. [LEvent a] -> Stream a from_sorted_list forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (a -> k) -> [[a]] -> [a] Lists.mergeAscLists LEvent Event -> RealTime levent_key (forall a b. (a -> b) -> [a] -> [b] map forall a. Stream a -> [LEvent a] to_list [Stream Event] streams) -- | This will make logs always merge ahead of score events, but that should -- be ok. levent_key :: LEvent.LEvent Score.Event -> RealTime levent_key :: LEvent Event -> RealTime levent_key (LEvent.Log Msg _) = -RealTime 1forall a. Fractional a => a -> a -> a /RealTime 0 -- -Infinity levent_key (LEvent.Event Event event) = Event -> RealTime Score.event_start Event event merge_log :: Log.Msg -> Stream a -> Stream a merge_log :: forall a. Msg -> Stream a -> Stream a merge_log Msg log = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap (forall a. Msg -> LEvent a LEvent.Log Msg log :) merge_logs :: [Log.Msg] -> Stream e -> Stream e merge_logs :: forall e. [Msg] -> Stream e -> Stream e merge_logs [Msg] logs = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap (forall a b. (a -> b) -> [a] -> [b] map forall a. Msg -> LEvent a LEvent.Log [Msg] logs ++) -- ** specific transformations -- | Apply to the first Event that matches the predicate. first :: (a -> Bool) -> (a -> a) -> Stream a -> Stream a first :: forall a. (a -> Bool) -> (a -> a) -> Stream a -> Stream a first a -> Bool matches a -> a f = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . [LEvent a] -> [LEvent a] go forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list where go :: [LEvent a] -> [LEvent a] go [] = [] go (LEvent a e : [LEvent a] es) = case LEvent a e of LEvent.Event a e | a -> Bool matches a e -> forall a. a -> LEvent a LEvent.Event (a -> a f a e) forall a. a -> [a] -> [a] : [LEvent a] es LEvent a _ -> LEvent a e forall a. a -> [a] -> [a] : [LEvent a] -> [LEvent a] go [LEvent a] es -- | Apply to the first and last Event that matches the predicate. If there -- are fewer than 2 such events, do nothing. first_last :: (a -> Bool) -> (a -> a) -> (a -> a) -> Stream a -> Stream a first_last :: forall a. (a -> Bool) -> (a -> a) -> (a -> a) -> Stream a -> Stream a first_last a -> Bool matches a -> a start a -> a end = forall a. [LEvent a] -> Stream a from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . [LEvent a] -> [LEvent a] at_start forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list where at_start :: [LEvent a] -> [LEvent a] at_start [] = [] at_start (LEvent a e : [LEvent a] es) = case LEvent a e of LEvent.Event a e | a -> Bool matches a e -> if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a LEvent.either a -> Bool matches (forall a b. a -> b -> a const Bool False)) [LEvent a] es then forall a. a -> LEvent a LEvent.Event (a -> a start a e) forall a. a -> [a] -> [a] : [LEvent a] -> [LEvent a] at_end [LEvent a] es else forall a. a -> LEvent a LEvent.Event a e forall a. a -> [a] -> [a] : [LEvent a] es LEvent a _ -> LEvent a e forall a. a -> [a] -> [a] : [LEvent a] -> [LEvent a] at_start [LEvent a] es at_end :: [LEvent a] -> [LEvent a] at_end [] = [] at_end (LEvent a e : [LEvent a] es) = case LEvent a e of LEvent.Event a e | a -> Bool matches a e Bool -> Bool -> Bool && forall (t :: * -> *) a. Foldable t => t a -> Bool null (forall a. (a -> Bool) -> [a] -> [a] dropWhile (forall d. (d -> Bool) -> LEvent d -> Bool LEvent.log_or (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Bool matches)) [LEvent a] es) -> forall a. a -> LEvent a LEvent.Event (a -> a end a e) forall a. a -> [a] -> [a] : [LEvent a] es LEvent a _ -> LEvent a e forall a. a -> [a] -> [a] : [LEvent a] -> [LEvent a] at_end [LEvent a] es -- ** zip zip :: [a] -> Stream x -> Stream (a, x) zip :: forall a x. [a] -> Stream x -> Stream (a, x) zip [a] as = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall a b. (a -> b) -> a -> b $ forall a x. [a] -> [LEvent x] -> [LEvent (a, x)] LEvent.zip [a] as zip_on :: ([a] -> [b]) -> Stream a -> Stream (b, a) zip_on :: forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a) zip_on [a] -> [b] key = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall a b. (a -> b) -> a -> b $ \[LEvent a] xs -> forall a x. [a] -> [LEvent x] -> [LEvent (a, x)] LEvent.zip ([a] -> [b] key (forall d. [LEvent d] -> [d] LEvent.events_of [LEvent a] xs)) [LEvent a] xs zip3 :: [a] -> [b] -> Stream x -> Stream (a, b, x) zip3 :: forall a b x. [a] -> [b] -> Stream x -> Stream (a, b, x) zip3 [a] as [b] bs = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall a b. (a -> b) -> a -> b $ forall a b x. [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)] LEvent.zip3 [a] as [b] bs zip3_on :: ([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a) zip3_on :: forall a b c. ([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a) zip3_on [a] -> [b] key1 [a] -> [c] key2 = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall a b. (a -> b) -> a -> b $ \[LEvent a] xs -> forall a b x. [a] -> [b] -> [LEvent x] -> [LEvent (a, b, x)] LEvent.zip3 ([a] -> [b] key1 (forall d. [LEvent d] -> [d] LEvent.events_of [LEvent a] xs)) ([a] -> [c] key2 (forall d. [LEvent d] -> [d] LEvent.events_of [LEvent a] xs)) [LEvent a] xs zip4 :: [a] -> [b] -> [c] -> Stream x -> Stream (a, b, c, x) zip4 :: forall a b c x. [a] -> [b] -> [c] -> Stream x -> Stream (a, b, c, x) zip4 [a] as [b] bs [c] cs = forall a b. ([LEvent a] -> [LEvent b]) -> Stream a -> Stream b emap forall a b. (a -> b) -> a -> b $ forall a b c x. [a] -> [b] -> [c] -> [LEvent x] -> [LEvent (a, b, c, x)] LEvent.zip4 [a] as [b] bs [c] cs -- * misc util -- | Like 'Score.short_events', but works on a Stream. pretty_short_events :: Stream Score.Event -> Text pretty_short_events :: Stream Event -> Text pretty_short_events = forall a. Pretty a => a -> Text pretty forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Pretty a => Char -> Char -> [a] -> Doc Pretty.formattedList Char '[' Char ']' forall b c a. (b -> c) -> (a -> b) -> a -> c . Stream Event -> [Text] short_events short_events :: Stream Score.Event -> [Text] short_events :: Stream Event -> [Text] short_events = forall a b. (a -> b) -> [a] -> [b] map (forall d a. (d -> a) -> (Msg -> a) -> LEvent d -> a LEvent.either Event -> Text Score.short_event forall a. Pretty a => a -> Text pretty) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] to_list