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