lily/context-property.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2004--2012 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
 122   for (int i = 0; i < 2; i++)
 123     if (!ly_is_procedure (vals[i])
 124         && !is_simple_closure (vals[i]))
 125       ok = ok && type_check_assignment (symbol, vals[i],
 126                                         ly_symbol2scm ("backend-type?"));
 127
 128   /*
 129     tack onto alist.  We can use set_car, since
 130     updated_grob_properties () in child contexts will check
 131     for changes in the car.
 132   */
 133   if (ok)
 134     {
 135       scm_set_car_x (current_context_val, target_alist);
 136     }
 137 }
 138
 139 /*
 140   do a pop (indicated by new_value==SCM_UNDEFINED) or push
 141  */
 142 void
 143 sloppy_general_pushpop_property (Context *context,
 144                                  SCM context_property,
 145                                  SCM grob_property_path,
 146                                  SCM new_value)
 147 {
 148   if (new_value == SCM_UNDEFINED)
 149     execute_revert_property (context, context_property,
 150                              grob_property_path);
 151   else
 152     execute_override_property (context, context_property,
 153                                grob_property_path,
 154                                new_value);
 155 }
 156
 157 /*
 158   Revert the property given by property_path.
 159 */
 160 void
 161 execute_revert_property (Context *context,
 162                          SCM context_property,
 163                          SCM grob_property_path)
 164 {
 165   SCM current_context_val = SCM_EOL;
 166   if (context->where_defined (context_property, &current_context_val)
 167       == context)
 168     {
 169       SCM current_alist = scm_car (current_context_val);
 170       SCM daddy = scm_cdr (current_context_val);
 171
 172       if (!scm_is_pair (grob_property_path)
 173           || !scm_is_symbol (scm_car (grob_property_path)))
 174         {
 175           programming_error ("Grob property path should be list of symbols.");
 176           return;
 177         }
 178
 179       SCM symbol = scm_car (grob_property_path);
 180       if (scm_is_pair (scm_cdr (grob_property_path)))
 181         {
 182           SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL);
 183           SCM new_val
 184             = nested_property_revert_alist (current_sub_alist,
 185                                             scm_cdr (grob_property_path));
 186
 187           if (scm_is_pair (current_alist)
 188               && scm_caar (current_alist) == symbol
 189               && current_alist != daddy)
 190             current_alist = scm_cdr (current_alist);
 191
 192           current_alist = scm_acons (symbol, new_val, current_alist);
 193           scm_set_car_x (current_context_val, current_alist);
 194         }
 195       else
 196         {
 197           SCM new_alist = evict_from_alist (symbol, current_alist, daddy);
 198
 199           if (new_alist == daddy)
 200             context->unset_property (context_property);
 201           else
 202             context->set_property (context_property,
 203                                    scm_cons (new_alist, daddy));
 204         }
 205     }
 206 }
 207 /*
 208   Convenience: a push/pop grob property using a single grob_property
 209   as argument.
 210 */
 211 void
 212 execute_pushpop_property (Context *context,
 213                           SCM context_property,
 214                           SCM grob_property,
 215                           SCM new_value)
 216 {
 217   general_pushpop_property (context, context_property,
 218                             scm_list_1 (grob_property),
 219                             new_value);
 220 }
 221
 222 /*
 223   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 224 */
 225 void
 226 apply_property_operations (Context *tg, SCM pre_init_ops)
 227 {
 228   for (SCM s = pre_init_ops; 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       if (!scm_is_pair (entry))
 234         continue;
 235       SCM context_prop = scm_car (entry);
 236       if (scm_is_pair (context_prop))
 237         {
 238           if (tg->is_alias (scm_car (context_prop)))
 239             context_prop = scm_cdr (context_prop);
 240           else
 241             continue;
 242         }
 243
 244       if (type == ly_symbol2scm ("push"))
 245         {
 246           SCM val = scm_cadr (entry);
 247           SCM grob_prop_path = scm_cddr (entry);
 248           sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 249         }
 250       else if (type == ly_symbol2scm ("pop"))
 251         {
 252           SCM val = SCM_UNDEFINED;
 253           SCM grob_prop_path = scm_cdr (entry);
 254           sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 255         }
 256       else if (type == ly_symbol2scm ("assign"))
 257         tg->set_property (context_prop, scm_cadr (entry));
 258       else if (type == ly_symbol2scm ("apply"))
 259         scm_apply_1 (context_prop, tg->self_scm (), scm_cdr (entry));
 260     }
 261 }
 262
 263 /*
 264   Return the object alist for SYM, checking if its base in enclosing
 265   contexts has changed. The alist is updated if necessary.
 266 */
 267 SCM
 268 updated_grob_properties (Context *tg, SCM sym)
 269 {
 270   assert (scm_is_symbol (sym));
 271
 272   SCM props;
 273   tg = tg->where_defined (sym, &props);
 274   if (!tg)
 275     return SCM_EOL;
 276
 277   SCM daddy_props
 278     = (tg->get_parent_context ())
 279       ? updated_grob_properties (tg->get_parent_context (), sym)
 280       : SCM_EOL;
 281
 282   if (!scm_is_pair (props))
 283     {
 284       programming_error ("grob props not a pair?");
 285       return SCM_EOL;
 286     }
 287
 288   SCM based_on = scm_cdr (props);
 289   if (based_on == daddy_props)
 290     return scm_car (props);
 291   else
 292     {
 293       SCM copy = daddy_props;
 294       SCM *tail = &copy;
 295       SCM p = scm_car (props);
 296       while (p != based_on)
 297         {
 298           *tail = scm_cons (scm_car (p), daddy_props);
 299           tail = SCM_CDRLOC (*tail);
 300           p = scm_cdr (p);
 301         }
 302
 303       scm_set_car_x (props, copy);
 304       scm_set_cdr_x (props, daddy_props);
 305
 306       return copy;
 307     }
 308 }