-- 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
_ <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    forall (m :: * -> *). M m => NoteDeriver -> m Result
derive 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.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Config
UiConfig.lilypond forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    (Constant
constant, InstrumentAliases
aliases) <-
        forall (m :: * -> *).
M m =>
State -> Cache -> ScoreDamage -> m (Constant, InstrumentAliases)
PlayUtil.get_constant (State -> State
add_ly_global State
ui_state) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RunResult (Stream Event) -> Result
Derive.extract_result forall a b. (a -> b) -> a -> b
$
        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))
            (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.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Default
UiConfig.default_forall a b c. Lens a b -> Lens b c -> Lens a c
#Default :-> Y
UiConfig.tempo forall f a. Lens f a -> a -> f -> f
#= Y
1 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.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config (Map Instrument Allocation)
UiConfig.allocations_map
        forall f a. Lens f a -> (a -> a) -> f -> f
%= 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 =
    forall {gen} {trans} {track} {val}.
ScopesT gen trans track val :-> gen
Derive.s_generatorforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {note} {control} {pitch}. Scope note control pitch :-> note
Derive.s_note
        forall f a. Lens f a -> (a -> a) -> f -> f
%= 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 = forall a. Monoid a => a
mempty
        { call_map :: Map Symbol (Generator Event)
Derive.call_map = 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
"" 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 =
    forall a. a -> Maybe a -> a
fromMaybe Key
Twelve.default_key forall a b. (a -> b) -> a -> b
$ 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 (Environ -> Maybe Key
lookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Environ
Derive.state_environ) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [a]
Map.elems (Performance -> TrackDynamic
Msg.perf_track_dynamic Performance
perf)
    where
    lookup :: Environ -> Maybe Key
lookup Environ
environ = case forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.key Environ
environ of
        Right Text
key -> forall a. a -> Maybe a
Just (Text -> Key
Pitch.Key Text
key)
        Left LookupError
_ -> 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 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 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 (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [Movement]
movements) [[Event]]
mvt_events),
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Msg]]
logs)
    where ([[Event]]
mvt_events, [[Msg]]
logs) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (Config -> [Event] -> ([Event], [Msg])
convert Config
config forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
Thread.start 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) = forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition 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 <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"ly_filename: no save dir"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe FilePath
Cmd.state_save_dir
    forall (m :: * -> *) a. Monad m => a -> m a
return 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) forall a. [a] -> [a] -> [a]
++ FilePath
".ly"
    where
    clean :: Text -> Text
clean = (Char -> Char) -> Text -> Text
Text.map Char -> Char
replace 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