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 = Unpure_pure_container::unsmob (value))
  59     return typecheck_grob (symbol, upc->unpure_part ())
  60       && typecheck_grob (symbol, upc->pure_part ());
  61   return ly_is_procedure (value)
  62     || Simple_closure::is_smob (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 ();
  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_
  86   int nested_;
  87
  88   Grob_properties (SCM alist, SCM based_on) :
  89     alist_ (alist), based_on_ (based_on),
  90     // if the constructor was called with lists possibly containing
  91     // partial overrides, we would need to initialize with based_on in
  92     // order to trigger an initial update.  But this should never
  93     // happen, so we initialize straight with alist.
  94     cooked_ (alist), cooked_from_ (alist), nested_ (0) { }
  95 };
  96
  97 ADD_SMOB_INIT (Grob_properties);
  98
  99 const char Grob_properties::type_p_name_[] = "ly:grob-properties?";
 100
 101 SCM
 102 Grob_properties::mark_smob ()
 103 {
 104   scm_gc_mark (alist_);
 105   scm_gc_mark (based_on_);
 106   scm_gc_mark (cooked_);
 107   return cooked_from_;
 108 }
 109
 110 LY_DEFINE (ly_make_grob_properties, "ly:make-grob-properties",
 111            1, 0, 0, (SCM alist),
 112            "This packages the given property list @var{alist} in"
 113            " a grob property container stored in a context property"
 114            " with the name of a grob.")
 115 {
 116   LY_ASSERT_TYPE (ly_is_list, alist, 1);
 117   return Grob_properties (alist, SCM_EOL).smobbed_copy ();
 118 }
 119
 120
 121 Grob_property_info
 122 Grob_property_info::find ()
 123 {
 124   if (props_)
 125     return *this;
 126   SCM res = SCM_UNDEFINED;
 127   if (Context *c = context_->where_defined (symbol_, &res))
 128     if (c != context_)
 129       return Grob_property_info (c, symbol_, Grob_properties::unsmob (res));
 130   props_  = Grob_properties::unsmob (res);
 131   return *this;
 132 }
 133
 134 bool
 135 Grob_property_info::check ()
 136 {
 137   if (props_)
 138     return true;
 139   SCM res = SCM_UNDEFINED;
 140   if (context_->here_defined (symbol_, &res))
 141     props_ = Grob_properties::unsmob (res);
 142   return props_;
 143 }
 144
 145 bool
 146 Grob_property_info::create ()
 147 {
 148   // Using scm_hashq_create_handle_x would seem like the one-lookup
 149   // way to create a handle if it does not exist yet.  However, we
 150   // need to check that there is a corresponding grob in this
 151   // particular output first, and we have to do this in the global
 152   // context.  By far the most frequent case will be that a
 153   // Grob_properties for this context already exists, so we optimize
 154   // for that and only check the global handle when the local
 155   // context is pristine.
 156   if (check ())
 157     return true;
 158   SCM current_context_val = SCM_EOL;
 159   Context *g = context_->get_global_context ();
 160   if (!g)
 161     return false; // Context is probably dead
 162
 163   /*
 164     Don't mess with MIDI.
 165   */
 166   if (g == context_
 167       || !g->here_defined (symbol_, &current_context_val))
 168     return false;
 169
 170   Grob_properties *def = Grob_properties::unsmob (current_context_val);
 171
 172   if (!def)
 173     {
 174       programming_error ("Grob definition expected");
 175       return false;
 176     }
 177
 178   // We create the new Grob_properties from the default definition
 179   // since this is what we have available right now.  It may or may
 180   // not be accurate since we don't take into account any
 181   // prospective overrides in intermediate contexts.  If there are
 182   // any, they will be factored in when `updated' is being called.
 183   SCM props = Grob_properties (def->alist_, def->alist_).smobbed_copy ();
 184   context_->set_property (symbol_, props);
 185   props_ = Grob_properties::unsmob (props);
 186   return props_;
 187 }
 188
 189 /*
 190   Grob descriptions (ie. alists with layout properties) are
 191   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
 192   alist defined in a parent context. BASED-ON should always be a tail
 193   of ALIST.
 194
 195   Push a single entry from a
 196   translator property list by name of PROP.  GROB_PROPERTY_PATH
 197   indicates nested alists, eg. '(beamed-stem-lengths details)
 198
 199   Return value can be passed to matched_pop and will only cancel the
 200   same override then.
 201 */
 202 SCM
 203 Grob_property_info::push (SCM grob_property_path, SCM new_value)
 204 {
 205   /*
 206     Don't mess with MIDI.
 207   */
 208   if (!create ())
 209     return SCM_EOL;
 210
 211   SCM symbol = scm_car (grob_property_path);
 212   SCM rest = scm_cdr (grob_property_path);
 213   if (scm_is_pair (rest))
 214     {
 215       // poor man's typechecking
 216       if (typecheck_grob (symbol, nested_create_alist (rest, new_value))) {
 217         SCM cell = scm_cons (grob_property_path, new_value);
 218         props_->alist_ = scm_cons (cell, props_->alist_);
 219         props_->nested_++;
 220         return cell;
 221       }
 222       return SCM_EOL;
 223     }
 224
 225   /* it's tempting to replace the head of the list if it's the same
 226    property. However, we have to keep this info around, in case we have to
 227    \revert back to it.
 228   */
 229
 230   if (typecheck_grob (symbol, new_value))
 231     {
 232       SCM cell = scm_cons (symbol, new_value);
 233       props_->alist_ = scm_cons (cell, props_->alist_);
 234       return cell;
 235     }
 236   return SCM_EOL;
 237 }
 238
 239 void
 240 Grob_property_info::matched_pop (SCM cell)
 241 {
 242   if (!scm_is_pair (cell))
 243     return;
 244   if (!check ())
 245     return;
 246   SCM current_alist = props_->alist_;
 247   SCM daddy = props_->based_on_;
 248   for (SCM p = current_alist; !scm_is_eq (p, daddy); p = scm_cdr (p))
 249     {
 250       if (scm_is_eq (scm_car (p), cell))
 251         {
 252           if (scm_is_pair (scm_car (cell)))
 253             props_->nested_--;
 254           props_->alist_ = partial_list_copy (current_alist, p, scm_cdr (p));
 255           return;
 256         }
 257     }
 258   return;
 259 }
 260
 261 /*
 262   Revert the property given by property_path.
 263 */
 264 void
 265 Grob_property_info::pop (SCM grob_property_path)
 266 {
 267   if (!check ())
 268     return;
 269
 270   SCM current_alist = props_->alist_;
 271   SCM daddy = props_->based_on_;
 272
 273   if (!scm_is_pair (grob_property_path)
 274       || !scm_is_symbol (scm_car (grob_property_path)))
 275     {
 276       programming_error ("Grob property path should be list of symbols.");
 277       return;
 278     }
 279
 280   if (scm_is_pair (scm_cdr (grob_property_path)))
 281     {
 282       SCM old_alist = current_alist;
 283       current_alist = evict_from_alist (grob_property_path, current_alist, daddy);
 284       if (scm_is_eq (old_alist, current_alist))
 285         return;
 286       props_->nested_--;
 287     }
 288   else
 289     current_alist = evict_from_alist (scm_car (grob_property_path),
 290                                       current_alist, daddy);
 291
 292   if (scm_is_eq (current_alist, daddy))
 293     {
 294       assert (props_->nested_ == 0);
 295       props_ = 0;
 296       context_->unset_property (symbol_);
 297       return;
 298     }
 299   props_->alist_ = current_alist;
 300 }
 301 /*
 302   Convenience: a push/pop grob property using a single grob_property
 303   as argument.
 304 */
 305 void
 306 execute_pushpop_property (Context *context,
 307                           SCM grob,
 308                           SCM grob_property,
 309                           SCM new_value)
 310 {
 311   Grob_property_info (context, grob).pushpop (scm_list_1 (grob_property), new_value);
 312 }
 313
 314 /*
 315   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 316 */
 317 void
 318 apply_property_operations (Context *tg, SCM pre_init_ops)
 319 {
 320   for (SCM s = pre_init_ops; scm_is_pair (s); s = scm_cdr (s))
 321     {
 322       SCM entry = scm_car (s);
 323       SCM type = scm_car (entry);
 324       entry = scm_cdr (entry);
 325
 326       if (scm_is_eq (type, ly_symbol2scm ("push")))
 327         {
 328           SCM context_prop = scm_car (entry);
 329           SCM val = scm_cadr (entry);
 330           SCM grob_prop_path = scm_cddr (entry);
 331           Grob_property_info (tg, context_prop).push (grob_prop_path, val);
 332         }
 333       else if (scm_is_eq (type, ly_symbol2scm ("pop")))
 334         {
 335           SCM context_prop = scm_car (entry);
 336           SCM grob_prop_path = scm_cdr (entry);
 337           Grob_property_info (tg, context_prop).pop (grob_prop_path);
 338         }
 339       else if (scm_is_eq (type, ly_symbol2scm ("assign")))
 340         tg->set_property (scm_car (entry), scm_cadr (entry));
 341       else if (scm_is_eq (type, ly_symbol2scm ("apply")))
 342         scm_apply_1 (scm_car (entry), tg->self_scm (), scm_cdr (entry));
 343       else if (scm_is_eq (type, ly_symbol2scm ("unset")))
 344         tg->unset_property (scm_car (entry));
 345     }
 346 }
 347
 348 /*
 349   Return the object alist for SYM, checking if its base in enclosing
 350   contexts has changed. The alist is updated if necessary.
 351 */
 352 SCM Grob_property_info::updated ()
 353 {
 354   assert (scm_is_symbol (symbol_));
 355
 356   Grob_property_info where = find ();
 357
 358   if (!where)
 359     return SCM_EOL;
 360
 361   Context *dad = where.context_->get_parent_context ();
 362
 363   SCM daddy_props
 364     = dad ? Grob_property_info (dad, symbol_).updated () : SCM_EOL;
 365
 366   SCM based_on = where.props_->based_on_;
 367   SCM alist = where.props_->alist_;
 368   if (!scm_is_eq (based_on, daddy_props))
 369     {
 370       where.props_->based_on_ = daddy_props;
 371       alist = partial_list_copy (alist, based_on, daddy_props);
 372       where.props_->alist_ = alist;
 373     }
 374   if (scm_is_eq (where.props_->cooked_from_, alist))
 375     return where.props_->cooked_;
 376   where.props_->cooked_from_ = alist;
 377   where.props_->cooked_ = nalist_to_alist (alist, where.props_->nested_);
 378   return where.props_->cooked_;
 379 }