{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
module Cmd.ControlTrack (
cmd_val_edit, cmd_tempo_val_edit
, cmd_method_edit
, val_edit_at
, modify_val
, Partial(..)
, parse, unparse
, parse_general, unparse_general
#ifdef TESTING
, module Cmd.ControlTrack
#endif
) where
import qualified Data.Text as Text
import qualified Util.Lists as Lists
import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Msg as Msg
import qualified Cmd.Selection as Selection
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Parse as Parse
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Key as Key
import qualified Ui.Ui as Ui
import Global
import Types
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 {a}. Text -> m a -> m a
suppress Text
"control track val edit" forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.WantBackspace Msg
msg
(BlockId
_, TrackNum
_, TrackId
track_id, TrackTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, TrackTime)
Selection.get_insert
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). M m => TrackId -> m Bool
infer_normalized TrackId
track_id)
(forall (m :: * -> *). M m => Msg -> m ()
edit_normalized Msg
msg) (forall (m :: * -> *). M m => Msg -> m ()
edit_non_normalized Msg
msg)
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
where suppress :: Text -> m a -> m a
suppress = forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
Cmd.suppress_history EditMode
Cmd.ValEdit
cmd_tempo_val_edit :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_tempo_val_edit :: forall (m :: * -> *). M m => Msg -> m Status
cmd_tempo_val_edit Msg
msg = forall {a}. Text -> m a -> m a
suppress Text
"tempo track val edit" forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.WantBackspace Msg
msg
forall (m :: * -> *). M m => Msg -> m ()
edit_non_normalized Msg
msg
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
where suppress :: Text -> m a -> m a
suppress = forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
Cmd.suppress_history EditMode
Cmd.ValEdit
infer_normalized :: Ui.M m => TrackId -> m Bool
infer_normalized :: forall (m :: * -> *). M m => TrackId -> m Bool
infer_normalized =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Text -> Bool
normal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Text
"'") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Event -> Text
Event.text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events -> [Event]
Events.ascending)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events
where
normal :: Text -> Bool
normal Text
event = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`Text.isInfixOf` Text
event) [Text]
normalized_prefixes
normalized_prefixes :: [Text]
normalized_prefixes :: [Text]
normalized_prefixes = [Text
"`0x`", Text
"0x"]
edit_non_normalized :: Cmd.M m => Msg.Msg -> m ()
edit_non_normalized :: forall (m :: * -> *). M m => Msg -> m ()
edit_non_normalized = \case
(Msg -> Maybe Key
EditUtil.num_key -> Just Key
key) -> forall (m :: * -> *). M m => Modify -> m ()
modify_event (Key -> Modify
modify_num Key
key)
(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
edit_normalized :: Cmd.M m => Msg.Msg -> m ()
edit_normalized :: forall (m :: * -> *). M m => Msg -> m ()
edit_normalized = \case
(Msg -> Maybe Key
EditUtil.hex_key -> Just Key
key) -> forall (m :: * -> *). M m => Modify -> m ()
modify_event (Key -> Modify
modify_hex Key
key)
(Msg -> Maybe Key
Msg.key_down -> Just (Key.Char Char
'\'')) -> forall (m :: * -> *). M m => Text -> m ()
EditUtil.soft_insert Text
"'"
Msg.InputNote (InputNote.NoteOn NoteId
_ (Pitch.Input KbdType
Pitch.PianoKbd Pitch
_ Frac
_) Frac
vel) ->
forall {m :: * -> *}. M m => Bool -> Frac -> m ()
insert_val Bool
False Frac
vel
Msg.InputNote (InputNote.Control NoteId
_ Control
_ Frac
val) -> forall {m :: * -> *}. M m => Bool -> Frac -> m ()
insert_val Bool
True Frac
val
Msg
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort
where
insert_val :: Bool -> Frac -> m ()
insert_val Bool
control_input Frac
val = do
Pos
pos <- forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
forall (m :: * -> *). M m => Pos -> Frac -> m ()
val_edit_at Pos
pos Frac
val
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). Monad m => [m Bool] -> m Bool
andM [forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
control_input),
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
modify_num :: EditUtil.Key -> Modify
modify_num :: Key -> Modify
modify_num Key
key Partial
partial =
case [Modifier] -> Key -> Text -> Maybe Text
EditUtil.modify_text_key [] Key
key (Partial -> Text
_val Partial
partial) of
Maybe Text
Nothing -> (forall a. Maybe a
Nothing, Text -> Bool
Text.null forall a b. (a -> b) -> a -> b
$ Partial -> Text
_val Partial
partial)
Just Text
new_val -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Partial
partial { _val :: Text
_val = Text
new_val }, Bool
False)
modify_hex :: EditUtil.Key -> Modify
modify_hex :: Key -> Modify
modify_hex Key
key Partial
partial
| Just Maybe Text
new_val <- Text -> Key -> Maybe (Maybe Text)
update_hex (Partial -> Text
_val Partial
partial) Key
key = case Maybe Text
new_val of
Maybe Text
Nothing -> (forall a. Maybe a
Nothing, Bool
True)
Just Text
val -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Partial
partial { _val :: Text
_val = Text
val }, Bool
False)
| Key -> Bool
EditUtil.is_num_key Key
key = Key -> Modify
modify_num Key
key Partial
partial
| Bool
otherwise = (forall a. a -> Maybe a
Just Partial
partial, Bool
False)
update_hex :: Text -> EditUtil.Key -> Maybe (Maybe Text)
update_hex :: Text -> Key -> Maybe (Maybe Text)
update_hex Text
val_ Key
key
| Text -> Bool
Text.null Text
val = case Key
key of
Key
EditUtil.Backspace -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
EditUtil.Key Char
c
| Char -> Bool
higit Char
c -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
ShowVal.hex_prefix forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack [Char
'0', Char
c]
| Bool
otherwise -> forall a. Maybe a
Nothing
| Just Char
c2 <- Text -> Maybe Char
parse_val Text
val = case Key
key of
Key
EditUtil.Backspace -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
EditUtil.Key Char
c
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if Bool
negative then Text
val else Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
val
| Char -> Bool
higit Char
c -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
prefix forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack [Char
c2, Char
c]
| Bool
otherwise -> forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Text
val)
| Bool
otherwise = forall a. Maybe a
Nothing
where
prefix :: Text
prefix = (if Bool
negative then Text
"-" else Text
"") forall a. Semigroup a => a -> a -> a
<> Text
ShowVal.hex_prefix
negative :: Bool
negative = Text
"-" Text -> Text -> Bool
`Text.isPrefixOf` Text
val_
val :: Text
val = if Bool
negative then TrackNum -> Text -> Text
Text.drop TrackNum
1 Text
val_ else Text
val_
higit :: Char -> Bool
higit Char
c = Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' Bool -> Bool -> Bool
|| Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'f'
parse_val :: Text -> Maybe Char
parse_val Text
t = case Text -> String
Text.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
strip Text
t of
Just [Char
c1, Char
c2] | Char -> Bool
higit Char
c1 Bool -> Bool -> Bool
&& Char -> Bool
higit Char
c2 -> forall a. a -> Maybe a
Just Char
c2
Maybe String
_ -> forall a. Maybe a
Nothing
where strip :: Text -> Maybe Text
strip Text
t = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a b. (a -> b) -> a -> b
$Text
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
Text.stripPrefix) [Text]
normalized_prefixes
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
"control 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
case Msg
msg of
(Msg -> Maybe Key
EditUtil.method_key -> Just Key
key) -> forall (m :: * -> *). M m => Modify -> m ()
modify_event 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
_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
_method Partial
partial)
}
, Bool
False
)
Msg
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
val_edit_at :: Cmd.M m => EditUtil.Pos -> Signal.Y -> m ()
val_edit_at :: forall (m :: * -> *). M m => Pos -> Frac -> m ()
val_edit_at Pos
pos Frac
val = 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
_val = Frac -> Text
ShowVal.show_hex_val Frac
val }, Bool
False)
type Modify = Partial -> (Maybe Partial, Bool)
modify_event :: Cmd.M m => Modify -> m ()
modify_event :: forall (m :: * -> *). M m => Modify -> m ()
modify_event Modify
f = do
Pos
pos <- forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
forall (m :: * -> *). M m => Pos -> Modify -> m ()
modify_event_at Pos
pos Modify
f
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
False
(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
"")
modify_val :: (Signal.Y -> Signal.Y) -> Text -> Maybe Text
modify_val :: (Frac -> Frac) -> Text -> Maybe Text
modify_val Frac -> Frac
f Text
text = case Text -> Either Text Val
Parse.parse_val (Partial -> Text
_val Partial
partial) of
Right Val
val | Just Typed Frac
num <- Val -> Maybe (Typed Frac)
DeriveT.constant_val Val
val ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Partial -> Text
unparse forall a b. (a -> b) -> a -> b
$ Partial
partial { _val :: Text
_val = Typed Frac -> Text
show_val (Frac -> Frac
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Frac
num) }
Either Text Val
_ -> forall a. Maybe a
Nothing
where
partial :: Partial
partial = Text -> Partial
parse Text
text
show_val :: Typed Frac -> Text
show_val Typed Frac
num
| ScoreT.Typed Type
ScoreT.Untyped Frac
n <- Typed Frac
num
, Text -> Bool
ShowVal.is_hex_val (Partial -> Text
_val Partial
partial) = Frac -> Text
ShowVal.show_hex_val Frac
n
| Bool
otherwise = forall a. ShowVal a => a -> Text
ShowVal.show_val Typed Frac
num
data Partial = Partial {
Partial -> [[Text]]
_transform :: [[Text]]
, Partial -> Text
_method :: Text
, Partial -> Text
_val :: Text
, Partial -> [Text]
_args :: [Text]
, :: Text
} deriving (TrackNum -> Partial -> ShowS
[Partial] -> ShowS
Partial -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Partial] -> ShowS
$cshowList :: [Partial] -> ShowS
show :: Partial -> String
$cshow :: Partial -> String
showsPrec :: TrackNum -> Partial -> ShowS
$cshowsPrec :: TrackNum -> Partial -> ShowS
Show, Partial -> Partial -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Partial -> Partial -> Bool
$c/= :: Partial -> Partial -> Bool
== :: Partial -> Partial -> Bool
$c== :: Partial -> Partial -> Bool
Eq)
parse :: Text -> Partial
parse :: Text -> Partial
parse = (Text -> Text -> [Text] -> (Text, Text, [Text])) -> Text -> Partial
parse_general (\Text
method Text
val [Text]
args -> (Text
method, Text
val, [Text]
args))
parse_general :: (Text -> Text -> [Text] -> (Text, Text, [Text]))
-> Text -> Partial
parse_general :: (Text -> Text -> [Text] -> (Text, Text, [Text])) -> Text -> Partial
parse_general Text -> Text -> [Text] -> (Text, Text, [Text])
split_expr = Maybe ([[Text]], [Text]) -> Partial
make forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe ([a], a)
Lists.unsnoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [[Text]]
Parse.split_pipeline
where
make :: Maybe ([[Text]], [Text]) -> Partial
make Maybe ([[Text]], [Text])
Nothing = [[Text]] -> Text -> Text -> [Text] -> Text -> Partial
Partial [] Text
"" Text
"" [] Text
""
make (Just ([[Text]]
transform, [Text]
expr)) = Partial
{ _transform :: [[Text]]
_transform = [[Text]]
transform
, _method :: Text
_method = Text -> Text
Text.strip Text
method
, _val :: Text
_val = Text -> Text
Text.strip Text
val
, _args :: [Text]
_args = [Text]
args
, _comment :: Text
_comment = Text
comment
}
where
([Text]
expr2, Text
comment) = case forall a. [a] -> Maybe ([a], a)
Lists.unsnoc [Text]
expr of
Just ([Text]
expr, Text
comment) | Text
"--" Text -> Text -> Bool
`Text.isPrefixOf` Text
comment ->
([Text]
expr, Text
comment)
Maybe ([Text], Text)
_ -> ([Text]
expr, Text
"")
(Text
method, Text
val, [Text]
args) = case [Text]
expr2 of
Text
method : Text
val : [Text]
args -> Text -> Text -> [Text] -> (Text, Text, [Text])
split_expr Text
method Text
val [Text]
args
[Text
arg]
| Text
" " Text -> Text -> Bool
`Text.isSuffixOf` Text
arg -> (Text
arg, Text
"", [])
| Bool
otherwise -> (Text
"", Text
arg, [])
[] -> (Text
"", Text
"", [])
unparse_general :: (Text -> Text -> [Text] -> [Text]) -> Partial -> Text
unparse_general :: (Text -> Text -> [Text] -> [Text]) -> Partial -> Text
unparse_general Text -> Text -> [Text] -> [Text]
join_expr (Partial [[Text]]
transform Text
method Text
val [Text]
args Text
comment) =
[[Text]] -> Text
Parse.join_pipeline forall a b. (a -> b) -> a -> b
$
[[Text]]
transform forall a. [a] -> [a] -> [a]
++ [forall a. (a -> a) -> [a] -> [a]
Lists.mapInit (forall a. Semigroup a => a -> a -> a
<>Text
" ") ([Text]
expr forall a. [a] -> [a] -> [a]
++ [Text]
comments)]
where
comments :: [Text]
comments = if Text -> Bool
Text.null Text
comment then [] else [Text
comment]
expr :: [Text]
expr = Text -> Text -> [Text] -> [Text]
join_expr Text
method Text
val [Text]
args
unparse :: Partial -> Text
unparse :: Partial -> Text
unparse = (Text -> Text -> [Text] -> [Text]) -> Partial -> Text
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
| Text -> Bool
Text.null Text
method = Text
val forall a. a -> [a] -> [a]
: [Text]
args
| Bool
otherwise = [Text
method, [Text] -> Text
Text.unwords (Text
val forall a. a -> [a] -> [a]
: [Text]
args)]