lily/context-property.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2004--2011 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 "international.hh"
  23 #include "item.hh"
  24 #include "main.hh"
  25 #include "simple-closure.hh"
  26 #include "spanner.hh"
  27 #include "unpure-pure-container.hh"
  28 #include "warn.hh"
  29
  30 /*
  31   like execute_general_pushpop_property(), but typecheck
  32   grob_property_path and context_property.
  33 */
  34 void
  35 general_pushpop_property (Context *context,
  36                           SCM context_property,
  37                           SCM grob_property_path,
  38                           SCM new_value)
  39 {
  40   if (!scm_is_symbol (context_property)
  41       || !scm_is_symbol (scm_car (grob_property_path)))
  42     {
  43       warning (_ ("need symbol arguments for \\override and \\revert"));
  44       if (do_internal_type_checking_global)
  45         assert (false);
  46     }
  47
  48   sloppy_general_pushpop_property (context, context_property,
  49                                    grob_property_path, new_value);
  50 }
  51
  52 /*
  53   Grob descriptions (ie. alists with layout properties) are
  54   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
  55   alist defined in a parent context. BASED-ON should always be a tail
  56   of ALIST.
  57
  58   Push or pop (depending on value of VAL) a single entry from a
  59   translator property list by name of PROP.  GROB_PROPERTY_PATH
  60   indicates nested alists, eg. '(beamed-stem-lengths details)
  61 */
  62 void
  63 execute_override_property (Context *context,
  64                            SCM context_property,
  65                            SCM grob_property_path,
  66                            SCM new_value)
  67 {
  68   SCM current_context_val = SCM_EOL;
  69
  70   Context *where = context->where_defined (context_property,
  71                                            &current_context_val);
  72
  73   /*
  74     Don't mess with MIDI.
  75   */
  76   if (!where)
  77     return;
  78
  79   if (where != context)
  80     {
  81       SCM base = updated_grob_properties (context, context_property);
  82       current_context_val = scm_cons (base, base);
  83       context->set_property (context_property, current_context_val);
  84     }
  85
  86   if (!scm_is_pair (current_context_val))
  87     {
  88       programming_error ("Grob definition should be cons");
  89       return;
  90     }
  91
  92   SCM target_alist = scm_car (current_context_val);
  93
  94   /*
  95     If the car is a list, the property path comes from a nested override
  96     using list syntax inside a \context block
  97   */
  98   if (scm_is_pair (scm_car (grob_property_path)))
  99     grob_property_path = scm_car (grob_property_path);
 100
 101   SCM symbol = scm_car (grob_property_path);
 102   if (scm_is_pair (scm_cdr (grob_property_path)))
 103     {
 104       new_value = nested_property_alist (ly_assoc_get (symbol, target_alist,
 105                                                        SCM_EOL),
 106                                          scm_cdr (grob_property_path),
 107                                          new_value);
 108     }
 109
 110   /* it's tempting to replace the head of the list if it's the same
 111    property. However, we have to keep this info around, in case we have to
 112    \revert back to it.
 113   */
 114   target_alist = scm_acons (symbol, new_value, target_alist);
 115
 116   bool ok = true;
 117   bool pc = is_unpure_pure_container (new_value);
 118   SCM vals[] = {pc ? unpure_pure_container_unpure_part (new_value) : new_value,
 119                 pc ? unpure_pure_container_pure_part (new_value) : SCM_BOOL_F};
 120
 121   for (int i = 0; i < 2; i++)
 122     if (!ly_is_procedure (vals[i])
 123         && !is_simple_closure (vals[i]))
 124       ok = ok && type_check_assignment (symbol, vals[i],
 125                                     ly_symbol2scm ("backend-type?"));
 126
 127   /*
 128     tack onto alist.  We can use set_car, since
 129     updated_grob_properties () in child contexts will check
 130     for changes in the car.
 131   */
 132   if (ok)
 133     {
 134       scm_set_car_x (current_context_val, target_alist);
 135     }
 136 }
 137
 138 /*
 139   do a pop (indicated by new_value==SCM_UNDEFINED) or push
 140  */
 141 void
 142 sloppy_general_pushpop_property (Context *context,
 143                                  SCM context_property,
 144                                  SCM grob_property_path,
 145                                  SCM new_value)
 146 {
 147   if (new_value == SCM_UNDEFINED)
 148     execute_revert_property (context, context_property,
 149                              grob_property_path);
 150   else
 151     execute_override_property (context, context_property,
 152                                grob_property_path,
 153                                new_value);
 154 }
 155
 156 /*
 157   Revert the property given by property_path.
 158 */
 159 void
 160 execute_revert_property (Context *context,
 161                          SCM context_property,
 162                          SCM grob_property_path)
 163 {
 164   SCM current_context_val = SCM_EOL;
 165   if (context->where_defined (context_property, &current_context_val)
 166       == context)
 167     {
 168       SCM current_alist = scm_car (current_context_val);
 169       SCM daddy = scm_cdr (current_context_val);
 170
 171       if (!scm_is_pair (grob_property_path)
 172           || !scm_is_symbol (scm_car (grob_property_path)))
 173         {
 174           programming_error ("Grob property path should be list of symbols.");
 175           return;
 176         }
 177
 178       SCM symbol = scm_car (grob_property_path);
 179       if (scm_is_pair (scm_cdr (grob_property_path)))
 180         {
 181           SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL);
 182           SCM new_val
 183             = nested_property_revert_alist (current_sub_alist,
 184                                             scm_cdr (grob_property_path));
 185
 186           if (scm_is_pair (current_alist)
 187               && scm_caar (current_alist) == symbol
 188               && current_alist != daddy)
 189             current_alist = scm_cdr (current_alist);
 190
 191           current_alist = scm_acons (symbol, new_val, current_alist);
 192           scm_set_car_x (current_context_val, current_alist);
 193         }
 194       else
 195         {
 196           SCM new_alist = evict_from_alist (symbol, current_alist, daddy);
 197
 198           if (new_alist == daddy)
 199             context->unset_property (context_property);
 200           else
 201             context->set_property (context_property,
 202                                    scm_cons (new_alist, daddy));
 203         }
 204     }
 205 }
 206 /*
 207   Convenience: a push/pop grob property using a single grob_property
 208   as argument.
 209 */
 210 void
 211 execute_pushpop_property (Context *context,
 212                           SCM context_property,
 213                           SCM grob_property,
 214                           SCM new_value)
 215 {
 216   general_pushpop_property (context, context_property,
 217                             scm_list_1 (grob_property),
 218                             new_value);
 219 }
 220
 221 /*
 222   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 223 */
 224 void
 225 apply_property_operations (Context *tg, SCM pre_init_ops)
 226 {
 227   SCM correct_order = scm_reverse (pre_init_ops);
 228   for (SCM s = correct_order; scm_is_pair (s); s = scm_cdr (s))
 229     {
 230       SCM entry = scm_car (s);
 231       SCM type = scm_car (entry);
 232       entry = scm_cdr (entry);
 233
 234       if (type == ly_symbol2scm ("push"))
 235         {
 236           SCM context_prop = scm_car (entry);
 237           SCM val = scm_cadr (entry);
 238           SCM grob_prop_path = scm_cddr (entry);
 239           sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 240         }
 241       else if (type == ly_symbol2scm ("pop"))
 242         {
 243           SCM context_prop = scm_car (entry);
 244           SCM val = SCM_UNDEFINED;
 245           SCM grob_prop_path = scm_cdr (entry);
 246           sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 247         }
 248       else if (type == ly_symbol2scm ("assign"))
 249         tg->set_property (scm_car (entry), scm_cadr (entry));
 250     }
 251 }
 252
 253 /*
 254   Return the object alist for SYM, checking if its base in enclosing
 255   contexts has changed. The alist is updated if necessary.
 256 */
 257 SCM
 258 updated_grob_properties (Context *tg, SCM sym)
 259 {
 260   assert (scm_is_symbol (sym));
 261
 262   SCM props;
 263   tg = tg->where_defined (sym, &props);
 264   if (!tg)
 265     return SCM_EOL;
 266
 267   SCM daddy_props
 268     = (tg->get_parent_context ())
 269       ? updated_grob_properties (tg->get_parent_context (), sym)
 270       : SCM_EOL;
 271
 272   if (!scm_is_pair (props))
 273     {
 274       programming_error ("grob props not a pair?");
 275       return SCM_EOL;
 276     }
 277
 278   SCM based_on = scm_cdr (props);
 279   if (based_on == daddy_props)
 280     return scm_car (props);
 281   else
 282     {
 283       SCM copy = daddy_props;
 284       SCM *tail = &copy;
 285       SCM p = scm_car (props);
 286       while (p != based_on)
 287         {
 288           *tail = scm_cons (scm_car (p), daddy_props);
 289           tail = SCM_CDRLOC (*tail);
 290           p = scm_cdr (p);
 291         }
 292
 293       scm_set_car_x (props, copy);
 294       scm_set_cdr_x (props, daddy_props);
 295
 296       return copy;
 297     }
 298 }