content: -- 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
  
  -- | Calls that create code events for the lilypond backend.
  module Derive.C.Lily (library) where
  import qualified Util.Doc as Doc
  import qualified Derive.Args as Args
  import qualified Derive.Call as Call
  import qualified Derive.Call.Ly as Ly
  import qualified Derive.Call.Make as Make
  import qualified Derive.Call.Module as Module
  import qualified Derive.Call.Sub as Sub
  import qualified Derive.Call.Tags as Tags
  import qualified Derive.Derive as Derive
  import qualified Derive.DeriveT as DeriveT
  import qualified Derive.Eval as Eval
  import qualified Derive.Expr as Expr
  import qualified Derive.Library as Library
  import qualified Derive.Score as Score
  import qualified Derive.ShowVal as ShowVal
  import qualified Derive.Sig as Sig
  import qualified Derive.Typecheck as Typecheck
  
  import qualified Perform.Lilypond.Constants as Constants
  import qualified Perform.Lilypond.Process as Process
  import qualified Perform.Lilypond.Types as Types
  
  import           Global
  import           Types
  
  
  library :: Library.Library
  library = mconcat
      [ Library.both
          [ ("8va", c_8va)
          , ("clef", c_clef)
          , ("dyn", c_dyn)
          , ("ly-!", attach0 "ly-reminder-accidental"
              "Force this note to display an accidental."
              (Ly.SetEnviron Constants.v_append_pitch, "!"))
          , ("ly-?", attach0 "ly-cautionary-accidental"
              "Force this note to display a cautionary accidental."
              (Ly.SetEnviron Constants.v_append_pitch, "?"))
  
          , ("ly-(", attach0 "ly-begin-slur"
              "Separately mark a lilypond slur, when `(` isn't cutting it."
              (Ly.append Constants.First, "("))
          , ("ly-)", attach0 "ly-end-slur"
              "Separately mark a lilypond slur, when `(` isn't cutting it."
              (Ly.append Constants.Last, ")"))
          , ("ly-[", attach0 "ly-begin-beam"
              "Begin a beam. Override lilypond's automatic beaming."
              (Ly.append Constants.First, "["))
          , ("ly-]", attach0 "ly-end-beam"
              "End a beam. Override lilypond's automatic beaming."
              (Ly.append Constants.First, "]"))
              -- Constants.First because it's unlikely the beam should go over
              -- a barline.
          , ("ly-<", c_hairpin "\\<")
          , ("ly->", c_hairpin "\\>")
          , ("ly-<>", emit0 "ly-crescendo-diminuendo"
              "Crescendo followed by diminuendo, on one note."
              (Ly.Position Constants.FreeAppend, "\\espressivo"))
          , ("ly-^~", c_tie_direction "^")
          , ("ly-_~", c_tie_direction "_")
          , ("ly-key", c_ly_key)
          , ("ly-post", c_ly_post)
          , ("ly-attach", c_ly_attach)
          , ("ly-emit", c_ly_emit)
          , ("ly-pre", c_ly_pre)
          , ("ly-span", c_ly_span)
          , ("ly-sus", c_ly_sustain)
          , ("ly-tr~", c_ly_tr_span)
          , ("ly^", c_ly_text "^")
          , ("ly_", c_ly_text "_")
          , ("ly-", c_ly_articulation)
          , ("tempo", c_tempo)
          , ("meter", c_meter)
          , ("subdivision", c_subdivision)
          , ("movement", c_movement)
          , ("xstaff", c_xstaff)
          , ("xstaff-a", c_xstaff_around)
          ]
      , Library.generators
          [ ("if-ly", c_if_ly)
          ]
      , Library.transformers
          [ ("ly-global", c_ly_global)
          , ("ly-track", c_ly_track)
          , ("not-ly-track", c_not_ly_track)
          , ("unless-ly", c_unless_ly)
          , ("when-ly", c_when_ly)
          ]
      ]
  
  c_when_ly :: Derive.Transformer Derive.Note
  c_when_ly = transformer "when-ly"
      "With no arguments, evaluate the deriver only when in lilypond mode.\
      \ Unlike `ly-track`, this doesn't evaluate subtracks, so you can use it to\
      \ emit an entirely different set of tracks.\n\
      \ With arguments, evaluate them as a transformer and apply it only\
      \ when in lilypond mode.  Otherwise, the deriver is unchanged."
      $ Sig.callt (Sig.many_vals "arg" "Call expression.") (when_ly False)
  
  c_unless_ly :: Derive.Transformer Derive.Note
  c_unless_ly = transformer "unless-ly"
      "The inverse of when-ly, evaluate the deriver or apply the args only when\
      \ not in lilypond mode."
      $ Sig.callt (Sig.many_vals "arg" "Call expression.") (when_ly True)
  
  when_ly :: Bool -> [DeriveT.Val] -> Derive.PassedArgs Score.Event
      -> Derive.NoteDeriver -> Derive.NoteDeriver
  when_ly inverted vals args deriver = case vals of
      [] -> when_lily deriver mempty
      call : vals -> when_lily (apply args (to_sym call) vals deriver) deriver
      where
      to_sym = Expr.Symbol . DeriveT.show_call_val
      when_lily = if inverted then flip Ly.when_lilypond else Ly.when_lilypond
      apply args sym vals deriver = do
          call <- Eval.get_transformer sym
          Eval.apply_transformer (Derive.passed_ctx args) call vals deriver
  
  c_ly_global :: Derive.Transformer Derive.Note
  c_ly_global = transformer "ly-global"
      ("Evaluate the deriver only when in lilypond mode, like `when-ly`, but\
      \ also set the " <> ShowVal.doc Constants.ly_global <> " instrument."
      ) $ Sig.call0t $ \_ deriver ->
          Ly.when_lilypond (Ly.global deriver) mempty
  
  c_ly_track :: Derive.Transformer Derive.Note
  c_ly_track = transformer "ly-track"
      "Evaluate the deriver only when in lilypond mode, otherwise ignore this\
      \ track but evaluate its subtracks. Apply this to a track\
      \ to omit lilypond-only articulations, or to apply different articulations\
      \ to lilypond and non-lilypond output. Only use it in the track title!"
      $ Sig.call0t $ \args deriver ->
          Ly.when_lilypond deriver $ Sub.derive_subs args
  
  c_not_ly_track :: Derive.Transformer Derive.Note
  c_not_ly_track = transformer "not-ly-track"
      "The inverse of `ly-track`, evaluate the track only when not in lilypond\
      \ mode. Only use it in the track title!"
      $ Sig.call0t $ \args deriver -> flip Ly.when_lilypond deriver $
          Sub.derive_subs args
  
  c_if_ly :: Derive.Generator Derive.Note
  c_if_ly = generator "if-ly"
      "Conditional for lilypond." $ Sig.call ((,)
      <$> Sig.required "is-ly" "Evaluated in lilypond mode."
      <*> Sig.required "not-ly" "Evaluated when not in lilypond mode."
      ) $ \(is_ly, not_ly) args -> Ly.when_lilypond
          (Eval.eval_quoted (Args.context args) is_ly)
          (Eval.eval_quoted (Args.context args) not_ly)
  
  c_8va :: Library.Calls Derive.Note
  c_8va = emit_pair "ottava" "Emit lilypond ottava mark.\
      \ If it has duration, end with `8va 0`."
      (Sig.defaulted "octave" (0 :: Double)
          "Transpose this many octaves up or down."
      ) $
      \oct -> (ottava oct, ottava 0)
      where
      ottava n =
          (Ly.Position Constants.FreePrepend, "\\ottava #" <> showt (n :: Int))
  
  c_xstaff :: Library.Calls Derive.Note
  c_xstaff = emit_start "xstaff"
      "Emit lilypond to put the notes on a different staff."
      (Sig.required "staff" "Switch to this staff.") $ \staff ->
          return (Ly.Position Constants.FreePrepend, change staff)
      where change staff = "\\change Staff = " <> lily_str (to_lily staff)
  
  c_xstaff_around :: Library.Calls Derive.Note
  c_xstaff_around = attach_wrap_notes "xstaff-around"
      "Emit lilypond to put the notes on a different staff."
      (Sig.required "staff" "Switch to this staff.") $ \staff -> return
          (change staff, change (other staff))
      where
      change staff = "\\change Staff = " <> lily_str (to_lily staff)
      other Call.Up = Call.Down
      other Call.Down = Call.Up
  
  to_lily :: Call.UpDown -> Text
  to_lily Call.Up = "up"
  to_lily Call.Down = "down"
  
  c_dyn :: Library.Calls Derive.Note
  c_dyn = emit_start "dyn"
      "Emit a lilypond dynamic. If there are notes below, they are derived\
      \ unchanged."
      (Sig.required "dynamic" "Should be `p`, `ff`, etc.")
      (return . (Ly.Position Constants.FreeAppend,) . ("\\"<>))
  
  c_clef :: Library.Calls Derive.Note
  c_clef = emit_start "clef" "Emit lilypond clef change."
      (Sig.required "clef" "Should be `bass`, `treble`, etc.")
      (return . (Ly.Position Constants.FreePrepend,) . ("\\clef "<>))
  
  c_tempo :: Library.Calls Derive.Note
  c_tempo = emit_start "tempo" "Emit tempo marking."
      (Sig.required "text" "4 = 120, etc.")
      (return . (Ly.Position Constants.FreePrepend,) . ("\\tempo "<>))
  
  c_meter :: Library.Calls Derive.Note
  c_meter = emit_global "meter"
      "Emit lilypond meter change. It will be interpreted as global no matter\
      \ where it is. Simultaneous different meters aren't supported yet, but\
      \ `subdivision` supports simultaneous different spellings."
      (Sig.required "meter" "Should be `4/4`, `6/8`, etc. An ambiguous meter like\
          \ `6/8` will default to 3+3, but you can explicitly set the\
          \ subdivision, e.g. `2+2+2/8`.") $
      \meter -> return (Ly.SetEnviron Constants.v_meter, meter)
  
  c_subdivision :: Library.Calls Derive.Note
  c_subdivision = emit_pair "subdivision"
      "Emit a subdivision change. This is the same format as `meter`, but it\
      \ affects the subdivision for this instrument only, instead of setting\
      \ the global meter. This is useful when instruments are playing\
      \ cross-rhythms and should beam accordingly."
      (fromMaybe "" <$> Sig.required "meter" "Same as `meter` call.") $
      \meter ->
          ( (Ly.SetEnviron Constants.v_subdivision, meter)
          , (Ly.SetEnviron Constants.v_subdivision, "")
          )
  
  c_movement :: Library.Calls Derive.Note
  c_movement = emit_global "movement"
      "Start a new movement with the given title."
      (Sig.required "title" "Title of this movement.") $
      \title -> return (Ly.SetEnviron Constants.v_movement, title)
  
  c_tie_direction :: Ly.Ly -> Library.Calls Derive.Note
  c_tie_direction code = attach0 "ly-tie-direction"
      "Force the note's tie to go either up or down."
      (Ly.SetEnviron Constants.v_tie_direction, code)
  
  c_hairpin :: Ly.Ly -> Library.Calls Derive.Note
  c_hairpin code = emit_pair "ly-hairpin"
      "Start a crescendo or diminuendo hairpin.  If it has non-zero duration,\
      \ stop at the event's end, otherwise it will stop at the\
      \ next hairpin or dynamic marking." Sig.no_args $
      \() ->
          ( (Ly.Position Constants.FreeAppend, code)
          , (Ly.Position Constants.FreeAppend, "\\!")
          )
  
  c_ly_text :: Ly.Ly -> Library.Calls Derive.Note
  c_ly_text dir = attach First "ly-text" "Attach text above or below the note."
      (Sig.required "text" "Text to attach.") $
      (Ly.append Constants.First,) . (dir<>) . lily_str
  
  c_ly_articulation :: Library.Calls Derive.Note
  c_ly_articulation = attach All "ly-articulation"
      "Append a `-articulation` to notes."
      (Sig.required "text" "Code to attach. A `-` is prepended.") $
      ((Ly.append Constants.First,) . ("-"<>))
  
  c_ly_pre :: Library.Calls Derive.Note
  c_ly_pre = emit_start "ly-pre"
      "Emit arbitrary lilypond code that will go before concurrent notes."
      (Sig.required "code" "A leading \\ will be prepended.") $
      \code -> return (Ly.Position Constants.FreePrepend, "\\" <> code)
  
  c_ly_post :: Library.Calls Derive.Note
  c_ly_post = emit_start "ly-post"
      "Emit arbitrary lilypond code that will go after concurrent notes."
      (Sig.required "code" "A leading \\ will be prepended.") $
      \code -> return (Ly.Position Constants.FreeAppend, "\\" <> code)
  
  c_ly_emit :: Library.Calls Derive.Note
  c_ly_emit = emit_start "ly-emit"
      "Emit a single fragment of freestanding lilypond code."
      ((,)
      <$> Sig.required "code" "Emit this code."
      <*> Sig.defaulted "pos" Constants.FreeAppend
          "Where to put it: 'Derive.Call.Ly.CodePosition'."
      ) $ \(code, pos) -> return (Ly.Position pos, code)
  
  c_ly_attach :: Library.Calls Derive.Note
  c_ly_attach = attach All "ly-attach"
      "Attach lilypond code to each transformed note."
      ((,)
      <$> Sig.required "code" "Attach this code."
      <*> Sig.defaulted "pos" (Ly.append Constants.Last)
          "Where to put it: 'Derive.Call.Ly.CodePosition'."
      ) $ \(code, pos) -> (pos, code)
  
  c_ly_key :: Library.Calls Derive.Note
  c_ly_key = emit_start "ly-key"
      "Emit a key change. This only emits a lilypond key change, it doesn't\
      \ actually set the key. This means diatonic operations won't work as\
      \ expected. Also, you have to add it to every staff manually.\
      \ On the up side, it doesn't force a structural change like `=` does."
      (Sig.required "key" "You can use any of the keys from the Twelve scale.") $
      \key -> do
          key <- Derive.require_right id $ Process.parse_key key
          return (Ly.Position Constants.FreePrepend, Types.to_lily key)
  
  c_ly_sustain :: Library.Calls Derive.Note
  c_ly_sustain = emit_start "ly-sus" "Emit \\sustainOn and \\sustainOff markup."
      (Sig.required "state" "t for \\sustainOn, f for \\sustainOff,\
          \ ft for \\sustainOff\\sustainOn.") $
      \mode -> return $ case mode of
          Off -> (Ly.Position Constants.FreePrepend, "\\sustainOff")
          On -> (Ly.Position Constants.FreePrepend, "\\sustainOn")
          OffOn -> (Ly.Position Constants.FreePrepend, "\\sustainOff\\sustainOn")
  
  c_ly_tr_span :: Library.Calls Derive.Note
  c_ly_tr_span = emit_pair "ly-tr-span"
      "Emit a \\startTrillSpan - \\stopTrillSpan pair."
      Sig.no_args $ \() ->
          ( (Ly.Position Constants.FreePrepend, "\\startTrillSpan")
          , (Ly.Position Constants.FreeAppend, "\\stopTrillSpan")
          )
  
  data SustainMode = Off | On | OffOn deriving (Bounded, Eq, Enum, Show)
  instance ShowVal.ShowVal SustainMode where
      show_val m = case m of
          Off -> "f"
          On -> "t"
          OffOn -> "ft"
  instance Typecheck.Typecheck SustainMode
  
  c_ly_span :: Library.Calls Derive.Note
  c_ly_span = emit "ly-span"
      "Emit a bit of text followed by a dashed line until the end of the event.\
      \ This is useful for things like `accel.` or `cresc.` If it has a\
      \ a zero duration, emit the start if the text is given, or the end if it's\
      \ not."
      (Sig.required "text" "Text.") ly_span
  
  -- TODO maybe this should use attach, so it can go on a single note and
  -- automatically extend to the end.
  ly_span :: Maybe Ly.Ly -> (ScoreTime, ScoreTime)
      -> Derive.Deriver [(ScoreTime, Ly.FreeCode)]
  ly_span maybe_text (start, end)
      | start == end = return $ case maybe_text of
          Just text -> start_code text
          Nothing -> end_code
      | otherwise = case maybe_text of
          Just text -> return $ start_code text ++ end_code
          Nothing -> Derive.throw "use zero dur to end a span"
      where
      start_code text =
          [ (start,) $ (Ly.Position Constants.FreePrepend,) $
              -- Lilypond likes to put it above, but for tempo and dynamic marks
              -- I think they should go below.
              "\\textSpannerDown\
              \ \\override TextSpanner.bound-details.left.text = \\markup { "
              <> Types.to_lily text <> " }"
          , (start, (Ly.Position Constants.FreeAppend, "\\startTextSpan"))
          ]
      end_code = [(end, (Ly.Position Constants.FreeAppend, "\\stopTextSpan"))]
  
  
  -- * Attach
  
  data AttachTo = First -- ^ attach code to only the first event
      | All -- ^ attach code to all the events
      deriving (Eq, Show)
  
  -- | The attach family attaches lilypond code to existing notes.  This is
  -- suitable for code which applies directly to a single note.
  attach :: AttachTo -> Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> Ly.Code) -> Library.Calls Derive.Note
  attach to name doc sig get_code =
      transform_notes name doc sig $ \arg deriver -> add (get_code arg) deriver
      where
      add = case to of
          First -> Ly.add_first
          All -> Ly.add_all
  
  -- | 'attach' with no arguments.
  attach0 :: Derive.CallName -> Doc.Doc -> Ly.Code -> Library.Calls Derive.Note
  attach0 name doc code =
      attach All name (doc <> "\nLilypond code: " <> Doc.Doc (pretty code))
          Sig.no_args (const code)
  
  transform_notes :: Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> Derive.NoteDeriver -> Derive.NoteDeriver)
      -> Library.Calls Derive.Note
  transform_notes name doc sig transform =
      Make.transform_notes Module.ly name Tags.ly doc sig $
          \arg deriver -> Ly.when_lilypond (transform arg deriver) deriver
  
  -- * Emit
  
  -- | The emit family creates 0 dur events that just carry lilypond code, and
  -- are not real notes.  This is suitable for score level directives, such as
  -- dynamics or tempo markings.  Technically in lilypond those are attached to
  -- notes too, but you wouldn't want to put one on every single note in
  -- a section.
  emit :: Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> (ScoreTime, ScoreTime)
      -> Derive.Deriver [(ScoreTime, Ly.FreeCode)])
      -> Library.Calls Derive.Note
  emit = emit_transform id False
  
  emit_start :: Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> Derive.Deriver Ly.FreeCode) -> Library.Calls Derive.Note
  emit_start name doc sig get_code = emit_transform id True name doc sig $
      \val (start, _) -> (:[]) . (start,) <$> get_code val
  
  -- | Like 'emit_start', but also set the instrument to 'Constants.ly_global'.
  emit_global :: Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> Derive.Deriver Ly.FreeCode) -> Library.Calls Derive.Note
  emit_global name doc sig get_code = emit_transform Ly.global True name doc sig $
      \val (start, _) -> (:[]) . (start,) <$> get_code val
  
  emit_transform :: (Derive.NoteDeriver -> Derive.NoteDeriver)
      -> Bool -- ^ if True, require that the generator have 0 duration
      -> Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> (ScoreTime, ScoreTime)
          -> Derive.Deriver [(ScoreTime, Ly.FreeCode)])
      -> Library.Calls Derive.Note
  emit_transform transform assert_0dur name doc_ sig get_events =
      Library.Calls gen trans
      where
      gen = generator name doc $ Sig.call sig $ \val args -> Ly.only_lilypond $ do
          Sub.assert_no_subs args
          when (assert_0dur && Args.duration args /= 0) $
              Derive.throw $ "this emits a single bit of lilypond code,\
                  \ so it should be either a transformer or a 0 dur generator: "
                  <> pretty (Args.range args)
          make val args
      trans = transformer name doc $ Sig.callt sig $ \val args deriver ->
          Ly.when_lilypond (make val args <> deriver) deriver
      make val args = transform $ mconcatMap (uncurry Ly.code0)
          =<< get_events val (Args.range args)
      doc = doc_ <> "\n" <> emit_doc
  
  emit0 :: Derive.CallName -> Doc.Doc -> Ly.FreeCode -> Library.Calls Derive.Note
  emit0 name doc code =
      emit name (doc <> "\nLilypond code: " <> Doc.Doc (pretty code))
      Sig.no_args $ \() (start, _) -> return [(start, code)]
  
  -- | Like 'emit_start', except that the call can emit 2 Codes.  The second
  -- will be used at the end of the event if it has non-zero duration.
  emit_pair :: Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> (Ly.FreeCode, Ly.FreeCode)) -> Library.Calls Derive.Note
  emit_pair name doc sig get_code = emit name doc sig (\val -> return . get val)
      where
      get val (start, end)
          | start == end = [(start, pre)]
          | otherwise = [(start, pre), (end, post)]
          where (pre, post) = get_code val
  
  -- | Wrap each individual note event in code.
  attach_wrap_notes :: Derive.CallName -> Doc.Doc -> Sig.Parser a
      -> (a -> Derive.Deriver (Ly.Ly, Ly.Ly)) -> Library.Calls Derive.Note
  attach_wrap_notes name doc sig get_code = Library.Calls gen trans
      where
      around_doc = emit_doc
          <> " The transformer will wrap each event in (start, end) pairs.\
          \ This way you can wrap all notes on a certain track with\
          \ complementary bits of lilypond code."
      gen = generator name (doc <> around_doc) $
          Sig.call sig $ \val args -> Ly.only_lilypond $
              transform val $ Sub.derive_subs args
      trans = transformer name (doc <> around_doc) $
          Sig.callt sig $ \val _args deriver ->
              Ly.when_lilypond (transform val deriver) deriver
      transform val deriver = do
          (pre, post) <- get_code val
          Ly.add_all (Ly.prepend, pre) $
              Ly.add_all (Ly.append Constants.Last, post) deriver
  
  emit_doc :: Doc.Doc
  emit_doc = "\nThis either be placed in a separate track as a zero-dur\
      \ event, or it can be attached to an individual note as a transformer."
  
  -- * util
  
  lily_str :: Text -> Ly.Ly
  lily_str = Types.to_lily
  
  generator :: Derive.CallName -> Doc.Doc
      -> Derive.WithArgDoc (Derive.GeneratorF d) -> Derive.Generator d
  generator name = Derive.generator Module.ly name Tags.ly
  
  transformer :: Derive.CallName -> Doc.Doc
      -> Derive.WithArgDoc (Derive.TransformerF d) -> Derive.Transformer d
  transformer name = Derive.transformer Module.ly name Tags.ly
  