lily/context-property.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2004--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
   5
   6   LilyPond is free software: you can redistribute it and/or modify
   7   it under the terms of the GNU General Public License as published by
   8   the Free Software Foundation, either version 3 of the License, or
   9   (at your option) any later version.
  10
  11   LilyPond is distributed in the hope that it will be useful,
  12   but WITHOUT ANY WARRANTY; without even the implied warranty of
  13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14   GNU General Public License for more details.
  15
  16   You should have received a copy of the GNU General Public License
  17   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18 */
  19
  20 #include "context.hh"
  21 #include "engraver.hh"
  22 #include "global-context.hh"
  23 #include "grob-properties.hh"
  24 #include "international.hh"
  25 #include "item.hh"
  26 #include "main.hh"
  27 #include "simple-closure.hh"
  28 #include "smobs.hh"
  29 #include "spanner.hh"
  30 #include "unpure-pure-container.hh"
  31 #include "warn.hh"
  32
  33 /*
  34   like execute_general_pushpop_property(), but typecheck
  35   grob_property_path and context_property.
  36 */
  37 void
  38 general_pushpop_property (Context *context,
  39                           SCM context_property,
  40                           SCM grob_property_path,
  41                           SCM new_value)
  42 {
  43   if (!scm_is_symbol (context_property)
  44       || !scm_is_symbol (scm_car (grob_property_path)))
  45     {
  46       warning (_ ("need symbol arguments for \\override and \\revert"));
  47       if (do_internal_type_checking_global)
  48         assert (false);
  49     }
  50
  51   Grob_property_info (context, context_property).pushpop
  52     (grob_property_path, new_value);
  53 }
  54
  55 bool
  56 typecheck_grob (SCM symbol, SCM value)
  57 {
  58   if (Unpure_pure_container *upc = unsmob<Unpure_pure_container> (value))
  59     return typecheck_grob (symbol, upc->unpure_part ())
  60       && typecheck_grob (symbol, upc->pure_part ());
  61   return ly_is_procedure (value)
  62     || unsmob<Simple_closure> (value)
  63     || type_check_assignment (symbol, value, ly_symbol2scm ("backend-type?"));
  64 }
  65
  66 class Grob_properties : public Simple_smob<Grob_properties>
  67 {
  68 public:
  69   SCM mark_smob () const;
  70   static const char type_p_name_[];
  71 private:
  72   friend class Grob_property_info;
  73   friend SCM ly_make_grob_properties (SCM);
  74   // alist_ may contain unexpanded nested overrides
  75   SCM alist_;
  76   // based_on_ is the cooked_ value from the next higher context that
  77   // alist_ is based on
  78   SCM based_on_;
  79   // cooked_ is a version of alist_ where nested overrides have been
  80   // expanded
  81   SCM cooked_;
  82   // cooked_from_ is the value of alist_ from which the expansion has
  83   // been done
  84   SCM cooked_from_;
  85   // nested_ is a count of nested overrides in alist_ Or rather: of
  86   // entries that must not appear in the cooked list and are
  87   // identified by having a "key" that is not a symbol.  Temporary
  88   // overrides and reverts also meet that description and have a
  89   // nominal key of #t/#f and a value of the original cons cell.
  90   int nested_;
  91
  92   Grob_properties (SCM alist, SCM based_on) :
  93     alist_ (alist), based_on_ (based_on),
  94     // if the constructor was called with lists possibly containing
  95     // partial overrides, we would need to initialize with based_on in
  96     // order to trigger an initial update.  But this should never
  97     // happen, so we initialize straight with alist.
  98     cooked_ (alist), cooked_from_ (alist), nested_ (0) { }
  99 };
 100
 101 const char Grob_properties::type_p_name_[] = "ly:grob-properties?";
 102
 103 SCM
 104 Grob_properties::mark_smob () const
 105 {
 106   scm_gc_mark (alist_);
 107   scm_gc_mark (based_on_);
 108   scm_gc_mark (cooked_);
 109   return cooked_from_;
 110 }
 111
 112 LY_DEFINE (ly_make_grob_properties, "ly:make-grob-properties",
 113            1, 0, 0, (SCM alist),
 114            "This packages the given property list @var{alist} in"
 115            " a grob property container stored in a context property"
 116            " with the name of a grob.")
 117 {
 118   LY_ASSERT_TYPE (ly_is_list, alist, 1);
 119   return Grob_properties (alist, SCM_EOL).smobbed_copy ();
 120 }
 121
 122
 123 Grob_property_info
 124 Grob_property_info::find ()
 125 {
 126   if (props_)
 127     return *this;
 128   SCM res = SCM_UNDEFINED;
 129   if (Context *c = context_->where_defined (symbol_, &res))
 130     if (c != context_)
 131       return Grob_property_info (c, symbol_, unsmob<Grob_properties> (res));
 132   props_  = unsmob<Grob_properties> (res);
 133   return *this;
 134 }
 135
 136 bool
 137 Grob_property_info::check ()
 138 {
 139   if (props_)
 140     return true;
 141   SCM res = SCM_UNDEFINED;
 142   if (context_->here_defined (symbol_, &res))
 143     props_ = unsmob<Grob_properties> (res);
 144   return props_;
 145 }
 146
 147 bool
 148 Grob_property_info::create ()
 149 {
 150   // Using scm_hashq_create_handle_x would seem like the one-lookup
 151   // way to create a handle if it does not exist yet.  However, we
 152   // need to check that there is a corresponding grob in this
 153   // particular output first, and we have to do this in the global
 154   // context.  By far the most frequent case will be that a
 155   // Grob_properties for this context already exists, so we optimize
 156   // for that and only check the global handle when the local
 157   // context is pristine.
 158   if (check ())
 159     return true;
 160   SCM current_context_val = SCM_EOL;
 161   Context *g = context_->get_global_context ();
 162   if (!g)
 163     return false; // Context is probably dead
 164
 165   /*
 166     Don't mess with MIDI.
 167   */
 168   if (g == context_
 169       || !g->here_defined (symbol_, &current_context_val))
 170     return false;
 171
 172   Grob_properties *def = unsmob<Grob_properties> (current_context_val);
 173
 174   if (!def)
 175     {
 176       programming_error ("Grob definition expected");
 177       return false;
 178     }
 179
 180   // We create the new Grob_properties from the default definition
 181   // since this is what we have available right now.  It may or may
 182   // not be accurate since we don't take into account any
 183   // prospective overrides in intermediate contexts.  If there are
 184   // any, they will be factored in when `updated' is being called.
 185   SCM props = Grob_properties (def->alist_, def->alist_).smobbed_copy ();
 186   context_->set_property (symbol_, props);
 187   props_ = unsmob<Grob_properties> (props);
 188   return props_;
 189 }
 190
 191 /*
 192   Grob descriptions (ie. alists with layout properties) are
 193   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
 194   alist defined in a parent context. BASED-ON should always be a tail
 195   of ALIST.
 196
 197   Push a single entry from a
 198   translator property list by name of PROP.  GROB_PROPERTY_PATH
 199   indicates nested alists, eg. '(beamed-stem-lengths details)
 200
 201   Return value can be passed to matched_pop and will only cancel the
 202   same override then.
 203 */
 204 SCM
 205 Grob_property_info::push (SCM grob_property_path, SCM new_value)
 206 {
 207   /*
 208     Don't mess with MIDI.
 209   */
 210   if (!create ())
 211     return SCM_EOL;
 212
 213   SCM symbol = scm_car (grob_property_path);
 214   SCM rest = scm_cdr (grob_property_path);
 215   if (scm_is_pair (rest))
 216     {
 217       // poor man's typechecking
 218       if (typecheck_grob (symbol, nested_create_alist (rest, new_value))) {
 219         SCM cell = scm_cons (grob_property_path, new_value);
 220         props_->alist_ = scm_cons (cell, props_->alist_);
 221         props_->nested_++;
 222         return cell;
 223       }
 224       return SCM_EOL;
 225     }
 226
 227   /* it's tempting to replace the head of the list if it's the same
 228    property. However, we have to keep this info around, in case we have to
 229    \revert back to it.
 230   */
 231
 232   if (typecheck_grob (symbol, new_value))
 233     {
 234       SCM cell = scm_cons (symbol, new_value);
 235       props_->alist_ = scm_cons (cell, props_->alist_);
 236       return cell;
 237     }
 238   return SCM_EOL;
 239 }
 240
 241 // Used for \once \override, returns a token for matched_pop
 242 SCM
 243 Grob_property_info::temporary_override (SCM grob_property_path, SCM new_value)
 244 {
 245   SCM cell = push (grob_property_path, new_value);
 246   if (!scm_is_pair (cell))
 247     return cell;
 248   if (scm_is_symbol (scm_car (cell)))
 249     props_->nested_++;
 250   cell = scm_cons (SCM_BOOL_T, cell);
 251   props_->alist_ = scm_cons (cell, scm_cdr (props_->alist_));
 252   return cell;
 253 }
 254
 255 // Used for \once \revert, returns a token for matched_pop
 256 SCM
 257 Grob_property_info::temporary_revert (SCM grob_property_path)
 258 {
 259   if (!check ())
 260     return SCM_EOL;
 261
 262   SCM current_alist = props_->alist_;
 263   SCM daddy = props_->based_on_;
 264   SCM tail = SCM_EOL;
 265
 266   if (!scm_is_pair (grob_property_path)
 267       || !scm_is_symbol (scm_car (grob_property_path)))
 268     {
 269       programming_error ("Grob property path should be list of symbols.");
 270       return SCM_EOL;
 271     }
 272
 273   if (scm_is_pair (scm_cdr (grob_property_path)))
 274     {
 275       tail = assoc_tail (grob_property_path, current_alist, daddy);
 276       if (scm_is_false (tail))
 277         return SCM_EOL;
 278     }
 279   else
 280     {
 281       tail = assq_tail (scm_car (grob_property_path), current_alist, daddy);
 282       if (scm_is_false (tail))
 283         return SCM_EOL;
 284       ++props_->nested_;
 285     }
 286
 287   SCM cell = scm_cons (SCM_BOOL_F, scm_car (tail));
 288   props_->alist_ = partial_list_copy (current_alist, tail,
 289                                       scm_cons (cell, scm_cdr (tail)));
 290   return cell;
 291 }
 292
 293
 294 void
 295 Grob_property_info::matched_pop (SCM cell)
 296 {
 297   if (!scm_is_pair (cell))
 298     return;
 299   if (!check ())
 300     return;
 301   SCM current_alist = props_->alist_;
 302   SCM daddy = props_->based_on_;
 303   for (SCM p = current_alist; !scm_is_eq (p, daddy); p = scm_cdr (p))
 304     {
 305       if (scm_is_eq (scm_car (p), cell))
 306         {
 307           SCM key = scm_car (cell);
 308           if (scm_is_false (key))
 309             {
 310               // temporary revert, reactivate
 311               cell = scm_cdr (cell);
 312               if (scm_is_symbol (scm_car (cell)))
 313                 props_->nested_--;
 314               props_->alist_ = partial_list_copy (current_alist, p,
 315                                                   scm_cons (cell, scm_cdr (p)));
 316               return;
 317             }
 318           if (!scm_is_symbol (key))
 319             props_->nested_--;
 320           props_->alist_ = partial_list_copy (current_alist, p, scm_cdr (p));
 321           return;
 322         }
 323     }
 324   return;
 325 }
 326
 327 /*
 328   Revert the property given by property_path.
 329 */
 330 void
 331 Grob_property_info::pop (SCM grob_property_path)
 332 {
 333   if (!check ())
 334     return;
 335
 336   SCM current_alist = props_->alist_;
 337   SCM daddy = props_->based_on_;
 338
 339   if (!scm_is_pair (grob_property_path)
 340       || !scm_is_symbol (scm_car (grob_property_path)))
 341     {
 342       programming_error ("Grob property path should be list of symbols.");
 343       return;
 344     }
 345
 346   if (scm_is_pair (scm_cdr (grob_property_path)))
 347     {
 348       SCM old_alist = current_alist;
 349       current_alist = evict_from_alist (grob_property_path, current_alist, daddy);
 350       if (scm_is_eq (old_alist, current_alist))
 351         return;
 352       props_->nested_--;
 353     }
 354   else
 355     current_alist = evict_from_alist (scm_car (grob_property_path),
 356                                       current_alist, daddy);
 357
 358   if (scm_is_eq (current_alist, daddy))
 359     {
 360       assert (props_->nested_ == 0);
 361       props_ = 0;
 362       context_->unset_property (symbol_);
 363       return;
 364     }
 365   props_->alist_ = current_alist;
 366 }
 367 /*
 368   Convenience: a push/pop grob property using a single grob_property
 369   as argument.
 370 */
 371 void
 372 execute_pushpop_property (Context *context,
 373                           SCM grob,
 374                           SCM grob_property,
 375                           SCM new_value)
 376 {
 377   Grob_property_info (context, grob).pushpop (scm_list_1 (grob_property), new_value);
 378 }
 379
 380 /*
 381   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 382 */
 383 void
 384 apply_property_operations (Context *tg, SCM pre_init_ops)
 385 {
 386   for (SCM s = pre_init_ops; scm_is_pair (s); s = scm_cdr (s))
 387     {
 388       SCM entry = scm_car (s);
 389       SCM type = scm_car (entry);
 390       entry = scm_cdr (entry);
 391
 392       if (scm_is_eq (type, ly_symbol2scm ("push")))
 393         {
 394           SCM context_prop = scm_car (entry);
 395           SCM val = scm_cadr (entry);
 396           SCM grob_prop_path = scm_cddr (entry);
 397           Grob_property_info (tg, context_prop).push (grob_prop_path, val);
 398         }
 399       else if (scm_is_eq (type, ly_symbol2scm ("pop")))
 400         {
 401           SCM context_prop = scm_car (entry);
 402           SCM grob_prop_path = scm_cdr (entry);
 403           Grob_property_info (tg, context_prop).pop (grob_prop_path);
 404         }
 405       else if (scm_is_eq (type, ly_symbol2scm ("assign")))
 406         tg->set_property (scm_car (entry), scm_cadr (entry));
 407       else if (scm_is_eq (type, ly_symbol2scm ("apply")))
 408         scm_apply_1 (scm_car (entry), tg->self_scm (), scm_cdr (entry));
 409       else if (scm_is_eq (type, ly_symbol2scm ("unset")))
 410         tg->unset_property (scm_car (entry));
 411     }
 412 }
 413
 414 /*
 415   Return the object alist for SYM, checking if its base in enclosing
 416   contexts has changed. The alist is updated if necessary.
 417 */
 418 SCM Grob_property_info::updated ()
 419 {
 420   assert (scm_is_symbol (symbol_));
 421
 422   Grob_property_info where = find ();
 423
 424   if (!where)
 425     return SCM_EOL;
 426
 427   Context *dad = where.context_->get_parent_context ();
 428
 429   SCM daddy_props
 430     = dad ? Grob_property_info (dad, symbol_).updated () : SCM_EOL;
 431
 432   SCM based_on = where.props_->based_on_;
 433   SCM alist = where.props_->alist_;
 434   if (!scm_is_eq (based_on, daddy_props))
 435     {
 436       where.props_->based_on_ = daddy_props;
 437       alist = partial_list_copy (alist, based_on, daddy_props);
 438       where.props_->alist_ = alist;
 439     }
 440   if (scm_is_eq (where.props_->cooked_from_, alist))
 441     return where.props_->cooked_;
 442   where.props_->cooked_from_ = alist;
 443   where.props_->cooked_ = nalist_to_alist (alist, where.props_->nested_);
 444   return where.props_->cooked_;
 445 }