-- Copyright 2018 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 -- | Functions to do incremental render. It hashes 'Note.Note's to skip -- rerendering when possible. module Synth.Lib.Checkpoint where import qualified Control.DeepSeq as DeepSeq import qualified Control.Monad.Trans.Resource as Resource import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as ByteString.Char8 import qualified Data.List as List import qualified Data.Set as Set import qualified Data.Time as Time import qualified System.Directory as Directory import qualified System.FilePath as FilePath import System.FilePath ((</>)) import qualified Util.Audio.Audio as Audio import qualified Util.Audio.File as Audio.File import qualified Util.Files as Files import qualified Util.Lists as Lists import qualified Synth.Lib.AUtil as AUtil import qualified Synth.Shared.Config as Config import qualified Synth.Shared.Note as Note import qualified Ui.Id as Id import Global import Synth.Types -- | This subdirectory in the outputDirectory </> instrument has the -- fingerprinted audio files. checkpointDir :: FilePath checkpointDir :: FilePath checkpointDir = FilePath "checkpoint" -- * state -- | This is the opaque state for a synthesizer or signal processor. It should -- be possible to resume synthesis by saving and restoring it. -- -- TODO maybe [ByteString] for multiple states newtype State = State ByteString.ByteString deriving (State -> State -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: State -> State -> Bool $c/= :: State -> State -> Bool == :: State -> State -> Bool $c== :: State -> State -> Bool Eq, Int -> State -> ShowS [State] -> ShowS State -> FilePath forall a. (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a showList :: [State] -> ShowS $cshowList :: [State] -> ShowS show :: State -> FilePath $cshow :: State -> FilePath showsPrec :: Int -> State -> ShowS $cshowsPrec :: Int -> State -> ShowS Show) instance Pretty State where pretty :: State -> Text pretty = FilePath -> Text txt forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> FilePath encodeState encodeState :: State -> String encodeState :: State -> FilePath encodeState (State ByteString bytes) = ByteString -> FilePath Note.fingerprintBytes ByteString bytes -- * checkpoints -- | Find where the checkpoints begin to differ from the given 'Note.Hash's. skipCheckpoints :: FilePath -> State -> [(Config.ChunkNum, Note.Hash)] -> IO ([FilePath], [(Config.ChunkNum, Note.Hash)], Maybe State) -- ^ (skipped chunks, remaining notes, state at that point) skipCheckpoints :: FilePath -> State -> [(Int, Hash)] -> IO ([FilePath], [(Int, Hash)], Maybe State) skipCheckpoints FilePath outputDir State initialState [(Int, Hash)] hashes = do -- Debug.put "hashes" (map (second Note.encodeHash) hashes) Bool -> FilePath -> IO () Directory.createDirectoryIfMissing Bool False (FilePath outputDir FilePath -> ShowS </> FilePath checkpointDir) [FilePath] files <- FilePath -> IO [FilePath] Directory.listDirectory (FilePath outputDir FilePath -> ShowS </> FilePath checkpointDir) let ([FilePath] skipped, ([(Int, Hash)] remainingHashes, FilePath stateFname)) = Set FilePath -> State -> [(Int, Hash)] -> ([FilePath], ([(Int, Hash)], FilePath)) findLastState (forall a. Ord a => [a] -> Set a Set.fromList [FilePath] files) State initialState [(Int, Hash)] hashes Maybe State mbState <- if forall (t :: * -> *) a. Foldable t => t a -> Bool null FilePath stateFname then forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing else forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> State State forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FilePath -> IO ByteString ByteString.readFile (FilePath outputDir FilePath -> ShowS </> FilePath checkpointDir FilePath -> ShowS </> FilePath stateFname) forall (m :: * -> *) a. Monad m => a -> m a return ([FilePath] skipped, [(Int, Hash)] remainingHashes, Maybe State mbState) -- | Find the first 'Note.Hash' that doesn't have a matching filename. -- -- Since the output state of the previous filename needs to match the input -- state of the next one as described in 'writeState', this has to follow the -- files in sequence. findLastState :: Set FilePath -> State -> [(Config.ChunkNum, Note.Hash)] -> ([FilePath], ([(Config.ChunkNum, Note.Hash)], FilePath)) -- ^ ([skipped], (remainingHashes, resumeState)) findLastState :: Set FilePath -> State -> [(Int, Hash)] -> ([FilePath], ([(Int, Hash)], FilePath)) findLastState Set FilePath files = FilePath -> FilePath -> [(Int, Hash)] -> ([FilePath], ([(Int, Hash)], FilePath)) go FilePath "" forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> FilePath encodeState where go :: FilePath -> FilePath -> [(Int, Hash)] -> ([FilePath], ([(Int, Hash)], FilePath)) go FilePath prevStateFname FilePath state ((Int chunknum, Hash hash) : [(Int, Hash)] hashes) | FilePath fname forall a. Ord a => a -> Set a -> Bool `Set.member` Set FilePath files = case forall a. Ord a => a -> Set a -> Maybe a Set.lookupGT FilePath prefix Set FilePath files of Just FilePath stateFname | FilePath prefix forall a. Eq a => [a] -> [a] -> Bool `List.isPrefixOf` FilePath stateFname -> forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (FilePath fname:) forall a b. (a -> b) -> a -> b $ FilePath -> FilePath -> [(Int, Hash)] -> ([FilePath], ([(Int, Hash)], FilePath)) go FilePath stateFname FilePath nextState forall a b. (a -> b) -> a -> b $ -- I ran out of notes, but there are still chunks. This -- indicates that there is a decay after the last note, -- so keep following chunks with empty note hash. They -- were rendered in the first place beceause 'extendHash' -- does the same thing for 'write'. if forall (t :: * -> *) a. Foldable t => t a -> Bool null [(Int, Hash)] hashes then [(Int chunknumforall a. Num a => a -> a -> a +Int 1, forall a. Monoid a => a mempty)] else [(Int, Hash)] hashes where nextState :: FilePath nextState = forall a. Int -> [a] -> [a] drop (forall (t :: * -> *) a. Foldable t => t a -> Int length FilePath prefix) FilePath stateFname -- I didn't find a corresponding .state file for the .wav. This -- can happen if a previous render was killed while writing them. -- Since the files are written atomically, the .state file marks -- the end of the transaction, so I should just be able to ignore -- an orphaned .wav. Maybe FilePath _ -> forall {a}. ([a], ([(Int, Hash)], FilePath)) done | Bool otherwise = forall {a}. ([a], ([(Int, Hash)], FilePath)) done where done :: ([a], ([(Int, Hash)], FilePath)) done -- This means I'm "in the decay", as above, so don't return one -- of my made-up empty note hashes. This way 'write' will notice -- null hashes, and skip all work. | Hash hash forall a. Eq a => a -> a -> Bool == forall a. Monoid a => a mempty Bool -> Bool -> Bool && forall (t :: * -> *) a. Foldable t => t a -> Bool null [(Int, Hash)] hashes = ([], ([], FilePath "")) | Bool otherwise = ([], ((Int chunknum, Hash hash) forall a. a -> [a] -> [a] : [(Int, Hash)] hashes, FilePath prevStateFname)) prefix :: FilePath prefix = FilePath -> ShowS FilePath.replaceExtension FilePath fname FilePath ".state." fname :: FilePath fname = Int -> Hash -> ShowS filenameOf2 Int chunknum Hash hash FilePath state go FilePath _ FilePath _ [] = ([], ([], FilePath "")) -- ** write -- | Write the audio with checkpoints. write :: Bool -> FilePath -> Set Id.TrackId -> Config.ChunkNum -> Audio.Frames -> [(Config.ChunkNum, Note.Hash)] -> IO State -> AUtil.Audio -- ^ get current audio state, see NOTE [audio-state] -> IO (Either Text (Config.ChunkNum, Config.ChunkNum)) -- ^ Either Error (writtenChunks, total) write :: Bool -> FilePath -> Set TrackId -> Int -> Frames -> [(Int, Hash)] -> IO State -> Audio -> IO (Either Text (Int, Int)) write Bool emitProgress FilePath outputDir Set TrackId trackIds Int skippedCount Frames chunkSize [(Int, Hash)] hashes IO State getState Audio audio | forall (t :: * -> *) a. Foldable t => t a -> Bool null [(Int, Hash)] hashes = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Int 0, Int skippedCount) | Bool otherwise = do Either Text Int result <- forall a. IO a -> IO (Either Text a) AUtil.catchSndfile forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a Resource.runResourceT forall a b. (a -> b) -> a -> b $ forall (rate :: Nat) (chan :: Nat) state. (KnownNat rate, KnownNat chan) => Frames -> (state -> IO FilePath) -> (FilePath -> IO ()) -> Format -> [state] -> AudioIO rate chan -> ResourceT IO Int Audio.File.writeCheckpoints Frames chunkSize (FilePath -> IO State -> (Int, Hash) -> IO FilePath getFilename FilePath outputDir IO State getState) FilePath -> IO () chunkComplete Format AUtil.outputFormat ([(Int, Hash)] -> [(Int, Hash)] extendHashes [(Int, Hash)] hashes) Audio audio forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ case Either Text Int result of Left Text err -> forall a b. a -> Either a b Left Text err Right Int written -> forall a b. b -> Either a b Right (Int written, Int written forall a. Num a => a -> a -> a + Int skippedCount) where chunkComplete :: FilePath -> IO () chunkComplete FilePath fname = do IO State -> FilePath -> IO () writeState IO State getState FilePath fname Int chunknum <- Bool -> FilePath -> FilePath -> IO Int linkOutput Bool False FilePath outputDir (ShowS FilePath.takeFileName FilePath fname) forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool emitProgress forall a b. (a -> b) -> a -> b $ HasCallStack => Message -> IO () Config.emitMessage forall a b. (a -> b) -> a -> b $ Config.Message { _blockId :: BlockId _blockId = FilePath -> BlockId Config.pathToBlockId FilePath outputDir , _trackIds :: Set TrackId _trackIds = Set TrackId trackIds , _instrument :: Instrument _instrument = FilePath -> Instrument Config.dirToInstrument FilePath outputDir , _payload :: Payload _payload = [Int] -> Payload Config.WaveformsCompleted [Int chunknum] } getFilename :: FilePath -> IO State -> (Config.ChunkNum, Note.Hash) -> IO FilePath getFilename :: FilePath -> IO State -> (Int, Hash) -> IO FilePath getFilename FilePath outputDir IO State getState (Int chunknum, Hash hash) -- This can happen if tempo is set really slow. | Int chunknum forall a. Ord a => a -> a -> Bool >= Int maxChunk = forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Text -> m a Audio.throwIO forall a b. (a -> b) -> a -> b $ Text "chunk num over limit: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int chunknum | Bool otherwise = do State state <- IO State getState let fname :: FilePath fname = FilePath outputDir FilePath -> ShowS </> FilePath checkpointDir FilePath -> ShowS </> Int -> Hash -> State -> FilePath filenameOf Int chunknum Hash hash State state -- XXX 'state' is actually an unsafe pointer to the underlying C state, -- so I have to make sure I'm done with it before returning. This is -- super sketchy, but it works now and it is non-copying. FilePath fname forall a b. NFData a => a -> b -> b `DeepSeq.deepseq` forall (m :: * -> *) a. Monad m => a -> m a return FilePath fname {- | Write synth state to the checkpointDir. The filename is derived from the audio chunk filename, which presumably has already been written. Each chunk writes two files: -- $hash over the chunk, and $state at beginning of .wav 000.$hash.$state.wav -- file contains the state at the end of the .wav, fingerprint is $endState 000.$hash.$state.state.$endState 001.$hash.$state.wav -- $state == previous $endState 001.$hash.$state.state.$endState -- as before -} writeState :: IO State -> FilePath -> IO () writeState :: IO State -> FilePath -> IO () writeState IO State getState FilePath fname = do state :: State state@(State ByteString stateBs) <- IO State getState FilePath -> ByteString -> IO () Files.writeAtomic (FilePath -> ShowS FilePath.replaceExtension FilePath fname (FilePath ".state." forall a. Semigroup a => a -> a -> a <> State -> FilePath encodeState State state)) ByteString stateBs -- | Link the audio chunk output (presumably already written) from the -- checkpointDir to its position in the output sequence. -- -- > 000.wav -> checkpoint/000.$hash.$state.wav linkOutput :: Bool -> FilePath -> FilePath -> IO Config.ChunkNum linkOutput :: Bool -> FilePath -> FilePath -> IO Int linkOutput Bool updateMtime FilePath outputDir FilePath fname = do let current :: FilePath current = FilePath outputDir FilePath -> ShowS </> ShowS filenameToOutput FilePath fname FilePath -> FilePath -> IO () Files.symlink (FilePath checkpointDir FilePath -> ShowS </> FilePath fname) FilePath current -- Bump mtime to protect it from ImGc for a while after it becomes dead. forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool updateMtime forall a b. (a -> b) -> a -> b $ FilePath -> UTCTime -> IO () Directory.setModificationTime (FilePath outputDir FilePath -> ShowS </> FilePath checkpointDir FilePath -> ShowS </> FilePath fname) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO UTCTime Time.getCurrentTime forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a -> a fromMaybe (forall a. HasCallStack => FilePath -> a error forall a b. (a -> b) -> a -> b $ FilePath "no parse: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> FilePath show FilePath current) forall a b. (a -> b) -> a -> b $ FilePath -> Maybe Int Config.isOutputLink forall a b. (a -> b) -> a -> b $ ShowS FilePath.takeFileName FilePath current -- | Remove any remaining output symlinks past the final chunk. clearRemainingOutput :: FilePath -> Config.ChunkNum -> IO () clearRemainingOutput :: FilePath -> Int -> IO () clearRemainingOutput FilePath outputDir Int start = do forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (FilePath -> IO () Directory.removeFile forall b c a. (b -> c) -> (a -> b) -> a -> c . (FilePath outputDir</>)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> [FilePath] -> [FilePath] outputPast Int start forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< FilePath -> IO [FilePath] Directory.listDirectory FilePath outputDir -- Uptime timestamps for tools/im-gc.py. UTCTime now <- IO UTCTime Time.getCurrentTime forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c flip FilePath -> UTCTime -> IO () Directory.setModificationTime UTCTime now forall b c a. (b -> c) -> (a -> b) -> a -> c . (FilePath outputDir</>)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< FilePath -> IO [FilePath] Directory.listDirectory FilePath outputDir outputPast :: Config.ChunkNum -> [FilePath] -> [FilePath] outputPast :: Int -> [FilePath] -> [FilePath] outputPast Int start = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter ((forall a. Ord a => a -> a -> Bool >=Int start) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a k. (a -> Maybe k) -> [a] -> [(k, a)] Lists.keyOnJust FilePath -> Maybe Int Config.isOutputLink filenameToOutput :: FilePath -> FilePath filenameToOutput :: ShowS filenameToOutput FilePath fname = case forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a) Lists.split FilePath "." FilePath fname of [FilePath num, FilePath _hash, FilePath _state, FilePath "wav"] -> FilePath num forall a. Semigroup a => a -> a -> a <> FilePath ".wav" [FilePath] _ -> FilePath fname -- | 000.$hash.$state.wav filenameOf :: Config.ChunkNum -> Note.Hash -> State -> FilePath filenameOf :: Int -> Hash -> State -> FilePath filenameOf Int chunknum Hash hash State state = Int -> Hash -> ShowS filenameOf2 Int chunknum Hash hash (State -> FilePath encodeState State state) -- | 'filenameOf' but with 'State' already encoded. filenameOf2 :: Config.ChunkNum -> Note.Hash -> String -> FilePath filenameOf2 :: Int -> Hash -> ShowS filenameOf2 Int chunknum Hash hash FilePath encodedState = ByteString -> FilePath ByteString.Char8.unpack (ByteString -> [ByteString] -> ByteString ByteString.Char8.intercalate ByteString "." [ forall a. Show a => Int -> a -> ByteString zeroPad Int 3 Int chunknum , FilePath -> ByteString ByteString.Char8.pack forall a b. (a -> b) -> a -> b $ Hash -> FilePath Note.encodeHash Hash hash ]) forall a. Semigroup a => a -> a -> a <> FilePath "." forall a. Semigroup a => a -> a -> a <> FilePath encodedState forall a. Semigroup a => a -> a -> a <> FilePath ".wav" -- | Crash after this chunk number. It's not an inherent limitation, but -- it indicates that something has probably gone off the rails. Also -- 'Config.isOutputLink' doesn't want to parse more than 3 digits. maxChunk :: Config.ChunkNum maxChunk :: Int maxChunk = Int 500 -- | 'Num.zeroPad' for ByteString. zeroPad :: Show a => Int -> a -> ByteString.ByteString zeroPad :: forall a. Show a => Int -> a -> ByteString zeroPad Int digits a n = Int -> Char -> ByteString ByteString.Char8.replicate (Int digits forall a. Num a => a -> a -> a - ByteString -> Int ByteString.length ByteString s) Char '0' forall a. Semigroup a => a -> a -> a <> ByteString s where s :: ByteString s = FilePath -> ByteString ByteString.Char8.pack (forall a. Show a => a -> FilePath show a n) -- * hash -- | Extend the [(index, hash)] list with mempty hashes. -- -- 'Audio.File.writeCheckpoints' needs this because it still wants states -- while rendering the decay of the last note. Previously, I just had -- 'hashOverlapping' return an infinite list with 0s on the end, but I want -- 'skipCheckpoints' to be able to detect when it ran out of notes so I can -- avoid rerendering the decay in that case, and it's hard to do that when it -- can't tell the difference between out of notes, and just no notes at this -- moment in time. extendHashes :: [(Int, Note.Hash)] -> [(Int, Note.Hash)] extendHashes :: [(Int, Hash)] -> [(Int, Hash)] extendHashes = forall {a} {b}. (Num a, Enum a, Monoid b) => [(a, b)] -> [(a, b)] go where go :: [(a, b)] -> [(a, b)] go [] = [] go [(a i, b h)] = (a i, b h) forall a. a -> [a] -> [a] : forall a b. [a] -> [b] -> [(a, b)] zip [a iforall a. Num a => a -> a -> a +a 1 ..] (forall a. a -> [a] repeat forall a. Monoid a => a mempty) go ((a, b) h : [(a, b)] hs) = (a, b) h forall a. a -> [a] -> [a] : [(a, b)] -> [(a, b)] go [(a, b)] hs noteHashes :: Audio.Frames -> [Span] -> [(Int, Note.Hash)] noteHashes :: Frames -> [Span] -> [(Int, Hash)] noteHashes Frames chunkSize = forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> RealTime -> [Span] -> [Hash] hashOverlapping RealTime 0 (Frames -> RealTime AUtil.toSeconds Frames chunkSize) data Span = Span { Span -> RealTime _start :: RealTime , Span -> RealTime _duration :: RealTime , Span -> Hash _hash :: Note.Hash } deriving (Int -> Span -> ShowS [Span] -> ShowS Span -> FilePath forall a. (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a showList :: [Span] -> ShowS $cshowList :: [Span] -> ShowS show :: Span -> FilePath $cshow :: Span -> FilePath showsPrec :: Int -> Span -> ShowS $cshowsPrec :: Int -> Span -> ShowS Show) instance Pretty Span where pretty :: Span -> Text pretty (Span RealTime start RealTime dur Hash hash) = forall a. Pretty a => a -> Text pretty RealTime start forall a. Semigroup a => a -> a -> a <> Text "+" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty RealTime dur forall a. Semigroup a => a -> a -> a <> Text "(" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Hash hash forall a. Semigroup a => a -> a -> a <> Text ")" hashOverlapping :: RealTime -> RealTime -> [Span] -> [Note.Hash] hashOverlapping :: RealTime -> RealTime -> [Span] -> [Hash] hashOverlapping RealTime start RealTime size = forall a b. (a -> b) -> [a] -> [b] map (forall a. Monoid a => [a] -> a mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. RealTime -> RealTime -> [(a, Span)] -> [[(a, Span)]] groupOverlapping RealTime start RealTime size forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn Span -> Hash _hash -- Pair each Note with its Hash, then group Notes and combine the Hashes. overlappingHashes :: RealTime -> RealTime -> [Span] -> [[Note.Hash]] overlappingHashes :: RealTime -> RealTime -> [Span] -> [[Hash]] overlappingHashes RealTime start RealTime size = forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. RealTime -> RealTime -> [(a, Span)] -> [[(a, Span)]] groupOverlapping RealTime start RealTime size forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn Span -> Hash _hash {- | Group all Spans that overlap the given range. So: > 0 1 2 3 4 5 6 7 8 > |=======|=======|=======| > a------ > b---c----- > d--- Should be: [[a], [a, b, c], [c, d]] -} groupOverlapping :: RealTime -> RealTime -> [(a, Span)] -> [[(a, Span)]] groupOverlapping :: forall a. RealTime -> RealTime -> [(a, Span)] -> [[(a, Span)]] groupOverlapping RealTime start RealTime size = forall {a}. [RealTime] -> [(a, Span)] -> [[(a, Span)]] go (forall a. Num a => a -> a -> [a] Lists.range_ RealTime start RealTime size) -- Use Lists.range_ instead of successive addition to avoid accumulating -- error. Size should integral, but let's just be careful. where go :: [RealTime] -> [(a, Span)] -> [[(a, Span)]] go (RealTime t1 : ts :: [RealTime] ts@(RealTime t2 : [RealTime] _)) [(a, Span)] spans | forall (t :: * -> *) a. Foldable t => t a -> Bool null [(a, Span)] spans = [] | forall (t :: * -> *) a. Foldable t => t a -> Bool null [(a, Span)] overlapping Bool -> Bool -> Bool && forall (t :: * -> *) a. Foldable t => t a -> Bool null [(a, Span)] rest = [] | Bool otherwise = [(a, Span)] overlapping forall a. a -> [a] -> [a] : [RealTime] -> [(a, Span)] -> [[(a, Span)]] go [RealTime] ts [(a, Span)] rest where ([(a, Span)] overlapping, [(a, Span)] rest) = forall a. RealTime -> RealTime -> [(a, Span)] -> ([(a, Span)], [(a, Span)]) splitOverlapping RealTime t1 RealTime t2 [(a, Span)] spans go [RealTime] _ [(a, Span)] _ = [] splitOverlapping :: RealTime -> RealTime -> [(a, Span)] -> ([(a, Span)], [(a, Span)]) splitOverlapping :: forall a. RealTime -> RealTime -> [(a, Span)] -> ([(a, Span)], [(a, Span)]) splitOverlapping RealTime start RealTime end [(a, Span)] spans = ([(a, Span)] overlapping, [(a, Span)] overlapping forall a. [a] -> [a] -> [a] ++ [(a, Span)] rest) where overlapping :: [(a, Span)] overlapping = forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . Span -> Bool passed forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(a, Span)] here ([(a, Span)] here, [(a, Span)] rest) = forall a. (a -> Bool) -> [a] -> ([a], [a]) span ((forall a. Ord a => a -> a -> Bool <RealTime end) forall b c a. (b -> c) -> (a -> b) -> a -> c . Span -> RealTime _start forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] dropWhile (Span -> Bool passed forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(a, Span)] spans passed :: Span -> Bool passed Span n = Span -> RealTime _start Span n forall a. Num a => a -> a -> a + Span -> RealTime _duration Span n forall a. Ord a => a -> a -> Bool <= RealTime start Bool -> Bool -> Bool && Span -> RealTime _start Span n forall a. Ord a => a -> a -> Bool < RealTime start