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