15.4.754  src/lib/global-controls/global-control.pkg

## global-control.pkg
#
#     "sadly, it IS just a warning. It's easy not to pay attention to the warnings 
#      and get in trouble. i wonder if a compiler option to make it an ERROR is 
#      appropriate..." 
#                -- Hue White   Wed, 12 Oct 2011
# 
# (Something like gcc -Werror does strike me as a good idea for the Mythryl compiler. -- 2011-10-12 CrT  XXX SUCKO FIXME.)

# Compiled by:
#     src/lib/global-controls/global-controls.lib


stipulate
    package cf  =  global_control_forms;                                                # global_control_forms          is from   src/lib/global-controls/global-control-forms.pkg
    package qs  =  quickstring__premicrothread;                                         # quickstring__premicrothread   is from   src/lib/src/quickstring--premicrothread.pkg
herein

    package    global_control
    : (weak)   Global_Control                                                           # Global_Control                is from   src/lib/global-controls/global-control.api
    {
        Menu_Slot           =  cf::Menu_Slot;
        Global_Control(X)   =  cf::Global_Control(X);
        Value_Converter(X)  =  cf::Value_Converter(X);

        fun make_control { name, menu_slot, obscurity, help, control }
            =
            cf::GLOBAL_CONTROL
              {
                name =>  qs::from_string name,
                get  =>  \\ () = *control,
                set  =>  \\ THE v =>  (\\ () =  control := v);
                            NULL  =>  { v = *control;   \\ () = control := v; };
                         end,
                menu_slot,
                obscurity,
                help
              };

        # This exception is raised to announce
        # that there is a syntax error in a
        # string representation of a control value:
        #
        exception
            BAD_VALUE_SYNTAX  {
              name_of_type:     String,
              control_name:  String,
              value:         String
            };

        fun make_string_control
              #
              { name_of_type, from_string, to_string }
              #
              (cf::GLOBAL_CONTROL c)
            =
            {   c ->   { name, get, set, menu_slot, obscurity, help };

                fun from_string' s
                    =
                    case (from_string s)
                        #                 
                        THE v => v;
                        #                 
                        NULL  =>
                            raise exception BAD_VALUE_SYNTAX { name_of_type,
                                                               control_name =>  qs::to_string name,
                                                               value        =>  s
                                                             };
                    esac;

                cf::GLOBAL_CONTROL
                  {
                    name,
                    get => to_string o get,
                    set => set o null_or::map from_string',
                    menu_slot,
                    obscurity,
                    help
                  };
            };

        fun name (cf::GLOBAL_CONTROL { name, ... }  ) =  qs::to_string name;
        fun get  (cf::GLOBAL_CONTROL { get, ... }   ) =  get ();
        fun set  (cf::GLOBAL_CONTROL { set, ... }, v) =  set (THE v) ();
        fun set' (cf::GLOBAL_CONTROL { set, ... }, v) =  set (THE v);

        fun info (cf::GLOBAL_CONTROL { menu_slot, obscurity, help, ... } )
            =
            { menu_slot, obscurity, help };

        fun save_controller_state (cf::GLOBAL_CONTROL { set, ... } )                                    # Generate a thunk containing current controller state, which when run will restore the controller to that state.
            =
            set NULL;

        fun menu_rank_gt
              (
                cf::GLOBAL_CONTROL { menu_slot => rank1, ... },
                cf::GLOBAL_CONTROL { menu_slot => rank2, ... }
              )
            =
            list::compare_sequences  int::compare (rank1, rank2);

    };
end;

## COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.