lily/context-property.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2004--2014 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 (is_unpure_pure_container (value))
  59     return typecheck_grob (symbol, unpure_pure_container_unpure_part (value))
  60       && typecheck_grob (symbol, unpure_pure_container_pure_part (value));
  61   return ly_is_procedure (value)
  62     || is_simple_closure (value)
  63     || type_check_assignment (symbol, value, ly_symbol2scm ("backend-type?"));
  64 }
  65
  66 class Grob_properties {
  67   friend class Grob_property_info;
  68   friend SCM ly_make_grob_properties (SCM);
  69   SCM alist_;
  70   SCM based_on_;
  71
  72   Grob_properties (SCM alist, SCM based_on) :
  73     alist_ (alist), based_on_ (based_on) { }
  74   DECLARE_SIMPLE_SMOBS (Grob_properties);
  75 };
  76
  77 #include "ly-smobs.icc"
  78 IMPLEMENT_SIMPLE_SMOBS (Grob_properties);
  79 IMPLEMENT_DEFAULT_EQUAL_P (Grob_properties);
  80 IMPLEMENT_TYPE_P (Grob_properties, "ly:grob-properties?");
  81
  82 SCM
  83 Grob_properties::mark_smob (SCM smob)
  84 {
  85   Grob_properties *gp = (Grob_properties *) SCM_SMOB_DATA (smob);
  86   scm_gc_mark (gp->alist_);
  87   return gp->based_on_;
  88 }
  89
  90 int
  91 Grob_properties::print_smob (SCM /*smob*/, SCM port, scm_print_state *)
  92 {
  93   scm_puts ("#<Grob_properties>", port);
  94
  95   return 1;
  96 }
  97
  98 LY_DEFINE (ly_make_grob_properties, "ly:make-grob-properties",
  99            1, 0, 0, (SCM alist),
 100            "This packages the given property list @var{alist} in"
 101            " a grob property container stored in a context property"
 102            " with the name of a grob.")
 103 {
 104   LY_ASSERT_TYPE (ly_is_list, alist, 1);
 105   return Grob_properties (alist, SCM_EOL).smobbed_copy ();
 106 }
 107
 108
 109 Grob_property_info
 110 Grob_property_info::find ()
 111 {
 112   if (props_)
 113     return *this;
 114   SCM res = SCM_UNDEFINED;
 115   if (Context *c = context_->where_defined (symbol_, &res))
 116     if (c != context_)
 117       return Grob_property_info (c, symbol_, Grob_properties::unsmob (res));
 118   props_  = Grob_properties::unsmob (res);
 119   return *this;
 120 }
 121
 122 bool
 123 Grob_property_info::check ()
 124 {
 125   if (props_)
 126     return true;
 127   SCM res = SCM_UNDEFINED;
 128   if (context_->here_defined (symbol_, &res))
 129     props_ = Grob_properties::unsmob (res);
 130   return props_;
 131 }
 132
 133 bool
 134 Grob_property_info::create ()
 135 {
 136   // Using scm_hashq_create_handle_x would seem like the one-lookup
 137   // way to create a handle if it does not exist yet.  However, we
 138   // need to check that there is a corresponding grob in this
 139   // particular output first, and we have to do this in the global
 140   // context.  By far the most frequent case will be that a
 141   // Grob_properties for this context already exists, so we optimize
 142   // for that and only check the global handle when the local
 143   // context is pristine.
 144   if (check ())
 145     return true;
 146   SCM current_context_val = SCM_EOL;
 147   Context *g = context_->get_global_context ();
 148   if (!g)
 149     return false; // Context is probably dead
 150
 151   /*
 152     Don't mess with MIDI.
 153   */
 154   if (g == context_
 155       || !g->here_defined (symbol_, &current_context_val))
 156     return false;
 157
 158   Grob_properties *def = Grob_properties::unsmob (current_context_val);
 159
 160   if (!def)
 161     {
 162       programming_error ("Grob definition expected");
 163       return false;
 164     }
 165
 166   // We create the new Grob_properties from the default definition
 167   // since this is what we have available right now.  It may or may
 168   // not be accurate since we don't take into account any
 169   // prospective overrides in intermediate contexts.  If there are
 170   // any, they will be factored in when `updated' is being called.
 171   SCM props = Grob_properties (def->alist_, def->alist_).smobbed_copy ();
 172   context_->set_property (symbol_, props);
 173   props_ = Grob_properties::unsmob (props);
 174   return props_;
 175 }
 176
 177 /*
 178   Grob descriptions (ie. alists with layout properties) are
 179   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
 180   alist defined in a parent context. BASED-ON should always be a tail
 181   of ALIST.
 182
 183   Push or pop (depending on value of VAL) a single entry from a
 184   translator property list by name of PROP.  GROB_PROPERTY_PATH
 185   indicates nested alists, eg. '(beamed-stem-lengths details)
 186 */
 187 void
 188 Grob_property_info::push (SCM grob_property_path, SCM new_value)
 189 {
 190   /*
 191     Don't mess with MIDI.
 192   */
 193   if (!create ())
 194     return;
 195
 196   SCM symbol = scm_car (grob_property_path);
 197   if (scm_is_pair (scm_cdr (grob_property_path)))
 198     {
 199       new_value = nested_property_alist (ly_assoc_get (symbol, updated (),
 200                                                        SCM_EOL),
 201                                          scm_cdr (grob_property_path),
 202                                          new_value);
 203     }
 204
 205   /* it's tempting to replace the head of the list if it's the same
 206    property. However, we have to keep this info around, in case we have to
 207    \revert back to it.
 208   */
 209
 210   if (typecheck_grob (symbol, new_value))
 211     props_->alist_ = scm_acons (symbol, new_value, props_->alist_);
 212 }
 213
 214 /*
 215   Revert the property given by property_path.
 216 */
 217 void
 218 Grob_property_info::pop (SCM grob_property_path)
 219 {
 220   if (!check ())
 221     return;
 222
 223   SCM current_alist = props_->alist_;
 224   SCM daddy = props_->based_on_;
 225
 226   if (!scm_is_pair (grob_property_path)
 227       || !scm_is_symbol (scm_car (grob_property_path)))
 228     {
 229       programming_error ("Grob property path should be list of symbols.");
 230       return;
 231     }
 232
 233   SCM symbol = scm_car (grob_property_path);
 234   if (scm_is_pair (scm_cdr (grob_property_path)))
 235     {
 236       // This is definitely wrong: the symbol must only be looked up
 237       // in the part of the alist before daddy.  We are not fixing
 238       // this right now since this is slated for complete replacement.
 239       SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL);
 240       SCM new_val
 241         = nested_property_revert_alist (current_sub_alist,
 242                                         scm_cdr (grob_property_path));
 243
 244       if (scm_is_pair (current_alist)
 245           && scm_caar (current_alist) == symbol
 246           && current_alist != daddy)
 247         current_alist = scm_cdr (current_alist);
 248
 249       current_alist = scm_acons (symbol, new_val, current_alist);
 250       props_->alist_ = current_alist;
 251     }
 252   else
 253     {
 254       SCM new_alist = evict_from_alist (symbol, current_alist, daddy);
 255
 256       if (new_alist == daddy)
 257         {
 258           props_ = 0;
 259           context_->unset_property (symbol_);
 260         }
 261       else
 262         props_->alist_ = new_alist;
 263     }
 264 }
 265 /*
 266   Convenience: a push/pop grob property using a single grob_property
 267   as argument.
 268 */
 269 void
 270 execute_pushpop_property (Context *context,
 271                           SCM grob,
 272                           SCM grob_property,
 273                           SCM new_value)
 274 {
 275   Grob_property_info (context, grob).pushpop (scm_list_1 (grob_property), new_value);
 276 }
 277
 278 /*
 279   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 280 */
 281 void
 282 apply_property_operations (Context *tg, SCM pre_init_ops)
 283 {
 284   for (SCM s = pre_init_ops; scm_is_pair (s); s = scm_cdr (s))
 285     {
 286       SCM entry = scm_car (s);
 287       SCM type = scm_car (entry);
 288       entry = scm_cdr (entry);
 289
 290       if (type == ly_symbol2scm ("push"))
 291         {
 292           SCM context_prop = scm_car (entry);
 293           SCM val = scm_cadr (entry);
 294           SCM grob_prop_path = scm_cddr (entry);
 295           Grob_property_info (tg, context_prop).push (grob_prop_path, val);
 296         }
 297       else if (type == ly_symbol2scm ("pop"))
 298         {
 299           SCM context_prop = scm_car (entry);
 300           SCM grob_prop_path = scm_cdr (entry);
 301           Grob_property_info (tg, context_prop).pop (grob_prop_path);
 302         }
 303       else if (type == ly_symbol2scm ("assign"))
 304         tg->set_property (scm_car (entry), scm_cadr (entry));
 305       else if (type == ly_symbol2scm ("apply"))
 306         scm_apply_1 (scm_car (entry), tg->self_scm (), scm_cdr (entry));
 307       else if (type == ly_symbol2scm ("unset"))
 308         tg->unset_property (scm_car (entry));
 309     }
 310 }
 311
 312 /*
 313   Return the object alist for SYM, checking if its base in enclosing
 314   contexts has changed. The alist is updated if necessary.
 315 */
 316 SCM Grob_property_info::updated ()
 317 {
 318   assert (scm_is_symbol (symbol_));
 319
 320   Grob_property_info where = find ();
 321
 322   if (!where)
 323     return SCM_EOL;
 324
 325   Context *dad = where.context_->get_parent_context ();
 326
 327   SCM daddy_props
 328     = dad ? Grob_property_info (dad, symbol_).updated () : SCM_EOL;
 329
 330   SCM based_on = where.props_->based_on_;
 331   if (based_on == daddy_props)
 332     return where.props_->alist_;
 333   else
 334     {
 335       SCM copy = daddy_props;
 336       SCM *tail = &copy;
 337       SCM p = where.props_->alist_;
 338       while (p != based_on)
 339         {
 340           *tail = scm_cons (scm_car (p), daddy_props);
 341           tail = SCM_CDRLOC (*tail);
 342           p = scm_cdr (p);
 343         }
 344
 345       where.props_->alist_ = copy;
 346       where.props_->based_on_ =  daddy_props;
 347
 348       return copy;
 349     }
 350 }