-- 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
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
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 = 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 = 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 = (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
lexeme (Char -> Parser Char
A.char Char
'>'
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Instrument
ScoreT.Instrument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Parser Text
Parse.p_identifier Bool
True String
""))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst 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 = 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
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
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 <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option [] (Parser ()
Parse.p_pipe forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. NonEmpty a -> [a]
NonEmpty.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser Expr
Parse.p_expr Bool
True)
    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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ControlType
p_pitch 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (forall a. Parser a -> Parser a
lexeme (Text -> Parser Text
A.string Text
"tempo") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser (Maybe a)
ParseText.optional (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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
lexeme Parser ScaleId
p_scale_id
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TrackCall
p_track_call)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option PControl
ScoreT.default_pitch (forall a. Parser a -> Parser a
lexeme Parser Text PControl
pcontrol)))
    where
    pcontrol :: Parser Text PControl
pcontrol = (\(DeriveT.Ref PControl
c Maybe PSignal
_) -> PControl
c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Ref PControl PSignal)
Parse.p_pcontrol_ref

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

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

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

-- ** unparse

-- | Invert 'parse_control_title'.
control_type_to_title :: ControlType -> Text
control_type_to_title :: ControlType -> Text
control_type_to_title ControlType
ctype = [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ case ControlType
ctype of
    Tempo Maybe TrackCall
sym -> Text
"tempo" forall a. a -> [a] -> [a]
: Maybe TrackCall -> [Text]
maybe_sym Maybe TrackCall
sym
    Pitch (Pitch.ScaleId Text
scale_id) Either TrackCall PControl
pcontrol ->
        Text
"*" forall a. Semigroup a => a -> a -> a
<> Text
scale_id
        forall a. a -> [a] -> [a]
: forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall -> Text
show_tcall) PControl -> [Text]
show_pcontrol Either TrackCall PControl
pcontrol
    Control Either TrackCall (Typed Control)
c Maybe TrackCall
merge -> 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 forall a. a -> [a] -> [a]
: Maybe TrackCall -> [Text]
show_merge Maybe TrackCall
merge
    where
    maybe_sym :: Maybe TrackCall -> [Text]
maybe_sym = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackCall -> Text
Expr.unsym)
    show_merge :: Maybe TrackCall -> [Text]
show_merge = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val)
    show_tcall :: TrackCall -> Text
show_tcall = (Text
"!"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val
    show_pcontrol :: PControl -> [Text]
show_pcontrol PControl
pcontrol = [PControl -> Text
show_ref PControl
pcontrol | PControl
pcontrol forall a. Eq a => a -> a -> Bool
/= PControl
""]
    -- I use the # ref prefix in the pitch track title as special syntax.
    -- I guess it's a mnemonic for the ref that will resolve this signal.
    show_ref :: PControl -> Text
show_ref =
        forall a. ShowVal a => a -> Text
ShowVal.show_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref PControl PSignal -> Val
DeriveT.VPControlRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall control val. control -> Maybe val -> Ref control val
DeriveT.Ref forall a. Maybe a
Nothing

-- | 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 forall a. Eq a => a -> a -> Bool
== Control
"" = Text
"%"
    | Bool
otherwise = Control -> Text
ScoreT.control_name Control
c
        forall a. Semigroup a => a -> a -> a
<> if Type
typ forall a. Eq a => a -> a -> Bool
== Type
ScoreT.Untyped then Text
""
            else 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Parser 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
'!' 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 ScaleId
p_scale_id = do
    Char -> Parser Char
A.char Char
'*'
    Text -> ScaleId
Pitch.ScaleId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Bool -> String -> Parser Text
Parse.p_identifier Bool
True String
"")
    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
_) -> forall a. a -> Maybe a
Just (forall a. Typed a -> a
ScoreT.val_of Typed Control
control)
    Either Text ControlType
_ -> 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 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 forall a. Semigroup a => a -> a -> a
<> Text
rest)
        where prefix :: Text
prefix = TrackCall -> Text
Expr.unsym TrackCall
Symbols.note_track forall a. Semigroup a => a -> a -> a
<> Text
" "
    Maybe (Char, Text)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"note track title should start with >: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
title

unparse_note :: DeriveT.Expr -> Text
unparse_note :: Expr -> Text
unparse_note = Text -> Text
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val
    where
    strip :: Text -> Text
strip Text
t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
t ((Text
">"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.stripStart) 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
_) -> forall a. a -> Maybe a
Just Instrument
inst
    Either Text (Instrument, Maybe TrackCall)
_ -> 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
">" 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.takeWhile (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
_) -> forall a. a -> Maybe a
Just ScaleId
scale_id
    Either Text ControlType
_ -> forall a. Maybe a
Nothing

scale_to_title :: Pitch.ScaleId -> Text
scale_to_title :: ScaleId -> Text
scale_to_title ScaleId
scale_id =
    forall a. ShowVal a => a -> Text
ShowVal.show_val (ScaleId -> Either TrackCall PControl -> ControlType
Pitch ScaleId
scale_id (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
"*"