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

-- | Cmd-level support for the lilypond backend.
module Cmd.Lilypond (
    -- * derive
    derive_block, derive, lookup_key
    -- * compile
    , Movement, extract_movements, explicit_movements
    , compile_ly, convert, ly_filename
) where
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.IO as Lazy.IO

import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))

import qualified Util.Log as Log
import qualified Util.Processes
import qualified Util.Thread as Thread

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Msg as Msg
import qualified Cmd.PlayUtil as PlayUtil

import qualified Derive.C.Prelude.Block as C.Block
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.LEvent as LEvent
import qualified Derive.Scale.Twelve as Twelve
import qualified Derive.Score as Score
import qualified Derive.Symbols as Symbols

import qualified Perform.Lilypond as Lilypond
import qualified Perform.Lilypond.Constants as Lilypond.Constants
import qualified Perform.Lilypond.Convert as Convert
import qualified Perform.Pitch as Pitch

import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- * derive

derive_block :: Cmd.M m => BlockId -> m Derive.Result
derive_block :: forall (m :: * -> *). M m => BlockId -> m Result
derive_block BlockId
block_id = do
    -- Make sure a bad block id will fail right away.
    Block
_ <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    NoteDeriver -> m Result
forall (m :: * -> *). M m => NoteDeriver -> m Result
derive (NoteDeriver -> m Result) -> NoteDeriver -> m Result
forall a b. (a -> b) -> a -> b
$ BlockId -> NoteDeriver
C.Block.eval_root_block BlockId
block_id

-- | Run a derivation in lilypond context, which will cause certain calls to
-- behave differently.
derive :: Cmd.M m => Derive.NoteDeriver -> m Derive.Result
derive :: forall (m :: * -> *). M m => NoteDeriver -> m Result
derive NoteDeriver
deriver = do
    Config
config <- Lens State Config
Ui.configLens State Config -> Lens Config Config -> Lens State Config
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config Config
UiConfig.lilypond Lens State Config -> m State -> m Config
forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> m State
forall (m :: * -> *). M m => m State
Ui.get
    State
ui_state <- m State
forall (m :: * -> *). M m => m State
Ui.get
    (Constant
constant, InstrumentAliases
aliases) <-
        State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
PlayUtil.get_constant (State -> State
add_ly_global State
ui_state) Cache
forall a. Monoid a => a
mempty ScoreDamage
forall a. Monoid a => a
mempty
    Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ RunResult (Stream Event) -> Result
Derive.extract_result (RunResult (Stream Event) -> Result)
-> RunResult (Stream Event) -> Result
forall a b. (a -> b) -> a -> b
$
        Constant -> Dynamic -> NoteDeriver -> RunResult (Stream Event)
forall a. Constant -> Dynamic -> Deriver a -> RunResult a
Derive.derive (Constant -> Constant
set_tempo Constant
constant)
            (Config -> Dynamic -> Dynamic
set_mode Config
config (InstrumentAliases -> Dynamic
PlayUtil.initial_dynamic InstrumentAliases
aliases))
            ((Scopes -> Scopes) -> NoteDeriver -> NoteDeriver
forall a. (Scopes -> Scopes) -> Deriver a -> Deriver a
Derive.with_scopes Scopes -> Scopes
lilypond_scope NoteDeriver
deriver)
    where
    set_tempo :: Constant -> Constant
set_tempo Constant
state = Constant
state
        { state_ui :: State
Derive.state_ui = Lens State Config
Ui.configLens State Config -> Lens Config Y -> Lens State Y
forall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Default
UiConfig.default_(Config :-> Default) -> Lens Default Y -> Lens Config Y
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Default Y
UiConfig.tempo Lens State Y -> Y -> State -> State
forall f a. Lens f a -> a -> f -> f
#= Y
1 (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$
            Constant -> State
Derive.state_ui Constant
state
        }
    set_mode :: Config -> Dynamic -> Dynamic
set_mode Config
config Dynamic
state = Dynamic
state { state_mode :: Mode
Derive.state_mode = Config -> Mode
Derive.Lilypond Config
config }
    add_ly_global :: State -> State
add_ly_global = Lens State Config
Ui.configLens State Config
-> Lens Config (Map Instrument Allocation)
-> Lens State (Map Instrument Allocation)
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config (Map Instrument Allocation)
UiConfig.allocations_map
        Lens State (Map Instrument Allocation)
-> (Map Instrument Allocation -> Map Instrument Allocation)
-> State
-> State
forall f a. Lens f a -> (a -> a) -> f -> f
%= Instrument
-> Allocation
-> Map Instrument Allocation
-> Map Instrument Allocation
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
Lilypond.Constants.ly_global Allocation
allocation
    allocation :: Allocation
allocation = Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
Lilypond.Constants.ly_qualified
        (Text -> Backend
UiConfig.Dummy Text
"")

-- | Override a few calls with lilypond versions.
lilypond_scope :: Derive.Scopes -> Derive.Scopes
lilypond_scope :: Scopes -> Scopes
lilypond_scope =
    Scopes
:-> Scope
      (ScopePriority (Generator Event))
      (ScopePriority (Generator Control))
      (ScopePriority (Generator Pitch))
forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
Derive.s_generator(Scopes
 :-> Scope
       (ScopePriority (Generator Event))
       (ScopePriority (Generator Control))
       (ScopePriority (Generator Pitch)))
-> Lens
     (Scope
        (ScopePriority (Generator Event))
        (ScopePriority (Generator Control))
        (ScopePriority (Generator Pitch)))
     (ScopePriority (Generator Event))
-> Lens Scopes (ScopePriority (Generator Event))
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens
  (Scope
     (ScopePriority (Generator Event))
     (ScopePriority (Generator Control))
     (ScopePriority (Generator Pitch)))
  (ScopePriority (Generator Event))
forall {note} {control} {pitch}. Scope note control pitch :-> note
Derive.s_note
        Lens Scopes (ScopePriority (Generator Event))
-> (ScopePriority (Generator Event)
    -> ScopePriority (Generator Event))
-> Scopes
-> Scopes
forall f a. Lens f a -> (a -> a) -> f -> f
%= CallPriority
-> CallMap (Generator Event)
-> ScopePriority (Generator Event)
-> ScopePriority (Generator Event)
forall call.
CallPriority
-> CallMap call -> ScopePriority call -> ScopePriority call
Derive.add_priority CallPriority
Derive.PrioOverride CallMap (Generator Event)
cmap
    where
    cmap :: CallMap (Generator Event)
cmap = CallMap (Generator Event)
forall a. Monoid a => a
mempty
        { call_map :: Map Symbol (Generator Event)
Derive.call_map = [(Symbol, Generator Event)] -> Map Symbol (Generator Event)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [(Symbol
Symbols.null_note, Generator Event
note), (Symbol
Symbols.default_note, Generator Event
note)]
        }
    -- Turn off the behaviour where staccato shortens the note, since that's
    -- already implicit when you see the dot.
    note :: Generator Event
note = CallName -> Doc -> Tags -> GenerateNote -> Generator Event
Note.note_call CallName
"" Doc
"" Tags
forall a. Monoid a => a
mempty
        (Config -> GenerateNote
Note.default_note Config
Note.no_duration_attributes)

lookup_key :: Cmd.Performance -> Pitch.Key
lookup_key :: Performance -> Key
lookup_key Performance
perf =
    Key -> Maybe Key -> Key
forall a. a -> Maybe a -> a
fromMaybe Key
Twelve.default_key (Maybe Key -> Key) -> Maybe Key -> Key
forall a b. (a -> b) -> a -> b
$ [Maybe Key] -> Maybe Key
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Key] -> Maybe Key) -> [Maybe Key] -> Maybe Key
forall a b. (a -> b) -> a -> b
$ (Dynamic -> Maybe Key) -> [Dynamic] -> [Maybe Key]
forall a b. (a -> b) -> [a] -> [b]
map (Environ -> Maybe Key
lookup (Environ -> Maybe Key)
-> (Dynamic -> Environ) -> Dynamic -> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Environ
Derive.state_environ) ([Dynamic] -> [Maybe Key]) -> [Dynamic] -> [Maybe Key]
forall a b. (a -> b) -> a -> b
$
        Map (BlockId, TrackId) Dynamic -> [Dynamic]
forall k a. Map k a -> [a]
Map.elems (Performance -> Map (BlockId, TrackId) Dynamic
Msg.perf_track_dynamic Performance
perf)
    where
    lookup :: Environ -> Maybe Key
lookup Environ
environ = case Text -> Environ -> Either LookupError Text
forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.key Environ
environ of
        Right Text
key -> Key -> Maybe Key
forall a. a -> Maybe a
Just (Text -> Key
Pitch.Key Text
key)
        Left LookupError
_ -> Maybe Key
forall a. Maybe a
Nothing

-- * compile

type Movement = (Lilypond.Title, [Score.Event])

-- | Generate lilypond code.  If there are movement divisions, they will
-- be extracted from the events.
extract_movements :: Lilypond.Config -> Lilypond.Title -> [Score.Event]
    -> (Either Log.Msg Lazy.Text, [Log.Msg])
extract_movements :: Config -> Text -> [Event] -> (Either Msg Text, [Msg])
extract_movements Config
config Text
title [Event]
score_events = (Either Msg Text
output, [Msg]
logs)
    where
    ([Event]
ly_events, [Msg]
logs) = Config -> [Event] -> ([Event], [Msg])
convert Config
config [Event]
score_events
    output :: Either Msg Text
output = Config -> Text -> [Movement] -> Text
Lilypond.ly_file Config
config Text
title ([Movement] -> Text) -> Either Msg [Movement] -> Either Msg Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Config -> [Event] -> Either Msg [Movement]
Lilypond.extract_movements Config
config [Event]
ly_events

-- | Generate lilypond from an explicit list of movements.
explicit_movements :: Lilypond.Config -> Lilypond.Title -> [Movement]
    -> (Either Log.Msg Lazy.Text, [Log.Msg])
explicit_movements :: Config -> Text -> [Movement] -> (Either Msg Text, [Msg])
explicit_movements Config
config Text
title [Movement]
movements = (Either Msg Text
output, [Msg]
logs)
    where
    (Either Msg [Movement]
result, [Msg]
logs) = Config -> [Movement] -> (Either Msg [Movement], [Msg])
convert_movements Config
config [Movement]
movements
    output :: Either Msg Text
output = Config -> Text -> [Movement] -> Text
Lilypond.ly_file Config
config Text
title ([Movement] -> Text) -> Either Msg [Movement] -> Either Msg Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Msg [Movement]
result

convert_movements :: Lilypond.Config -> [Movement]
    -> (Either Log.Msg [Lilypond.Movement], [Log.Msg])
convert_movements :: Config -> [Movement] -> (Either Msg [Movement], [Msg])
convert_movements Config
config [Movement]
movements =
    (Config -> [(Text, [Event])] -> Either Msg [Movement]
Lilypond.explicit_movements Config
config ([Text] -> [[Event]] -> [(Text, [Event])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Movement -> Text) -> [Movement] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Movement -> Text
forall a b. (a, b) -> a
fst [Movement]
movements) [[Event]]
mvt_events),
        [[Msg]] -> [Msg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Msg]]
logs)
    where ([[Event]]
mvt_events, [[Msg]]
logs) = [([Event], [Msg])] -> ([[Event]], [[Msg]])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Movement -> ([Event], [Msg])) -> [Movement] -> [([Event], [Msg])]
forall a b. (a -> b) -> [a] -> [b]
map (Config -> [Event] -> ([Event], [Msg])
convert Config
config ([Event] -> ([Event], [Msg]))
-> (Movement -> [Event]) -> Movement -> ([Event], [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Movement -> [Event]
forall a b. (a, b) -> b
snd) [Movement]
movements)

compile_ly :: FilePath -> Lazy.Text -> IO ()
compile_ly :: FilePath -> Text -> IO ()
compile_ly FilePath
filename Text
text = do
    Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
True (FilePath -> FilePath
FilePath.takeDirectory FilePath
filename)
    FilePath -> Text -> IO ()
Lazy.IO.writeFile FilePath
filename Text
text
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
Thread.start (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ()
Util.Processes.call
        FilePath
"lilypond" [FilePath
"-o", FilePath -> FilePath
FilePath.dropExtension FilePath
filename, FilePath
filename]

convert :: Lilypond.Config -> [Score.Event] -> ([Lilypond.Event], [Log.Msg])
convert :: Config -> [Event] -> ([Event], [Msg])
convert Config
config [Event]
score_events =
    (Duration -> [Event] -> [Event]
Convert.quantize (Config -> Duration
Lilypond.config_quantize Config
config) [Event]
events, [Msg]
logs)
    where
    ([Event]
events, [Msg]
logs) = [LEvent Event] -> ([Event], [Msg])
forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition ([LEvent Event] -> ([Event], [Msg]))
-> [LEvent Event] -> ([Event], [Msg])
forall a b. (a -> b) -> a -> b
$ Config -> [Event] -> [LEvent Event]
Convert.convert Config
config [Event]
score_events

ly_filename :: Cmd.M m => Lilypond.Title -> m FilePath
ly_filename :: forall (m :: * -> *). M m => Text -> m FilePath
ly_filename Text
title = do
    FilePath
dir <- Text -> Maybe FilePath -> m FilePath
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"ly_filename: no save dir"
        (Maybe FilePath -> m FilePath) -> m (Maybe FilePath) -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (State -> Maybe FilePath) -> m (Maybe FilePath)
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe FilePath
Cmd.state_save_dir
    FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"ly" FilePath -> FilePath -> FilePath
</> Text -> FilePath
untxt (Text -> Text
clean Text
title) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".ly"
    where
    clean :: Text -> Text
clean = (Char -> Char) -> Text -> Text
Text.map Char -> Char
replace (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower
    replace :: Char -> Char
replace Char
'/' = Char
'-'
    replace Char
' ' = Char
'-'
    replace Char
c = Char
c