-- 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 CPP #-}
{-# LANGUAGE ViewPatterns #-}
{- | Cmds to edit a pitch track, which is a special kind of control track.

    This module creates the pitches that are later parsed by Derive.Control.
-}
module Cmd.PitchTrack (
    cmd_val_edit, cmd_method_edit
    , val_edit_at, method_edit_at
    , cmd_record_note_status
    -- * edits
    , transpose_selection
    , transpose
    , cycle_enharmonics
    , pitches
    , pitch_tracks
#ifdef TESTING
    , module Cmd.PitchTrack
#endif
) where
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.ControlTrack as ControlTrack
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.InputNote as InputNote
import qualified Cmd.ModifyEvents as ModifyEvents
import qualified Cmd.Msg as Msg
import qualified Cmd.Perf as Perf
import qualified Cmd.Selection as Selection

import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.Expr as Expr
import qualified Derive.Parse as Parse
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Scale as Scale
import qualified Derive.Symbols as Symbols

import qualified Perform.Pitch as Pitch
import qualified Ui.Key as Key

import           Global


-- * entry

-- | Val edit turns 'Msg.InputNote's into the appropriate scale degree call
-- for the scale in scope.
--
-- Like control tracks, @'@ will add a @'@ call, which repeats the last value.
-- This is useful to extend a constant pitch value to the desired breakpoint.
cmd_val_edit :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_val_edit :: forall (m :: * -> *). M m => Msg -> m Status
cmd_val_edit Msg
msg = forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
Cmd.suppress_history EditMode
Cmd.ValEdit Text
"pitch track val edit" forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.NoBackspace Msg
msg
    case Msg
msg of
        Msg.InputNote (InputNote.NoteOn NoteId
_ Input
input Y
_) -> do
            Pos
pos <- forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
            Note
note <- forall (m :: * -> *). M m => Input -> m Note
EditUtil.input_to_note Input
input
            forall (m :: * -> *). M m => Pos -> Note -> m ()
val_edit_at Pos
pos Note
note
            forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (EditState -> Bool
Cmd.state_advance forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit))
                forall (m :: * -> *). M m => m ()
Selection.advance
        Msg.InputNote (InputNote.PitchChange NoteId
_ Input
input) -> do
            Pos
pos <- forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
            Note
note <- forall (m :: * -> *). M m => Input -> m Note
EditUtil.input_to_note Input
input
            forall (m :: * -> *). M m => Pos -> Note -> m ()
val_edit_at Pos
pos Note
note
        (Msg -> Maybe Key
Msg.key_down -> Just (Key.Char Char
'\'')) -> forall (m :: * -> *). M m => Text -> m ()
EditUtil.soft_insert Text
"'"
        Msg
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done

-- | Method edit directs keystrokes to the (optional) call around the pitch
-- call.  Pitches by themselves simply set a constant pitch by default, but
-- a call can create an interpolated curve, or a trill, or anything really.
cmd_method_edit :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_method_edit :: forall (m :: * -> *). M m => Msg -> m Status
cmd_method_edit Msg
msg = forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
Cmd.suppress_history EditMode
Cmd.MethodEdit
        Text
"pitch track method edit" forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.WantBackspace Msg
msg
    Key
key <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall a b. (a -> b) -> a -> b
$ Msg -> Maybe Key
EditUtil.method_key Msg
msg
    Pos
pos <- forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
    forall (m :: * -> *). M m => Pos -> Key -> m ()
method_edit_at Pos
pos Key
key
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done

val_edit_at :: Cmd.M m => EditUtil.Pos -> Pitch.Note -> m ()
val_edit_at :: forall (m :: * -> *). M m => Pos -> Note -> m ()
val_edit_at Pos
pos Note
note = forall (m :: * -> *). M m => Pos -> Modify -> m ()
modify_event_at Pos
pos forall a b. (a -> b) -> a -> b
$ \Partial
partial ->
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Partial
partial { _val :: Text
ControlTrack._val = Note -> Text
Pitch.note_text Note
note }, Bool
False)

method_edit_at :: Cmd.M m => EditUtil.Pos -> EditUtil.Key -> m ()
method_edit_at :: forall (m :: * -> *). M m => Pos -> Key -> m ()
method_edit_at Pos
pos Key
key = forall (m :: * -> *). M m => Pos -> Modify -> m ()
modify_event_at Pos
pos forall a b. (a -> b) -> a -> b
$ \Partial
partial ->
    ( forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Partial
partial
        { _method :: Text
ControlTrack._method = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$
            [Modifier] -> Key -> Text -> Maybe Text
EditUtil.modify_text_key [] Key
key (Partial -> Text
ControlTrack._method Partial
partial)
        }
    , Bool
False
    )

-- | Record the last note entered.
cmd_record_note_status :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_record_note_status :: forall (m :: * -> *). M m => Msg -> m Status
cmd_record_note_status Msg
msg = do
    case Msg
msg of
        Msg.InputNote (InputNote.NoteOn NoteId
_ Input
input Y
_) -> do
            Note
note <- forall (m :: * -> *). M m => Input -> m Note
EditUtil.input_to_note Input
input
            forall (m :: * -> *). M m => (Int, Text) -> Maybe Text -> m ()
Cmd.set_status (Int, Text)
Config.status_note forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Note -> Text
Pitch.note_text Note
note
        Msg
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue

-- * implementation

-- | old -> (new, advance?)
type Modify = ControlTrack.Partial -> (Maybe ControlTrack.Partial, Bool)

modify_event_at :: Cmd.M m => EditUtil.Pos -> Modify -> m ()
modify_event_at :: forall (m :: * -> *). M m => Pos -> Modify -> m ()
modify_event_at Pos
pos Modify
f = forall (m :: * -> *). M m => Pos -> Bool -> Bool -> Modify -> m ()
EditUtil.modify_event_at Pos
pos Bool
True Bool
True
    (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Partial -> Text
unparse) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modify
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Partial
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Text
"")

parse :: Text -> ControlTrack.Partial
parse :: Text -> Partial
parse = (Text -> Text -> [Text] -> (Text, Text, [Text])) -> Text -> Partial
ControlTrack.parse_general Text -> Text -> [Text] -> (Text, Text, [Text])
split_expr
    where
    split_expr :: Text -> Text -> [Text] -> (Text, Text, [Text])
split_expr Text
method Text
val [Text]
args
        -- Uses parens to disambiguate between call and val vs. val
        -- with args.
        | Text
"(" Text -> Text -> Bool
`Text.isPrefixOf` Text
val = (Text
method, Text
val, [Text]
args)
        | Bool
otherwise = (Text
"", Text
method, Text
val forall a. a -> [a] -> [a]
: [Text]
args)

-- | Since pitches are calls, they need to lose or gain parens when they move
-- to or from toplevel call position.  This is one reason parse and unparse
-- are not exact inverses.
unparse :: ControlTrack.Partial -> Text
unparse :: Partial -> Text
unparse = (Text -> Text -> [Text] -> [Text]) -> Partial -> Text
ControlTrack.unparse_general Text -> Text -> [Text] -> [Text]
join_expr
    where
    join_expr :: Text -> Text -> [Text] -> [Text]
join_expr Text
method Text
val [Text]
args
        | Text -> Bool
Text.null Text
method Bool -> Bool -> Bool
&& Text -> Bool
Text.null Text
val = [Text]
args
        -- If the method is gone, the note no longer needs its parens.
        | Text -> Bool
Text.null Text
method = Text -> Text
strip_parens Text
val forall a. a -> [a] -> [a]
: [Text]
args
        | Bool
otherwise = [Text
method, Text -> Text
add_parens ([Text] -> Text
Text.unwords (Text
val forall a. a -> [a] -> [a]
: [Text]
args))]
    strip_parens :: Text -> Text
strip_parens Text
t
        | Text
"(" Text -> Text -> Bool
`Text.isPrefixOf` Text
t Bool -> Bool -> Bool
&& Text
")" Text -> Text -> Bool
`Text.isSuffixOf` Text
t =
            Int -> Text -> Text
Text.drop Int
1 forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.take (Text -> Int
Text.length Text
t forall a. Num a => a -> a -> a
- Int
1) Text
t
        | Bool
otherwise = Text
t
    -- If there's a method and it doesn't already have parens, it'll need them.
    add_parens :: Text -> Text
add_parens Text
val
        | Text -> Bool
Text.null Text
val Bool -> Bool -> Bool
|| Text
"(" Text -> Text -> Bool
`Text.isPrefixOf` Text
val = Text
val
        | Bool
otherwise = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
val forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Try to figure out where the pitch call part is in event text and modify
-- that with the given function.  The function can signal failure by returning
-- Left.
--
-- This is a bit of a heuristic because by design a pitch is a normal call and
-- there's no syntactic way to tell where the pitches are in an expression.  If
-- the text is a call with a val call as its first argument, that's considered
-- the pitch call.  Otherwise, if the text is just a call, that's the pitch
-- call.  Otherwise the text is unchanged.
--
-- This works with the convention that pitch calls take the \"base\" pitch as
-- their first argument.
modify_note :: (Pitch.Note -> Either Text Pitch.Note) -> Text
    -> Either Text Text
modify_note :: (Note -> Either Text Note) -> Text -> Either Text Text
modify_note Note -> Either Text Note
f = (Text -> Either Text Text) -> Text -> Either Text Text
modify_expr forall a b. (a -> b) -> a -> b
$ \Text
note_str -> case Text -> Maybe (Char, Text)
Text.uncons Text
note_str of
    Just (Char
'(', Text
rest) ->
        let (Text
note, Text
post) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
" )" :: [Char])) Text
rest
        in Char -> Text -> Text
Text.cons Char
'(' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>Text
post) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Text
Pitch.note_text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> Either Text Note
f (Text -> Note
Pitch.Note Text
note)
    Maybe (Char, Text)
_ -> Note -> Text
Pitch.note_text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> Either Text Note
f (Text -> Note
Pitch.Note Text
note_str)

-- | Modify the note expression, e.g. in @i (a b c)@ it would be @(a b c)@,
-- including the parens.
modify_expr :: (Text -> Either Text Text) -> Text -> Either Text Text
modify_expr :: (Text -> Either Text Text) -> Text -> Either Text Text
modify_expr Text -> Either Text Text
f Text
text = case Text -> Either Text Expr
Parse.parse_expr Text
text of
    Left Text
_ -> forall a b. b -> Either a b
Right Text
text
    Right Expr
expr -> case Expr
expr of
        Expr.Call Symbol
sym (Expr.ValCall Call Val
_ : [Term Val]
_) :| []
            | Symbol
sym forall a. Eq a => a -> a -> Bool
/= Symbol
Symbols.equal ->
                let (Text
pre, Text
within) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'(') Text
text
                    (Text
note, Text
post) = (Char -> Bool) -> Text -> (Text, Text)
break1 (forall a. Eq a => a -> a -> Bool
==Char
')') Text
within
                in (\Text
n -> Text
pre forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
post) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Text
f Text
note
        Expr.Call Symbol
sym [Term Val]
_ :| []
            | Symbol
sym forall a. Eq a => a -> a -> Bool
/= Symbol
Symbols.equal ->
                let (Text
pre, Text
post) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
' ') Text
text
                in (forall a. Semigroup a => a -> a -> a
<>Text
post) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Text
f Text
pre
        Expr
_ -> forall a b. b -> Either a b
Right Text
text

    where
    break1 :: (Char -> Bool) -> Text -> (Text, Text)
break1 Char -> Bool
f Text
t = case (Char -> Bool) -> Text -> Maybe Int
Text.findIndex Char -> Bool
f Text
t of
        Just Int
i -> Int -> Text -> (Text, Text)
Text.splitAt (Int
iforall a. Num a => a -> a -> a
+Int
1) Text
t
        Maybe Int
Nothing -> (Text
t, Text
"")


-- * edits

-- | Function that modifies the pitch of an event on a pitch track, or a Left
-- if the operation failed.
type ModifyPitch =
    Scale.Scale -> Env.Environ -> Pitch.Note -> Either Text Pitch.Note

transpose_selection :: Cmd.M m => Scale.Transposition -> Pitch.Octave
    -> Pitch.Step -> m ()
transpose_selection :: forall (m :: * -> *). M m => Transposition -> Int -> Int -> m ()
transpose_selection Transposition
transposition Int
oct Int
steps =
    forall (m :: * -> *). M m => ModifyPitch -> m ()
pitches forall a b. (a -> b) -> a -> b
$ Transposition -> Int -> Int -> ModifyPitch
transpose Transposition
transposition Int
oct Int
steps

transpose :: Scale.Transposition -> Pitch.Octave -> Pitch.Step -> ModifyPitch
transpose :: Transposition -> Int -> Int -> ModifyPitch
transpose Transposition
transposition Int
octaves Int
steps = \Scale
scale Environ
env Note
note ->
    case Transposition
-> Scale -> Environ -> Int -> Int -> Note -> Either PitchError Note
Scale.transpose Transposition
transposition Scale
scale Environ
env Int
octaves Int
steps Note
note of
        -- Leave non-pitches alone.
        Left DeriveT.UnparseableNote {} -> forall a b. b -> Either a b
Right Note
note
        Left PitchError
err -> forall a b. a -> Either a b
Left (forall a. Pretty a => a -> Text
pretty PitchError
err)
        Right Note
note2 -> forall a b. b -> Either a b
Right Note
note2

cycle_enharmonics :: ModifyPitch
cycle_enharmonics :: ModifyPitch
cycle_enharmonics Scale
scale Environ
env Note
note = 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
$ do
    [Note]
enharmonics <- Scale -> Enharmonics
Scale.scale_enharmonics Scale
scale Environ
env Note
note
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Note
note (forall a. [a] -> Maybe a
Lists.head [Note]
enharmonics)

pitches :: Cmd.M m => ModifyPitch -> m ()
pitches :: forall (m :: * -> *). M m => ModifyPitch -> m ()
pitches = forall (m :: * -> *). M m => Track m -> m ()
ModifyEvents.selection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => ModifyPitch -> Track m
pitch_tracks

-- | Apply a ModifyPitch to only pitch tracks.
pitch_tracks :: Cmd.M m => ModifyPitch -> ModifyEvents.Track m
pitch_tracks :: forall (m :: * -> *). M m => ModifyPitch -> Track m
pitch_tracks ModifyPitch
f = forall (m :: * -> *). M m => (Text -> Bool) -> Track m -> Track m
ModifyEvents.tracks_named Text -> Bool
ParseTitle.is_pitch_track forall a b. (a -> b) -> a -> b
$
        \BlockId
block_id TrackId
track_id [Event]
events -> do
    Scale
scale <- forall (m :: * -> *). M m => Track -> m Scale
Perf.get_scale (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id)
    Environ
env <- forall (m :: * -> *). M m => Track -> m Environ
Perf.get_environ (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id)
    let modify :: Text -> Either Text Text
modify = (Note -> Either Text Note) -> Text -> Either Text Text
modify_note (ModifyPitch
f Scale
scale Environ
env)
    forall (m :: * -> *). M m => (Text -> Either Text Text) -> Track m
ModifyEvents.failable_text Text -> Either Text Text
modify BlockId
block_id TrackId
track_id [Event]
events