-- Copyright 2013 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 ViewPatterns #-}
-- | Utilities to deal with block and track titles.
--
-- This module is used by both Cmd and Derive since Cmd also wants to know
-- track types for track specific cmds.
--
-- Note track titles are just tracklang expressions, so no extra code is
-- needed.  Control tracks titles are just a hardcoded list of special cases,
-- though they are parsed as tracklang Vals.
module Derive.ParseTitle where
import qualified Data.Attoparsec.Text as A
import           Data.Attoparsec.Text ((<?>))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text

import qualified Util.ParseText as ParseText
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.Parse as Parse
import           Derive.Parse (lexeme)
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Symbols as Symbols

import qualified Perform.Pitch as Pitch

import           Global


-- * blocks

-- | A block title is a normal expression, applied as a transform.
parse_block :: Text -> Either Text DeriveT.Expr
parse_block :: Text -> Either Text Expr
parse_block = Text -> Either Text Expr
Parse.parse_expr

-- * tracks

data Type = TempoTrack | ControlTrack | PitchTrack | NoteTrack
    deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show)

instance Pretty Type where pretty :: Type -> Text
pretty = Type -> Text
forall a. Show a => a -> Text
showt

track_type :: Text -> Type
track_type :: Text -> Type
track_type Text
title
    | Text -> Bool
is_note_track Text
title = Type
NoteTrack
    | Text -> Bool
is_pitch_track Text
title = Type
PitchTrack
    | Text -> Bool
is_tempo_track Text
title = Type
TempoTrack
    | Bool
otherwise = Type
ControlTrack

-- ** note track

-- TODO this is actually unused, and I think track-call is unimplemented?
{-# SCC parse_note_track #-}
parse_note_track :: Text -> Either Text (ScoreT.Instrument, Maybe TrackCall)
parse_note_track :: Text -> Either Text (Instrument, Maybe TrackCall)
parse_note_track = Parser (Instrument, Maybe TrackCall)
-> Text -> Either Text (Instrument, Maybe TrackCall)
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser (Instrument, Maybe TrackCall)
p_note_track

-- > >inst !track-call
p_note_track :: A.Parser (ScoreT.Instrument, Maybe TrackCall)
p_note_track :: Parser (Instrument, Maybe TrackCall)
p_note_track = (,)
    (Instrument -> Maybe TrackCall -> (Instrument, Maybe TrackCall))
-> Parser Text Instrument
-> Parser Text (Maybe TrackCall -> (Instrument, Maybe TrackCall))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Instrument -> Parser Text Instrument
forall a. Parser a -> Parser a
lexeme (Char -> Parser Char
A.char Char
'>'
        Parser Char -> Parser Text Instrument -> Parser Text Instrument
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Instrument
ScoreT.Instrument (Text -> Instrument) -> Parser Text Text -> Parser Text Instrument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Parser Text Text
Parse.p_identifier Bool
True String
""))
    Parser Text (Maybe TrackCall -> (Instrument, Maybe TrackCall))
-> Parser Text (Maybe TrackCall)
-> Parser (Instrument, Maybe TrackCall)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TrackCall -> Parser Text (Maybe TrackCall)
forall a. Parser a -> Parser (Maybe a)
ParseText.optional Parser TrackCall
p_track_call

-- ** control track

-- | Parse the first part of the control track title.  This is special syntax,
-- and is not the usual call plus list of argument values.
{-# SCC parse_control_type #-}
parse_control_type :: Text -> Either Text ControlType
parse_control_type :: Text -> Either Text ControlType
parse_control_type = ((ControlType, [Call]) -> ControlType)
-> Either Text (ControlType, [Call]) -> Either Text ControlType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ControlType, [Call]) -> ControlType
forall a b. (a, b) -> a
fst (Either Text (ControlType, [Call]) -> Either Text ControlType)
-> (Text -> Either Text (ControlType, [Call]))
-> Text
-> Either Text ControlType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (ControlType, [Call])
parse_control_title

parse_control_title :: Text -> Either Text (ControlType, [DeriveT.Call])
parse_control_title :: Text -> Either Text (ControlType, [Call])
parse_control_title = Parser (ControlType, [Call])
-> Text -> Either Text (ControlType, [Call])
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser (ControlType, [Call])
p_control_title

data ControlType =
    -- | Tempo track with an optional modifying symbol.
    Tempo (Maybe Expr.Symbol)
    -- | Pitch track that sets a ScaleId (unless it's 'Pitch.empty_scale'),
    -- and sets the given pitch signal.
    | Pitch Pitch.ScaleId (Either TrackCall ScoreT.PControl)
    -- | Control track with an optional combining operator.
    | Control (Either TrackCall (ScoreT.Typed ScoreT.Control)) (Maybe Merge)
    deriving (ControlType -> ControlType -> Bool
(ControlType -> ControlType -> Bool)
-> (ControlType -> ControlType -> Bool) -> Eq ControlType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlType -> ControlType -> Bool
$c/= :: ControlType -> ControlType -> Bool
== :: ControlType -> ControlType -> Bool
$c== :: ControlType -> ControlType -> Bool
Eq, Int -> ControlType -> ShowS
[ControlType] -> ShowS
ControlType -> String
(Int -> ControlType -> ShowS)
-> (ControlType -> String)
-> ([ControlType] -> ShowS)
-> Show ControlType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlType] -> ShowS
$cshowList :: [ControlType] -> ShowS
show :: ControlType -> String
$cshow :: ControlType -> String
showsPrec :: Int -> ControlType -> ShowS
$cshowsPrec :: Int -> ControlType -> ShowS
Show)

type Merge = Expr.Symbol
type TrackCall = Expr.Symbol

instance ShowVal.ShowVal ControlType where
    show_val :: ControlType -> Text
show_val = ControlType -> Text
control_type_to_title

p_control_title :: A.Parser (ControlType, [DeriveT.Call])
p_control_title :: Parser (ControlType, [Call])
p_control_title = do
    ControlType
ctype <- Parser ControlType
p_control_type
    [Call]
expr <- [Call] -> Parser Text [Call] -> Parser Text [Call]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option [] (Parser ()
Parse.p_pipe Parser () -> Parser Text [Call] -> Parser Text [Call]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr -> [Call]
forall a. NonEmpty a -> [a]
NonEmpty.toList (Expr -> [Call]) -> Parser Text Expr -> Parser Text [Call]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser Text Expr
Parse.p_expr Bool
True)
    (ControlType, [Call]) -> Parser (ControlType, [Call])
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlType
ctype, [Call]
expr)

p_control_type :: A.Parser ControlType
p_control_type :: Parser ControlType
p_control_type = Parser ControlType
p_tempo Parser ControlType -> Parser ControlType -> Parser ControlType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ControlType
p_pitch Parser ControlType -> Parser ControlType -> Parser ControlType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ControlType
p_control

p_tempo :: A.Parser ControlType
p_tempo :: Parser ControlType
p_tempo = Maybe TrackCall -> ControlType
Tempo (Maybe TrackCall -> ControlType)
-> Parser Text (Maybe TrackCall) -> Parser ControlType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Parser Text Text -> Parser Text Text
forall a. Parser a -> Parser a
lexeme (Text -> Parser Text Text
A.string Text
"tempo") Parser Text Text
-> Parser Text (Maybe TrackCall) -> Parser Text (Maybe TrackCall)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TrackCall -> Parser Text (Maybe TrackCall)
forall a. Parser a -> Parser (Maybe a)
ParseText.optional (Parser TrackCall -> Parser TrackCall
forall a. Parser a -> Parser a
lexeme Parser TrackCall
p_merge))

-- | *twelve (#name | !track-call) merge
p_pitch :: A.Parser ControlType
p_pitch :: Parser ControlType
p_pitch = ScaleId -> Either TrackCall PControl -> ControlType
Pitch
    (ScaleId -> Either TrackCall PControl -> ControlType)
-> Parser Text ScaleId
-> Parser Text (Either TrackCall PControl -> ControlType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text ScaleId -> Parser Text ScaleId
forall a. Parser a -> Parser a
lexeme Parser Text ScaleId
p_scale_id
    Parser Text (Either TrackCall PControl -> ControlType)
-> Parser Text (Either TrackCall PControl) -> Parser ControlType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Text (Either TrackCall PControl)
-> Parser Text (Either TrackCall PControl)
forall a. Parser a -> Parser a
lexeme (Parser Text (Either TrackCall PControl)
 -> Parser Text (Either TrackCall PControl))
-> Parser Text (Either TrackCall PControl)
-> Parser Text (Either TrackCall PControl)
forall a b. (a -> b) -> a -> b
$ (TrackCall -> Either TrackCall PControl
forall a b. a -> Either a b
Left (TrackCall -> Either TrackCall PControl)
-> Parser TrackCall -> Parser Text (Either TrackCall PControl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TrackCall
p_track_call)
        Parser Text (Either TrackCall PControl)
-> Parser Text (Either TrackCall PControl)
-> Parser Text (Either TrackCall PControl)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PControl -> Either TrackCall PControl
forall a b. b -> Either a b
Right (PControl -> Either TrackCall PControl)
-> Parser Text PControl -> Parser Text (Either TrackCall PControl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PControl -> Parser Text PControl -> Parser Text PControl
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option PControl
ScoreT.default_pitch (Parser Text PControl -> Parser Text PControl
forall a. Parser a -> Parser a
lexeme Parser Text PControl
Parse.p_pcontrol)))

-- | (!track-call | % | control:typ) merge
p_control :: A.Parser ControlType
p_control :: Parser ControlType
p_control = Either TrackCall (Typed Control) -> Maybe TrackCall -> ControlType
Control
    (Either TrackCall (Typed Control)
 -> Maybe TrackCall -> ControlType)
-> Parser Text (Either TrackCall (Typed Control))
-> Parser Text (Maybe TrackCall -> ControlType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text (Either TrackCall (Typed Control))
-> Parser Text (Either TrackCall (Typed Control))
forall a. Parser a -> Parser a
lexeme (Parser Text (Either TrackCall (Typed Control))
 -> Parser Text (Either TrackCall (Typed Control)))
-> Parser Text (Either TrackCall (Typed Control))
-> Parser Text (Either TrackCall (Typed Control))
forall a b. (a -> b) -> a -> b
$ [Parser Text (Either TrackCall (Typed Control))]
-> Parser Text (Either TrackCall (Typed Control))
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
        [ TrackCall -> Either TrackCall (Typed Control)
forall a b. a -> Either a b
Left (TrackCall -> Either TrackCall (Typed Control))
-> Parser TrackCall
-> Parser Text (Either TrackCall (Typed Control))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TrackCall
p_track_call
        , Char -> Parser Char
A.char Char
'%'
            Parser Char
-> Parser Text (Either TrackCall (Typed Control))
-> Parser Text (Either TrackCall (Typed Control))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Either TrackCall (Typed Control)
-> Parser Text (Either TrackCall (Typed Control))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Typed Control -> Either TrackCall (Typed Control)
forall a b. b -> Either a b
Right (Typed Control -> Either TrackCall (Typed Control))
-> Typed Control -> Either TrackCall (Typed Control)
forall a b. (a -> b) -> a -> b
$ Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Control -> Typed Control) -> Control -> Typed Control
forall a b. (a -> b) -> a -> b
$ Text -> Control
ScoreT.unchecked_control Text
"")
        , Typed Control -> Either TrackCall (Typed Control)
forall a b. b -> Either a b
Right (Typed Control -> Either TrackCall (Typed Control))
-> Parser Text (Typed Control)
-> Parser Text (Either TrackCall (Typed Control))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Typed Control)
p_typed_control
        ])
    Parser Text (Maybe TrackCall -> ControlType)
-> Parser Text (Maybe TrackCall) -> Parser ControlType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TrackCall -> Parser Text (Maybe TrackCall)
forall a. Parser a -> Parser (Maybe a)
ParseText.optional (Parser TrackCall -> Parser TrackCall
forall a. Parser a -> Parser a
lexeme Parser TrackCall
p_merge)

p_typed_control :: A.Parser (ScoreT.Typed ScoreT.Control)
p_typed_control :: Parser Text (Typed Control)
p_typed_control = ((Type -> Control -> Typed Control)
-> Control -> Type -> Typed Control
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Control -> Typed Control
forall a. Type -> a -> Typed a
ScoreT.Typed)
    (Control -> Type -> Typed Control)
-> Parser Text Control -> Parser Text (Type -> Typed Control)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Control
ScoreT.unchecked_control (Text -> Control) -> Parser Text Text -> Parser Text Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Parser Text Text
Parse.p_identifier Bool
False String
":")
    Parser Text (Type -> Typed Control)
-> Parser Text Type -> Parser Text (Typed Control)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Parser Text Type -> Parser Text Type
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Type
ScoreT.Untyped Parser Text Type
p_type_annotation

p_type_annotation :: A.Parser ScoreT.Type
p_type_annotation :: Parser Text Type
p_type_annotation = do
    Char -> Parser Char
A.char Char
':'
    Text
typ <- Bool -> String -> Parser Text Text
Parse.p_identifier Bool
False String
""
    case Text -> Maybe Type
ScoreT.code_to_type Text
typ of
        Maybe Type
Nothing -> String -> Parser Text Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Text Type) -> String -> Parser Text Type
forall a b. (a -> b) -> a -> b
$ String
"unknown type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
typ
        Just Type
typ -> Type -> Parser Text Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ

-- ** unparse

control_type_to_title :: ControlType -> Text
control_type_to_title :: ControlType -> Text
control_type_to_title ControlType
ctype = [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ case ControlType
ctype of
    Tempo Maybe TrackCall
sym -> Text
"tempo" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Maybe TrackCall -> [Text]
maybe_sym Maybe TrackCall
sym
    Pitch (Pitch.ScaleId Text
scale_id) Either TrackCall PControl
pcontrol ->
        Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scale_id
        Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (TrackCall -> [Text])
-> (PControl -> [Text]) -> Either TrackCall PControl -> [Text]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) (Text -> [Text]) -> (TrackCall -> Text) -> TrackCall -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall -> Text
show_tcall) PControl -> [Text]
forall {a}. (Eq a, IsString a, ShowVal a) => a -> [Text]
show_pcontrol Either TrackCall PControl
pcontrol
    Control Either TrackCall (Typed Control)
c Maybe TrackCall
merge -> (TrackCall -> Text)
-> (Typed Control -> Text)
-> Either TrackCall (Typed Control)
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TrackCall -> Text
show_tcall Typed Control -> Text
control_to_title Either TrackCall (Typed Control)
c Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Maybe TrackCall -> [Text]
show_merge Maybe TrackCall
merge
    where
    maybe_sym :: Maybe TrackCall -> [Text]
maybe_sym = [Text] -> (TrackCall -> [Text]) -> Maybe TrackCall -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) (Text -> [Text]) -> (TrackCall -> Text) -> TrackCall -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall -> Text
Expr.unsym)
    show_merge :: Maybe TrackCall -> [Text]
show_merge = [Text] -> (TrackCall -> [Text]) -> Maybe TrackCall -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) (Text -> [Text]) -> (TrackCall -> Text) -> TrackCall -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val)
    show_tcall :: TrackCall -> Text
show_tcall = (Text
"!"<>) (Text -> Text) -> (TrackCall -> Text) -> TrackCall -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val
    show_pcontrol :: a -> [Text]
show_pcontrol a
pcontrol = [a -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val a
pcontrol | a
pcontrol a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
""]

-- | This is different from ShowVal (Typed Control) because the control doesn't
-- need a % in the control track title.
control_to_title :: ScoreT.Typed ScoreT.Control -> Text
control_to_title :: Typed Control -> Text
control_to_title (ScoreT.Typed Type
typ Control
c)
    | Control
c Control -> Control -> Bool
forall a. Eq a => a -> a -> Bool
== Control
"" = Text
"%"
    | Bool
otherwise = Control -> Text
ScoreT.control_name Control
c
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Type
typ Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ScoreT.Untyped then Text
""
            else Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
ScoreT.type_to_code Type
typ

-- ** parse util

p_merge :: A.Parser Merge
p_merge :: Parser TrackCall
p_merge = Text -> TrackCall
Expr.Symbol (Text -> TrackCall) -> Parser Text Text -> Parser TrackCall
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Parser Text Text
Parse.p_identifier Bool
False String
""

p_track_call :: A.Parser Expr.Symbol
p_track_call :: Parser TrackCall
p_track_call = Char -> Parser Char
A.char Char
'!' Parser Char -> Parser TrackCall -> Parser TrackCall
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser TrackCall
Parse.p_symbol Bool
True

-- | This is special syntax that's only allowed in control track titles.
p_scale_id :: A.Parser Pitch.ScaleId
p_scale_id :: Parser Text ScaleId
p_scale_id = do
    Char -> Parser Char
A.char Char
'*'
    Text -> ScaleId
Pitch.ScaleId (Text -> ScaleId) -> Parser Text Text -> Parser Text ScaleId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Bool -> String -> Parser Text Text
Parse.p_identifier Bool
True String
"")
    Parser Text ScaleId -> String -> Parser Text ScaleId
forall i a. Parser i a -> String -> Parser i a
<?> String
"scale id"

-- * util

-- | Convert a track title to its control.
title_to_control :: Text -> Maybe ScoreT.Control
title_to_control :: Text -> Maybe Control
title_to_control Text
title = case Text -> Either Text ControlType
parse_control_type Text
title of
    Right (Control (Right Typed Control
control) Maybe TrackCall
_) -> Control -> Maybe Control
forall a. a -> Maybe a
Just (Typed Control -> Control
forall a. Typed a -> a
ScoreT.typed_val Typed Control
control)
    Either Text ControlType
_ -> Maybe Control
forall a. Maybe a
Nothing

-- | A pitch track is also considered a control track.
is_control_track :: Text -> Bool
is_control_track :: Text -> Bool
is_control_track = Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
is_note_track

-- | This is like 'is_control_track' but doesn't include pitch tracks.
is_signal_track :: Text -> Bool
is_signal_track :: Text -> Bool
is_signal_track Text
title =
    Text -> Bool
is_control_track Text
title Bool -> Bool -> Bool
&& case Text -> Either Text ControlType
parse_control_type Text
title of
        Right (Control {}) -> Bool
True
        Either Text ControlType
_ -> Bool
False

is_tempo_track :: Text -> Bool
is_tempo_track :: Text -> Bool
is_tempo_track Text
title = case Text -> Either Text ControlType
parse_control_type Text
title of
    Right (Tempo {}) -> Bool
True
    Either Text ControlType
_ -> Bool
False

-- ** note

-- | Parse a note track like @>inst@ as @note-track inst@.  Other than
-- this, note track titles are normal expressions.
{-# SCC parse_note #-}
parse_note :: Text -> Either Text DeriveT.Expr
parse_note :: Text -> Either Text Expr
parse_note Text
title = case Text -> Maybe (Char, Text)
Text.uncons Text
title of
    Just (Char
'>', Text
rest) -> Text -> Either Text Expr
Parse.parse_expr (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
        where prefix :: Text
prefix = TrackCall -> Text
Expr.unsym TrackCall
Symbols.note_track Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
    Maybe (Char, Text)
_ -> Text -> Either Text Expr
forall a b. a -> Either a b
Left (Text -> Either Text Expr) -> Text -> Either Text Expr
forall a b. (a -> b) -> a -> b
$ Text
"note track title should start with >: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
title

unparse_note :: DeriveT.Expr -> Text
unparse_note :: Expr -> Text
unparse_note = Text -> Text
strip (Text -> Text) -> (Expr -> Text) -> Expr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val
    where
    strip :: Text -> Text
strip Text
t = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
t ((Text
">"<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.stripStart) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> Maybe Text
Text.stripPrefix (TrackCall -> Text
Expr.unsym TrackCall
Symbols.note_track) Text
t

-- | Convert a track title into its instrument.
{-# SCC title_to_instrument #-}
title_to_instrument :: Text -> Maybe ScoreT.Instrument
title_to_instrument :: Text -> Maybe Instrument
title_to_instrument Text
title = case Text -> Either Text (Instrument, Maybe TrackCall)
parse_note_track Text
title of
    Right (Instrument
inst, Maybe TrackCall
_) -> Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just Instrument
inst
    Either Text (Instrument, Maybe TrackCall)
_ -> Maybe Instrument
forall a. Maybe a
Nothing

-- | Convert from an instrument to the title of its instrument track.
instrument_to_title :: ScoreT.Instrument -> Text
instrument_to_title :: Instrument -> Text
instrument_to_title (ScoreT.Instrument Text
a) = Text
">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a

is_note_track :: Text -> Bool
is_note_track :: Text -> Bool
is_note_track = (Text
">" `Text.isPrefixOf`)

strip_expr :: Text -> Text
strip_expr :: Text -> Text
strip_expr = Text -> Text
Text.stripEnd (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'|')

note_track :: Text
note_track :: Text
note_track = Text
">"

-- ** pitch

title_to_scale :: Text -> Maybe Pitch.ScaleId
title_to_scale :: Text -> Maybe ScaleId
title_to_scale Text
title = case Text -> Either Text ControlType
parse_control_type Text
title of
    Right (Pitch ScaleId
scale_id Either TrackCall PControl
_) -> ScaleId -> Maybe ScaleId
forall a. a -> Maybe a
Just ScaleId
scale_id
    Either Text ControlType
_ -> Maybe ScaleId
forall a. Maybe a
Nothing

scale_to_title :: Pitch.ScaleId -> Text
scale_to_title :: ScaleId -> Text
scale_to_title ScaleId
scale_id =
    ControlType -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val (ScaleId -> Either TrackCall PControl -> ControlType
Pitch ScaleId
scale_id (PControl -> Either TrackCall PControl
forall a b. b -> Either a b
Right PControl
ScoreT.default_pitch))

is_pitch_track :: Text -> Bool
is_pitch_track :: Text -> Bool
is_pitch_track = (Text
"*" `Text.isPrefixOf`)
    -- Previously it was 'Maybe.isJust . title_to_scale', but this is called
    -- a lot during slicing so efficiency matters.

pitch_track :: Text
pitch_track :: Text
pitch_track = Text
"*"