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

module Perform.Lilypond.Constants where
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Derive.Env as Env
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Typecheck as Typecheck

import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT

import           Global
import           Types


-- * ly-global instrument

-- | This is a pseudo-instrument used to mark notes which are actually global
-- lilypond directives.  E.g., meter changes, page breaks, movement titles.
ly_global :: ScoreT.Instrument
ly_global :: Instrument
ly_global = Text -> Instrument
ScoreT.Instrument Text
"ly-global"

ly_qualified :: InstT.Qualified
ly_qualified :: Qualified
ly_qualified = Text -> Text -> Qualified
InstT.Qualified Text
"ly" Text
"global"

ly_synth :: code -> Inst.SynthDecl code
ly_synth :: forall code. code -> SynthDecl code
ly_synth code
code = forall code. Text -> Text -> [(Text, Inst code)] -> SynthDecl code
Inst.SynthDecl Text
"ly" Text
"Fake synth for fake lilypond instrument."
    [ (Text
"global"
      , forall code. Backend -> Common code -> Inst code
Inst.Inst (Text -> Backend
Inst.Dummy Text
dummy_doc)
        (forall {code}. Common code :-> Doc
Common.doc forall f a. Lens f a -> a -> f -> f
#= Doc
doc forall a b. (a -> b) -> a -> b
$ forall code. code -> Common code
Common.common code
code)
      )
    ]
    where
    dummy_doc :: Text
dummy_doc = Text
"fake instrument for lilypond directives"
    doc :: Doc
doc = Doc
"The lilypond deriver will automatically allocate `>ly-global`, and\
        \ instruments with global lilypond directives will get this instrument."

-- * code fragments

-- | A free-standing code fragment is merged in with its nearest
data FreeCodePosition = FreePrepend | FreeAppend
    deriving (FreeCodePosition -> FreeCodePosition -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FreeCodePosition -> FreeCodePosition -> Bool
$c/= :: FreeCodePosition -> FreeCodePosition -> Bool
== :: FreeCodePosition -> FreeCodePosition -> Bool
$c== :: FreeCodePosition -> FreeCodePosition -> Bool
Eq, Eq FreeCodePosition
FreeCodePosition -> FreeCodePosition -> Bool
FreeCodePosition -> FreeCodePosition -> Ordering
FreeCodePosition -> FreeCodePosition -> FreeCodePosition
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FreeCodePosition -> FreeCodePosition -> FreeCodePosition
$cmin :: FreeCodePosition -> FreeCodePosition -> FreeCodePosition
max :: FreeCodePosition -> FreeCodePosition -> FreeCodePosition
$cmax :: FreeCodePosition -> FreeCodePosition -> FreeCodePosition
>= :: FreeCodePosition -> FreeCodePosition -> Bool
$c>= :: FreeCodePosition -> FreeCodePosition -> Bool
> :: FreeCodePosition -> FreeCodePosition -> Bool
$c> :: FreeCodePosition -> FreeCodePosition -> Bool
<= :: FreeCodePosition -> FreeCodePosition -> Bool
$c<= :: FreeCodePosition -> FreeCodePosition -> Bool
< :: FreeCodePosition -> FreeCodePosition -> Bool
$c< :: FreeCodePosition -> FreeCodePosition -> Bool
compare :: FreeCodePosition -> FreeCodePosition -> Ordering
$ccompare :: FreeCodePosition -> FreeCodePosition -> Ordering
Ord, Int -> FreeCodePosition -> ShowS
[FreeCodePosition] -> ShowS
FreeCodePosition -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FreeCodePosition] -> ShowS
$cshowList :: [FreeCodePosition] -> ShowS
show :: FreeCodePosition -> String
$cshow :: FreeCodePosition -> String
showsPrec :: Int -> FreeCodePosition -> ShowS
$cshowsPrec :: Int -> FreeCodePosition -> ShowS
Show, Int -> FreeCodePosition
FreeCodePosition -> Int
FreeCodePosition -> [FreeCodePosition]
FreeCodePosition -> FreeCodePosition
FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
FreeCodePosition
-> FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: FreeCodePosition
-> FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
$cenumFromThenTo :: FreeCodePosition
-> FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
enumFromTo :: FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
$cenumFromTo :: FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
enumFromThen :: FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
$cenumFromThen :: FreeCodePosition -> FreeCodePosition -> [FreeCodePosition]
enumFrom :: FreeCodePosition -> [FreeCodePosition]
$cenumFrom :: FreeCodePosition -> [FreeCodePosition]
fromEnum :: FreeCodePosition -> Int
$cfromEnum :: FreeCodePosition -> Int
toEnum :: Int -> FreeCodePosition
$ctoEnum :: Int -> FreeCodePosition
pred :: FreeCodePosition -> FreeCodePosition
$cpred :: FreeCodePosition -> FreeCodePosition
succ :: FreeCodePosition -> FreeCodePosition
$csucc :: FreeCodePosition -> FreeCodePosition
Enum, FreeCodePosition
forall a. a -> a -> Bounded a
maxBound :: FreeCodePosition
$cmaxBound :: FreeCodePosition
minBound :: FreeCodePosition
$cminBound :: FreeCodePosition
Bounded)

instance Typecheck.Typecheck FreeCodePosition
instance Typecheck.ToVal FreeCodePosition

instance ShowVal.ShowVal FreeCodePosition where
    show_val :: FreeCodePosition -> Text
show_val FreeCodePosition
FreePrepend = Text
"prepend"
    show_val FreeCodePosition
FreeAppend = Text
"append"

-- | A code fragment that has to be attached to notes.
data CodePosition = CodePosition Attach Position Distribution
    deriving (CodePosition -> CodePosition -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodePosition -> CodePosition -> Bool
$c/= :: CodePosition -> CodePosition -> Bool
== :: CodePosition -> CodePosition -> Bool
$c== :: CodePosition -> CodePosition -> Bool
Eq, Eq CodePosition
CodePosition -> CodePosition -> Bool
CodePosition -> CodePosition -> Ordering
CodePosition -> CodePosition -> CodePosition
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CodePosition -> CodePosition -> CodePosition
$cmin :: CodePosition -> CodePosition -> CodePosition
max :: CodePosition -> CodePosition -> CodePosition
$cmax :: CodePosition -> CodePosition -> CodePosition
>= :: CodePosition -> CodePosition -> Bool
$c>= :: CodePosition -> CodePosition -> Bool
> :: CodePosition -> CodePosition -> Bool
$c> :: CodePosition -> CodePosition -> Bool
<= :: CodePosition -> CodePosition -> Bool
$c<= :: CodePosition -> CodePosition -> Bool
< :: CodePosition -> CodePosition -> Bool
$c< :: CodePosition -> CodePosition -> Bool
compare :: CodePosition -> CodePosition -> Ordering
$ccompare :: CodePosition -> CodePosition -> Ordering
Ord, Int -> CodePosition -> ShowS
[CodePosition] -> ShowS
CodePosition -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodePosition] -> ShowS
$cshowList :: [CodePosition] -> ShowS
show :: CodePosition -> String
$cshow :: CodePosition -> String
showsPrec :: Int -> CodePosition -> ShowS
$cshowsPrec :: Int -> CodePosition -> ShowS
Show)

-- | Chord goes before or after the whole chord, Note goes before or after the
-- individual pitch within the chord.
data Attach = Chord | Note
    deriving (Attach -> Attach -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attach -> Attach -> Bool
$c/= :: Attach -> Attach -> Bool
== :: Attach -> Attach -> Bool
$c== :: Attach -> Attach -> Bool
Eq, Eq Attach
Attach -> Attach -> Bool
Attach -> Attach -> Ordering
Attach -> Attach -> Attach
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Attach -> Attach -> Attach
$cmin :: Attach -> Attach -> Attach
max :: Attach -> Attach -> Attach
$cmax :: Attach -> Attach -> Attach
>= :: Attach -> Attach -> Bool
$c>= :: Attach -> Attach -> Bool
> :: Attach -> Attach -> Bool
$c> :: Attach -> Attach -> Bool
<= :: Attach -> Attach -> Bool
$c<= :: Attach -> Attach -> Bool
< :: Attach -> Attach -> Bool
$c< :: Attach -> Attach -> Bool
compare :: Attach -> Attach -> Ordering
$ccompare :: Attach -> Attach -> Ordering
Ord, Int -> Attach -> ShowS
[Attach] -> ShowS
Attach -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attach] -> ShowS
$cshowList :: [Attach] -> ShowS
show :: Attach -> String
$cshow :: Attach -> String
showsPrec :: Int -> Attach -> ShowS
$cshowsPrec :: Int -> Attach -> ShowS
Show)

data Position = Prepend | Append
    deriving (Position -> Position -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Eq Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmax :: Position -> Position -> Position
>= :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c< :: Position -> Position -> Bool
compare :: Position -> Position -> Ordering
$ccompare :: Position -> Position -> Ordering
Ord, Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show)

all_positions :: [CodePosition]
all_positions :: [CodePosition]
all_positions =
    [ Attach -> Position -> Distribution -> CodePosition
CodePosition Attach
a Position
p Distribution
d
    | Attach
a <- [Attach
Chord, Attach
Note], Position
p <- [Position
Prepend, Position
Append], Distribution
d <- [Distribution
First, Distribution
Last, Distribution
All]
    ]

-- | If the note is split into multiple tied notes, which ones should get the
-- code?
data Distribution = First | Last | All
    deriving (Distribution -> Distribution -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Distribution -> Distribution -> Bool
$c/= :: Distribution -> Distribution -> Bool
== :: Distribution -> Distribution -> Bool
$c== :: Distribution -> Distribution -> Bool
Eq, Eq Distribution
Distribution -> Distribution -> Bool
Distribution -> Distribution -> Ordering
Distribution -> Distribution -> Distribution
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Distribution -> Distribution -> Distribution
$cmin :: Distribution -> Distribution -> Distribution
max :: Distribution -> Distribution -> Distribution
$cmax :: Distribution -> Distribution -> Distribution
>= :: Distribution -> Distribution -> Bool
$c>= :: Distribution -> Distribution -> Bool
> :: Distribution -> Distribution -> Bool
$c> :: Distribution -> Distribution -> Bool
<= :: Distribution -> Distribution -> Bool
$c<= :: Distribution -> Distribution -> Bool
< :: Distribution -> Distribution -> Bool
$c< :: Distribution -> Distribution -> Bool
compare :: Distribution -> Distribution -> Ordering
$ccompare :: Distribution -> Distribution -> Ordering
Ord, Int -> Distribution -> ShowS
[Distribution] -> ShowS
Distribution -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Distribution] -> ShowS
$cshowList :: [Distribution] -> ShowS
show :: Distribution -> String
$cshow :: Distribution -> String
showsPrec :: Int -> Distribution -> ShowS
$cshowsPrec :: Int -> Distribution -> ShowS
Show)

instance Pretty FreeCodePosition where pretty :: FreeCodePosition -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty CodePosition where pretty :: CodePosition -> Text
pretty = forall a. Show a => a -> Text
showt

position_key :: CodePosition -> Env.Key
position_key :: CodePosition -> Text
position_key (CodePosition Attach
attach Position
pos Distribution
distribution) =
    Text -> [Text] -> Text
Text.intercalate Text
"-" forall a b. (a -> b) -> a -> b
$ Text
"ly" forall a. a -> [a] -> [a]
:
        [ case Attach
attach of
            Attach
Chord -> Text
"chord"
            Attach
Note -> Text
"note"
        , case Position
pos of
            Position
Prepend -> Text
"prepend"
            Position
Append -> Text
"append"
        , case Distribution
distribution of
            Distribution
First -> Text
"first"
            Distribution
Last -> Text
"last"
            Distribution
All -> Text
"all"
        ]

key_position :: Env.Key -> Maybe CodePosition
key_position :: Text -> Maybe CodePosition
key_position Text
k = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k Map Text CodePosition
m
    where m :: Map Text CodePosition
m = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn CodePosition -> Text
position_key [CodePosition]
all_positions

environ_code :: Env.Environ -> [(CodePosition, Text)]
environ_code :: Environ -> [(CodePosition, Text)]
environ_code Environ
env =
    [ (CodePosition
code, Text
val)
    | (Just CodePosition
code, Just Text
val)
        <- forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Maybe CodePosition
key_position forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple) (Environ -> [(Text, Val)]
Env.to_list Environ
env)
    ]

with_code :: CodePosition -> Text -> Env.Environ -> Env.Environ
with_code :: CodePosition -> Text -> Environ -> Environ
with_code CodePosition
pos Text
code Environ
env = forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key (Text
old forall a. Semigroup a => a -> a -> a
<> Text
code) Environ
env
    where
    old :: Text
old = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
key Environ
env
    key :: Text
key = CodePosition -> Text
position_key CodePosition
pos

free_code_key :: FreeCodePosition -> Env.Key
free_code_key :: FreeCodePosition -> Text
free_code_key FreeCodePosition
FreePrepend = Text
"ly-prepend"
free_code_key FreeCodePosition
FreeAppend = Text
"ly-append"

key_free_code :: Env.Key -> Maybe FreeCodePosition
key_free_code :: Text -> Maybe FreeCodePosition
key_free_code Text
"ly-prepend" = forall a. a -> Maybe a
Just FreeCodePosition
FreePrepend
key_free_code Text
"ly-append" = forall a. a -> Maybe a
Just FreeCodePosition
FreeAppend
key_free_code Text
_ = forall a. Maybe a
Nothing

environ_free_code :: Env.Environ -> [(FreeCodePosition, Text)]
environ_free_code :: Environ -> [(FreeCodePosition, Text)]
environ_free_code Environ
env =
    [ (FreeCodePosition
code, Text
val)
    | (Just FreeCodePosition
code, Just Text
val)
        <- forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Maybe FreeCodePosition
key_free_code forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple) (Environ -> [(Text, Val)]
Env.to_list Environ
env)
    ]

with_free_code :: FreeCodePosition -> Text -> Env.Environ -> Env.Environ
with_free_code :: FreeCodePosition -> Text -> Environ -> Environ
with_free_code FreeCodePosition
pos Text
code = forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val (FreeCodePosition -> Text
free_code_key FreeCodePosition
pos) Text
code

-- ** other env keys

-- | String: append after the pitch, and before the duration.  This is for
-- pitch modifiers like reminder accidentals (!) and cautionary accidentals
-- (?).  TODO this isn't integrated with 'CodePosition', but maybe could be.
-- Would Prepend make any sense?
v_append_pitch :: Env.Key
v_append_pitch :: Text
v_append_pitch = Text
"ly-append-pitch"

-- | String: \"^\" or \"_\", manually sets tie direction, if this note is
-- tied.
v_tie_direction :: Env.Key
v_tie_direction :: Text
v_tie_direction = Text
"ly-tie-direction"

-- * tuplet

-- | Set the env vars that signals that the lilypond converter should make
-- the following notes into a tuplet.
set_tuplet :: RealTime -- ^ score_dur is the visible duration in the score
    -> RealTime -- ^ real_dur is the duration it actually consumes, so
    -- 3 quarters into 1 whole will be 3/4.
    -> Env.Environ
set_tuplet :: RealTime -> RealTime -> Environ
set_tuplet RealTime
score_dur RealTime
real_dur = [(Text, Val)] -> Environ
Env.from_list
    [ (Text
"ly-tuplet-score-dur", forall a. ToVal a => a -> Val
Typecheck.to_val RealTime
score_dur)
    , (Text
"ly-tuplet-real-dur", forall a. ToVal a => a -> Val
Typecheck.to_val RealTime
real_dur)
    ]

get_tuplet :: Env.Environ -> Maybe (RealTime, RealTime)
get_tuplet :: Environ -> Maybe (RealTime, RealTime)
get_tuplet Environ
env = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Typecheck a => Text -> Maybe a
get Text
"ly-tuplet-score-dur" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. Typecheck a => Text -> Maybe a
get Text
"ly-tuplet-real-dur"
    where get :: Text -> Maybe a
get Text
k = forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
k Environ
env

-- * tremolo

-- | This marks a tremolo event, which triggers special treatment for
-- coincident notes.
v_tremolo :: Env.Key
v_tremolo :: Text
v_tremolo = Text
"ly-tremolo"

-- * ly-global

-- | String: should be parseable by 'Meter.parse_meter',
-- e.g. @\'3/4\'@.  Used only on @>ly-global@ events.
v_meter :: Env.Key
v_meter :: Text
v_meter = Text
"ly-meter"

-- | String: this has the same format as 'v_meter', but it affects the rhythmic
-- spelling for the instrument.
v_subdivision :: Env.Key
v_subdivision :: Text
v_subdivision = Text
"ly-subdivision"

-- | String: Gives the title of a new movement.  An event with 'ly_global'
-- instrument and this env val will cause a movement break.
v_movement :: Env.Key
v_movement :: Text
v_movement = Text
"ly-movement"

-- * common code

-- | Emit Ped___^___/ style pedal markings.
mixed_pedal_style :: Text
mixed_pedal_style :: Text
mixed_pedal_style = Text
"\\set Staff.pedalSustainStyle = #'mixed"