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