-- 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