lily/context-property.cc

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