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