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