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

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
-- | This ties together the lower level tscore components.
--
-- Parse tscore, check and postprocess it, convert to Ui.State, and integrate.
module Derive.TScore.TScore (
    cmd_integrate
    , parse_score
#ifdef TESTING
    , module Derive.TScore.TScore
#endif
) where
import qualified Control.Monad.Identity as Identity
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Logger as Logger
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Integrate.Convert as Convert
import qualified Cmd.Integrate.Manual as Manual
import qualified Cmd.Perf as Perf
import qualified Cmd.Ruler.RulerUtil as RulerUtil

import qualified Derive.Derive as Derive
import qualified Derive.Eval as Eval
import qualified Derive.Note
import qualified Derive.Parse.Instruments as Instruments
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stack as Stack
import qualified Derive.TScore.Check as Check
import qualified Derive.TScore.Parse as Parse
import qualified Derive.TScore.T as T

import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.GenId as GenId
import qualified Ui.Id as Id
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Ruler as Ruler
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Transform as Transform
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- * types

data Block track = Block {
    forall track. Block track -> BlockId
_block_id :: !BlockId
    , forall track. Block track -> Text
_block_title :: !Text
    , forall track. Block track -> (Config, MSection)
_meter :: !(Meter.Config, Meter.MSection)
    -- | True if this was created via T.SubBlock.
    , forall track. Block track -> Bool
_is_sub :: !Bool
    , forall track. Block track -> [track]
_tracks :: ![track]
    } deriving (Block track -> Block track -> Bool
forall track. Eq track => Block track -> Block track -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block track -> Block track -> Bool
$c/= :: forall track. Eq track => Block track -> Block track -> Bool
== :: Block track -> Block track -> Bool
$c== :: forall track. Eq track => Block track -> Block track -> Bool
Eq, TrackNum -> Block track -> ShowS
forall track. Show track => TrackNum -> Block track -> ShowS
forall track. Show track => [Block track] -> ShowS
forall track. Show track => Block track -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block track] -> ShowS
$cshowList :: forall track. Show track => [Block track] -> ShowS
show :: Block track -> String
$cshow :: forall track. Show track => Block track -> String
showsPrec :: TrackNum -> Block track -> ShowS
$cshowsPrec :: forall track. Show track => TrackNum -> Block track -> ShowS
Show, forall a b. a -> Block b -> Block a
forall a b. (a -> b) -> Block a -> Block 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 -> Block b -> Block a
$c<$ :: forall a b. a -> Block b -> Block a
fmap :: forall a b. (a -> b) -> Block a -> Block b
$cfmap :: forall a b. (a -> b) -> Block a -> Block b
Functor)

-- | A tscore track consists of multiple tracklang tracks, since it includes
-- both rhythm and pitch.
data NTrack = NTrack {
    NTrack -> Track
_note :: !Track
    , NTrack -> Text
_key :: !Text
    , NTrack -> [Track]
_controls :: ![Track]
    -- | End of the track.  This could be past the end of the last event if
    -- there was a rest on the end.  This is intentionally not strict, because
    -- you should iterate over the tracks and events before looking at it.
    , NTrack -> Time
_end :: T.Time
    } deriving (NTrack -> NTrack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NTrack -> NTrack -> Bool
$c/= :: NTrack -> NTrack -> Bool
== :: NTrack -> NTrack -> Bool
$c== :: NTrack -> NTrack -> Bool
Eq, TrackNum -> NTrack -> ShowS
[NTrack] -> ShowS
NTrack -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NTrack] -> ShowS
$cshowList :: [NTrack] -> ShowS
show :: NTrack -> String
$cshow :: NTrack -> String
showsPrec :: TrackNum -> NTrack -> ShowS
$cshowsPrec :: TrackNum -> NTrack -> ShowS
Show)

-- | This track has been parsed, and directives propagated to Check.Config,
-- but not yet converted to a Track.
data ParsedTrack = ParsedTrack {
    ParsedTrack -> Config
track_config :: !Check.Config
    , ParsedTrack -> Text
track_key :: !Text
    , ParsedTrack -> Text
track_title :: !Text
    , ParsedTrack -> [Token (NPitch Pitch)]
track_tokens :: ![Token (T.NPitch T.Pitch)]
    , ParsedTrack -> Pos
track_pos :: !T.Pos
    } deriving (TrackNum -> ParsedTrack -> ShowS
[ParsedTrack] -> ShowS
ParsedTrack -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParsedTrack] -> ShowS
$cshowList :: [ParsedTrack] -> ShowS
show :: ParsedTrack -> String
$cshow :: ParsedTrack -> String
showsPrec :: TrackNum -> ParsedTrack -> ShowS
$cshowsPrec :: TrackNum -> ParsedTrack -> ShowS
Show)

type Token pitch = T.Token T.CallText pitch T.NDuration T.Duration

-- | A complete track, ready to be integrated or directly put in a block.
data Track = Track {
    Track -> Text
_title :: !Text
    , Track -> Events
_events :: !Events.Events
    } deriving (Track -> Track -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Track -> Track -> Bool
$c/= :: Track -> Track -> Bool
== :: Track -> Track -> Bool
$c== :: Track -> Track -> Bool
Eq, TrackNum -> Track -> ShowS
[Track] -> ShowS
Track -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: TrackNum -> Track -> ShowS
$cshowsPrec :: TrackNum -> Track -> ShowS
Show)

type Error = Text

instance Pretty track => Pretty (Block track) where
    format :: Block track -> Doc
format (Block BlockId
block_id Text
block_title (Config, MSection)
meter Bool
is_sub [track]
tracks) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Block"
            [ (Text
"block_id", forall a. Pretty a => a -> Doc
Pretty.format BlockId
block_id)
            , (Text
"block_title", forall a. Pretty a => a -> Doc
Pretty.format Text
block_title)
            , (Text
"meter", forall a. Pretty a => a -> Doc
Pretty.format (Config, MSection)
meter)
            , (Text
"is_sub", forall a. Pretty a => a -> Doc
Pretty.format Bool
is_sub)
            , (Text
"tracks", forall a. Pretty a => a -> Doc
Pretty.format [track]
tracks)
            ]

instance Pretty NTrack where
    format :: NTrack -> Doc
format (NTrack Track
note Text
key [Track]
controls Time
end) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"NTrack"
        [ (Text
"note", forall a. Pretty a => a -> Doc
Pretty.format Track
note)
        , (Text
"key", forall a. Pretty a => a -> Doc
Pretty.format Text
key)
        , (Text
"controls", forall a. Pretty a => a -> Doc
Pretty.format [Track]
controls)
        , (Text
"end", forall a. Pretty a => a -> Doc
Pretty.format Time
end)
        ]

instance Pretty Track where
    format :: Track -> Doc
format (Track Text
title Events
events) = forall a. Pretty a => a -> Doc
Pretty.format Text
title forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Pretty.format Events
events

-- * toplevel

cmd_integrate :: Cmd.M m => Text -> m [BlockId]
cmd_integrate :: forall (m :: * -> *). M m => Text -> m [BlockId]
cmd_integrate Text
source = do
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    State
cmd_state <- forall (m :: * -> *). M m => m State
Cmd.get
    forall (m :: * -> *).
M m =>
GetExternalCallDuration -> Text -> m [BlockId]
integrate (State -> State -> GetExternalCallDuration
get_external_duration State
ui_state State
cmd_state) Text
source

integrate :: Ui.M m => GetExternalCallDuration -> Text -> m [BlockId]
    -- ^ newly created blocks
integrate :: forall (m :: * -> *).
M m =>
GetExternalCallDuration -> Text -> m [BlockId]
integrate GetExternalCallDuration
get_ext_dur Text
source = do
    Namespace
ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
    ([Block NTrack]
blocks, ScoreConfig
config) <- forall (m :: * -> *) err a.
(HasCallStack, M m) =>
(err -> Text) -> Either err a -> m a
Ui.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Namespace
-> GetExternalCallDuration
-> Text
-> Either Text ([Block NTrack], ScoreConfig)
track_blocks Namespace
ns GetExternalCallDuration
get_ext_dur Text
source
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScoreConfig
config forall a. Eq a => a -> a -> Bool
== [Allocation] -> Text -> ScoreConfig
ScoreConfig forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (HasCallStack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"instruments or ky are only for standalone tscore,\
            \ put those in the Ui.State directly: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt ScoreConfig
config
    let ([Block NTrack]
subs, [Block NTrack]
parents) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition forall track. Block track -> Bool
_is_sub [Block NTrack]
blocks
    -- Unlike normal blocks, sub-blocks aren't integrated, but deleted and
    -- created from scratch each time.  This is so I don't have to worry about
    -- making their generated BlockIds stable.
    forall (m :: * -> *). M m => m ()
destroy_subs
    [BlockId]
sub_ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => Block NTrack -> m BlockId
ui_block [Block NTrack]
subs
    -- Mark them as sub blocks so I can delete them on the next integrate.
    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 forall (m :: * -> *). M m => BlockId -> (Meta -> Meta) -> m ()
Ui.modify_block_meta (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
sub_meta Text
"")) [BlockId]
sub_ids
    Map BlockId Block
old <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    let renames :: [(BlockId, BlockId)]
renames = Map BlockId Block -> [Block NTrack] -> [(BlockId, BlockId)]
find_block_renames Map BlockId Block
old [Block NTrack]
parents
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(BlockId, BlockId)]
renames) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => (Id -> Id) -> m ()
Transform.map_block_ids forall a b. (a -> b) -> a -> b
$ \Id
id ->
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe Id
id forall a. Ident a => a -> Id
Id.unpack_id (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Id -> BlockId
Id.BlockId Id
id) [(BlockId, BlockId)]
renames)
    forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall (m :: * -> *). M m => Block NTrack -> m (Maybe BlockId)
integrate_block [Block NTrack]
parents

destroy_subs :: Ui.M m => m ()
destroy_subs :: forall (m :: * -> *). M m => m ()
destroy_subs = do
    [(BlockId, Block)]
blocks <- forall a. (a -> Bool) -> [a] -> [a]
filter (Block -> Bool
is_sub_block forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> m ()
Ui.destroy_block forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(BlockId, Block)]
blocks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m ()
Ui.destroy_track forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Block -> [TrackId]
Block.block_track_ids forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(BlockId, Block)]
blocks

track_blocks :: Id.Namespace -> GetExternalCallDuration -> Text
    -> Either Error ([Block NTrack], ScoreConfig)
track_blocks :: Namespace
-> GetExternalCallDuration
-> Text
-> Either Text ([Block NTrack], ScoreConfig)
track_blocks Namespace
namespace GetExternalCallDuration
get_ext_dur Text
source = do
    ([Block ParsedTrack]
blocks, ScoreConfig
config) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error -> Text
T.show_error Text
source) forall a b. (a -> b) -> a -> b
$ Text -> Either Error ([Block ParsedTrack], ScoreConfig)
parse_blocks Text
source
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall pitch. [Block [Token pitch]] -> Maybe Text
check_recursion forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ParsedTrack -> [Token (NPitch Pitch)]
track_tokens <$>) [Block ParsedTrack]
blocks) forall a b. a -> Either a b
Left
    case [Block ParsedTrack] -> [Error]
check_recursive_copy_from [Block ParsedTrack]
blocks of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [Error]
errs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"recursive %f: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Error -> Text
T.show_error Text
source) [Error]
errs)
    case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block ParsedTrack -> [Error]
check_unique_keys [Block ParsedTrack]
blocks of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [Error]
errs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Error -> Text
T.show_error Text
source) [Error]
errs)

    -- -- TODO not implemented yet
    -- let cmd_config = undefined
    -- derive_args <- make_derive_args cmd_config (config_instruments config)
    --     (config_ky config)
    -- let get_ext_dur = get_external_duration2 derive_args

    ([Text]
errs, [Block NTrack]
blocks) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall err track.
[Block (Either err track)] -> ([err], [Block track])
partition_errors forall a b. (a -> b) -> a -> b
$ GetExternalCallDuration
-> Text -> [Block ParsedTrack] -> [Block (Either Text NTrack)]
resolve_blocks GetExternalCallDuration
get_ext_dur Text
source [Block ParsedTrack]
blocks
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
errs
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (forall track. Namespace -> Block track -> Block track
set_namespace Namespace
namespace) [Block NTrack]
blocks, ScoreConfig
config)

check_unique_keys :: Block ParsedTrack -> [T.Error]
check_unique_keys :: Block ParsedTrack -> [Error]
check_unique_keys Block ParsedTrack
block =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ParsedTrack, NonEmpty ParsedTrack) -> [Error]
mkerror forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> k) -> [a] -> [(a, NonEmpty a)]
Lists.findDups ParsedTrack -> (Text, Text)
key_of (forall track. Block track -> [track]
_tracks Block ParsedTrack
block)
    where
    mkerror :: (ParsedTrack, NonEmpty ParsedTrack) -> [Error]
mkerror (ParsedTrack
track, NonEmpty ParsedTrack
tracks) =
        Pos -> Text -> Error
T.Error (ParsedTrack -> Pos
track_pos ParsedTrack
track)
            (Text
"non-unique track key " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (ParsedTrack -> (Text, Text)
key_of ParsedTrack
track))
        forall a. a -> [a] -> [a]
: [Pos -> Text -> Error
T.Error (ParsedTrack -> Pos
track_pos ParsedTrack
t) Text
"" | ParsedTrack
t <- forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ParsedTrack
tracks]
    key_of :: ParsedTrack -> (Text, Text)
key_of ParsedTrack
t = (ParsedTrack -> Text
track_key ParsedTrack
t, ParsedTrack -> Text
track_title ParsedTrack
t)

-- | Replace the namespace.
--
-- I used to put tscore-generated things in 'Parse.default_namespace', so
-- they wouldn't clash with non-tscore blocks.  But then it turns out that
-- means tscore blocks can't call other tscore blocks without qualification!
-- Since I want more seemless integration, I no longer want a separate tscore
-- namespace.
set_namespace :: Id.Namespace -> Block track -> Block track
set_namespace :: forall track. Namespace -> Block track -> Block track
set_namespace Namespace
ns Block track
block =
    Block track
block { _block_id :: BlockId
_block_id = forall a. Ident a => (Id -> Id) -> a -> a
Id.modify Id -> Id
update (forall track. Block track -> BlockId
_block_id Block track
block) }
    where
    update :: Id -> Id
update Id
block_id
        | forall a. Ident a => a -> Namespace
Id.ident_namespace Id
block_id forall a. Eq a => a -> a -> Bool
== Namespace
Parse.default_namespace =
            Namespace -> Id -> Id
Id.set_namespace Namespace
ns Id
block_id
        | Bool
otherwise = Id
block_id

partition_errors :: [Block (Either err track)] -> ([err], [Block track])
partition_errors :: forall err track.
[Block (Either err track)] -> ([err], [Block track])
partition_errors = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {track}. Block (Either a track) -> ([a], Block track)
partition_block
    where
    partition_block :: Block (Either a track) -> ([a], Block track)
partition_block Block (Either a track)
block = ([a]
errs, Block (Either a track)
block { _tracks :: [track]
_tracks = [track]
tracks })
        where ([a]
errs, [track]
tracks) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers (forall track. Block track -> [track]
_tracks Block (Either a track)
block)

-- | Get the duration of a block call from the tracklang performance, not
-- tscore.
--
-- transformers -> call -> (duration, logs)
type GetExternalCallDuration =
    [Text] -> Text -> (Either Error TrackTime, [Log.Msg])

-- TODO I'll need some way to get the logs out, but I'd prefer to not make
-- everything monadic.
get_external_duration :: Ui.State -> Cmd.State -> GetExternalCallDuration
get_external_duration :: State -> State -> GetExternalCallDuration
get_external_duration State
ui_state State
cmd_state [Text]
transformers Text
call =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {b}. Either String (Maybe b) -> Either Text b
adapt forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
Identity.runIdentity forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
Monad m =>
State -> State -> CmdT m a -> m (Either String a, [Msg])
Cmd.eval State
ui_state State
cmd_state (forall (m :: * -> *). M m => [Text] -> Text -> m (Maybe TrackTime)
lookup_call_duration [Text]
transformers Text
call)
    where
    adapt :: Either String (Maybe b) -> Either Text b
adapt (Left String
err) = forall a b. a -> Either a b
Left (String -> Text
txt String
err)
    adapt (Right Maybe b
Nothing) = forall a b. a -> Either a b
Left Text
"call doesn't support CallDuration"
    adapt (Right (Just b
dur)) = forall a b. b -> Either a b
Right b
dur

lookup_call_duration :: Cmd.M m => [Text] -> Text -> m (Maybe TrackTime)
lookup_call_duration :: forall (m :: * -> *). M m => [Text] -> Text -> m (Maybe TrackTime)
lookup_call_duration [Text]
transformers Text
call = do
    -- I need BlockId, TrackId to get the Dynamic, for deriving context.
    -- I think it shouldn't really matter for call duration, but of course it
    -- could.  If I pick the root block then I get global transform and
    -- whatever transform is in the root.
    (BlockId
block_id, TrackId
track_id) <- forall (m :: * -> *). M m => m (BlockId, TrackId)
root_block
    Either Error (CallDuration TrackTime)
result <- forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m a
Perf.derive_at_throw BlockId
block_id TrackId
track_id forall a b. (a -> b) -> a -> b
$
        forall a.
Deriver a -> Deriver (Either Error (CallDuration TrackTime))
Derive.get_score_duration Deriver (Stream Event)
deriver
    case Either Error (CallDuration TrackTime)
result of
        Left Error
err -> forall (m :: * -> *) a. (HasCallStack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Error
err
        Right CallDuration TrackTime
Derive.Unknown -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right (Derive.CallDuration TrackTime
dur) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TrackTime
dur
    where
    -- I think if I have a root block with a performance then I don't need
    -- with_default_imported, but for tests I don't have a Performance.
    -- TODO it would be better to get a Performance for tests.

    transform :: [Deriver (Stream Event) -> Deriver (Stream Event)]
transform = forall a b. (a -> b) -> [a] -> [b]
map (forall d.
(Callable (Transformer d), Taggable d) =>
Text -> Text -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transform_expr Text
"lookup_call_duration") forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) [Text]
transformers
    deriver :: Deriver (Stream Event)
deriver = forall a. Deriver a -> Deriver a
Derive.with_default_imported forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [Deriver (Stream Event) -> Deriver (Stream Event)]
transform forall a b. (a -> b) -> a -> b
$
        forall d.
CallableExpr d =>
TrackInfo d -> Event -> Deriver (Stream d)
Perf.derive_event (Track -> [EventsNode] -> TrackInfo Event
Derive.Note.track_info Track
track [])
            (TrackTime -> TrackTime -> Text -> Event
Event.event TrackTime
0 TrackTime
1 Text
call)
    track :: Track
track = Text -> Events -> TrackTime -> Track
TrackTree.make_track Text
"title" forall a. Monoid a => a
mempty TrackTime
1

root_block :: Ui.M m => m (BlockId, TrackId)
root_block :: forall (m :: * -> *). M m => m (BlockId, TrackId)
root_block = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Ui.get_root_id
    TrackId
track_id <- forall (m :: * -> *) a.
(HasCallStack, M m) =>
Text -> Maybe a -> m a
Ui.require Text
"root block has no tracks" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m [TrackId]
Ui.track_ids_of BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, TrackId
track_id)

-- * get_external_duration2

-- TODO: not implemented yet

data DeriveArgs =
    DeriveArgs Cmd.Config UiConfig.Allocations Derive.Builtins
        Derive.InstrumentAliases
    deriving (TrackNum -> DeriveArgs -> ShowS
[DeriveArgs] -> ShowS
DeriveArgs -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeriveArgs] -> ShowS
$cshowList :: [DeriveArgs] -> ShowS
show :: DeriveArgs -> String
$cshow :: DeriveArgs -> String
showsPrec :: TrackNum -> DeriveArgs -> ShowS
$cshowsPrec :: TrackNum -> DeriveArgs -> ShowS
Show)

make_derive_args :: Cmd.Config -> [Instruments.Allocation] -> Text
    -> Either Error DeriveArgs
make_derive_args :: Config -> [Allocation] -> Text -> Either Text DeriveArgs
make_derive_args Config
cmd_config [Allocation]
allocs Text
ky = do
    (Builtins
builtins, InstrumentAliases
aliases) <- Text -> Either Text (Builtins, InstrumentAliases)
parse_ky Text
ky
    Allocations
allocations <- [Allocation] -> Either Text Allocations
convert_allocations [Allocation]
allocs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config
-> Allocations -> Builtins -> InstrumentAliases -> DeriveArgs
DeriveArgs Config
cmd_config Allocations
allocations Builtins
builtins InstrumentAliases
aliases
    where
    parse_ky :: Text -> Either Error (Derive.Builtins, Derive.InstrumentAliases)
    parse_ky :: Text -> Either Text (Builtins, InstrumentAliases)
parse_ky = forall a. HasCallStack => a
undefined -- TODO
    convert_allocations :: [Instruments.Allocation]
        -> Either Error UiConfig.Allocations
    convert_allocations :: [Allocation] -> Either Text Allocations
convert_allocations = forall a. HasCallStack => a
undefined -- TODO

get_external_duration2 :: DeriveArgs -> GetExternalCallDuration
get_external_duration2 :: DeriveArgs -> GetExternalCallDuration
get_external_duration2 DeriveArgs
derive_args [Text]
transformers Text
call =
    ( case Either Error (Either Error (CallDuration TrackTime))
result of
        Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Error
err
        Right (Left Error
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Error
err
        Right (Right CallDuration TrackTime
Derive.Unknown) ->
            forall a b. a -> Either a b
Left Text
"call doesn't support CallDuration"
        Right (Right (Derive.CallDuration TrackTime
dur)) -> forall a b. b -> Either a b
Right TrackTime
dur
    , [Msg]
logs
    )
    where
    (Either Error (Either Error (CallDuration TrackTime))
result, [Msg]
logs) = forall a. DeriveArgs -> Deriver a -> (Either Error a, [Msg])
mini_derive DeriveArgs
derive_args forall a b. (a -> b) -> a -> b
$
        forall a. Deriver a -> Deriver a
Derive.with_default_imported forall a b. (a -> b) -> a -> b
$
        forall a.
Deriver a -> Deriver (Either Error (CallDuration TrackTime))
Derive.get_score_duration forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [Deriver (Stream Event) -> Deriver (Stream Event)]
transform forall a b. (a -> b) -> a -> b
$
        forall d.
CallableExpr d =>
TrackInfo d -> Event -> Deriver (Stream d)
Perf.derive_event (Track -> [EventsNode] -> TrackInfo Event
Derive.Note.track_info Track
track [])
            (TrackTime -> TrackTime -> Text -> Event
Event.event TrackTime
0 TrackTime
1 Text
call)
    transform :: [Deriver (Stream Event) -> Deriver (Stream Event)]
transform = forall a b. (a -> b) -> [a] -> [b]
map (forall d.
(Callable (Transformer d), Taggable d) =>
Text -> Text -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transform_expr Text
"lookup_call_duration") forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) [Text]
transformers
    track :: Track
track = Text -> Events -> TrackTime -> Track
TrackTree.make_track Text
"title" forall a. Monoid a => a
mempty TrackTime
1

mini_derive :: DeriveArgs -> Derive.Deriver a
    -> (Either Derive.Error a, [Log.Msg])
mini_derive :: forall a. DeriveArgs -> Deriver a -> (Either Error a, [Msg])
mini_derive (DeriveArgs Config
cmd_config Allocations
allocs Builtins
builtins InstrumentAliases
aliases) Deriver a
deriver = do
    let ui_state :: State
ui_state = Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= Allocations
allocs forall a b. (a -> b) -> a -> b
$ State
Ui.empty
    forall a.
State
-> Config
-> Builtins
-> InstrumentAliases
-> Deriver a
-> (Either Error a, [Msg])
Perf.mini_derive State
ui_state Config
cmd_config Builtins
builtins InstrumentAliases
aliases Deriver a
deriver

-- * detect moves

{- | Use a heuristic to see if any blocks have been renamed.

    I can't know for sure because tscore is just text, and there's no identetiy
    for the chunk of test that represents a block.  But I do rename blocks
    often, so I'd like something smarter than making an unrelated copy.  I could
    exit and issue a rename command, but I'd have to also modify the text, and
    besides the UI seems awkward.  So I detect the rename, but you have to
    just rename the block, not modify any events.

    A block is a rename of another one if:
    - I am its source: An existing one has integrated_manual = "tscore"
    - With NoteDestinations equal to the ones I would produce.
    - It was deleted: BlockId is not in current blocks.

    I don't care if its actual events differ, because I want to retain local
    edits across the rename.
-}
find_block_renames :: Map BlockId Block.Block -> [Block NTrack]
    -> [(BlockId, BlockId)]
find_block_renames :: Map BlockId Block -> [Block NTrack] -> [(BlockId, BlockId)]
find_block_renames Map BlockId Block
old_blocks [Block NTrack]
new_blocks = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Block NTrack -> Maybe (BlockId, BlockId)
renamed [Block NTrack]
new_blocks
    where
    renamed :: Block NTrack -> Maybe (BlockId, BlockId)
renamed Block NTrack
new_block = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
==[(Track, [Track])]
converted) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(BlockId, [(Track, [Track])])]
candidates of
        Maybe (BlockId, [(Track, [Track])])
Nothing -> forall a. Maybe a
Nothing
        Just (BlockId
old_block_id, [(Track, [Track])]
_) -> forall a. a -> Maybe a
Just (BlockId
old_block_id, forall track. Block track -> BlockId
_block_id Block NTrack
new_block)
        where converted :: [(Track, [Track])]
converted = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (Track, b) -> (Track, b)
strip_title forall a b. (a -> b) -> a -> b
$ Block NTrack -> [(Track, [Track])]
convert_tracks Block NTrack
new_block
    -- See convert_destination below.
    strip_title :: (Track, b) -> (Track, b)
strip_title (Track
note, b
controls) = (Track
note { track_title :: Text
Convert.track_title = Text
"" }, b
controls)
    candidates :: [(BlockId, [(Convert.Track, [Convert.Track])])]
    candidates :: [(BlockId, [(Track, [Track])])]
candidates = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map NoteDestination -> (Track, [Track])
convert_destination)) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
            (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
source_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> ManualDestinations
Block.block_integrated_manual))
        [(BlockId, Block)]
deleted
    deleted :: [(BlockId, Block)]
deleted = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BlockId]
block_ids) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map BlockId Block
old_blocks
    block_ids :: [BlockId]
block_ids = forall a b. (a -> b) -> [a] -> [b]
map forall track. Block track -> BlockId
_block_id [Block NTrack]
new_blocks

convert_destination :: Block.NoteDestination -> (Convert.Track, [Convert.Track])
convert_destination :: NoteDestination -> (Track, [Track])
convert_destination (Block.NoteDestination Text
_key (TrackId, EventIndex)
note Map Text (TrackId, EventIndex)
controls) =
    -- NoteDestinations don't record the track title.  I guess it could, but
    -- I'm just going to replace it anyway.  So strip it out of the new blocks
    -- too before comparing.  But this means I should do a merge after the
    -- rename, or I'll miss a possible simultaneous track title change.
    ( forall {k}. Text -> Map k Event -> Track
convert Text
"" (forall a b. (a, b) -> b
snd (TrackId, EventIndex)
note)
    , forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {k}. Text -> Map k Event -> Track
convert) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (TrackId, EventIndex)
controls)
    )
    where
    convert :: Text -> Map k Event -> Track
convert Text
title Map k Event
index = Convert.Track
        { track_title :: Text
track_title = Text
title
        , track_events :: [Event]
track_events = forall k a. Map k a -> [a]
Map.elems Map k Event
index
        }

-- * resolve blocks

-- | Look for recursive block calls.  If there are none, it's safe to
-- 'resolve_blocks'.
check_recursion :: [Block [Token pitch]] -> Maybe Error
check_recursion :: forall pitch. [Block [Token pitch]] -> Maybe Text
check_recursion [Block [Token pitch]]
blocks =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([BlockId] -> Block [Token pitch] -> Either Text ()
check_block []) [Block [Token pitch]]
blocks
    where
    by_block_id :: Map BlockId (Block [Token pitch])
by_block_id = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall track. Block track -> BlockId
_block_id [Block [Token pitch]]
blocks
    check_block :: [BlockId] -> Block [Token pitch] -> Either Text ()
check_block [BlockId]
stack_ Block [Token pitch]
block
        | forall track. Block track -> BlockId
_block_id Block [Token pitch]
block forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BlockId]
stack_ =
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"recursive loop: "
                forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map BlockId -> Text
Parse.show_block (forall a. [a] -> [a]
reverse [BlockId]
stack))
        | Bool
otherwise =
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([BlockId] -> BlockId -> [Token pitch] -> Either Text ()
check_track [BlockId]
stack (forall track. Block track -> BlockId
_block_id Block [Token pitch]
block)) (forall track. Block track -> [track]
_tracks Block [Token pitch]
block)
        where stack :: [BlockId]
stack = forall track. Block track -> BlockId
_block_id Block [Token pitch]
block forall a. a -> [a] -> [a]
: [BlockId]
stack_
    check_track :: [BlockId] -> BlockId -> [Token pitch] -> Either Text ()
check_track [BlockId]
stack BlockId
parent =
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([BlockId] -> BlockId -> Text -> Either Text ()
check_call [BlockId]
stack BlockId
parent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall pitch ndur rdur. Token Text pitch ndur rdur -> Maybe Text
call_of
    check_call :: [BlockId] -> BlockId -> Text -> Either Text ()
check_call [BlockId]
stack BlockId
parent Text
call =
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (BlockId -> Text -> Maybe BlockId
Check.call_block_id BlockId
parent Text
call) forall a b. (a -> b) -> a -> b
$ \BlockId
block_id ->
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId (Block [Token pitch])
by_block_id) forall a b. (a -> b) -> a -> b
$
                [BlockId] -> Block [Token pitch] -> Either Text ()
check_block [BlockId]
stack

call_of :: T.Token T.CallText pitch ndur rdur -> Maybe T.CallText
call_of :: forall pitch ndur rdur. Token Text pitch ndur rdur -> Maybe Text
call_of (T.TNote Pos
_ Note Text pitch ndur
note) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall call pitch dur. Note call pitch dur -> call
T.note_call Note Text pitch ndur
note
call_of Token Text pitch ndur rdur
_ = forall a. Maybe a
Nothing

type ResolvedNote = (T.Time, T.Note T.CallText (Maybe T.PitchText) T.Time)

-- | Check and resolve pitches and durations with 'Check.check'.
--
-- This has to be interleaved across blocks because 'T.CallDuration' means the
-- duration of a note can depend on the duration of other blocks, and so forth.
-- I can get this interleaved and cached via a lazy memo table, but it's only
-- safe because I previously did 'check_recursion'.
resolve_blocks :: GetExternalCallDuration -> Text -> [Block ParsedTrack]
    -> [Block (Either Error NTrack)]
resolve_blocks :: GetExternalCallDuration
-> Text -> [Block ParsedTrack] -> [Block (Either Text NTrack)]
resolve_blocks GetExternalCallDuration
get_ext_dur Text
source [Block ParsedTrack]
blocks =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Bool, [ResolvedNote], Text, Text), Time) -> NTrack
make_track)) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map
  BlockId
  (Block (Either Text ((Bool, [ResolvedNote], Text, Text), Time)))
resolved_notes
    where
    resolved_notes :: Map Id.BlockId
        (Block (Either Error ((Bool, [ResolvedNote], Text, Text), T.Time)))
    resolved_notes :: Map
  BlockId
  (Block (Either Text ((Bool, [ResolvedNote], Text, Text), Time)))
resolved_notes = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [(forall track. Block track -> BlockId
_block_id Block ParsedTrack
block, Block ParsedTrack
-> Block (Either Text ((Bool, [ResolvedNote], Text, Text), Time))
resolve_block Block ParsedTrack
block) | Block ParsedTrack
block <- [Block ParsedTrack]
blocks]
    -- Memoized duration of blocks.
    block_durations :: Map Id.BlockId (Either Error T.Time)
    block_durations :: Map BlockId (Either Text Time)
block_durations = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey forall {p :: * -> * -> *} {a} {b} {a}.
(Monad (p Text), Bifunctor p, Pretty a, Ord b, Num b) =>
a -> Block (p Text (a, b)) -> p Text b
block_duration Map
  BlockId
  (Block (Either Text ((Bool, [ResolvedNote], Text, Text), Time)))
resolved_notes

    -- Convert [ResolvedNote] to NTrack.
    make_track :: ((Bool, [ResolvedNote], Text, Text), Time) -> NTrack
make_track ((Bool
negative, [ResolvedNote]
notes, Text
key, Text
title), Time
end) = NTrack
        { _note :: Track
_note = Track
            { _title :: Text
_title = if Text
title forall a. Eq a => a -> a -> Bool
== Text
"" then Text
">" else Text
title
            , _events :: Events
_events = [Event] -> Events
Events.from_list forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall pitch. Time -> Note Text pitch Time -> Event
note_event) [ResolvedNote]
notes
            }
        , _key :: Text
_key = Text
key
        , _controls :: [Track]
_controls = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
pitches then [] else (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ Track
            { _title :: Text
_title = Text
"*"
            , _events :: Events
_events = [Event] -> Events
Events.from_list [Event]
pitches
            }
        , _end :: Time
_end = Time
end
        }
        where
        pitches :: [Event]
pitches = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> (Time, Text) -> Event
pitch_event Bool
negative) forall a b. (a -> b) -> a -> b
$
            forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Lists.mapMaybeSnd forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch [ResolvedNote]
notes

    resolve_block :: Block ParsedTrack
-> Block (Either Text ((Bool, [ResolvedNote], Text, Text), Time))
resolve_block Block ParsedTrack
block = Block ParsedTrack
block
        { _tracks :: [Either Text ((Bool, [ResolvedNote], Text, Text), Time)]
_tracks = BlockId
-> Text
-> [ParsedTrack]
-> [Either Text ((Bool, [ResolvedNote], Text, Text), Time)]
resolve_tracks (forall track. Block track -> BlockId
_block_id Block ParsedTrack
block) (forall track. Block track -> Text
_block_title Block ParsedTrack
block)
            (forall track. Block track -> [track]
_tracks Block ParsedTrack
block)
        }
    resolve_tracks :: BlockId
-> Text
-> [ParsedTrack]
-> [Either Text ((Bool, [ResolvedNote], Text, Text), Time)]
resolve_tracks BlockId
block_id Text
block_title =
        forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (BlockId
-> Text
-> Maybe [AssertCoincident]
-> (TrackNum, ParsedTrack)
-> (Maybe [AssertCoincident],
    Either Text ((Bool, [ResolvedNote], Text, Text), Time))
resolve BlockId
block_id Text
block_title) forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
1..]
    resolve :: BlockId
-> Text
-> Maybe [AssertCoincident]
-> (TrackNum, ParsedTrack)
-> (Maybe [AssertCoincident],
    Either Text ((Bool, [ResolvedNote], Text, Text), Time))
resolve BlockId
block_id Text
block_title Maybe [AssertCoincident]
mb_asserts
            (TrackNum
tracknum, ParsedTrack Config
config Text
key Text
title [Token (NPitch Pitch)]
tokens Pos
_pos) =
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [AssertCoincident]
asserts Maybe [AssertCoincident]
mb_asserts,) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error -> Text
T.show_error Text
source)forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. [a] -> Maybe a
Lists.head [Error]
errs) forall a b. a -> Either a b
Left
            let to_tracks :: Block (Either Text ((a, b, c, d), b)) -> [Either Text b]
to_tracks = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\(a
_, b
notes, c
_, d
_) -> b
notes) 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 track. Block track -> [track]
_tracks
            Maybe [ResolvedNote]
mb_from_track <- case Config -> Maybe From
Check.config_from Config
config of
                Just From
from -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                    Either Text [ResolvedNote]
from_track <- forall track.
Map BlockId [track]
-> BlockId -> TrackNum -> From -> Either Error track
resolve_from (forall {a} {b} {c} {d} {b}.
Block (Either Text ((a, b, c, d), b)) -> [Either Text b]
to_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  BlockId
  (Block (Either Text ((Bool, [ResolvedNote], Text, Text), Time)))
resolved_notes)
                        BlockId
block_id TrackNum
tracknum From
from
                    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Pos -> Text -> Error
T.Error (From -> Pos
Check.from_pos From
from)
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"can't copy from a broken track: "<>)) Either Text [ResolvedNote]
from_track
                Maybe From
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            [ResolvedNote]
notes <- Maybe [ResolvedNote]
-> [(Time, Note Text (NPitch (Maybe Text)) Time)]
-> Either Error [ResolvedNote]
resolve_copy_from Maybe [ResolvedNote]
mb_from_track [(Time, Note Text (NPitch (Maybe Text)) Time)]
uncopied
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe [AssertCoincident]
mb_asserts forall a b. (a -> b) -> a -> b
$ \[AssertCoincident]
prev ->
                forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall call pitch dur.
[AssertCoincident]
-> [AssertCoincident]
-> [(Time, Note call pitch dur)]
-> Maybe Error
match_asserts [AssertCoincident]
prev [AssertCoincident]
asserts [ResolvedNote]
notes) forall a b. a -> Either a b
Left
            forall (m :: * -> *) a. Monad m => a -> m a
return ((Config -> Bool
Check.config_negative Config
config, [ResolvedNote]
notes, Text
key, Text
title), Time
end)
        where
        (([Meta]
metas, [(Time, Note Text (NPitch (Maybe Text)) Time)]
uncopied), Time
end) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall a b. (a -> b) -> a -> b
$
            GetCallDuration
-> Config
-> [Token (NPitch Pitch)]
-> ([Either Meta (Time, Note Text (NPitch (Maybe Text)) Time)],
    Time)
Check.check ([Text] -> BlockId -> GetCallDuration
get_dur (Text -> Text -> [Text]
to_transformers Text
block_title Text
title) BlockId
block_id)
                Config
config [Token (NPitch Pitch)]
tokens
        ([Error]
errs, [AssertCoincident]
asserts) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Meta]
metas
    -- I could memoize external calls in the same way as internal ones, but
    -- a tracklang call duration is set manually, so it can't affect another
    -- call duration, so the recursive thing doesn't happen.  Which is good,
    -- because there's a phase difference between tscore and tracklang (that's
    -- the integration), so it wouldn't be reliable anyway.  So a non-memoized
    -- lookup shouldn't have the same quadratic performance.
    get_dur :: [Text] -> BlockId -> GetCallDuration
get_dur [Text]
transformers BlockId
parent Text
call = case BlockId -> Text -> Maybe BlockId
Check.call_block_id BlockId
parent Text
call of
        Maybe BlockId
Nothing -> (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"not a block call: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
call, [])
        Just BlockId
block_id -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId (Either Text Time)
block_durations of
            Maybe (Either Text Time)
Nothing ->
                ( forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Text
"call " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
call forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) TrackTime -> Time
from_track_time
                    Either Text TrackTime
result
                , [Msg]
logs
                )
                where (Either Text TrackTime
result, [Msg]
logs) = GetExternalCallDuration
get_ext_dur [Text]
transformers Text
call
            Just Either Text Time
err_dur -> (Either Text Time
err_dur, [])
    to_transformers :: Text -> Text -> [Text]
to_transformers Text
block_title Text
track_title = Text
block_title
        forall a. a -> [a] -> [a]
: if Text
track_title forall a. Eq a => a -> a -> Bool
== Text
"" then [] else [Text -> Text
note_to_transform Text
track_title]
    note_to_transform :: Text -> Text
note_to_transform =
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Text
"") forall a. ShowVal a => a -> Text
ShowVal.show_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Expr
ParseTitle.parse_note
    block_duration :: a -> Block (p Text (a, b)) -> p Text b
block_duration a
block_id Block (p Text (a, b))
block = do
        [(a, b)]
tracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
1..] (forall track. Block track -> [track]
_tracks Block (p Text (a, b))
block)) forall a b. (a -> b) -> a -> b
$
            \(TrackNum
tracknum, p Text (a, b)
track) -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
                ((Text
"can't get duration of broken track: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (a
block_id, TrackNum
tracknum :: TrackNum) forall a. Semigroup a => a -> a -> a
<> Text
": ")<>)
                p Text (a, b)
track
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ b
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, b)]
tracks

-- | If an expected assert isn't found, or if I got one that wasn't expected,
-- emit an error with the location.
match_asserts :: [Check.AssertCoincident] -> [Check.AssertCoincident]
    -> [(T.Time, T.Note call pitch dur)] -> Maybe T.Error
match_asserts :: forall call pitch dur.
[AssertCoincident]
-> [AssertCoincident]
-> [(Time, Note call pitch dur)]
-> Maybe Error
match_asserts [] (Check.AssertCoincident Time
_ Pos
pos : [AssertCoincident]
_) [(Time, Note call pitch dur)]
_ =
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error Pos
pos Text
"got unexpected assert"
match_asserts (Check.AssertCoincident Time
t1 Pos
_ : [AssertCoincident]
expected) [AssertCoincident]
asserts [(Time, Note call pitch dur)]
time_notes =
    case [AssertCoincident]
asserts of
        Check.AssertCoincident Time
t2 Pos
_ : [AssertCoincident]
asserts
            | Time
t1 forall a. Eq a => a -> a -> Bool
== Time
t2 -> forall call pitch dur.
[AssertCoincident]
-> [AssertCoincident]
-> [(Time, Note call pitch dur)]
-> Maybe Error
match_asserts [AssertCoincident]
expected [AssertCoincident]
asserts [(Time, Note call pitch dur)]
time_notes
        [AssertCoincident]
_ -> case forall call pitch dur.
Time -> [(Time, Note call pitch dur)] -> Maybe Pos
find_pos Time
t1 [(Time, Note call pitch dur)]
time_notes of
            Maybe Pos
Nothing -> forall a. Maybe a
Nothing
            Just Pos
pos -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error Pos
pos Text
"expected assert here"
match_asserts [] [] [(Time, Note call pitch dur)]
_ = forall a. Maybe a
Nothing

find_pos :: T.Time -> [(T.Time, T.Note call pitch dur)] -> Maybe T.Pos
find_pos :: forall call pitch dur.
Time -> [(Time, Note call pitch dur)] -> Maybe Pos
find_pos Time
t [(Time, Note call pitch dur)]
time_notes = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<Time
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Time, Note call pitch dur)]
time_notes of
    (Time
_, Note call pitch dur
note) : [(Time, Note call pitch dur)]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall call pitch dur. Note call pitch dur -> Pos
T.note_pos Note call pitch dur
note
    -- Don't enforce asserts past the end of the notes.
    [] -> forall a. Maybe a
Nothing

-- ** copy from

-- | Each %f must refer to a track without %f.  This also forbids non-recursive
-- multiple levels of %f, which 'resolve_copy_from' would handle fine, but I
-- don't mind forbidding those too.
--
-- This does a redundant 'resolve_from' since 'resolve_blocks' will do it in
-- again, but it seems like a hassle to try to stash the resolved froms in a
-- Block.
check_recursive_copy_from :: [Block ParsedTrack] -> [T.Error]
check_recursive_copy_from :: [Block ParsedTrack] -> [Error]
check_recursive_copy_from [Block ParsedTrack]
blocks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block ParsedTrack -> [Error]
check_block [Block ParsedTrack]
blocks
    where
    check_block :: Block ParsedTrack -> [Error]
check_block Block ParsedTrack
block =
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (BlockId -> (TrackNum, ParsedTrack) -> Maybe Error
check (forall track. Block track -> BlockId
_block_id Block ParsedTrack
block)) (forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
1..] (forall track. Block track -> [track]
_tracks Block ParsedTrack
block))
    check :: BlockId -> (TrackNum, ParsedTrack) -> Maybe Error
check BlockId
block_id (TrackNum
tracknum, ParsedTrack
track) = do
        From
from <- Config -> Maybe From
Check.config_from (ParsedTrack -> Config
track_config ParsedTrack
track)
        ParsedTrack
track2 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            forall track.
Map BlockId [track]
-> BlockId -> TrackNum -> From -> Either Error track
resolve_from Map BlockId [ParsedTrack]
block_tracks BlockId
block_id TrackNum
tracknum From
from
        From
from2 <- Config -> Maybe From
Check.config_from (ParsedTrack -> Config
track_config ParsedTrack
track2)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error (From -> Pos
Check.from_pos From
from) forall a b. (a -> b) -> a -> b
$
            BlockId -> TrackNum -> Text
Parse.show_block_track BlockId
block_id TrackNum
tracknum
            forall a. Semigroup a => a -> a -> a
<> Text
" has %f=" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty From
from forall a. Semigroup a => a -> a -> a
<> Text
", which has %f="
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty From
from2
    block_tracks :: Map BlockId [ParsedTrack]
block_tracks =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall track. Block track -> BlockId
_block_id Block ParsedTrack
block, forall track. Block track -> [track]
_tracks Block ParsedTrack
block) | Block ParsedTrack
block <- [Block ParsedTrack]
blocks]

-- | Resolve 'Check.From' to the track it names.  On a track %f=n copies
-- from the track number.  On a block, %f=name is like a %f on each track
-- with its corresponding track on the given block.
resolve_from :: Map Id.BlockId [track]
    -> Id.BlockId -> TrackNum -> Check.From -> Either T.Error track
resolve_from :: forall track.
Map BlockId [track]
-> BlockId -> TrackNum -> From -> Either Error track
resolve_from Map BlockId [track]
blocks BlockId
current_block TrackNum
current_tracknum
        (Check.From Maybe BlockId
mb_block_id TrackNum
tracknum Pos
pos) = do
    let block_id :: BlockId
block_id = forall a. a -> Maybe a -> a
fromMaybe BlockId
current_block Maybe BlockId
mb_block_id
    [track]
tracks <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text -> Error
mkerror
            (Text
"block not found: " forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
Parse.show_block BlockId
block_id)) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId [track]
blocks
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockId
block_id forall a. Eq a => a -> a -> Bool
== BlockId
current_block Bool -> Bool -> Bool
&& TrackNum
tracknum forall a. Eq a => a -> a -> Bool
== TrackNum
current_tracknum) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Error
mkerror forall a b. (a -> b) -> a -> b
$ Text
"can't copy from the same track: "
            forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
Parse.show_block BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackNum
tracknum
    forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text -> Error
mkerror forall a b. (a -> b) -> a -> b
$ BlockId -> Text
Parse.show_block BlockId
block_id
            forall a. Semigroup a => a -> a -> a
<> Text
" doesn't have track " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackNum
tracknum) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> TrackNum -> Maybe a
Lists.at [track]
tracks (TrackNum
tracknum forall a. Num a => a -> a -> a
- TrackNum
1)
    where
    mkerror :: Text -> Error
mkerror = Pos -> Text -> Error
T.Error Pos
pos

-- | Resolve T.CopyFrom.
--
-- Since I use the 'resolve_blocks' memo table, they will chain, even though
-- I'd sort of rather they didn't.
resolve_copy_from :: Maybe [ResolvedNote]
    -> [(T.Time, T.Note T.CallText (T.NPitch (Maybe T.PitchText)) T.Time)]
    -> Either T.Error [ResolvedNote]
resolve_copy_from :: Maybe [ResolvedNote]
-> [(Time, Note Text (NPitch (Maybe Text)) Time)]
-> Either Error [ResolvedNote]
resolve_copy_from Maybe [ResolvedNote]
Nothing = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {call} {pitch} {dur}.
Note call (NPitch pitch) dur -> Either Error (Note call pitch dur)
no_from)
    where
    no_from :: Note call (NPitch pitch) dur -> Either Error (Note call pitch dur)
no_from Note call (NPitch pitch) dur
note = case forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note call (NPitch pitch) dur
note of
        T.NPitch pitch
pitch -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Note call (NPitch pitch) dur
note { note_pitch :: pitch
T.note_pitch = pitch
pitch }
        NPitch pitch
T.CopyFrom -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error (forall call pitch dur. Note call pitch dur -> Pos
T.note_pos Note call (NPitch pitch) dur
note) Text
"no %f for track"
resolve_copy_from (Just [ResolvedNote]
from_track) = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (Time, Note Text (NPitch (Maybe Text)) Time)
-> Either Error [ResolvedNote]
resolve
    where
    resolve :: (Time, Note Text (NPitch (Maybe Text)) Time)
-> Either Error [ResolvedNote]
resolve (Time
t, Note Text (NPitch (Maybe Text)) Time
note) = case forall call pitch dur. Note call pitch dur -> pitch
T.note_pitch Note Text (NPitch (Maybe Text)) Time
note of
        T.NPitch Maybe Text
pitch -> forall a b. b -> Either a b
Right [(Time
t, Note Text (NPitch (Maybe Text)) Time
note { note_pitch :: Maybe Text
T.note_pitch = Maybe Text
pitch })]
        NPitch (Maybe Text)
T.CopyFrom -> Pos -> Time -> Time -> Either Error [ResolvedNote]
copy_from (forall call pitch dur. Note call pitch dur -> Pos
T.note_pos Note Text (NPitch (Maybe Text)) Time
note) Time
t (Time
t forall a. Num a => a -> a -> a
+ forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note Text (NPitch (Maybe Text)) Time
note)
    copy_from :: Pos -> Time -> Time -> Either Error [ResolvedNote]
copy_from Pos
pos Time
start Time
end
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ResolvedNote]
copied = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error Pos
pos forall a b. (a -> b) -> a -> b
$
            Text
"no notes to copy in range " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
start forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
end
        | Bool
otherwise = forall a b. b -> Either a b
Right [ResolvedNote]
copied
        where
        copied :: [ResolvedNote]
copied = forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
<Time
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<Time
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [ResolvedNote]
from_track

-- * integrate

-- | Tracks are written in reverse order.  This is because when notation is
-- horizontal, it's natural to write higher parts above above lower parts, as
-- with staff notation.  But when notation is vertical, it's natural to put
-- higher parts on the right, by analogy to instruments that are layed out that
-- way.
reverse_tracks :: Block track -> [track]
reverse_tracks :: forall track. Block track -> [track]
reverse_tracks = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall track. Block track -> [track]
_tracks

integrate_block :: Ui.M m => Block NTrack -> m (Maybe BlockId)
integrate_block :: forall (m :: * -> *). M m => Block NTrack -> m (Maybe BlockId)
integrate_block Block NTrack
block = do
    RulerId
ruler_id <- forall (m :: * -> *). M m => Block NTrack -> m RulerId
ui_ruler Block NTrack
block
    forall (m :: * -> *).
M m =>
Text
-> BlockId
-> RulerId
-> Text
-> [(Track, [Track])]
-> m (Maybe BlockId)
Manual.block Text
source_key (forall track. Block track -> BlockId
_block_id Block NTrack
block) RulerId
ruler_id (forall track. Block track -> Text
_block_title Block NTrack
block)
        (Block NTrack -> [(Track, [Track])]
convert_tracks Block NTrack
block)

convert_tracks :: Block NTrack -> [(Convert.Track, [Convert.Track])]
convert_tracks :: Block NTrack -> [(Track, [Track])]
convert_tracks Block NTrack
block =
    [ (Track -> Track
convert (NTrack -> Track
_note NTrack
track), forall a b. (a -> b) -> [a] -> [b]
map Track -> Track
convert (NTrack -> [Track]
_controls NTrack
track))
    | NTrack
track <- forall track. Block track -> [track]
reverse_tracks Block NTrack
block
    ]
    where
    convert :: Track -> Track
convert Track
track = Convert.Track
        { track_title :: Text
track_title = Track -> Text
_title Track
track
        , track_events :: [Event]
track_events = Events -> [Event]
Events.ascending (Track -> Events
_events Track
track)
        }

source_key :: Block.SourceKey
source_key :: Text
source_key = Text
"tscore"

-- * ui_state

parse_score :: Text -> Either Error (Ui.State, [Instruments.Allocation])
parse_score :: Text -> Either Text (State, [Allocation])
parse_score = GetExternalCallDuration
-> Text -> Either Text (State, [Allocation])
score_to_ui forall {a} {p} {p} {b} {a}.
IsString a =>
p -> p -> (Either a b, [a])
get_ext_dur
    where get_ext_dur :: p -> p -> (Either a b, [a])
get_ext_dur p
_ p
_ = (forall a b. a -> Either a b
Left a
"external call duration not supported", [])

score_to_ui :: GetExternalCallDuration -> Text
    -> Either Error (Ui.State, [Instruments.Allocation])
score_to_ui :: GetExternalCallDuration
-> Text -> Either Text (State, [Allocation])
score_to_ui GetExternalCallDuration
get_ext_dur Text
source = do
    ([Block NTrack]
blocks, ScoreConfig [Allocation]
instruments Text
ky) <- Namespace
-> GetExternalCallDuration
-> Text
-> Either Text ([Block NTrack], ScoreConfig)
track_blocks
        (Config -> Namespace
UiConfig.config_namespace Config
UiConfig.empty_config)
        GetExternalCallDuration
get_ext_dur Text
source
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (, [Allocation]
instruments) forall a b. (a -> b) -> a -> b
$ forall a. State -> StateId a -> Either Error State
Ui.exec State
Ui.empty forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Block NTrack -> m BlockId
ui_block [Block NTrack]
blocks
        forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Text
UiConfig.ky forall f a. Lens f a -> a -> f -> f
#= Text
ky

-- | Turn a Block NTrack into a UI block directly.  'integrate_block' does same
-- thing, but does so via the integrate machinery.
ui_block :: Ui.M m => Block NTrack -> m BlockId
ui_block :: forall (m :: * -> *). M m => Block NTrack -> m BlockId
ui_block Block NTrack
block = do
    let tracks :: [NTrack]
tracks = forall track. Block track -> [track]
reverse_tracks Block NTrack
block
    [TrackId]
track_ids <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NTrack]
tracks forall a b. (a -> b) -> a -> b
$ \(NTrack Track
note Text
_ [Track]
controls Time
_) ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Track
note forall a. a -> [a] -> [a]
: [Track]
controls) forall a b. (a -> b) -> a -> b
$ \(Track Text
title Events
events) -> do
                Id
track_id <- forall (m :: * -> *). M m => BlockId -> m Id
GenId.track_id (forall track. Block track -> BlockId
_block_id Block NTrack
block)
                forall (m :: * -> *). M m => Id -> Track -> m TrackId
Ui.create_track Id
track_id (Text -> Events -> Track
Track.track Text
title Events
events)
    RulerId
ruler_id <- forall (m :: * -> *). M m => Block NTrack -> m RulerId
ui_ruler Block NTrack
block
    let btracks :: [Track]
btracks =
            [ TracklikeId -> TrackNum -> Track
Block.track (TrackId -> RulerId -> TracklikeId
Block.TId TrackId
tid RulerId
ruler_id) TrackNum
Config.track_width
            | TrackId
tid <- [TrackId]
track_ids
            ]
    -- No longer necessary with Block.Implicit.
    -- Ui.set_skeleton block_id $ ui_skeleton tracks
    forall (m :: * -> *). M m => Id -> Text -> [Track] -> m BlockId
Ui.create_block (forall a. Ident a => a -> Id
Id.unpack_id (forall track. Block track -> BlockId
_block_id Block NTrack
block))
        (forall track. Block track -> Text
_block_title Block NTrack
block)
        (TracklikeId -> TrackNum -> Track
Block.track (RulerId -> TracklikeId
Block.RId RulerId
ruler_id) TrackNum
Config.ruler_width forall a. a -> [a] -> [a]
: [Track]
btracks)

-- This was obsoleted by Block.Implicit
-- ui_skeleton :: [NTrack] -> Skeleton.Skeleton
-- ui_skeleton = Skeleton.make . concat . snd . List.mapAccumL make 1
--     where
--     make tracknum track = (tracknum+len, zip ns (drop 1 ns))
--         where
--         len = length (_controls track) + 1
--         ns = [tracknum .. tracknum+len - 1]

ui_ruler :: Ui.M m => Block NTrack -> m RulerId
ui_ruler :: forall (m :: * -> *). M m => Block NTrack -> m RulerId
ui_ruler Block NTrack
block = forall (m :: * -> *). M m => BlockId -> ModifyRuler -> m RulerId
RulerUtil.replace (forall track. Block track -> BlockId
_block_id Block NTrack
block) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
    Meter -> Ruler
Ruler.meter_ruler forall a b. (a -> b) -> a -> b
$ (Config -> Config) -> Meter -> Meter
Meter.modify_config (forall a b. a -> b -> a
const Config
config) forall a b. (a -> b) -> a -> b
$
        AbstractMeter -> TrackTime -> TrackNum -> TrackTime -> Meter
RulerUtil.meter_until AbstractMeter
meter TrackTime
measure_dur TrackNum
per_section TrackTime
end
    where
    (Config
config, Meter.MSection TrackNum
per_section TrackTime
measure_dur AbstractMeter
meter) = forall track. Block track -> (Config, MSection)
_meter Block NTrack
block
    end :: TrackTime
end = Time -> TrackTime
track_time forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Time
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map NTrack -> Time
_end (forall track. Block track -> [track]
_tracks Block NTrack
block)

-- * make_blocks

data ScoreConfig = ScoreConfig {
    ScoreConfig -> [Allocation]
config_instruments :: ![Instruments.Allocation]
    , ScoreConfig -> Text
config_ky :: !Text
    } deriving (ScoreConfig -> ScoreConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScoreConfig -> ScoreConfig -> Bool
$c/= :: ScoreConfig -> ScoreConfig -> Bool
== :: ScoreConfig -> ScoreConfig -> Bool
$c== :: ScoreConfig -> ScoreConfig -> Bool
Eq, TrackNum -> ScoreConfig -> ShowS
[ScoreConfig] -> ShowS
ScoreConfig -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScoreConfig] -> ShowS
$cshowList :: [ScoreConfig] -> ShowS
show :: ScoreConfig -> String
$cshow :: ScoreConfig -> String
showsPrec :: TrackNum -> ScoreConfig -> ShowS
$cshowsPrec :: TrackNum -> ScoreConfig -> ShowS
Show)

parse_blocks :: Text -> Either T.Error ([Block ParsedTrack], ScoreConfig)
parse_blocks :: Text -> Either Error ([Block ParsedTrack], ScoreConfig)
parse_blocks Text
source = do
    T.Score [(Pos, Toplevel)]
defs <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Pos -> Text -> Error
T.Error (TrackNum -> Pos
T.Pos TrackNum
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) forall a b. (a -> b) -> a -> b
$ Text -> Either String Score
Parse.parse_score Text
source
    ([Block ParsedTrack]
blocks, Config
config) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {a}.
([Block ParsedTrack], Config)
-> (a, Toplevel) -> Either Error ([Block ParsedTrack], Config)
collect ([], Config
Check.default_config) [(Pos, Toplevel)]
defs
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( [Block ParsedTrack]
blocks
        , ScoreConfig
            { config_instruments :: [Allocation]
config_instruments = Config -> [Allocation]
Check.config_instruments Config
config
            , config_ky :: Text
config_ky = Config -> Text
Check.config_ky Config
config
            }
        )
    where
    collect :: ([Block ParsedTrack], Config)
-> (a, Toplevel) -> Either Error ([Block ParsedTrack], Config)
collect ([Block ParsedTrack]
accum, Config
config) (a
_pos, Toplevel
def) = do
        ([Block ParsedTrack]
blocks, Config
config) <- Config -> Toplevel -> Either Error ([Block ParsedTrack], Config)
interpret_toplevel Config
config Toplevel
def
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Block ParsedTrack]
blocks forall a. [a] -> [a] -> [a]
++ [Block ParsedTrack]
accum, Config
config)

interpret_toplevel :: Check.Config -> T.Toplevel
    -> Either T.Error ([Block ParsedTrack], Check.Config)
interpret_toplevel :: Config -> Toplevel -> Either Error ([Block ParsedTrack], Config)
interpret_toplevel Config
config (T.ToplevelDirective Directive
dir) =
    ([],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope -> Directive -> Config -> Either Error Config
Check.parse_directive Scope
Check.Global Directive
dir Config
config
interpret_toplevel Config
config (T.BlockDefinition Block WrappedTracks
block) = do
    Block (Tracks Call)
block <- Block WrappedTracks -> Either Error (Block (Tracks Call))
unwrap_block_tracks Block WrappedTracks
block
    (Block (Tracks Text)
block, [Block (Tracks Text)]
subs) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Block (Tracks Call) -> (Block (Tracks Text), [Block (Tracks Text)])
resolve_sub_block Block (Tracks Call)
block
    Block ParsedTrack
block <- Config
-> Bool -> Block (Tracks Text) -> Either Error (Block ParsedTrack)
interpret_block Config
config Bool
False Block (Tracks Text)
block
    [Block ParsedTrack]
subs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Config
-> Bool -> Block (Tracks Text) -> Either Error (Block ParsedTrack)
interpret_block Config
config Bool
True) [Block (Tracks Text)]
subs
    forall (m :: * -> *) a. Monad m => a -> m a
return (Block ParsedTrack
block forall a. a -> [a] -> [a]
: [Block ParsedTrack]
subs, Config
config)

unwrap_block_tracks :: T.Block T.WrappedTracks
    -> Either T.Error (T.Block (T.Tracks T.Call))
unwrap_block_tracks :: Block WrappedTracks -> Either Error (Block (Tracks Call))
unwrap_block_tracks Block WrappedTracks
block = do
    Tracks Call
tracks <- WrappedTracks -> Either Error (Tracks Call)
unwrap_tracks forall a b. (a -> b) -> a -> b
$ forall tracks. Block tracks -> tracks
T.block_tracks Block WrappedTracks
block
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Block WrappedTracks
block { block_tracks :: Tracks Call
T.block_tracks = Tracks Call
tracks }

-- | The number of tracks must match, and their titles must match.
unwrap_tracks :: T.WrappedTracks -> Either T.Error (T.Tracks T.Call)
unwrap_tracks :: WrappedTracks -> Either Error (Tracks Call)
unwrap_tracks (T.WrappedTracks Pos
_ []) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall call. [Track call] -> Tracks call
T.Tracks []
unwrap_tracks (T.WrappedTracks Pos
_ [Tracks Call
tracks]) = forall a b. b -> Either a b
Right Tracks Call
tracks
unwrap_tracks (T.WrappedTracks Pos
pos (T.Tracks [Track Call]
tracks1 : [Tracks Call]
wrapped))
    | Just [Text]
different <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall a. Eq a => a -> a -> Bool
/= [Text]
titles1) [[Text]]
titles =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Error
T.Error Pos
pos forall a b. (a -> b) -> a -> b
$ Text
"wrapped track titles must match: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Text]
titles1 forall a. Semigroup a => a -> a -> a
<> Text
" /= " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Text]
different
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall call. [Track call] -> Tracks call
T.Tracks forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {call}. Track call -> [Track call] -> Track call
merge [Track Call]
tracks1 forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [[a]]
Lists.rotate forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map forall call. Tracks call -> [Track call]
T.untracks [Tracks Call]
wrapped
    where
    -- [Tracks, Tracks] -> map untracks
    -- [[Track "a" a1, Track "b" b1], [Track "a" a2, Track "b" b2]] -> rotate
    -- [[Track "a" a1, Track "a" a2], [Track "b" b1, Track "b" b2]] -> merge
    -- [Track "a" (a1 ++ a2), Track "b" (b1 ++ b2)]
    merge :: Track call -> [Track call] -> Track call
merge Track call
track1 [Track call]
tracks = Track call
track1
        { track_tokens :: [Token call (NPitch Pitch) NDuration Duration]
T.track_tokens = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall call.
Track call -> [Token call (NPitch Pitch) NDuration Duration]
T.track_tokens Track call
track1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall call.
Track call -> [Token call (NPitch Pitch) NDuration Duration]
tokens [Track call]
tracks
        }
    tokens :: Track call -> [Token call (NPitch Pitch) NDuration Duration]
tokens Track call
track = case forall call.
Track call -> [Token call (NPitch Pitch) NDuration Duration]
T.track_tokens Track call
track of
        ts :: [Token call (NPitch Pitch) NDuration Duration]
ts@(Token call (NPitch Pitch) NDuration Duration
t : [Token call (NPitch Pitch) NDuration Duration]
_) -> forall {call} {pitch} {ndur} {rdur}.
Pos -> Token call pitch ndur rdur
coincident (forall call pitch ndur rdur. Token call pitch ndur rdur -> Pos
T.token_pos Token call (NPitch Pitch) NDuration Duration
t) forall a. a -> [a] -> [a]
: [Token call (NPitch Pitch) NDuration Duration]
ts
        [] -> []
    titles1 :: [Text]
titles1 = forall a b. (a -> b) -> [a] -> [b]
map forall call. Track call -> Text
T.track_title [Track Call]
tracks1
    titles :: [[Text]]
titles = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall call. Track call -> Text
T.track_title forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call. Tracks call -> [Track call]
T.untracks) [Tracks Call]
wrapped
    coincident :: Pos -> Token call pitch ndur rdur
coincident Pos
pos = forall call pitch ndur rdur.
Pos -> Barline -> Token call pitch ndur rdur
T.TBarline Pos
pos Barline
T.AssertCoincident

interpret_block :: Check.Config -> Bool -> T.Block (T.Tracks T.CallText)
    -> Either T.Error (Block ParsedTrack)
interpret_block :: Config
-> Bool -> Block (Tracks Text) -> Either Error (Block ParsedTrack)
interpret_block Config
config Bool
is_sub
        (T.Block BlockId
block_id [Directive]
directives Text
title (T.Tracks [Track Text]
tracks)) = do
    Config
block_config <- Scope -> Config -> [Directive] -> Either Error Config
Check.parse_directives Scope
Check.Block Config
config [Directive]
directives
    [Config]
track_configs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
        (Scope -> Config -> [Directive] -> Either Error Config
Check.parse_directives Scope
Check.Track Config
block_config forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call. Track call -> [Directive]
T.track_directives)
        [Track Text]
tracks
    [Config]
track_configs <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Config -> TrackNum -> Config -> Config
Check.apply_block_from Config
block_config) [TrackNum
1..] [Config]
track_configs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Block
        { _block_id :: BlockId
_block_id = BlockId
block_id
        , _block_title :: Text
_block_title = Text
title
        , _is_sub :: Bool
_is_sub = Bool
is_sub
        , _meter :: (Config, MSection)
_meter = Meter -> (Config, MSection)
Check.meter_ui forall a b. (a -> b) -> a -> b
$ Config -> Meter
Check.config_meter Config
block_config
        , _tracks :: [ParsedTrack]
_tracks =
            [ ParsedTrack
                { track_config :: Config
track_config = Config
track_config
                , track_key :: Text
track_key = Text
key
                , track_title :: Text
track_title = Text
title
                , track_tokens :: [Token (NPitch Pitch)]
track_tokens = [Token (NPitch Pitch)]
tokens
                , track_pos :: Pos
track_pos = Pos
pos
                }
            | (Config
track_config, T.Track Text
key Text
title [Directive]
_ [Token (NPitch Pitch)]
tokens Pos
pos)
                <- forall a b. [a] -> [b] -> [(a, b)]
zip [Config]
track_configs [Track Text]
tracks
            ]
        }

-- * sub-blocks

-- | Replace T.SubBlock with T.CallText, and return the generated blocks.
resolve_sub_block :: T.Block (T.Tracks T.Call)
    -> (T.Block (T.Tracks T.CallText), [T.Block (T.Tracks T.CallText)])
resolve_sub_block :: Block (Tracks Call) -> (Block (Tracks Text), [Block (Tracks Text)])
resolve_sub_block Block (Tracks Call)
block = forall w a. Logger w a -> (a, [w])
Logger.runId forall a b. (a -> b) -> a -> b
$ do
    Tracks Text
tracks <- BlockId -> Tracks Call -> ResolveM (Tracks Text)
resolve_sub_tracks (forall tracks. Block tracks -> BlockId
T.block_id Block (Tracks Call)
block) (forall tracks. Block tracks -> tracks
T.block_tracks Block (Tracks Call)
block)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Block (Tracks Call)
block { block_tracks :: Tracks Text
T.block_tracks = Tracks Text
tracks }

type ResolveM a = Logger.Logger (T.Block (T.Tracks T.CallText)) a

resolve_sub_tracks :: BlockId -> T.Tracks T.Call
    -> ResolveM (T.Tracks T.CallText)
resolve_sub_tracks :: BlockId -> Tracks Call -> ResolveM (Tracks Text)
resolve_sub_tracks BlockId
block_id (T.Tracks [Track Call]
tracks) =
    -- Since tracks will be reversed, start from the end, so the tracknums
    -- in the generated block names match up.
    forall call. [Track call] -> Tracks call
T.Tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TrackNum, Track Call)
-> LoggerT (Block (Tracks Text)) Identity (Track Text)
resolve (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Track Call]
tracks) (-TrackNum
1)) [Track Call]
tracks)
    where
    resolve :: (TrackNum, Track Call)
-> LoggerT (Block (Tracks Text)) Identity (Track Text)
resolve (TrackNum
tracknum, Track Call
track) = do
        [Token (NPitch Pitch)]
tokens <- forall pitch ndur rdur.
BlockId
-> TrackNum
-> [Token Call pitch ndur rdur]
-> ResolveM [Token Text pitch ndur rdur]
resolve_sub_tokens BlockId
block_id TrackNum
tracknum (forall call.
Track call -> [Token call (NPitch Pitch) NDuration Duration]
T.track_tokens Track Call
track)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Track Call
track { track_tokens :: [Token (NPitch Pitch)]
T.track_tokens = [Token (NPitch Pitch)]
tokens }

resolve_sub_tokens :: BlockId -> TrackNum -> [T.Token T.Call pitch ndur rdur]
    -> ResolveM [T.Token T.CallText pitch ndur rdur]
resolve_sub_tokens :: forall pitch ndur rdur.
BlockId
-> TrackNum
-> [Token Call pitch ndur rdur]
-> ResolveM [Token Text pitch ndur rdur]
resolve_sub_tokens BlockId
block_id TrackNum
tracknum = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) state x y.
Monad m =>
(state -> x -> m (state, y)) -> state -> [x] -> m (state, [y])
Lists.mapAccumLM forall {pitch} {dur} {rdur}.
[TrackNum]
-> Token Call pitch dur rdur
-> LoggerT
     (Block (Tracks Text))
     Identity
     ([TrackNum], Token Text pitch dur rdur)
resolve [TrackNum
1..]
    where
    resolve :: [TrackNum]
-> Token Call pitch dur rdur
-> LoggerT
     (Block (Tracks Text))
     Identity
     ([TrackNum], Token Text pitch dur rdur)
resolve (TrackNum
n:[TrackNum]
ns) (T.TNote Pos
pos Note Call pitch dur
note) = case forall call pitch dur. Note call pitch dur -> call
T.note_call Note Call pitch dur
note of
        T.SubBlock Text
prefix [Tracks Call]
subs -> do
            [Text]
sub_calls <- BlockId -> TrackNum -> TrackNum -> [Tracks Call] -> ResolveM [Text]
resolve_sub_tracks_to_calls BlockId
block_id TrackNum
tracknum TrackNum
n [Tracks Call]
subs
            let call :: Text
call = Text -> Text
pipe_tweak Text
prefix forall a. Textlike a => a -> a -> a
`Texts.unwords2` [Text] -> Text
Text.unwords [Text]
sub_calls
            forall (m :: * -> *) a. Monad m => a -> m a
return ([TrackNum]
ns, forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos (Note Call pitch dur
note { note_call :: Text
T.note_call = Text
call }))
        T.Call Text
call -> forall (m :: * -> *) a. Monad m => a -> m a
return (TrackNum
nforall a. a -> [a] -> [a]
:[TrackNum]
ns, forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote Pos
pos (Note Call pitch dur
note { note_call :: Text
T.note_call = Text
call }))
    resolve [] (T.TNote {}) = forall a. HasCallStack => String -> a
error String
"unreached, infinite list"
    resolve [TrackNum]
ns (T.TBarline Pos
pos Barline
bar) = forall (m :: * -> *) a. Monad m => a -> m a
return ([TrackNum]
ns, forall call pitch ndur rdur.
Pos -> Barline -> Token call pitch ndur rdur
T.TBarline Pos
pos Barline
bar)
    resolve [TrackNum]
ns (T.TRest Pos
pos Rest rdur
rest) = forall (m :: * -> *) a. Monad m => a -> m a
return ([TrackNum]
ns, forall call pitch ndur rdur.
Pos -> Rest rdur -> Token call pitch ndur rdur
T.TRest Pos
pos Rest rdur
rest)

-- | Add a space so "foo|" -> "foo |", because of the xyz|[a] syntax.  But
-- don't add a space if it looks like it's not coming from that syntax, e.g.
-- "x |"[a].
pipe_tweak :: Text -> Text
pipe_tweak :: Text -> Text
pipe_tweak Text
prefix
    | Just Text
rest <- Text -> Text -> Maybe Text
Text.stripSuffix Text
"|" Text
prefix,
        Just (Text
_, Char
c) <- Text -> Maybe (Text, Char)
Text.unsnoc Text
rest, Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'|', Char
' '] = Text
rest forall a. Semigroup a => a -> a -> a
<> Text
" |"
    | Bool
otherwise = Text
prefix

resolve_sub_tracks_to_calls :: BlockId -> TrackNum -> TrackNum
    -> [T.Tracks T.Call] -> ResolveM [T.CallText]
resolve_sub_tracks_to_calls :: BlockId -> TrackNum -> TrackNum -> [Tracks Call] -> ResolveM [Text]
resolve_sub_tracks_to_calls BlockId
parent_block_id TrackNum
tracknum TrackNum
callnum [Tracks Call]
subs =
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Tracks Call]
subs [Maybe Text]
sub_callnums) forall a b. (a -> b) -> a -> b
$ \(Tracks Call
tracks, Maybe Text
sub_callnum) -> do
        let block_id :: BlockId
block_id = BlockId -> TrackNum -> TrackNum -> Maybe Text -> BlockId
make_relative BlockId
parent_block_id TrackNum
tracknum TrackNum
callnum
                Maybe Text
sub_callnum
        Tracks Text
tracks <- BlockId -> Tracks Call -> ResolveM (Tracks Text)
resolve_sub_tracks BlockId
block_id Tracks Call
tracks
        forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log forall a b. (a -> b) -> a -> b
$ T.Block
            { block_id :: BlockId
block_id = BlockId
block_id
            , block_directives :: [Directive]
block_directives = []
            , block_title :: Text
block_title = Text
""
            , block_tracks :: Tracks Text
block_tracks = Tracks Text
tracks
            }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> BlockId -> BlockId -> Text
Eval.block_id_to_call Bool
True BlockId
parent_block_id BlockId
block_id
    where
    sub_callnums :: [Maybe Text]
sub_callnums
        | TrackNum
len forall a. Eq a => a -> a -> Bool
== TrackNum
1 = [forall a. Maybe a
Nothing]
        | TrackNum
len forall a. Ord a => a -> a -> Bool
<= TrackNum
26 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
Text.singleton) [Char
'a'..Char
'z']
        | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"-"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) [Integer
1..]
        where len :: TrackNum
len = forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Tracks Call]
subs

make_relative :: BlockId -> TrackNum -> TrackNum -> Maybe Text -> BlockId
make_relative :: BlockId -> TrackNum -> TrackNum -> Maybe Text -> BlockId
make_relative BlockId
parent TrackNum
tracknum TrackNum
callnum Maybe Text
sub_callnum =
    Id -> BlockId
Id.BlockId forall a b. (a -> b) -> a -> b
$ Text -> Id -> Id
Id.set_name Text
relative (forall a. Ident a => a -> Id
Id.unpack_id BlockId
parent)
    where
    relative :: Text
relative = BlockId -> Text -> Text
Eval.make_relative BlockId
parent forall a b. (a -> b) -> a -> b
$
        Text
"t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum forall a. Semigroup a => a -> a -> a
<> Text
"c" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
callnum
            forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
sub_callnum

is_sub_block :: Block.Block -> Bool
is_sub_block :: Block -> Bool
is_sub_block = forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
sub_meta forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Meta
Block.block_meta

-- | This marks a sub-block.
sub_meta :: Text
sub_meta :: Text
sub_meta = Text
"is_sub"

-- * local util

note_event :: T.Time -> T.Note T.CallText pitch T.Time -> Event.Event
note_event :: forall pitch. Time -> Note Text pitch Time -> Event
note_event Time
start Note Text pitch Time
note =
    Event -> Event
add_stack forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> Text -> Event
Event.event (Time -> TrackTime
track_time Time
start)
        (if forall call pitch dur. Note call pitch dur -> Bool
T.note_zero_duration Note Text pitch Time
note then TrackTime
0
            else Time -> TrackTime
track_time (forall call pitch dur. Note call pitch dur -> dur
T.note_duration Note Text pitch Time
note))
        (forall call pitch dur. Note call pitch dur -> call
T.note_call Note Text pitch Time
note)

pitch_event :: Bool -> (T.Time, T.PitchText) -> Event.Event
pitch_event :: Bool -> (Time, Text) -> Event
pitch_event Bool
negative (Time
start, Text
pitch) = Event -> Event
add_stack forall a b. (a -> b) -> a -> b
$
    TrackTime -> TrackTime -> Text -> Event
Event.event (Time -> TrackTime
track_time Time
start) (if Bool
negative then -TrackTime
0 else TrackTime
0) Text
pitch

track_time :: T.Time -> TrackTime
track_time :: Time -> TrackTime
track_time = forall a b. (Real a, Fractional b) => a -> b
realToFrac

from_track_time :: TrackTime -> T.Time
from_track_time :: TrackTime -> Time
from_track_time = forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | A stack marks these events as being from an integration.  Event style uses
-- this, but I think that's all since I have SourceKey hardcoded.
add_stack :: Event.Event -> Event.Event
add_stack :: Event -> Event
add_stack Event
event =
    Lens Event (Maybe Stack)
Event.stack_ forall f a. Lens f a -> a -> f -> f
#= forall a. a -> Maybe a
Just (Stack -> TrackTime -> Stack
Event.Stack Stack
stack (Event -> TrackTime
Event.start Event
event)) forall a b. (a -> b) -> a -> b
$ Event
event
    where stack :: Stack
stack = Frame -> Stack -> Stack
Stack.add (Text -> Frame
Stack.Call Text
source_key) Stack
Stack.empty